Repository: sundmanbo/opencalphad Branch: master Commit: 8487a647a308 Files: 187 Total size: 8.3 MB Directory structure: gitextract_c_zt9wcv/ ├── Makefile ├── Makefile.am ├── Makefile_Claude ├── Makefile_MacOS ├── OCisoCbinding/ │ ├── liboctq.F90 │ ├── liboctqisoc.F90 │ ├── octqc.h │ └── pyOC/ │ ├── example.ipynb │ ├── example.py │ ├── pyOC.f90 │ ├── pyOC.py │ └── pyOCUnitTest.py ├── README.md ├── build_configure ├── configure.ac.1 ├── doc/ │ ├── makedok4.F90 │ └── manual/ │ ├── ochelp.html │ └── ochelp.tex ├── examples/ │ ├── TQ4lib/ │ │ ├── Cpp/ │ │ │ ├── Makefile │ │ │ ├── Matthias/ │ │ │ │ ├── FECRMNC.TDB │ │ │ │ ├── FENI.TDB │ │ │ │ ├── Makefile │ │ │ │ ├── Makefile-parallel │ │ │ │ ├── OC-isoC.h │ │ │ │ ├── crfe/ │ │ │ │ │ ├── crfe.TDB │ │ │ │ │ └── tqex1.cpp │ │ │ │ ├── feni/ │ │ │ │ │ ├── FENI.TDB │ │ │ │ │ └── tqex2.cpp │ │ │ │ ├── liboctqcpp.cpp │ │ │ │ ├── liboctqcpp.h │ │ │ │ ├── liboctqisoc.F90 │ │ │ │ ├── linkmake │ │ │ │ ├── steel1.TDB │ │ │ │ ├── tqcpptest1.cpp │ │ │ │ ├── tqex3.cpp │ │ │ │ └── tqintf.h │ │ │ ├── Scheil/ │ │ │ │ ├── Compile_OCASI_win32.bash │ │ │ │ ├── Example_OCASI.cpp │ │ │ │ ├── cost507r.TDB │ │ │ │ ├── liboctqisoc.F90 │ │ │ │ ├── linkscheil │ │ │ │ ├── ocasiintf.h │ │ │ │ ├── octqc.h │ │ │ │ ├── readme-scheil.tex │ │ │ │ └── tqintf.h │ │ │ ├── liboctq.F90 │ │ │ └── liboctqisoc.F90 │ │ ├── F90/ │ │ │ ├── crfe/ │ │ │ │ ├── TQ1-crfe.F90 │ │ │ │ ├── crfe.TDB │ │ │ │ ├── link-tqtest1 │ │ │ │ └── readme-tq1.tex │ │ │ ├── feni/ │ │ │ │ ├── FENI.TDB │ │ │ │ ├── TQ2-feni.F90 │ │ │ │ ├── linkmake │ │ │ │ └── readme.tex │ │ │ ├── liboctq.F90 │ │ │ └── parallel-alnipt/ │ │ │ ├── AlNiPt-2005.TDB │ │ │ ├── README.sim │ │ │ ├── liboctq.F90 │ │ │ ├── linksim │ │ │ ├── setup.input │ │ │ └── sim-alnipt.F90 │ │ └── readme.tex │ └── macros/ │ ├── AlC-OC.TDB │ ├── AlC-diagrams.OCM │ ├── AlFe-4SLBF.TDB │ ├── BEF.TDB │ ├── CHO-gas.TDB │ ├── MgNaCl.TDB │ ├── MgNaClX.TDB │ ├── MoRe.TDB │ ├── MoRe1.PDB │ ├── OU.TDB │ ├── SGTE-unary1991-2010.TDB │ ├── agcu.TDB │ ├── all-from-map19.OCM │ ├── all-from-map4.OCM │ ├── all-from-tzero.OCM │ ├── all.OCM │ ├── allcost.OCM │ ├── alni-4slx.TDB │ ├── cost507R.TDB │ ├── cslaf-excess.TDB │ ├── cslaf-map.OCM │ ├── hogas.TDB │ ├── iron4cd.TDB │ ├── map1.OCM │ ├── map10.OCM │ ├── map11.OCM │ ├── map12.OCM │ ├── map13.OCM │ ├── map14.OCM │ ├── map15.OCM │ ├── map16.OCM │ ├── map17.OCM │ ├── map18.OCM │ ├── map19.OCM │ ├── map2.OCM │ ├── map3.OCM │ ├── map4.OCM │ ├── map5.OCM │ ├── map6.OCM │ ├── map7.OCM │ ├── map8.OCM │ ├── map9.OCM │ ├── maplast.OCM │ ├── melting.OCM │ ├── mqtest-1C.OCM │ ├── opttest1.OCM │ ├── opttest2-map-diagram.OCM │ ├── opttest2-plot-cpcumg2.OCM │ ├── opttest2-plot-cplaves.OCM │ ├── opttest2-plot-hliq.OCM │ ├── opttest2.OCM │ ├── opttest2A.OCM │ ├── opttest2B.OCM │ ├── opttest2C.OCM │ ├── opttest2D.OCM │ ├── opttest2E.OCM │ ├── opttest2F.OCM │ ├── opttest2G.OCM │ ├── parallel1.OCM │ ├── parallel2.OCM │ ├── saf2507.TDB │ ├── save.OCM │ ├── sro-cef.OCM │ ├── steel1.TDB │ ├── steel7.TDB │ ├── step-epz.OCM │ ├── step-scheil.OCM │ ├── step-tzero.OCM │ ├── step1.OCM │ ├── step2.OCM │ ├── step3.OCM │ ├── step4.OCM │ ├── step5.OCM │ ├── step6.OCM │ ├── step7.OCM │ ├── step8.OCM │ ├── step9.OCM │ ├── testcond1.OCM │ ├── unary.OCM │ └── uniquac.OCM ├── linkmake ├── linkoc ├── linkpara ├── oc6P └── src/ ├── linkocdate.F90 ├── minimizer/ │ └── matsmin.F90 ├── models/ │ ├── OC-isoC.h │ ├── gtp3.F90 │ ├── gtp3A.F90 │ ├── gtp3B.F90 │ ├── gtp3C.F90 │ ├── gtp3D.F90 │ ├── gtp3E.F90 │ ├── gtp3EX.F90 │ ├── gtp3EY.F90 │ ├── gtp3F.F90 │ ├── gtp3G.F90 │ ├── gtp3H.F90 │ ├── gtp3X.F90 │ ├── gtp3XQ.F90 │ ├── gtp3Y.F90 │ ├── gtp3Z.F90 │ ├── gtp3_dd1.F90 │ ├── gtp3_dd2.F90 │ ├── gtp3_xml.F90 │ └── ocparam.F90 ├── numlib/ │ ├── minpack1.F90 │ ├── oclablas.F90 │ └── ocnum.F90 ├── pmain1.F90 ├── stepmapplot/ │ ├── smp2.F90 │ ├── smp2A.F90 │ └── smp2B.F90 ├── userif/ │ └── pmon6.F90 └── utilities/ ├── GETKEY/ │ ├── M_getkey.F90 │ ├── Makefile │ └── getkey.c ├── TINYFILEDIALOGS/ │ ├── Makefile │ ├── compile_and_link │ ├── ftinyopen.F90 │ ├── tinyfiledialogs.c │ ├── tinyfiledialogs.h │ └── tinyopen.c └── metlib4.F90 ================================================ FILE CONTENTS ================================================ ================================================ FILE: Makefile ================================================ # # Modified 2020.04.25 for the new direcory structure. Bo Sundman # OBJS=getkey.o M_getkey.o ftinyopen.o tinyopen.o tinyfiledialogs.o metlib4.o oclablas.o ocnum.o minpack1.o gtp3.o matsmin.o smp2.o pmon6.o LIBS=liboctq.o liboctqisoc.o liboctqcpp.o EXE=oc6P # # IMPORTANT 1. select getkey version # 2. select GNUPLOT terminal # # echo "Do not forget to uncomment a line for your OS" # #=============================================================================# # original provided by Matthias Strathmann including OC examples # NOTE getkey.o : you have to select which getkey routine to compile #=============================================================================# FC=gfortran C=gcc CPP=g++ FCOPT= -O2 -fopenmp -fPIC # for debugging #FCOPT= -fbounds-check -finit-local-zero # no parallel #FCOPT= -O2 #FC=ifort #FCOPT= -check bounds -zero EX1PATH = ./examples/TQ4lib/F90/crfe EX2PATH = ./examples/TQ4lib/F90/feni EX3PATH = ./examples/TQ4lib/Cpp/Matthias/crfe EX4PATH = ./examples/TQ4lib/Cpp/Matthias/feni EX5PATH = ./examples/TQ4lib/Cpp/Matthias #=============================================================================# #Available compilation flags: all, OCASI, OCASIEXAMPLES, clean .PHONY : all OCASI OCASIEXAMPLES clean #Compiles OpenCalphad to use as standalone Thermodynamic Equilibrium Calculation #software. # ************************************ # OC now requires GNUPLOT 5.2 or later # ************************************ # To have the command line editing and history feature on your OS # you must uncomment the appropriate line after the header getkey.o: all: $(OBJS) $(EXE) #Compiles the OCASI interfaces of OpenCalphad, so third party software can #interact with OpenCalphad. Interfaces are provided in C++ and Fortran, and #additional interfaces are available in C and Python. OCASI: make $(OBJS) $(LIBS) ar sq liboctq-f90.a liboctq.o $(OBJS) ar sq liboctq-isoc.a liboctqisoc.o liboctq.o $(OBJS) ar sq liboctqcpp.a liboctqcpp.o liboctqisoc.o liboctq.o $(OBJS) $(CPP) -shared liboctqcpp.o liboctqisoc.o liboctq.o $(OBJS) -o $(EXE)_OCASI.so -lgfortran #Compiles the OCASI interface and various examples. OCASIEXAMPLES: make OCASI $(FC) -o $(EX1PATH)/tqex1 $(EX1PATH)/TQ1-crfe.F90 liboctq-f90.a -fopenmp $(FC) -o $(EX2PATH)/tqex2 $(EX2PATH)/TQ2-feni.F90 liboctq-f90.a -fopenmp $(CPP) -o $(EX3PATH)/tqex1 $(EX3PATH)/tqex1.cpp liboctqcpp.a -lgfortran -fopenmp $(CPP) -o $(EX4PATH)/tqex2 $(EX4PATH)/tqex2.cpp liboctqcpp.a -lgfortran -fopenmp $(CPP) -o $(EX5PATH)/tqex3 $(EX5PATH)/tqex3.cpp liboctqcpp.a -lgfortran -fopenmp clean: rm -r *.mod *.a $(LIBS) $(OBJS) linkoc $(EXE)_OCASI.so $(EXE) $(EX1PATH)/tqex1 $(EX2PATH)/tqex2 $(EX3PATH)/tqex1 $(EX4PATH)/tqex2 $(EX5PATH)/tqex3 #==============================================================================# # IMPORTRANT 1: # To have the command line editing and history feature on your OS # you must uncomment the appropriate line after the header getkey.o: # Default is Linux getkey.o: echo "Do not forget to uncomment the correct line below for your OS" # compile utilities/GETKEY for command line editing # uncomment the line for the kind of Linux system you have # Mac >> #$(C) -c $(FCOPT) -DBSD src/utilities/GETKEY/getkey.c # Linux >> $(C) -c -DLinux src/utilities/GETKEY/getkey.c # other UNIX systems >> #$(C) -c -DG77 src/utilities/GETKEY/getkey.c # CYGWIN >> #$(C) -c -DCYGWIN src/utilities/GETKEY/getkey.c # If you have not uncommented any getkey.c line above COMMENT next line # and also remove the -Dlixed option for the metlib4.F90 M_getkey.o: $(FC) -c $(FCOPT) src/utilities/GETKEY/M_getkey.F90 tinyfiledialogs.o: $(C) -c src/utilities/TINYFILEDIALOGS/tinyfiledialogs.c tinyopen.o: $(C) -c src/utilities/TINYFILEDIALOGS/tinyopen.c ftinyopen.o: $(FC) -c $(FCOPT) src/utilities/TINYFILEDIALOGS/ftinyopen.F90 metlib4.o: src/utilities/metlib4.F90 $(FC) -c $(FCOPT) src/models/ocparam.F90 # lixed for command line editing, # tinyfd for open files # lixhlp for browser help on Linux and MacOS $(FC) -c $(FCOPT) -Dlixed -Dtinyfd -Dlixhlp src/utilities/metlib4.F90 oclablas.o: src/numlib/oclablas.F90 $(FC) -c $(FCOPT) src/numlib/oclablas.F90 ocnum.o: src/numlib/ocnum.F90 $(FC) -c $(FCOPT) -DNOLAPACK src/numlib/ocnum.F90 minpack1.o: src/numlib/minpack1.F90 $(FC) -c $(FCOPT) src/numlib/minpack1.F90 gtp3.o: src/models/gtp3.F90 $(FC) -c $(FCOPT) src/models/gtp3.F90 matsmin.o: src/minimizer/matsmin.F90 $(FC) -c $(FCOPT) src/minimizer/matsmin.F90 smp2.o: src/stepmapplot/smp2.F90 # Remove -Dnotwin if compiled on Windows (for spawning) $(FC) -c $(FCOPT) -Dnotwin src/stepmapplot/smp2.F90 # IMPORTANT 2: select GNUPLOT terminal pmon6.o: src/userif/pmon6.F90 # default wxt graphical driver # use -Dqtplt for Qt or (also smaller window) # use -Daqplt for aqua plot drivers (also smaller window) # use -Dx11 for X11 plot drivers DEFAULT # use -Dlixhlp for online help in Linux # use -Dmachlp for online help in MacOS (browser) $(FC) -c $(FCOPT) -Dx11 -Dlixhlp src/userif/pmon6.F90 liboctq.o: ./examples//TQ4lib/Cpp/liboctq.F90 $(FC) -c -g $(FCOPT) ./examples/TQ4lib/Cpp/liboctq.F90 liboctqisoc.o: ./examples/TQ4lib/Cpp/Matthias/liboctqisoc.F90 $(FC) -c -g $(FCOPT) ./examples/TQ4lib/Cpp/Matthias/liboctqisoc.F90 liboctqcpp.o: ./examples/TQ4lib/Cpp/Matthias/liboctqcpp.cpp $(CPP) -c -g $(FCOPT) ./examples/TQ4lib/Cpp/Matthias/liboctqcpp.cpp $(EXE): # Add date of linking to main program cp src/pmain1.F90 src/pmain1-save.F90 $(FC) -o linkoc src/linkocdate.F90 ./linkoc rm src/pmain1-save.F90 # create library liboceq.a mkdir -p libs ar sq libs/liboceq.a metlib4.o oclablas.o ocnum.o gtp3.o matsmin.o minpack1.o # If getkey.o is undefined below # you have forgotten to uncomment a line above at getkey.o !! # static: $(FC) -o $(EXE) $(FCOPT) -static-libgfortran pmain1.F90 $(OBJS) liboceq.a #$(FC) -o $(EXE) $(FCOPT) src/pmain1.F90 $(OBJS) libs/liboceq.a $(FC) -o $(EXE) $(FCOPT) src/pmain1.F90 pmon6.o smp2.o ftinyopen.o tinyopen.o tinyfiledialogs.o getkey.o libs/liboceq.a ================================================ FILE: Makefile.am ================================================ AUTOMAKE_OPTIONS = subdir-objects .NOTPARALLEL: SUBDIRS= DIST_SUBDIRS= AM_FCFLAGS=-Dnotwin @OPENMP_FCFLAGS@ bin_PROGRAMS= OC lib_LTLIBRARIES= libOC.la lib_LTLIBRARIES+= libOPENCALPHAD.la if WITH_PYTHON # SUBDIRS+= OCisoCbinding/pyOC PYTHONdir=$(prefix)/python dist_PYTHON_DATA = OCisoCbinding/pyOC/pyOC.py \ OCisoCbinding/pyOC/pyOCUnitTest.py \ OCisoCbinding/pyOC/example.ipynb \ OCisoCbinding/pyOC/example.py libpyOC_la_SOURCES = OCisoCbinding/pyOC/pyOC.f90 libpyOC_la_FCFLAGS = -I. libpyOC_la_DEPENDENCIES = libOPENCALPHAD.la lib_LTLIBRARIES += libpyOC.la endif EXTRA_DIST=src/models/gtp3A.F90 \ src/models/gtp3B.F90 \ src/models/gtp3C.F90 \ src/models/gtp3D.F90 \ src/models/gtp3E.F90 \ src/models/gtp3F.F90 \ src/models/gtp3G.F90 \ src/models/gtp3H.F90 \ src/models/gtp3X.F90 \ src/models/gtp3Y.F90 \ src/models/gtp3Z.F90 \ src/models/ocparam.F90 \ src/stepmapplot/smp2A.F90 \ src/stepmapplot/smp2B.F90 \ OCisoCbinding/octqc.h \ doc/manual/ochelp.html\ doc/manual/ochelp.pdf manualdir=$(pkgdatadir)/doc/manual dist_manual_SCRIPTS = \ doc/manual/ochelp.html\ doc/manual/ochelp.pdf ############################################# # files used to build the libOC.la library # It is then used to build the OC executable # and the libOPENCALPHAD.la shared library ############################################# libOC_la_SOURCES= \ src/models/ocparam.F90 \ src/utilities/metlib4.F90 OC_FCFLAGS= if WITH_OCHELP OC_FCFLAGS+= -Dlixed -Dtinyfd -Dlixhlp endif if WITH_OCPLOT OC_FCFLAGS+= -Dx11 endif if WITH_LAPACK OC_FCFLAGS +=-Dnotwin #LAPACKLIBS = -L$(LAPACKLIB) -llapack -L$(LAPACKLIB) -lrefblas LAPACKLIBS = -llapack -lblas else OC_FCFLAGS +=-Dnotwin -DNOLAPACK AM_FCFLAGS += -DNOLAPACK libOC_la_SOURCES +=src/numlib/oclablas.F90 endif libOC_la_SOURCES +=src/numlib/ocnum.F90 \ src/numlib/minpack1.F90 \ src/models/gtp3.F90 \ src/minimizer/matsmin.F90 ######################################## # files used to build the OC executable ######################################## BUILT_SOURCES=libOC.la OC_SOURCES= \ src/stepmapplot/smp2.F90 \ src/userif/pmon6.F90 \ src/pmain1.F90 OC_LDADD=libOC.la @OPENMPLIB@ $(LAPACKLIBS) OC_DEPENDENCIES=libOC.la ########################################################### # files used to build the libOPENCALPHAD.la shared library ########################################################### libOPENCALPHAD_la_SOURCES= \ OCisoCbinding/liboctq.F90 \ OCisoCbinding/liboctqisoc.F90 libOPENCALPHAD_la_LIBADD=libOC.la @OPENMPLIB@ libOPENCALPHAD_la_DEPENDENCIES=libOC.la ############################################################ # Some targets for standalone execution ############################################################ if WITH_PYTHON PYTHON_MODN = rawpyOC F90WRAP = ${CURDIR}/f90wrap/bin/f90wrap F2PY = ${CURDIR}/f90wrap/bin/f2py-f90wrap all-local: _${PYTHON_MODN}.so f90wrap: git clone https://github.com/jameskermode/f90wrap.git f90wrap # cd f90wrap && $(PYTHON) setup.py install* touch f90wrap/installedFiles cd f90wrap && $(PYTHON) setup.py install --single-version-externally-managed --prefix $(CURDIR)/f90wrap --record $(CURDIR)/f90wrap/installedFiles _${PYTHON_MODN}.so: export LDFLAGS=-Wl,-rpath=$(libdir) -L./.libs _${PYTHON_MODN}.so: export NPY_DISTUTILS_APPEND_FLAGS=1 _${PYTHON_MODN}.so: libpyOC.la f90wrap $(F90WRAP) -m $(PYTHON_MODN) $(top_srcdir)/OCisoCbinding/pyOC/pyOC.f90 #-v $(F2PY) --fcompiler=$(FC) --build-dir . -c -m _$(PYTHON_MODN) -lOPENCALPHAD -L. -lpyOC f90wrap*.f90 ln -s _${PYTHON_MODN}*.so _${PYTHON_MODN}.so install-data-hook: export OCPUBLICDATA=$(abs_top_srcdir)/examples/macros install-data-hook: cp _${PYTHON_MODN}.so $(PYTHONdir) cp ${PYTHON_MODN}.py $(PYTHONdir) cd $(PYTHONdir) && ${PYTHON} pyOCUnitTest.py endif .PHONY: doc clean-local: find . -name "*.mod" |xargs rm -f find . -name "*.info" |xargs rm -f install-data-local: $(mkinstalldirs) $(DESTDIR)$(bindir) @echo "# This script is generated by make install " >$(DESTDIR)$(bindir)/envOC.sh @echo "# Use it to set environment for running from install dir" >> $(DESTDIR)$(bindir)/envOC.sh @echo "" >> $(DESTDIR)$(bindir)/envOC.sh @echo "## OCHOME " >>$(DESTDIR)$(bindir)/envOC.sh @echo "export OCHOME=$(manualdir)/" >>$(DESTDIR)$(bindir)/envOC.sh @echo 'LD_LIBRARY_PATH=$$LD_LIBRARY_PATH:$(DESTDIR)/lib' >> $(DESTDIR)$(bindir)/envOC.sh @echo 'PATH=$(DESTDIR)$(bindir):$$PATH' >> $(DESTDIR)$(bindir)/envOC.sh @echo "export PATH" >> $(DESTDIR)$(bindir)/envOC.sh @echo "" >> $(DESTDIR)$(bindir)/envOC.sh uninstall-local: $(RM) $(DESTDIR)$(bindir)/envOC.sh distclean-local: $(RM) configure.ac configure build_configure.log find . -name "Makefile.in" |xargs $(RM) -f $(RM) -r config CLEANFILES=envOC.sh DISTCLEANFILES=envOC.sh ================================================ FILE: Makefile_Claude ================================================ # # Makefile for Open Calphad (OC) - Claude version # # Targets: all, debug, clean # # ************************************ # OC now requires GNUPLOT 5.2 or later # ************************************ EXE = oc7C LIBS_A = libs/liboceq.a #============================================================================== # Compiler selection #============================================================================== FC = gfortran CPP = g++ # Auto-detect OS # Override any variable on the command line, e.g.: make PLOTFLAG=-Daqplt UNAME := $(shell uname) ifeq ($(UNAME), Darwin) C = cc GETKEY_OS = -DBSD HELPFLAG = -Dmachlp PLOTFLAG = -Dqtplt # Qt driver; use -Daqplt for Aqua WINFLAG = -Dnotwin else ifneq (,$(findstring CYGWIN, $(UNAME))) C = gcc GETKEY_OS = -DCYGWIN HELPFLAG = # no browser help on Cygwin PLOTFLAG = # wxt is gnuplot default; no flag needed WINFLAG = # Windows spawning: do NOT define notwin else # Linux and other Unix C = gcc GETKEY_OS = -DLinux HELPFLAG = -Dlixhlp PLOTFLAG = # wxt is gnuplot default; no flag needed WINFLAG = -Dnotwin # Other UNIX (AIX, HP-UX, etc.): override with make GETKEY_OS=-DG77 endif #============================================================================== # Compiler flags — gfortran (default) or ifort #============================================================================== ifneq (,$(findstring ifort, $(FC))) # Intel Fortran FCOMP = -O2 -qopenmp -fPIC -zero FCDEBUG = -check bounds -zero else # GNU Fortran (gfortran) FCOMP = -O2 -fopenmp -fPIC -finit-local-zero FCDEBUG = -O1 -fopenmp -fbounds-check -finit-local-zero endif FCOPT = $(FCOMP) #============================================================================== # Object files (in link order) #============================================================================== OBJS = getkey.o M_getkey.o ftinyopen.o tinyopen.o tinyfiledialogs.o \ ocparam.o metlib4.o oclablas.o ocnum.o minpack1.o \ gtp3.o matsmin.o smp2.o pmon6.o #============================================================================== # gtp3.F90 pulls in these files via #include — list them so a change # to any sub-file triggers recompilation of gtp3.o #============================================================================== GTP3_INCS = \ src/models/gtp3_dd1.F90 src/models/gtp3_dd2.F90 src/models/gtp3_xml.F90 \ src/models/gtp3A.F90 src/models/gtp3B.F90 src/models/gtp3C.F90 \ src/models/gtp3D.F90 src/models/gtp3E.F90 src/models/gtp3EX.F90 \ src/models/gtp3EY.F90 src/models/gtp3F.F90 src/models/gtp3G.F90 \ src/models/gtp3H.F90 src/models/gtp3X.F90 src/models/gtp3XQ.F90 \ src/models/gtp3Y.F90 src/models/gtp3Z.F90 # smp2.F90 pulls in these files via #include SMP2_INCS = src/stepmapplot/smp2A.F90 src/stepmapplot/smp2B.F90 #============================================================================== .PHONY: all debug clean all: $(EXE) # Debug build: make debug debug: FCOPT = $(FCDEBUG) debug: all #============================================================================== # C / utility objects #============================================================================== getkey.o: src/utilities/GETKEY/getkey.c $(C) -c $(GETKEY_OS) src/utilities/GETKEY/getkey.c M_getkey.o: src/utilities/GETKEY/M_getkey.F90 $(FC) -c $(FCOPT) src/utilities/GETKEY/M_getkey.F90 tinyfiledialogs.o: src/utilities/TINYFILEDIALOGS/tinyfiledialogs.c $(C) -c src/utilities/TINYFILEDIALOGS/tinyfiledialogs.c tinyopen.o: src/utilities/TINYFILEDIALOGS/tinyopen.c $(C) -c src/utilities/TINYFILEDIALOGS/tinyopen.c ftinyopen.o: src/utilities/TINYFILEDIALOGS/ftinyopen.F90 $(FC) -c $(FCOPT) src/utilities/TINYFILEDIALOGS/ftinyopen.F90 #============================================================================== # Fortran modules (in dependency order) #============================================================================== ocparam.o: src/models/ocparam.F90 $(FC) -c $(FCOPT) src/models/ocparam.F90 # metlib4 needs ocparam.mod (from ocparam.o) and M_getkey.mod metlib4.o: src/utilities/metlib4.F90 ocparam.o M_getkey.o ftinyopen.o $(FC) -c $(FCOPT) -Dlixed -Dtinyfd $(HELPFLAG) src/utilities/metlib4.F90 oclablas.o: src/numlib/oclablas.F90 $(FC) -c $(FCOPT) src/numlib/oclablas.F90 ocnum.o: src/numlib/ocnum.F90 $(FC) -c $(FCOPT) -DNOLAPACK src/numlib/ocnum.F90 minpack1.o: src/numlib/minpack1.F90 $(FC) -c $(FCOPT) src/numlib/minpack1.F90 # gtp3 depends on all its #included sub-files plus the modules it USEs gtp3.o: src/models/gtp3.F90 $(GTP3_INCS) ocparam.o ocnum.o metlib4.o $(FC) -c $(FCOPT) src/models/gtp3.F90 matsmin.o: src/minimizer/matsmin.F90 gtp3.o minpack1.o $(FC) -c $(FCOPT) src/minimizer/matsmin.F90 # WINFLAG=-Dnotwin on non-Windows; empty on Cygwin/Windows smp2.o: src/stepmapplot/smp2.F90 $(SMP2_INCS) matsmin.o $(FC) -c $(FCOPT) $(WINFLAG) src/stepmapplot/smp2.F90 # PLOTFLAG: -Dqtplt (Darwin/Qt), -Daqplt (Aqua), or empty (wxt default) pmon6.o: src/userif/pmon6.F90 smp2.o $(FC) -c $(FCOPT) $(PLOTFLAG) $(HELPFLAG) src/userif/pmon6.F90 #============================================================================== # Link #============================================================================== $(EXE): $(OBJS) # Stamp today's date into pmain1.F90 cp src/pmain1.F90 src/pmain1-save.F90 $(FC) -o linkoc src/linkocdate.F90 ./linkoc rm src/pmain1-save.F90 # Build static library mkdir -p libs ar sq $(LIBS_A) metlib4.o oclablas.o ocnum.o gtp3.o matsmin.o minpack1.o # Link final executable $(FC) -o $(EXE) $(FCOPT) src/pmain1.F90 $(OBJS) $(LIBS_A) #============================================================================== clean: rm -f *.o *.mod linkoc $(EXE) rm -f src/pmain1-save.F90 rm -rf libs ================================================ FILE: Makefile_MacOS ================================================ # # Modified but not tested for the new directory structure # OBJS=getkey.o M_getkey.o ftinyopen.o tinyopen.o tinyfiledialogs.o metlib4.o oclablas.o ocnum.o minpack1.o gtp3.o matsmin.o smp2.o ocparam.o pmon6.o LIBS=liboctq.o liboctqisoc.o liboctqcpp.o EXE=oc6P # # IMPORTANT check at the getkey.o: label # # echo "Do not forget to uncomment a line for your OS" # #=============================================================================# # original provided by Matthias Strathmann including OC examples # NOTE getkey.o : you have to select which getkey routine to compile #=============================================================================# FC=gfortran #=============================================================================# # For MacOS C=cc #=============================================================================# # For other Unix dialects #C=gcc #=============================================================================# CPP=g++ FCOPT= -O2 -fopenmp -fPIC # for debugging #FCOPT= -fbounds-check -finit-local-zero # no parallel #FCOPT= -O2 #FC=ifort # Compiler options for debug, -O1 reduces memory/register operations #FCOPT= -O1 -fbounds-check -g -finit-local-zero #=============================================================================# #Available compilation flags: all, OCASI, OCASIEXAMPLES, clean .PHONY : all OCASI OCASIEXAMPLES clean #Compiles OpenCalphad to use as standalone Thermodynamic Equilibrium Calculation #software. # ************************************ # OC now requires GNUPLOT 5.2 or later # ************************************ # To have the command line editing and history feature on your OS # you must uncomment the appropriate line after the header getkey.o: all: $(OBJS) $(EXE) clean: rm -r *.mod *.a $(LIBS) $(OBJS) linkoc $(EXE)_OCASI.so $(EXE) #==============================================================================# # To have the command line editing and history feature on your OS # you must uncomment the appropriate line after the header getkey.o: getkey.o: echo "The line below for MacOS is used" # compile utilities/GETKEY for command line editing # This makefile use MacOS own cc compiler # Mac >> $(C) -c -DBSD src/utilities/GETKEY/getkey.c # Linux >> #$(C) -c -DLinux src/utilities/GETKEY/getkey.c # other UNIX systems >> #$(C) -c -DG77 src/utilities/GETKEY/getkey.c # CYGWIN >> #$(C) -c -DCYGWIN src/utilities/GETKEY/getkey.c M_getkey.o: $(FC) -c $(FCOPT) src/utilities/GETKEY/M_getkey.F90 tinyfiledialogs.o: $(C) -c src/utilities/TINYFILEDIALOGS/tinyfiledialogs.c tinyopen.o: $(C) -c src/utilities/TINYFILEDIALOGS/tinyopen.c ftinyopen.o: $(FC) -c $(FCOPT) src/utilities/TINYFILEDIALOGS/ftinyopen.F90 metlib4.o: src/utilities/metlib4.F90 $(FC) -c $(FCOPT) src/models/ocparam.F90 # lixed for command line editing, tinyfd for open files # lixhlp for browser help on Linux and MacOS $(FC) -c $(FCOPT) -Dlixed -Dtinyfd -Dlixhlp src/utilities/metlib4.F90 oclablas.o: src/numlib/oclablas.F90 $(FC) -c $(FCOPT) src/numlib/oclablas.F90 ocnum.o: src/numlib/ocnum.F90 $(FC) -c $(FCOPT) -DNOLAPACK src/numlib/ocnum.F90 minpack1.o: src/numlib/minpack1.F90 $(FC) -c $(FCOPT) src/numlib/minpack1.F90 gtp3.o: src/models/gtp3.F90 $(FC) -c $(FCOPT) src/models/gtp3.F90 matsmin.o: src/minimizer/matsmin.F90 $(FC) -c $(FCOPT) src/minimizer/matsmin.F90 smp2.o: src/stepmapplot/smp2.F90 # Remove -Dnotwin if compiled on Windows (for spawning) $(FC) -c $(FCOPT) -Dnotwin src/stepmapplot/smp2.F90 pmon6.o: src/userif/pmon6.F90 # default wxt graphical driver # use -Dqtplt for Qt or (also smaller window) # use -Daqplt for aqua plot drivers (also smaller window) # use -Dlixhlp for online help in Linux # use -Dmachlp for online help in MacOS (browser) $(FC) -c $(FCOPT) -Dqtplt -Dmachlp src/userif/pmon6.F90 liboctq.o: ./examples/TQ4lib/Cpp/liboctq.F90 $(FC) -c -g $(FCOPT) ./examples/TQ4lib/Cpp/liboctq.F90 liboctqisoc.o: ./examples/TQ4lib/Cpp/Matthias/liboctqisoc.F90 $(FC) -c -g $(FCOPT) ./examples/TQ4lib/Cpp/Matthias/liboctqisoc.F90 liboctqcpp.o: ./examples/TQ4lib/Cpp/Matthias/liboctqcpp.cpp $(CPP) -c -g $(FCOPT) ./examplesTQ4lib/Cpp/Matthias/liboctqcpp.cpp $(EXE): # Add date of linking to main program cp src/pmain1.F90 src/pmain1-save.F90 $(FC) -o linkoc src/linkocdate.F90 ./linkoc rm src/pmain1-save.F90 # create library liboceq.a mkdir -p libs ar sq libs/liboceq.a metlib4.o oclablas.o ocnum.o gtp3.o matsmin.o minpack1.o # If getkey.o is undefined below # you have forgotten to uncomment a line above at getkey.o !! $(FC) -o $(EXE) $(FCOPT) src/pmain1.F90 $(OBJS) libs/liboceq.a # replace the version on Desktop # rm ../../Desktop/$(EXE) # cp $(EXE) ../../Desktop/ ================================================ FILE: OCisoCbinding/liboctq.F90 ================================================ ! ! ! Update proposed by Romain Le Tellier and Clément Introïni ! ! ! Minimal TQ interface. ! ! To compile and link this with an application one must first compile ! and form a library with of the most OC subroutines (oclib.a) ! and to copy this and the corresponding "mov" files from this compilation ! to the folder with this library ! ! NOTE that for the identification of phase and composition sets this TQ ! interface use a Fortran TYPE called gtp_phasetuple containing five integers: ! lokph is the index of the phase in the phlista array ! compset is the composition index starting from 1 ! ixphase is the index of the phase in the phases array ! lokvares is the index of the phase and compset in the phase_varres array ! nextcs if nonzero the index in the phasetuple array of next comp.set ! ! The number of phase tuples is initially equal to the number ! of phases and have the same index. This represent comp.set 1 of the ! phases as each phase has just one composition set. A phase may have ! several comp.sets created by calculations or by commands and these will ! have phase tuple index higher than the number of phases and their index ! is in the order of which they were created. ! This may cause some problems if composition sets are deleted because that ! will change the phase tuple index for those with higher index. So do not ! delete comp.sets or at least be very careful when deleting! ! ! 161103 BOS A few fixes for compatibility for version 4 release ! 150520 BOS added a few subroutines for single phase data and calculations ! 141210 BOS changed to use phase tuples ! 140128 BOS added D2G and phase specific V and G ! 140128 BOS added possibility to calculate without invoking grid minimizer ! 140125 BOS Changed name to liboctq ! 140123 BOS Added ouput of MQ G, V and normalized !------------------------------------------------------------ ! subroutines and functions ! tqini ok initiate ! tqrfil ok read a database file ! tqrpfil ok read specified elements from database file ! ------------------------- ! tqgcom ok get number of system components and their names ! tqgnp ok get number of phase tuples (phases and comp. sets) ! tqgpn ok get name of phase tuple ! tqgpi ok get phase tuple index of phase using its name ! tqgpi2 ok get phase and composition indices of phase using its name ! tqgpcn2 ok get name of consitutent with index c in phase with index n ! tqgpci - get index of constituent of a phase using name ! tqgpcs ok get descrition of constituent c (stoichiometry, mass, charge) ! tqgccf - get stoichiometry of system component as elements ! tqgnpc - get number of constituents in phase ! ------------------------- ! tqcref ok set reference state for component ! tqphsts ok set status of phase tuple ! tqphsts2 ok set status of many phases at the same time ! tqsetc ok set condition ! tqce ok calculate equilibrium ! tqgetv ok get equilibrium results as state variable values ! ------------------------- ! tqgphc1 ok get phase constitution ! tqsphc1 ok set phase constitution ! tqcph1 ok calculate phase properties and return arrays ! tqcph2 ok calculate phase properties and return index ! tqcph3 ok calculate phase properties and return single array ! tqdceq ok delete equilibrium record ! tqcceq ok copy current equilibrium to a new one ! tqselceq ok select new current equilibrium ! tqgdmat ok calculate quantities related to diffusion matrix ! -------- ! reset_conditions ok reset any condition on T ! Change_Status_Phase ok change status of a named phase ! tqlr ok listing of results on screen (for debugging) ! tqlc ok list current conditions (for debugging) ! tqtgsw ok toggle global status word of index i ! tqquiet ok set verbosity ! !------------------------------------------------------------ ! ! The name of this library module liboctq ! ! access to main OC library for equilibrium calculations and models use liboceqplus ! implicit none ! integer, parameter :: maxc=maxel,maxp=maxph ! ! This is for storage and use of components integer nel character, dimension(maxc) :: cnam*24 double precision, dimension(maxc) :: cmass ! Number of phase tuples integer ntup ! use the array PHASETUPLE available from OC ! save phase constitution to speed up calculation by interpolation double precision, allocatable, dimension(:,:) :: ysave ! contains ! !\begin{verbatim} subroutine tqini(n,ceq) ! initiate workspace implicit none integer n ! Not nused, could be used for some initial allocation type(gtp_equilibrium_data), pointer :: ceq ! EXIT: current equilibrium !\end{verbatim} ! these should be provide linits and defaults integer intv(10) double precision dblv(10) intv(1)=-1 ! This call initiates the OC package if (allocated(eqlista)) then call new_gtp endif call init_gtp(intv,dblv) ceq=>firsteq write(*,*)'tqini created: ',ceq%eqname 1000 continue return end subroutine tqini !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqrfil(filename,ceq) ! read all elements from a TDB file implicit none character*(*) filename ! IN: database filename character ellista(10)*2 ! dummy type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} %+ integer iz character elname*2,name*24,refs*24 double precision a1,a2,a3 ! second argument 0 means ellista is ignored, all element read call readtdb(filename,0,ellista) ! ceq=>firsteq nel=noel() do iz=1,nel ! store the element name in the cname array call get_element_data(iz,elname,name,refs,a1,a2,a3) cnam(iz)=elname enddo ! store phase tuples ntup=nooftup() 1000 continue return end subroutine tqrfil !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} %- subroutine tqrpfil(filename,nsel,selel,ceq) ! read TDB file with selection of elements implicit none character*(*) filename ! IN: database filename integer nsel character selel(*)*2 ! IN: elements to be read from the database type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} integer iz character elname*2,name*24,refs*24 double precision a1,a2,a3 ! call readtdb(filename,nsel,selel) if(gx%bmperr.ne.0) goto 1000 ! is this really necessary?? ! ceq=>firsteq nel=noel() do iz=1,nel ! store element name in module array components call get_element_data(iz,elname,name,refs,a1,a2,a3) cnam(iz)=elname enddo ! store phase tuples and indices ntup=nooftup() 1000 continue return end subroutine tqrpfil !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgcom(n,compnames,ceq) ! get system component names. At present the elements implicit none integer n ! EXIT: number of components character*24, dimension(*) :: compnames ! EXIT: names of components type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} integer iz character elname*24,refs*24 double precision a1,a2,a3 do iz=1,nel compnames(iz)=' ' call get_element_data(iz,compnames(iz),elname,refs,a1,a2,a3) ! store name in module array components also (already done when reading TDB) cnam(iz)=compnames(iz) enddo n=nel 1000 continue return end subroutine tqgcom !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgnp(n,ceq) ! get total number of phase tuples (phases and composition sets) ! A second composition set of a phase is normally placed after all other ! phases with one composition set implicit none integer n !EXIT: n is number of phases type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} ! NOTE the number composition sets may change at a calculation or if new ! composition sets are added or deleted explicitly ! This changes the number of phase tuples! ntup=nooftup() n=ntup 1000 continue return end subroutine tqgnp !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgpn(phtupx,phasename,ceq) ! get name of phase tuple with index phtupx (ceq redundant) implicit none integer phtupx ! IN: index in phase tuple array character phasename*(*) !EXIT: phase name, max 24+8 for pre/suffix type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} call get_phasetup_name(phtupx,phasename) 1000 continue return end subroutine tqgpn !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgpi(phtupx,phasename,ceq) ! get phasetuple index of phase phasename (including comp.set (ceq redundant) implicit none integer phtupx !EXIT: phase tuple index character phasename*(*) !IN: phase name type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} call find_phasetuple_by_name(phasename,phtupx) 1000 continue return end subroutine tqgpi !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgpi2(iph,ics,phasename,ceq) ! get indices of phase phasename (ceq redundant) implicit none integer iph, ics !EXIT: phase indices character phasename*(*) !IN: phase name type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium integer phtupx !\end{verbatim} call find_phasetuple_by_name(phasename,phtupx) iph = phasetuple(phtupx)%ixphase ics = phasetuple(phtupx)%compset 1000 continue return end subroutine tqgpi2 !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgpcn2(n,c,csname) ! get name of consitutent with index c in phase with index n ! NOTE An identical routine with different constituent index is tqgpcn implicit none integer n !IN: phase number (not phase tuple) integer c !IN: constituent index sequentially over all sublattices character csname*(*) !EXIT: costituent name !\end{verbatim} double precision mass call get_constituent_name(n,c,csname,mass) 1000 continue return end subroutine tqgpcn2 !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgpci(n,c,constituentname,ceq) ! get index of constituent with name in phase n implicit none integer n !IN: phase index !NO integer c !IN: extended constituent index: 10*species_number+sublattice integer c !IN: sequantial constituent index over all sublattices character constituentname*(*) type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} write(*,*)'tqgpci not implemented yet' gx%bmperr=8888 1000 continue return end subroutine tqgpci !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgpcs(c,nspel,ielno,stoi,smass,qsp) ! get descrition of constituent c (stoichiometry, mass, charge) implicit none integer c !IN: sequential constituent index over all sublattices integer nspel !EXIT: number of elements in species integer ielno(*) !EXIT: element indices double precision stoi(*) !EXIT: stoichiometry of elements double precision smass !EXIT: mass double precision qsp !EXIT: charge of the species double precision extra(10) integer nextra !number of additional values ! call get_species_data(c,nspel,ielno,stoi,smass,qsp,nextra,extra) 1000 continue return end subroutine tqgpcs !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgccf(n1,n2,elnames,stoi,mass,ceq) ! get stoichiometry of component n1 ! n2 is number of elements (dimension of elnames and stoi) implicit none integer n1 !IN: component number integer n2 !EXIT: number of elements in component character elnames(*)*(2) ! EXIT: element symbols double precision stoi(*) ! EXIT: element stoichiometry double precision mass ! EXIT: component mass (sum of element mass) type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} write(*,*)'tqgccf not implemented yet' gx%bmperr=8888 1000 continue return end subroutine tqgccf !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgnpc(n,c,ceq) ! get number of constituents of phase n implicit none integer n !IN: Phase number integer c !EXIT: number of constituents type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} write(*,*)'tqgnpc not implemented yet' gx%bmperr=8888 1000 continue return end subroutine tqgnpc !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqphsts(phtupx,newstat,val,ceq) ! set status of phase tuple: SUSPEND, DORMANT, ENTERED, FIX integer phtupx,newstat double precision val type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium !\end{verbatim} integer n if(phtupx.le.0) then ! if tup<0 change status of all phases do n=1,ntup call change_phtup_status(n,newstat,val,ceq) if(gx%bmperr.ne.0) goto 1000 enddo elseif(phtupx.le.ntup) then call change_phtup_status(phtupx,newstat,val,ceq) else write(*,*)'Illegal phase tuple index',phtupx gx%bmperr=8888 endif 1000 continue return end subroutine tqphsts !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqphsts2(phnames,newstat,val,ceq) ! set status of many phases at the same time: SUSPEND, DORMANT, ENTERED, FIX character phnames*(*) integer newstat double precision val type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium !\end{verbatim} call change_many_phase_status(phnames,newstat,val,ceq) 1000 continue return end subroutine tqphsts2 !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqsetc(stavar,n1,n2,value,cnum,ceq) ! set condition ! stavar is state variable as text ! n1 and n2 are auxilliary indices ! value is the value of the condition ! cnum is returned as an index of the condition. ! to remove a condition the value sould be equial to RNONE ???? ! when a phase indesx is needed it should be 10*nph + ics ! see TQGETV for doucumentation of stavar etc. implicit none integer n1 ! IN: 0 or phase tuple index or component number integer n2 ! IN: 0 or component number integer cnum ! EXIT: sequential number of this condition character stavar*(*) ! IN: character with state variable symbol double precision value ! IN: value of condition type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium !\end{verbatim} integer ip,ip2 character cline*60,selvar*4,cval*24 ! ! write(*,11)'In tqsetc ',stavar(1:len_trim(stavar)),n1,n2,value 11 format(a,a,2i5,1pe14.6) cline=' ' ! extract a value after an = ip=index(stavar,'=') if(ip.gt.0) then selvar=stavar(1:ip-1) cval=stavar(ip:) ip2=index(stavar,'(') if(ip2.gt.0) then ip = ip2 selvar=stavar(1:ip-1) cval=stavar(ip:) endif ! write(*,*)'Value after = :',cval else selvar=stavar cval=' ' endif call capson(selvar) select case(selvar) case default write(*,*)'Condition wrong, not implemented or illegal: ',stavar gx%bmperr=8888; goto 1000 ! Potentials T and P case('T ','P ') if(ip.gt.0) then cline=' '//stavar else ! none condition if( n2.lt.0) then write(cline,109)selvar(1:1) 109 format(' ',a,'=none') ! numerical condition else write(cline,110)selvar(1:1),value 110 format(' ',a,'=',E15.8) endif endif ! Total amount or amount of a component in moles case('N ') if(ip.gt.0) then cline=' '//stavar else if(n1.gt.0) then ! call get_component_name(n1,name,ceq) ! if(gx%bmperr.ne.0) goto 1000 ! none condition if( n2.lt.0) then write(cline,108)selvar(1:1),cnam(n1)(1:len_trim(cnam(n1))) 108 format(' ',a,'(',a,')=none') ! numerical condition else write(cline,112)selvar(1:1),cnam(n1)(1:len_trim(cnam(n1))),value 112 format(' ',a,'(',a,')=',E15.8) endif ! write(*,*)'Setting condition: ',cline(1:len_trim(cline)) else ! none condition if( n2.lt.0) then write(cline,109)selvar(1:1) ! numerical condition else write(cline,110)selvar(1:1),value endif endif endif ! Overall fraction of a component case('X ','W ') ! ?? fraction of phase component not implemented, n1 must be component number ! call get_component_name(n1,cnam,ceq) ! if(gx%bmperr.ne.0) goto 1000 if(ip.gt.0) then cline=' '//stavar else write(cline,120)selvar(1:1),cnam(n1)(1:len_trim(cnam(n1))),value 120 format(1x,a,'(',a,')=',1pE15.8) endif case('H ','V ') ! enthalpy or volume of system if(cval(1:1).eq.'=') then cline=' '//stavar else write(cline,130)selvar(1:1),value 130 format(1x,a,'=',1pE15.8) endif case('MU ','AC ') if(ip.gt.0) then cline=' '//stavar else if(n1.gt.0) then ! none condition if(n2.lt.0) then write(cline,108)selvar(1:1),cnam(n1)(1:len_trim(cnam(n1))) ! numerical condition else write(cline,113)selvar(1:2),cnam(n1)(1:len_trim(cnam(n1))),value 113 format(' ',a2,'(',a,')=',E15.8) endif write(*,*)'Setting condition: ',cline(1:len_trim(cline)) else ! none condition if(n2.lt.0) then write(cline,109)selvar(1:1) ! numerical condition else write(cline,110)selvar(1:1),value endif endif endif ! case .... ! ?? MORE CONDITIONS WILL BE ADDED ... end select ! write(*,*)'tqsetc condition: ',trim(cline) ip=1 call set_condition(cline,ip,ceq) if(gx%bmperr.ne.0) then write(*,*)'Error setting condition: ',cline(1:len_trim(cline)),ip endif 1000 continue return end subroutine tqsetc !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqtgsw(i) ! toggle global status word of index i implicit none integer i !\end{verbatim} if(btest(globaldata%status,i)) then globaldata%status=ibclr(globaldata%status,i) write(*,10) i,'unset ' else globaldata%status=ibset(globaldata%status,i) write(*,10) i,'set ' endif 10 format('bit ',i2 ,a) return end subroutine tqtgsw !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqce(target,n1,n2,value,ceq) ! calculate quilibrium with possible target ! Target can be empty or a state variable with indices n1 and n2 ! value is the calculated value of target implicit none integer n1,n2,mode character target*(*) double precision value logical confirm type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} integer nyfas,j1,j2 ! mode=1 means start values using global gridminimization if(n1.lt.0) then ! this means calculate without grid minimuzer mode=0 confirm=.FALSE. ! calcqeq3 is silent, no listing of phase changes etc. call calceq3(mode,confirm,ceq) else mode=1 call calceq2(mode,ceq) endif if(gx%bmperr.ne.0) goto 1000 ! there may be new composition sets, update ntup ! write(*,*)'Number of phase tuples: ',ntup nyfas=nooftup() ! write(*,*)'Number of phase tuples: ',ntup,nyfas if(nyfas.ne.ntup) then ! write(*,*)'Number of phase tuples changed: ',nyfas,ntup ntup=nyfas endif if(allocated(ysave)) deallocate(ysave) allocate(ysave(nyfas,maxconst)) ! copy the constitution to a local save array ! the intention of saving constitution is to make it possible to interpolate ! the calculation of G if the constitution is changed very little do j1=1,nyfas do j2=1,size(ceq%phase_varres(phasetuple(j1)%lokvares)%yfr) ysave(j1,j2)=ceq%phase_varres(phasetuple(j1)%lokvares)%yfr(j2) enddo enddo 1000 continue return end subroutine tqce !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgetv(stavar,n1,n2,n3,values,ceq) ! get equilibrium results using state variables ! stavar is the state variable IN CAPITAL LETTERS with indices n1 and n2 ! n1 can be a phase tuple index, n2 a component index ! n3 at the call is the dimension of the array values, ! changed to number of values on exit ! value is an array with the calculated value(s), n3 set to number of values. implicit none integer n1,n2,n3 character stavar*(*) double precision values(*) type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !======================================================== ! stavar must be a symbol listed below ! IMPORTANT: some terms explained after the table ! Symbol index1,index2 Meaning (unit) !.... potentials ! T 0,0 Temperature (K) ! P 0,0 Pressure (Pa) ! MU component,0 or ext.phase.index*1,constituent*2 Chemical potential (J) ! AC component,0 or ext.phase.index,constituent Activity = EXP(MU/RT) ! LNAC component,0 or ext.phase.index,constituent LN(activity) = MU/RT !...... extensive variables ! U 0,0 or ext.phase.index,0 Internal energy (J) whole system or phase ! UM 0,0 or ext.phase.index,0 same per mole components ! UW 0,0 or ext.phase.index,0 same per kg ! UV 0,0 or ext.phase.index,0 same per m3 ! UF ext.phase.index,0 same per formula unit of phase ! S*3 0,0 or ext.phase.index,0 Entropy (J/K) ! V 0,0 or ext.phase.index,0 Volume (m3) ! H 0,0 or ext.phase.index,0 Enthalpy (J) ! A 0,0 or ext.phase.index,0 Helmholtz energy (J) ! G 0,0 or ext.phase.index,0 Gibbs energy (J) ! ..... some extra state variables ! NP ext.phase.index,0 Moles of phase ! BP ext.phase.index,0 Mass of moles (kg) ! Q ext.phase.index,0 Internal stability/RT (dimensionless) ! DG ext.phase.index,0 Driving force/RT (dimensionless) !....... amounts of components ! N 0,0 or component,0 or ext.phase.index,component Moles of component ! X component,0 or ext.phase.index,component Mole fraction of component ! B 0,0 or component,0 or ext.phase.index,component Mass of component ! W component,0 or ext.phase.index,component Mass fraction of component ! Y ext.phase.index,constituent*1 Constituent fraction !........ some parameter identifiers ! TC ext.phase.index,0 Magnetic ordering temperature ! BMAG ext.phase.index,0 Aver. Bohr magneton number ! MQ& ext.phase.index,constituent Mobility ! THET ext.phase.index,0 Debye temperature ! LNX ext.phase.index,0 Lattice parameter ! EC11 ext.phase.index,0 Elastic constant C11 ! EC12 ext.phase.index,0 Elastic constant C12 ! EC44 ext.phase.index,0 Elastic constant C44 !........ NOTES: ! *1 The ext.phase.index is 10*phase_number+comp.set_number ! *2 The constituent index is 10*species_number + sublattice_number ! *3 S, V, H, A, G, NP, BP, N, B and DG can have suffixes M, W, V, F also !-------------------------------------------------------------------- ! special addition for TQ interface: d2G/dyidyj ! D2G + phase tuple !-------------------------------------------------------------------- !\end{verbatim} double precision tpfunvalue integer ics,mjj,nph,ki,kj,lp,lokph,lokcs character statevar*60,encoded*2048,name*24,selvar*4,norm*4 ! mjj should be the dimension of the array values ... mjj=n3 selvar=stavar call capson(selvar) ! for state variables like MQ&FE remove the part from & before the select ! write(*,11)'In tqgetv: ',selvar,n1,n2,n3 11 format(a,a,3i5) norm=' ' lp=index(selvar,'&') if(lp.gt.0) then selvar(lp:)=' ' else ! check if variable is normallized ki=len_trim(selvar) if(ki.ge.2) then if(selvar(ki:ki).eq.'M') then norm='M' selvar(ki:)=' ' ki=ki-1 endif endif endif !======================================================================= kj=index(selvar,'(') if(kj.gt.0) then selvar=selvar(1:kj-1) endif ! write(*,*)'tqgetv 0: ',kj,selvar,'>',stavar,'<' select case(selvar) case default write(*,*)'Unknown state variable: ',stavar(1:20),'>:<',selvar gx%bmperr=8888; goto 1000 !-------------------------------------------------------------------- ! T or P case('T ','P ') call get_state_var_value(selvar,values(1),encoded,ceq) n3=1 !-------------------------------------------------------------------- ! chemical potential for a component case('MU ','MUS ') if(n1.lt.-1 .or. n1.eq.0) then write(*,*)'tqgetv 17: component number must be positive' gx%bmperr=8888; goto 1000 elseif(n1 .eq.-1) then ! this means all components statevar=trim(selvar)//'(*)' call get_many_svar(statevar,values,mjj,n3,encoded,ceq) elseif(n1.le.noel()) then statevar=trim(selvar)//'('//trim(cnam(n1))//') ' ! write(*,*)'tqgetv 4: ',statevar(1:len_trim(statevar)) ! we must use index value(1) as the subroutine expect a single variable call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 else write(*,*)'No such component' endif !-------------------------------------------------------------------- ! Amount of moles /mass of components in a phase case('NP ', 'BP ') if(n1.lt.0) then ! all phases statevar=stavar(1:2)//'(*)' ! this returns all composition sets for all phases call get_many_svar(statevar,values,mjj,n3,encoded,ceq) ! this output gives the amounts for all compsets of a phase sequentially ! but here we want them in phase tuple order ! the second argument is the number of values for each phase, here is 1 but ! it can be for example compositions, then it should be number of components call sortinphtup(n3,1,values) else ! NP for just one phase call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar='NP('//trim(name)//') ' call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 endif !-------------------------------------------------------------------- ! Mole or mass fractions case('N ','B ','X ','W ') ! write(*,*)'in tqgetv n,x,w: ',n1,n2,n3 if(n2.eq.0) then if(n1.lt.0) then ! moles, mole or mass fraction of all components for all phases statevar=stavar(1:1)//'(*) ' ! write(*,*)'tqgetv 3: ',mjj,statevar(1:len_trim(statevar)) call get_many_svar(statevar,values,mjj,n3,encoded,ceq) elseif(n1.eq.0) then ! mole fraction for the state variable written as X(FE) ! n1 and n2 not used, just check for wildcard ! write(*,*)'tqgetv 20: ',stavar(1:len_trim(stavar)) if(index(stavar,'*').gt.0) then call get_many_svar(stavar,values,mjj,n3,encoded,ceq) else call get_state_var_value(stavar,values(1),encoded,ceq) endif else ! mole fraction of a single component, no phase specification n3=1 ics=1 ! call get_component_name(n1,name,ceq) ! if(gx%bmperr.ne.0) goto 1000 statevar=stavar(1:1)//'('//trim(cnam(n1))//')' ! write(*,*)'tqgetv 4: ',statevar(1:len_trim(statevar)) call get_state_var_value(statevar,values(1),encoded,ceq) endif elseif(n1.lt.0) then !........................................................ ! for all phases one or several components if(n2.lt.0) then ! this means all components all phases, for example x(*,*) statevar=stavar(1:1)//'(*,*) ' ! write(*,*)'tqgetv 5: ',mjj,statevar(1:len_trim(statevar)) call get_many_svar(statevar,values,mjj,n3,encoded,ceq) ! this output gives the composition for all compsets of a phase sequentially ! but we want them in phase tuple order ! The second argument is the number of values for each phase, noel() ! in this case ics=noel() call sortinphtup(n3,ics,values) else ! a single component in all phases. n2 must not be zero ! call get_component_name(n2,name,ceq) ! if(gx%bmperr.ne.0) goto 1000 if(n2.le.0 .or. n2.ge.noel()) then write(*,*)'No such component' goto 1000 endif ! state variable like w(*,cr), the Cr content in all (stable) phases statevar=stavar(1:1)//'(*,'//cnam(n2)(1:len_trim(cnam(n2)))//')' ! write(*,*)'tqgetv 6: ',mjj,statevar(1:len_trim(statevar)) call get_many_svar(statevar,values,mjj,n3,encoded,ceq) ! this output gives the composition for all compsets of a phase sequentially ! but we want them in phase tuple order ! The second argument is the number of values for each phase, in this case 1 ! ics=noel() ics=1 call sortinphtup(n3,ics,values) endif elseif(n2.lt.0) then ! this means all components in one phase call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=stavar(1:1)//'('//trim(name)//',*) ' call get_many_svar(statevar,values,mjj,n3,encoded,ceq) else ! one component (n2) of one phase (n1) call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=stavar(1:1)//'('//trim(name)//',' call get_component_name(n2,name,ceq) if(gx%bmperr.ne.0) goto 1000 statevar(len_trim(statevar)+1:)=trim(name)//') ' ! write(*,*)'tqgetv 8: ',statevar call get_state_var_value(statevar,values(1),encoded,ceq) endif !-------------------------------------------------------------------- ! volume case('V ') if(norm(1:1).ne.' ') then statevar='V'//norm ki=2 else statevar='V ' ki=1 endif if(n1.gt.0) then ! Volume for a specific phase call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=statevar(1:ki)//'('//trim(name)//') ' call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 else ! Total volume call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 endif !-------------------------------------------------------------------- ! Enthalpy case('H ') ! phase specifier not allowed if(norm(1:1).ne.' ') then statevar='H'//norm ki=2 else statevar='H ' ki=1 endif ! write(*,*)'tqgetv 1: ',n1,ki if(n1.gt.0) then ! Gibbs energy for a specific phase call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=statevar(1:ki)//'('//trim(name)//') ' call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 else ! Total enthalpy call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 endif !-------------------------------------------------------------------- ! Gibbs energy case('G ') ! phase specifier not allowed if(norm(1:1).ne.' ') then statevar='G'//norm ki=2 else statevar='G ' ki=1 endif ! write(*,*)'tqgetv 1: ',n1,ki if(n1.gt.0) then ! Gibbs energy for a specific phase call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=statevar(1:ki)//'('//trim(name)//') ' ! write(*,*)'tqgetv 3: ',statevar call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 else ! Total Gibbs energy call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 endif !-------------------------------------------------------------------- ! Mobilities case('MQ ') call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=stavar(1:len_trim(stavar))//'('//trim(name)//')' ! write(*,*)'statevar: ',statevar call get_state_var_value(statevar,values(1),encoded,ceq) !-------------------------------------------------------------------- ! Second derivatives of the Gibbs energy of a phase case('D2G ') lokcs=phasetuple(n1)%lokvares ! this gives wrong value!! ?? n3=size(ceq%phase_varres(lokcs)%yfr) ! write(*,*)'D2G 3: ',n3 kj=(n3*(n3+1))/2 ! write(*,*)'D2G 3: ',kj do ki=1,kj values(ki)=ceq%phase_varres(lokcs)%d2gval(ki,1) enddo end select !=========================================================================== 1000 continue return end subroutine tqgetv !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgdmat(phtupx,tpval,xknown,cpot,tyst,nend,mugrad,mobval,consnames,n1,ceq) ! equilibrates the constituent fractions of a phase for mole fractions xknown ! and calculates the Darken matrix and unreduced diffusivities ! phtup is phase tuple ! tpval is T and P ! ceq is a datastructure with all relevant thermodynamic data ! cpot are the (calculated) chemical potentials ! tyst is TRUE means no outut ! nend is the number of values returned in mugrad ! mugrad are the derivatives of the chemical potentials wrt mole fractions?? ! mobval are the mobilities implicit none integer phtupx ! IN: index in phase tuple array integer nend logical tyst double precision tpval(*),xknown(*),cpot(*),mugrad(*),mobval(*) character*24, dimension(*) :: consnames integer n1 TYPE(gtp_phasetuple), pointer :: phtup TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer iph, ics, ll double precision mass character*24 spname phtup=>phasetuple(phtupx) call equilph1d(phtup,tpval,xknown,cpot,tyst,nend,mugrad,mobval,ceq) iph=phasetuple(phtupx)%ixphase ics=1 n1 = noconst(iph,ics,firsteq) do ll=1,n1 call get_constituent_name(iph,ll,consnames(ll),mass) enddo end subroutine tqgdmat !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgphc1(n1,nsub,cinsub,spix,yfrac,sites,extra,ceq) ! tq_get_phase_constitution ! This subroutine returns the sublattices and constitution of a phase ! n1 is phase tuple index ! nsub is the number of sublattices (1 if no sublattices) ! cinsub is an array with the number of constítuents in each sublattice ! spix is an array with the species index of the constituents in all sublattices ! sites is an array of the site ratios for all sublattices. ! yfrac is the constituent fractions in same order as in spix ! extra is an array with some extra values: ! extra(1) is the number of moles of components per formula unit ! extra(2) is the net charge of the phase implicit none integer n1,nsub,cinsub(*),spix(*) double precision sites(*),yfrac(*),extra(*) type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} call get_phase_data(phasetuple(n1)%ixphase,phasetuple(n1)%compset,& nsub,cinsub,spix,yfrac,sites,extra,ceq) 1000 continue return end subroutine tqgphc1 !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqsphc1(n1,yfra,extra,ceq) ! tq_set_phase_constitution ! To set the constitution of a phase ! n1 is phase tuple index ! yfra is an array with the constituent fractions in all sublattices ! in the same order as obtained by tqgphc1 ! extra is an array with returned values with the same meaning as in tqgphc1 ! NOTE The constituents fractions are normallized to sum to unity for each ! sublattice and extra is calculated by tqsphc1 ! T and P must be set as conditions. implicit none integer n1 double precision yfra(*),extra(*) type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} call set_constitution(phasetuple(n1)%ixphase,phasetuple(n1)%compset,& yfra,extra,ceq) 1000 continue return end subroutine tqsphc1 !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqcph1(n1,n2,n3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,ceq) ! tq_calculate_phase_properties !vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! WARNIG: this is not a subroutine to calculate chemical potentials ! those can only be obtained by an equilibrium calculation. ! The values returned are partial derivatives of G for the phase at the ! current T, P and phase constitution. The phase constitution has been ! obtained by a previous equilibrium calculation or ! set by the subroutine tqsphc ! The subroutine is equivalent to the "calculate phase" command. ! ! NOTE that values are per formula unit divided by RT, ! divide also by extra(1) in subroutine tqsphc1 to get them per mole component ! !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! calculate G and some or all derivatives for a phase at current composition ! n1 is the phase tuple index ! n2 is 0 if only G and derivatves wrt T and P, 1 also first drivatives wrt ! compositions, 2 if also 2nd derivatives ! n3 is returned as number of constituents (dimension of returned arrays) ! gtp is an array with G, G.T, G:P, G.T.T, G.T.P and G.P.P ! dgdy is an array with G.Yi ! d2gdydt is an array with G.T.Yi ! d2gdydp is an array with G.P.Yi ! d2gdy2 is an array with the upper triangle of the symmetrix matrix G.Yi.Yj ! returned in the order: 1,1; 1,2; 1,3; ... ! 2,2; 2,3; ... ! 3,3; ... ! for indexing one can use the integer function ixsym(i1,i2) implicit none integer n1,n2,n3 double precision gtp(6),dgdy(*),d2gdydt(*),d2gdydp(*),d2gdy2(*) type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer ij,lokres,nofc ! write(*,*)'tqcph1 1: ',ceq%eqname ! write(*,*)'tqcph1 2',phasetuple(n1)%ixphase,phasetuple(n1)%compset !---------------------------------------------------------------------- ! THIS IS NO EQUILIBRIUM, JUST G AND DERIVATIVES FOR CURRENT T, P AND Y call calcg(phasetuple(n1)%ixphase,phasetuple(n1)%compset,n2,lokres,ceq) !---------------------------------------------------------------------- ! write(*,*)'tqcph1 3A',lokres,gx%bmperr n3=size(ceq%phase_varres(lokres)%yfr) ! write(*,*)'tqcph1 3C',n3 ! gval last index is the property, other properties can also be extracted ! t.ex. mobilites ! The application program can also access these data directly ... if(gx%bmperr.eq.0) then do ij=1,6 gtp(ij)=ceq%phase_varres(lokres)%gval(ij,1) enddo do ij=1,n3 dgdy(ij)=ceq%phase_varres(lokres)%dgval(1,ij,1) d2gdydt(ij)=ceq%phase_varres(lokres)%dgval(2,ij,1) d2gdydp(ij)=ceq%phase_varres(lokres)%dgval(3,ij,1) enddo ! size of upper triangle of symetrix matrix nofc=n3*(n3+1)/2 do ij=1,nofc d2gdy2(ij)=ceq%phase_varres(lokres)%d2gval(ij,1) enddo else gtp=zero do ij=1,nofc dgdy(ij)=zero d2gdydt(ij)=zero d2gdydp(ij)=zero enddo nofc=nofc*(nofc+1)/2 do ij=1,nofc d2gdy2(ij)=zero enddo endif 1000 continue return end subroutine tqcph1 !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} %- subroutine tqcph2(n1,n2,n3,n4,ceq) ! tq_calculate_phase_properties !vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! WARNIG: this is not a subroutine to calculate chemical potentials ! those can only be made by an equilibrium calculation. ! The values returned are partial derivatives of G for the phase at the ! current T, P and phase constitution. The phase constitution has been ! obtained by a previous equilibrium calculation or ! set by the subroutine tqsphc ! It corresponds to the "calculate phase" command. ! ! NOTE that values are per formula unit divided by RT, ! divide also by extra(1) in subroutine tqsphc1 to get them per mole component ! !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! calculate G and some or all derivatives for a phase at current composition ! n1 is the phase tuple index ! n2 is type of calculation (0, 1 or 2) ! n3 is returned as number of constituents ! n4 is index to ceq%phase_varres(lokres)% with all results ! for indexing one can use the integer function ixsym(i1,i2) implicit none integer n1,n2,n3,n4 type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer ij,lokres,nofc ! write(*,*)'tqcph1 1: ',ceq%eqname ! write(*,*)'tqcph1 2',phasetuple(n1)%ixphase,phasetuple(n1)%compset !---------------------------------------------------------------------- ! THIS IS NO EQUILIBRIUM, JUST G AND DERIVATIVES FOR CURRENT T, P AND Y call calcg(phasetuple(n1)%ixphase,phasetuple(n1)%compset,n2,lokres,ceq) !---------------------------------------------------------------------- ! write(*,*)'tqcph1 3A',lokres,gx%bmperr ! this should work but gave segmentation fault, find this a more cumbersum way n3=size(ceq%phase_varres(lokres)%yfr) n4=lokres ! Uer can access results like ! ceq%phase_varres(n4)%gval(1..6,1..prop) ! prop=1 is G, other can be t.ex. Curie T, mobilites etc ! ceq%phase_varres(lokres)%dgval(1,ij,1) are dG/dy(ij) ! ceq%phase_varres(lokres)%dgval(2,ij,1) are d2G/dy(ij)dT ! ceq%phase_varres(lokres)%dgval(3,ij,1) are d2G/dy(ij)dP ! ceq%phase_varres(lokres)%d2gval(ij,1) are d2G/dy(i)dy(j) ! arranged as a single dimenion array indexed by ixsym(i,j) ! ! NEVER CHANGE THE CONSTITUTION DIRECTLY, using n4, ALWAYS CALL tqsph1(...) ! 1000 continue return end subroutine tqcph2 !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqcph3(n1,n2,g,ceq) ! tq_calculate_phase_properties !vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! WARNIG: this is not a subroutine to calculate chemical potentials ! those can only be made by an equilibrium calculation. ! The values returned are partial derivatives of G for the phase at the ! current T, P and phase constitution. The phase constitution has been ! obtained by a previous equilibrium calculation or ! set by the subroutine tqsphc ! It corresponds to the "calculate phase" command. ! ! NOTE that values are per formula unit divided by RT, ! divide also by extra(1) in subroutine tqsphc1 to get them per mole component ! !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! calculate G and some or all derivatives for a phase at current composition ! n1 is the phase tuple index ! n2 is 0 if only G and derivatves wrt T and P, 1 also first drivatives wrt ! compositions, 2 if also 2nd derivatives ! g is an array with G derivatives under the form: ! G_m^\alpha = G_M^\alpha/N^\alpha, \frac{\partial G_m^\alpha}{\partial T}, \frac{\partial G_m^\alpha}{\partial P}, \frac{\partial^2 G_m^\alpha}{\partial T^2} ! 1/N^\alpha * \frac{\partial G_M^\alpha}{\partial y_i} (if n2>=1) ! 1/N^\alpha * \frac{\partial^2 G_M^\alpha}{\partial y_i\partial y_j} (if n2>=2) implicit none integer n1,n2 double precision g(*) type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer lokres integer ncons, ndcons, count double precision napfu, rgast TYPE(gtp_phase_varres), pointer :: parres !---------------------------------------------------------------------- ! THIS IS NO EQUILIBRIUM, JUST G AND DERIVATIVES FOR CURRENT T, P AND Y call calcg(phasetuple(n1)%ixphase,phasetuple(n1)%compset,n2,lokres,ceq) !---------------------------------------------------------------------- ncons=noconst(phasetuple(n1)%ixphase,phasetuple(n1)%compset,firsteq) ndcons=ncons*(ncons+1)/2 count=1 napfu=ceq%phase_varres(lokres)%abnorm(1) rgast=globaldata%rgas*ceq%tpval(1) parres=>ceq%phase_varres(lokres) ! G_m^\alpha = G_M^\alpha/N^\alpha, \frac{\partial G_m^\alpha}{\partial T}, \frac{\partial G_m^\alpha}{\partial P}, \frac{\partial^2 G_m^\alpha}{\partial T^2} g(count:count+3) = rgast*parres%gval(1:4,1)/napfu count = count + 4 if (n2>0) then ! 1/N^\alpha * \frac{\partial G_M^\alpha}{\partial y_i} g(count:count+ncons-1) = rgast*parres%dgval(1,1:ncons,1)/napfu count = count + ncons if (n2>1) then ! 1/N^\alpha * \frac{\partial^2 G_M^\alpha}{\partial y_i\partial y_j} g(count:count+ndcons-1) = rgast*parres%d2gval(1:ndcons,1)/napfu endif endif end subroutine tqcph3 !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqdceq(name) ! delete equilibrium with name implicit none character name*24 ! integer n1 !\end{verbatim} integer n1 call findeq(name,n1) ! print *, name, n1 if(gx%bmperr.ne.0) goto 1000 ! do not allow delete equilibrium 1 if(n1.eq.1) then write(*,*)'No allowed to delete default equilibrium' gx%bmperr=4333 goto 1000 endif call delete_equilibria(name,firsteq) 1000 continue return end subroutine tqdceq !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqcceq(name,n1,newceq,ceq) ! copy_current_equilibrium to newceq ! creates a new equilibrium record with name with values same as ceq ! n1 is returned as index implicit none character name*24 integer n1 type(gtp_equilibrium_data), pointer :: newceq,ceq !\end{verbatim} !call enter_equilibrium(name,n1) !if(gx%bmperr.ne.0) goto 1000 !newceq=>eqlista(n1) call copy_equilibrium(newceq,name,ceq) newceq%status=ibclr(newceq%status,EQNOACS) 1000 continue return end subroutine tqcceq !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqselceq(name,ceq) ! select current equilibrium to be that with name. ! Note that equilibria can be deleted and change number but not name implicit none character name*24 type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer n1 call findeq(name,n1) ! print *, name, n1 if(gx%bmperr.ne.0) goto 1000 call selecteq(n1,ceq) ! print *, name, n1, loc(ceq) 1000 continue return end subroutine tqselceq !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine reset_conditions(cline,ceq) !reset any condition on temperature implicit none character cline*24 type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer ip ip=0 ! write(*,*) cline call set_condition(cline,ip,ceq) 1000 continue return end subroutine reset_conditions !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine Change_Status_Phase(myname,nystat,myval,ceq) implicit none character myname*24 integer nystat double precision myval type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer iph,ics call find_phase_by_name(myname,iph,ics) call change_phase_status(iph,ics,nystat,myval,ceq) 1000 continue return end subroutine Change_Status_Phase !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqcref(ciel,phase,tpref,ceq) ! set component reference state integer ciel character phase*(*) double precision tpref(*) type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium !\end{verbatim} integer phtupx call find_phasetuple_by_name(phase,phtupx) if(gx%bmperr.ne.0) goto 1000 call set_reference_state(ciel,phtupx,tpref,ceq) 1000 continue return end subroutine tqcref !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqlr(lut,ceq) ! list the equilibrium results like in OC implicit none integer lut type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer phtupx,iph,ics,lokvares,mode logical once write(lut,10) 10 format(/20('*')/'Start debug output from TQLR: ') call list_conditions(lut,ceq) call list_global_results(lut,ceq) call list_components_result(lut,1,ceq) once=.TRUE. mode=0 do phtupx=1,nooftup() lokvares=phasetuple(phtupx)%lokvares if(ceq%phase_varres(lokvares)%phstate.ge.phentstab) then iph=phasetuple(phtupx)%ixphase ics=phasetuple(phtupx)%compset call list_phase_results(iph,ics,mode,lut,once,ceq) endif enddo write(lut,20) 20 format('End debug output from TQLR'/20('*')/) 1000 continue return end subroutine tqlr !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqlc(lut,ceq) ! list conditions like in OC implicit none integer lut type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} write(lut,10) 10 format(/'Debug output from TQLC: ') call list_conditions(lut,ceq) 1000 continue return end subroutine tqlc !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqquiet(yes) ! if argument TRUE spurious output should be suppressed implicit none logical yes !\end{verbatim} if(yes) then globaldata%status=ibclr(globaldata%status,GSVERBOSE) globaldata%status=ibset(globaldata%status,GSSILENT) else globaldata%status=ibset(globaldata%status,GSVERBOSE) endif return end subroutine tqquiet !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ end MODULE LIBOCTQ ================================================ FILE: OCisoCbinding/liboctqisoc.F90 ================================================ ! ! ! Part of iso-C binding for OC TQlib from Teslos ! modified by Matthias Stratmann, Christophe Sigli, ! and Bo Sundman ! ! Update proposed by Romain Le Tellier and Clément Introïni ! MODULE cstr ! ! convert characters from Fortran to C and vice versa contains function c_to_f_string(s) result(str) use iso_c_binding implicit none character(kind=c_char,len=1), intent(in) :: s(*) character(len=:), allocatable :: str integer i, nchars i = 1 do if (s(i) == c_null_char) exit i = i + 1 end do nchars = i - 1 ! Exclude null character from Fortran string allocate(character(len=nchars) :: str) str = transfer(s(1:nchars), str) end function c_to_f_string !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! subroutine c_to_f_str(s,sty) use iso_c_binding implicit none character(kind=c_char,len=1), intent(in) :: s(*) character(len=24), intent(out) :: sty character(len=:), allocatable :: str integer i, nchars i = 1 do if (s(i) == c_null_char) exit i = i + 1 end do nchars = i - 1 ! Exclude null character from Fortran string allocate(character(len=nchars) :: str) sty = transfer(s(1:nchars), str) deallocate (str) end subroutine c_to_f_str !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! subroutine f_to_c_string(fstring, cstr) use iso_c_binding implicit none character(len=24) :: fstring character(kind=c_char, len=1), intent(out) :: cstr(*) integer i do i = 1, len(fstring) cstr(i) = fstring(i:i) cstr(i+1) = c_null_char end do end subroutine f_to_c_string END MODULE cstr !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! ! ! module liboctqisoc ! !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! MODULE liboctqisoc ! ! OCTQlib with iso-C binding ! use iso_c_binding use cstr use liboctq ! use general_thermodynamic_package implicit none integer(c_int), bind(c) :: c_niter=-1 integer(c_int), bind(c) :: c_nel=-1 integer(c_int), bind(c) ::c_maxc=40, c_maxp=500 type(c_ptr), bind(c), dimension(maxc) :: c_cnam character(len=25), dimension(maxc), target :: cnames real(c_double), bind(c), dimension(maxc) :: c_mass integer(c_int), bind(c) :: c_ntup TYPE, bind(c) :: c_gtp_equilibrium_data ! this contains all data specific to an equilibrium like conditions, ! status, constitution and calculated values of all phases etc ! Several equilibria may be calculated simultaneously in parallell threads ! so each equilibrium must be independent ! NOTE: the error code must be local to each equilibria!!!! ! During step and map these records with results are saved ! values of T and P, conditions etc. ! Values here are normally set by external conditions or calculated from model ! local list of components, phase_varres with amounts and constitution ! lists of element, species, phases and thermodynamic parameters are global ! tpval(1) is T, tpval(2) is P, rgas is R, rtn is R*T ! status: not used yet? ! multiuse: used for various things like direction in start equilibria ! eqno: sequential number assigned when created ! next: index of next equilibrium in a sequence during step/map calculation. ! eqname: name of equilibrium ! tpval: value of T and P ! rtn: value of R*T integer(c_int) :: status,multiuse,eqno,next character(c_char) :: eqname(24) real(c_double) :: tpval(2),rtn ! svfunres: the values of state variable functions valid for this equilibrium type(c_ptr) :: svfunres ! the experiments are used in assessments and stored like conditions ! lastcondition: link to condition list ! lastexperiment: link to experiment list TYPE(c_ptr) :: lastcondition,lastexperiment ! components and conversion matrix from components to elements ! complist: array with components ! compstoi: stoichiometric matrix of compoents relative to elements ! invcompstoi: inverted stoichiometric matrix TYPE(c_ptr) :: complist real(c_double) :: compstoi real(c_double) :: invcompstoi ! one record for each phase+composition set that can be calculated ! phase_varres: here all calculated data for the phase is stored TYPE(c_ptr) :: phase_varres ! index to the tpfun_parres array is the same as in the global array tpres ! eq_tpres: here local calculated values of TP functions are stored TYPE(c_ptr) :: eq_tpres ! current values of chemical potentials stored in component record but ! duplicated here for easy acces by application software real(c_double) :: cmuval ! xconc: convergence criteria for constituent fractions and other things real(c_double) :: xconv ! delta-G value for merging gridpoints in grid minimizer ! smaller value creates problem for test step3.BMM, MC and austenite merged real(c_double) :: gmindif ! maxiter: maximum number of iterations allowed integer(c_int) :: maxiter !CCI ! conv_iter: number of iterations reached after the equilibrium calculation integer(c_int) :: conv_iter !CCI ! this is to save a copy of the last calculated system matrix, needed ! to calculate dot derivatives, initiate to zero integer(c_int) :: sysmatdim=0,nfixmu=0,nfixph=0 integer(c_int) :: fixmu integer(c_int) :: fixph real(c_double) :: savesysmat END TYPE c_gtp_equilibrium_data contains ! functions !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! integer function c_noofcs(iph) bind(c, name='c_noofcs') integer(c_int), value :: iph c_noofcs = noofcs(iph) return end function c_noofcs !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! integer function c_noconst(iph,ics,c_ceq) bind(c, name='c_noconst') integer(c_int), intent(in), value :: iph integer(c_int), intent(in), value :: ics type(c_ptr), intent(inout) :: c_ceq type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) c_noconst = noconst(iph,ics,ceq) nullify(ceq) return end function c_noconst !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! subroutine examine_gtp_equilibrium_data(c_ceq) & bind(c, name='examine_gtp_equilibrium_data') type(c_ptr), intent(in), value :: c_ceq type(gtp_equilibrium_data), pointer :: ceq integer :: i,j call c_f_pointer(c_ceq, ceq) write(*,10) ceq%status, ceq%multiuse, ceq%eqno 10 format(/'gtp_equilibrium_data: status, multiuse, eqno, next'/, 3i4) write(*,20) ceq%eqname 20 format(/'Name of equilibrium'/,a) write(*,30) ceq%tpval, ceq%rtn 30 format(/'Value of T and P'/, 2f8.3, /'R*T'/, f8.4) do i = 1, size(ceq%compstoi,1) write(*,*) (ceq%compstoi(i,j), j=1,size(ceq%compstoi,2)) end do write(*,*) ceq%cmuval write(*,*) ceq%xconv write(*,*) ceq%gmindif write(*,*) ceq%maxiter write(*,*) ceq%sysmatdim, ceq%nfixmu, ceq%nfixph write(*,*) ceq%fixmu, ceq%fixph, ceq%savesysmat end subroutine examine_gtp_equilibrium_data !CCI !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} ! Get the stoichiometric factor of an element in a species given by name ! species_name: name of the species (input character) ! iel: index of the element (input intger) ! el_name: name of the element (output character) ! stoi: value of the stoichiometric coefficient (output real) ! subroutine get_stoichiometric_coef(species_name, iel, el_name, c_stoi) bind(c, name='c_get_stoichiometry') character(kind=c_char), intent(in) :: species_name integer(c_int), intent(in), value :: iel character(kind=c_char), intent(inout) :: el_name(24) real(c_double), intent(inout) :: c_stoi !\end{verbatim} integer :: loksp character(len=:), allocatable :: eq_species_name character :: fstring*24 ! Get the index of the species by its name eq_species_name = c_to_f_string(species_name) call find_species_record_exact(eq_species_name,loksp) if(gx%bmperr.ne.0) goto 1000 ! Get the stoichiometric coefficient call get_stoichiometry(loksp, iel, fstring, c_stoi) call f_to_c_string(fstring, el_name) 1000 continue deallocate(eq_species_name) return end subroutine get_stoichiometric_coef !CCI !CCI !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} ! Change the stoichiometric factor of a species given by name ! species_name: name of the species (input character) ! new_stoi: new value of the stoichiometric coefficient (input real) ! subroutine change_stoichiometric(species_name,new_stoi) bind(c, name='c_change_stoichiometric') !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! character(kind=c_char), intent(in) :: species_name real(c_double), intent(in), value :: new_stoi !\end{verbatim} integer :: loksp character(len=:), allocatable :: eq_species_name eq_species_name = c_to_f_string(species_name) ! Get the index of the species by its name call find_species_record(eq_species_name,loksp) if(gx%bmperr.ne.0) goto 1000 ! Change the stoichiometric factor (new_stoi) of the loksp-th species call set_new_stoichiometry(loksp,new_stoi) 1000 continue deallocate(eq_species_name) return end subroutine change_stoichiometric !CCI !\begin{verbatim} subroutine getelem() !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! ! ! When an external unformatted file is read without reading any data base ! it is necessary to get the name of each component for setting new conditions ! The number of elements is then updated ut also the number of phase tuples ! for possible using before doing another equilibrium calculation integer iz character elname*2,name*24,refs*24 double precision a1,a2,a3 ! by default, c_nel is initialized to -1 if(c_nel.lt.0) then nel=noel() c_nel=noel() do iz=1,nel call get_element_data(iz,elname,name,refs,a1,a2,a3) cnam(iz)=elname cnames(iz)=trim(elname) // c_null_char c_cnam(iz) = c_loc(cnames(iz)) enddo ntup=nooftup() c_ntup=nooftup() endif ! end subroutine getelem !\end{verbatim} !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqini(n, c_ceq) bind(c, name='c_tqini') integer(c_int), intent(in) :: n type(c_ptr), intent(out) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq integer :: i1,i2 call tqini(n, ceq) c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_tqini !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqvalpfu(phtupx, c_molepfu, c_masspfu, c_napfu, c_ncpfu, c_ceq) bind(c, name='c_tqvalpfu') ! get the number of moles, the mass of components and the number of components/atoms per Formula Units of phase n, ! NOTE: n is phase number, not extended phase index integer(c_int), intent(in), value :: phtupx ! IN: index in phase tuple array real(c_double), intent(inout) :: c_molepfu ! INOUT: moles per FU real(c_double), intent(inout) :: c_masspfu ! INOUT: mass of components per FU real(c_double), intent(inout) :: c_ncpfu ! INOUT: number of components per FU real(c_double), intent(inout) :: c_napfu ! INOUT: number of atoms per FU type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fstring double precision :: napfu character name*(24) call c_f_pointer(c_ceq, ceq) c_ncpfu=ceq%phase_varres(phasetuple(phtupx)%lokvares)%abnorm(1) c_masspfu=ceq%phase_varres(phasetuple(phtupx)%lokvares)%abnorm(2) c_napfu=ceq%phase_varres(phasetuple(phtupx)%lokvares)%abnorm(3) c_molepfu=ceq%phase_varres(phasetuple(phtupx)%lokvares)%amfu c_ceq = c_loc(ceq) nullify(ceq) end subroutine c_tqvalpfu !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqrfil(filename,c_ceq) bind(c, name='c_tqrfil') character(kind=c_char,len=1), intent(in) :: filename(*) type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq character(len=:), allocatable :: fstring integer :: i,j,l character(kind=c_char, len=1),dimension(24), target :: f_pointers ! convert type(c_ptr) to fptr call c_f_pointer(c_ceq, ceq) fstring = c_to_f_string(filename) !CCI : turn off warnings from reading the TDB file !call readtdbsilent !CCI call tqrfil(fstring, ceq) ! after tqrfil ntup variable is defined c_ntup = ntup c_nel = nel do i = 1, nel cnames(i) = trim(cnam(i)) // c_null_char c_cnam(i) = c_loc(cnames(i)) c_mass(i)=cmass(i) write(*,*) cmass(i) end do c_ceq = c_loc(ceq) deallocate(fstring) nullify(ceq) end subroutine c_tqrfil !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqrpfil(filename,nel,c_selel,c_ceq) bind(c, name='c_tqrpfil') !change character(kind=c_char), intent(in) :: filename integer(c_int), intent(in), value :: nel type(c_ptr), intent(in), dimension(nel), target :: c_selel type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq character(len=:), allocatable :: fstring character, pointer :: selel(:) integer :: i character elem(nel)*2 fstring = c_to_f_string(filename) call c_f_pointer(c_ceq, ceq) ! convert the c type selel strings to f-selel strings ! note: additional character is for C terminated '\0' do i = 1, nel call c_f_pointer(c_selel(i), selel, [3]) elem(i) = c_to_f_string(selel) end do !CCI : turn off warnings from reading the TDB file call readtdbsilent !CCI call tqrpfil(fstring, nel, elem, ceq) ! after tqrpfil ntup variable is defined c_ntup = ntup c_nel = nel do i = 1, nel cnames(i) = trim(cnam(i)) // c_null_char c_cnam(i) = c_loc(cnames(i)) c_mass(i)=cmass(i) end do c_ceq = c_loc(ceq) deallocate (fstring) nullify(ceq) end subroutine c_tqrpfil !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgcom(n,components,c_ceq) bind(c, name='c_tqgcom') ! get system components integer(c_int), intent(inout) :: n !character(kind=c_char, len=24), dimension(24), intent(out) :: c_components type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} integer, target :: nc character(len=24) :: fcomponents(maxel) character(kind=c_char, len=1), dimension(maxel*24) :: components type(gtp_equilibrium_data), pointer :: ceq integer :: i,j,l call c_f_pointer(c_ceq, ceq) call tqgcom(nc, fcomponents, ceq) ! convert the F components strings to C l = len(fcomponents(1)) do i = 1, nc do j = 1, l components((i-1)*l+j)(1:1) = fcomponents(i)(j:j) end do ! null termination components(i*l) = c_null_char end do c_ceq = c_loc(ceq) n = nc nullify(ceq) return end subroutine c_tqgcom !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgnp(n, c_ceq) bind(c, name='c_tqgnp') integer(c_int), intent(inout) :: n type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) call tqgnp(n, ceq) c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_tqgnp !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgpn(n,phasename, c_ceq) bind(c, name='c_tqgpn') ! get name of phase n, ! NOTE: n is phase number, not extended phase index integer(c_int), intent(in), value :: n character(kind=c_char, len=1), intent(inout) :: phasename(24) type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fstring integer :: i call c_f_pointer(c_ceq, ceq) ! fstring = c_to_f_string(phasename) call tqgpn(n, fstring, ceq) ! copy the f-string to c-string and end with '\0' call f_to_c_string(fstring, phasename) ! do i=1,len(trim(fstring)) ! phasename(i)(1:1) = fstring(i:i) ! phasename(i+1)(1:1) = c_null_char ! end do c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_tqgpn !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgpi(n,phasename,c_ceq) bind(c, name='c_tqgpi') ! get index of phase phasename integer(c_int), intent(out) :: n character(c_char), intent(in) :: phasename(24) type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fstring call c_f_pointer(c_ceq, ceq) fstring = c_to_f_string(phasename) call tqgpi(n, fstring, ceq) c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_tqgpi !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgpi2(iph,ics,phasename,c_ceq) bind(c, name='c_tqgpi2') ! get index of phase phasename integer(c_int), intent(out) :: iph integer(c_int), intent(out) :: ics character(c_char), intent(in) :: phasename(24) type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fstring call c_f_pointer(c_ceq, ceq) fstring = c_to_f_string(phasename) call tqgpi2(iph, ics, fstring, ceq) c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_tqgpi2 !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgpcn2(n, c, csname) bind(c, name='c_tqgpcn2') ! get name of constituent c in phase n integer(c_int), intent(in), value :: n ! phase number integer(c_int), intent(in), value :: c ! extended constituent index: ! 10*species_number + sublattice character(kind=c_char, len=1), intent(inout) :: csname(24) !\end{verbatim} character(len=24) :: fstring integer :: i call tqgpcn2(n,c,fstring) call f_to_c_string(fstring, csname) ! copy the f-string to c-string and end with '\0' ! do i=1,len(trim(fstring)) ! csname(i)(1:1) = fstring(i:i) ! csname(i+1)(1:1) = c_null_char ! end do end subroutine c_tqgpcn2 !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgpci(n,c, constituentname, c_ceq) bind(c, name='c_tqgpci') ! get index of constituent with name in phase n integer(c_int), intent(in) :: n integer(c_int), intent(out) :: c ! exit: extended constituent index: ! 10*species_number+sublattice character(c_char), intent(in) :: constituentname(24) type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fstring fstring = c_to_f_string(constituentname) call c_f_pointer(c_ceq, ceq) call tqgpci(n, c, fstring, ceq) c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_tqgpci !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgpcs(c,nspel,ielno,stoi,smass,qsp) bind(c, name='c_tqgpcs') !get stoichiometry of constituent c in phase n integer(c_int), intent(in), value :: c ! in: extended constituent index: ! 10*species_number + sublattice integer(c_int), intent(out) :: nspel integer(c_int), intent(out) :: ielno(*) real(c_double), intent(out) :: stoi(*) ! exit: stoichiometry of elements real(c_double), intent(out) :: smass ! exit: total mass real(c_double), intent(out) :: qsp !\end{verbatim} call tqgpcs(c,nspel,ielno,stoi,smass,qsp) end subroutine c_tqgpcs !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgccf(n1,n2,elnames,stoi,mass,c_ceq) ! get stoichiometry of component n1 ! n2 is number of elements ( dimension of elements and stoi ) integer(c_int), intent(in) :: n1 ! in: component number integer(c_int), intent(out) :: n2 ! exit: number of elements in component character(c_char), intent(out) :: elnames(2) ! exit: element symbols real(c_double), intent(out) :: stoi(*) ! exit: element stoichiometry real(c_double), intent(out) :: mass ! exit: component mass ! (sum of element mass) type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) call tqgccf(n1,n2,elnames,stoi, mass, ceq) c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_tqgccf !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgnpc(n,c,c_ceq) bind(c, name='c_tqgnpc') ! get number of constituents of phase n integer(c_int), intent(in) :: n ! in: phase number integer(c_int), intent(out) :: c ! exit: number of constituents type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq,ceq) call tqgnpc(n,c,ceq) c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_tqgnpc !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqphsts(phtupx,newstat,val,c_ceq) bind(c, name='c_tqphsts') ! set status of phase tuple: SUSPEND, DORMANT, ENTERED, FIX integer(c_int), intent(in), value :: phtupx integer(c_int), intent(in), value :: newstat real(c_double), intent(in) :: val type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq,ceq) call tqphsts(phtupx,newstat,val,ceq) c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_tqphsts !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqphsts2(phnames,newstat,val,c_ceq) bind(c, name='c_tqphsts2') ! set status of phase tuple: SUSPEND, DORMANT, ENTERED, FIX character(c_char), intent(in) :: phnames integer(c_int), intent(in), value :: newstat real(c_double), intent(in) :: val type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq character(len=:), allocatable :: fphnames call c_f_pointer(c_ceq,ceq) fphnames = c_to_f_string(phnames) call tqphsts2(fphnames,newstat,val,ceq) c_ceq = c_loc(ceq) nullify(ceq) deallocate(fphnames) return end subroutine c_tqphsts2 !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqsetc(statvar, n1, n2, mvalue, cnum, c_ceq) & bind(c, name='c_tqsetc') ! set condition ! stavar is state variable as text ! n1 and n2 are auxilliary indices ! value is the value of the condition ! cnum is returned as an index of the condition. ! to remove a condition the value sould be equial to RNONE ???? ! when a phase indesx is needed it should be 10*nph + ics ! SEE TQGETV for doucumentation of stavar etc. !>>>> to be modified to use phase tuplets integer(c_int), intent(in),value :: n1 !in: 0 or extended phase index: ! 10*phase_number+comp.set ! or component set integer(c_int), intent(in),value :: n2 ! integer(c_int), intent(out) :: cnum !exit: ! sequential number of this condition character(c_char), intent(in) :: statvar !in: character ! with state variable symbol real(c_double), intent(in),value :: mvalue !in: value of condition type(c_ptr), intent(in) :: c_ceq ! in: current equilibrium type(gtp_equilibrium_data), pointer :: ceq character(len=:), allocatable :: fstatvar ! call c_f_pointer(c_ceq, ceq) fstatvar = c_to_f_string(statvar) call tqsetc(fstatvar, n1, n2, mvalue, cnum, ceq) nullify(ceq) deallocate(fstatvar) end subroutine c_tqsetc !\end{verbatim} !\begin{verbatim} subroutine c_tqcalc(c_ceq,mode) bind(c,name='c_tqcalc') ! calculate equilibrium with different methods ! mode=0 means calculate without grid minimizer ! mode=1 means start values using global gridminimization ! mode=2 means calculate carefully (default) integer(c_int), intent(in),value :: mode integer n logical confirm double precision, allocatable, dimension(:) ::xknown,aphl,cmu integer, allocatable, dimension(:) ::iphl,icsl,nyphl integer nv double precision totam type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq,ceq) ! mode=0 means calculate without global minimizer if(mode.eq.0) then call calceq2(mode,ceq) ! mode=1 means start values using global gridminimization elseif(mode.eq.1) then call calceq2(mode,ceq) ! mode=2 means calculate carefully (default) else ! first parameter 0 means bosses_method, 1 means carefully n=1 ! allocate(xknown(noel())) xknown(:)=0.0 allocate(aphl(noel())) aphl(:)=0.0 allocate(cmu(noel())) cmu(:)=0.0 allocate(iphl(noel())) iphl(:)=0 allocate(icsl(noel())) icsl(:)=0 allocate(nyphl(noel())) nyphl(:)=0 ! call extract_massbalcond(ceq%tpval,xknown,totam,ceq) if(gx%bmperr.eq.0) then call global_gridmin(1,ceq%tpval,xknown,nv,iphl,icsl,& aphl,nyphl,cmu,ceq) if(gx%bmperr.eq.0) then call calculate_carefully(n,ceq) endif endif ! deallocate(xknown) deallocate(aphl) deallocate(cmu) deallocate(iphl) deallocate(icsl) deallocate(nyphl) endif if(gx%bmperr.ne.0) goto 1000 ntup=nooftup() c_ntup=nooftup() c_niter=ceq%conv_iter 1000 continue c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_tqcalc !\begin{verbatim} subroutine c_tqce(mtarget,n1,n2,mvalue,c_ceq) bind(c,name='c_tqce') ! calculate equilibrium with possible target ! Target can be empty or a state variable with indicies n1 and n2 ! value is the calculated value of target integer(c_int), intent(in),value :: n1 integer(c_int), intent(in),value :: n2 type(c_ptr), intent(inout) :: c_ceq character(c_char), intent(inout) :: mtarget real(c_double), intent(inout) :: mvalue !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq character(len=:), allocatable :: fstring call c_f_pointer(c_ceq,ceq) fstring = c_to_f_string(mtarget) call tqce(fstring,n1,n2,mvalue,ceq) if(gx%bmperr.ne.0) goto 1000 c_ntup=ntup !CCI c_niter=ceq%conv_iter !CCI 1000 continue c_ceq = c_loc(ceq) deallocate(fstring) nullify(ceq) return end subroutine c_tqce !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine c_tqdceq(ceqname) bind(c,name='c_tqdceq') character(kind=c_char), intent(in) :: ceqname ! delete equilibrium with name !\end{verbatim} character(len=:), allocatable :: name integer n1 name = c_to_f_string(ceqname) call tqdceq(name) deallocate(name) end subroutine c_tqdceq !\begin{verbatim} subroutine c_tqfree() bind(c, name='c_tqfree') !\end{verbatim} integer intv(10) double precision dblv(10) call deallocate_gtp(intv,dblv) end subroutine c_tqfree !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgetv(statvar,n1,n2,n3,values,c_ceq) bind(c,name='c_tqgetv') ! get equilibrium results using state variables ! stavar is the state variable IN CAPITAL LETTERS with indices n1 and n2 ! n3 at the call is the dimension of values, changed to number of values ! value is the calculated value, it can be an array with n3 values. implicit none integer(c_int), intent(in),value :: n1,n2 integer(c_int), intent(inout) :: n3 character(c_char), intent(in) :: statvar real(c_double), intent(inout) :: values(*) type(c_ptr), intent(inout) :: c_ceq !IN: current equilibrium !======================================================== ! >>>> implement use of phase tuples ! stavar must be a symbol listed below ! IMPORTANT: some terms explained after the table ! Symbol index1,index2 Meaning (unit) !.... potentials ! T 0,0 Temperature (K) ! P 0,0 Pressure (Pa) ! MU component,0 or phase-tuple*1,constituent*2 Chemical potential (J) ! AC component,0 or phase-tuple,constituent Activity = EXP(MU/RT) ! LNAC component,0 or phase-tuple,constituent LN(activity) = MU/RT !...... extensive variables ! U 0,0 or phase-tuple,0 Internal energy (J) whole system or phase ! UM 0,0 or phase-tuple,0 same per mole components ! UW 0,0 or phase-tuple,0 same per kg ! UV 0,0 or phase-tuple,0 same per m3 ! UF phase-tuple,0 same per formula unit of phase ! S*3 0,0 or phase-tuple,0 Entropy (J/K) ! V 0,0 or phase-tuple,0 Volume (m3) ! H 0,0 or phase-tuple,0 Enthalpy (J) ! A 0,0 or phase-tuple,0 Helmholtz energy (J) ! G 0,0 or phase-tuple,0 Gibbs energy (J) ! ..... some extra state variables ! NP phase-tuple,0 Moles of phase ! BP phase-tuple,0 Mass of moles (kg) ! Q phase-tuple,0 Internal stability/RT (dimensionless) ! DG phase-tuple,0 Driving force/RT (dimensionless) !....... amounts of components ! N 0,0 or component,0 or phase-tuple,component Moles of component ! X component,0 or phase-tuple,component Mole fraction of component ! B 0,0 or component,0 or phase-tuple,component Mass of component ! W component,0 or phase-tuple,component Mass fraction of component ! Y phase-tuple,constituent*1 Constituent fraction !........ some parameter identifiers ! TC phase-tuple,0 Magnetic ordering temperature ! BMAG phase-tuple,0 Aver. Bohr magneton number ! MQ& phase-tuple,constituent Mobility ! THET phase-tuple,0 Debye temperature ! LNX phase-tuple,0 Lattice parameter ! EC11 phase-tuple,0 Elastic constant C11 ! EC12 phase-tuple,0 Elastic constant C12 ! EC44 phase-tuple,0 Elastic constant C44 !........ NOTES: ! *1 The phase-tuple is is structure with 2 integers: phase and comp.set ! *2 The constituent index is 10*species_number + sublattice_number ! *3 S, V, H, A, G, NP, BP, N, B and DG can have suffixes M, W, V, F also !-------------------------------------------------------------------- ! special addition for TQ interface: d2G/dyidyj ! D2G + extended phase index !------------------------------------ type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fstring integer :: n integer :: i call c_f_pointer(c_ceq, ceq) ! call list_conditions(6,ceq) ! call list_phase_results(1,1,0,6,ceq) ! write(*,*)'Phase and error code: ',1,gx%bmperr ! call list_phase_results(2,1,0,6,ceq) ! write(*,*)'Phase and error code: ',2,gx%bmperr ! write(*,*) call c_to_f_str(statvar,fstring) call tqgetv(fstring, n1, n2, n3, values, ceq) ! debug ... ! write(*,55)fstring(1:len_trim(fstring)),n1,n2,n3,(values(i),i=1,n3) !55 format(/'From c_tqgetv: ',a,': ',3i3,6(1pe12.4)) ! write(*,*) ! end debug c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_tqgetv !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgnsubl(n1,nsub,c_ceq) bind(c,name='c_tqgnsubl') ! This subroutine returns the number of sublattices (1 if no sublattices) ! of phase identified by its phase tuple index implicit none integer(c_int), intent(in), value :: n1 integer(c_int), intent(out) :: nsub type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) call get_sublattice_number(phasetuple(n1)%ixphase,nsub,ceq) c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_tqgnsubl !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgsubstruc(n1,nsub,nkl,nsites,c_ceq) bind(c,name='c_tqgsubstruc') ! This subroutine returns structures of each sublattice ! of phase identified by its phase tuple and composition set indexes ! (number of constituents in each sublattice and number of sites) implicit none integer(c_int), intent(in), value :: n1,nsub integer(c_int), intent(out), dimension(nsub) :: nkl real(c_double), intent(out), dimension(nsub) :: nsites type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) call get_sublattice_structure(phasetuple(n1)%ixphase,phasetuple(n1)%compset,nsub,nkl,nsites,ceq) c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_tqgsubstruc !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgconsdata(n1,icons,yarr,charge,csname,ncel,c_ceq) bind(c,name='c_tqgconsdata') ! This subroutine returns mole fraction, charge and name of constituent ! of phase identified by its phase tuple and composition set indexes ! (index of constituents and number of sites) implicit none integer(c_int), intent(in), value :: n1,icons real(c_double), intent(inout) :: yarr integer(c_int), intent(inout) :: charge, ncel character(kind=c_char, len=1), intent(inout) :: csname(24) type(c_ptr), intent(inout) :: c_ceq character(len=24) :: fstring !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) call get_constituent_data(phasetuple(n1)%ixphase,phasetuple(n1)%compset,icons,yarr,charge,& fstring,ncel,ceq) call f_to_c_string(fstring, csname) c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_tqgconsdata !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgphc1(n1,nsub,cinsub,spix,yfrac,sites,extra,c_ceq)& bind(c,name='c_tqgphc1') ! tq_get_phase_constitution ! This subroutine returns the sublattices and constitution of a phase ! n1 is phase tuple index ! nsub is the number of sublattices (1 if no sublattices) ! cinsub is an array with the number of const\EDtuents in each sublattice ! spix is an array with the species index of the constituents in all sublattices ! sites is an array of the site ratios for all sublattices. ! yfrac is the constituent fractions in same order as in spix ! extra is an array with some extra values: ! extra(1) is the number of moles of components per formula unit ! extra(2) is the net charge of the phase implicit none !integer n1,nsub,cinsub(*),spix(*) integer(c_int), intent(in), value :: n1 integer(c_int), intent(out) :: nsub integer(c_int), intent(out) :: cinsub(*) integer(c_int), intent(in) :: spix(*) !double precision sites(*),yfrac(*),extra(*) real(c_double), intent(in) :: sites(*) real(c_double), intent(in) :: yfrac(*) real(c_double), intent(in) :: extra(*) !type(gtp_equilibrium_data), pointer :: ceq type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) !call tqgphc1(n1,nsub2,cinsub2,spix2,yfrac2,sites2,extra2,ceq) call tqgphc1(n1,nsub,cinsub,spix,yfrac,sites,extra,ceq) c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_tqgphc1 !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqsphc1(n1,yfra,extra,c_ceq) bind(c,name='c_tqsphc1') ! tq_set_phase_constitution ! To set the constitution of a phase ! n1 is phase tuple index ! yfra is an array with the constituent fractions in all sublattices ! in the same order as obtained by tqgphc1 ! extra is an array with returned values with the same meaning as in tqgphc1 ! NOTE The constituents fractions are normallized to sum to unity for each ! sublattice and extra is calculated by tqsphc1 ! T and P must be set as conditions. implicit none integer(c_int), intent(in), value :: n1 real(c_double), intent(in) ::yfra(*) real(c_double), intent(out) :: extra(*) type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) call set_constitution(phasetuple(n1)%ixphase,phasetuple(n1)%compset,& yfra,extra,ceq) c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_tqsphc1 !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqcph1(n1,n2,n3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,c_ceq) & bind(c,name='c_tqcph1') ! tq_calculate_phase_properties !vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! WARNIG: this is not a subroutine to calculate chemical potentials ! those can only be made by an equilibrium calculation. ! The values returned are partial derivatives of G for the phase at the ! current T, P and phase constitution. The phase constitution has been ! obtained by a previous equilibrium calculation or ! set by the subroutine tqsphc ! It corresponds to the "calculate phase" command. ! ! NOTE that values are per formula unit divided by RT, ! divide also by extra(1) in subroutine tqsphc1 to get them per mole component ! !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! calculate G and some or all derivatives for a phase at current composition ! n1 is the phase tuple index ! n2 is 0 if only G and derivatves wrt T and P, 1 also first drivatives wrt ! compositions, 2 if also 2nd derivatives ! n3 is returned as number of constituents (dimension of returned arrays) ! gtp is an array with G, G.T, G:P, G.T.T, G.T.P and G.P.P ! dgdy is an array with G.Yi ! d2gdydt is an array with G.T.Yi ! d2gdydp is an array with G.P.Yi ! d2gdy2 is an array with the upper triangle of the symmetrix matrix G.Yi.Yj ! reurned in the order: 1,1; 1,2; 1,3; ... ! 2,2; 2,3; ... ! 3,3; ... ! for indexing one can use the integer function ixsym(i1,i2) implicit none integer(c_int), intent(in), value :: n1 integer(c_int), intent(in), value :: n2 integer(c_int), intent(out) :: n3 real(c_double), intent(out) :: gtp(6) real(c_double), intent(out) :: dgdy(*) real(c_double), intent(out) :: d2gdydt(*) real(c_double), intent(out) :: d2gdydp(*) real(c_double), intent(out) :: d2gdy2(*) type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) call tqcph1(n1,n2,n3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,ceq) c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_tqcph1 !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqcph3(n1,n2,g,c_ceq) bind(c,name='c_tqcph3') implicit none integer(c_int), intent(in), value :: n1 integer(c_int), intent(in), value :: n2 real(c_double), intent(out) :: g(*) type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) call tqcph3(n1,n2,g,ceq) c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_tqcph3 !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_reset_conditions(cline,c_ceq) bind(c, name='c_reset_conditions') implicit none character(c_char), intent(in) :: cline(24) type(c_ptr), intent(inout) :: c_ceq ! in: current equilibrium !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fstring fstring = c_to_f_string(cline) call c_f_pointer(c_ceq, ceq) call reset_conditions(fstring,ceq) c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_reset_conditions !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_Change_Status_Phase(phasename,nystat,myval,c_ceq)& bind(c, name='c_Change_Status_Phase') !change the status Fixed or Entered of a phase !PHFIXED=2 !PHENTERED=0 implicit none character(c_char), intent(in) :: phasename(24) integer(c_int), intent(in), value :: nystat real(c_double), intent(in),value :: myval type(c_ptr), intent(inout) :: c_ceq ! in: current equilibrium !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fstring call c_f_pointer(c_ceq, ceq) call c_to_f_str(phasename,fstring) call change_many_phase_status(fstring,nystat,myval,ceq) ! call Change_Status_Phase(fstring,nystat,myval,ceq) c_ceq = c_loc(ceq) 1000 continue nullify(ceq) return end subroutine c_Change_Status_Phase !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine c_Set_Reference_State(iel,c_phase,tpref,c_ceq)& bind(c, name='c_Set_Reference_State') ! set component reference state integer(c_int), intent(in), value :: iel character(c_char), intent(in) :: c_phase(24) real(c_double), intent(in) :: tpref(2) type(c_ptr), intent(inout) :: c_ceq character(len=24) :: phase type(gtp_equilibrium_data), pointer :: ceq integer phtupx !\end{verbatim} call c_f_pointer(c_ceq, ceq) phase = c_to_f_string(c_phase) call find_phasetuple_by_name(phase,phtupx) if(gx%bmperr.ne.0) goto 1000 call set_reference_state(iel,phtupx,tpref,ceq) 1000 continue c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_Set_Reference_State !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_List_Conditions(c_ceq)& bind(c, name='c_List_Conditions') !change the status Fixed or Entered of a phase !PHFIXED=2 !PHENTERED=0 implicit none type(c_ptr), intent(inout) :: c_ceq ! in: current equilibrium !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) call list_conditions(6,ceq) 1000 continue c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_List_Conditions !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_checktdb(tdbfile)& bind(c, name='c_checktdb') character(kind=c_char), intent(in) :: tdbfile !\end{verbatim} integer:: nel,i character selel(maxel)*2 character(len=:), allocatable :: fstring character(len=:), allocatable :: ext ext='.tdb' fstring = c_to_f_string(tdbfile) call checkdb(fstring,ext,nel,selel) c_nel = nel do i = 1, nel cnames(i) = trim(selel(i)) // c_null_char c_cnam(i) = c_loc(cnames(i)) end do deallocate(fstring) return end subroutine c_checktdb !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_newEquilibrium(ceqname,ieq) bind(c, name='c_newEquilibrium') character(kind=c_char), intent(in) :: ceqname integer(c_int), intent(out):: ieq !\end{verbatim} character(len=:), allocatable :: fstring fstring = c_to_f_string(ceqname) call enter_equilibrium(fstring,ieq) deallocate(fstring) end subroutine c_newEquilibrium !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine c_tqcceq(ceqname,n1,c_newceq,c_ceq) & bind(c, name='c_tqcceq') character(kind=c_char), intent(in) :: ceqname integer(c_int), intent(out) :: n1 type(c_ptr), intent(inout) :: c_newceq type(c_ptr), intent(in) :: c_ceq !\end{verbatim} character(len=:), allocatable :: name type(gtp_equilibrium_data), pointer :: newceq,ceq call c_f_pointer(c_ceq, ceq) call c_f_pointer(c_newceq, newceq) name = c_to_f_string(ceqname) call tqcceq(name,n1,newceq,ceq) c_newceq=c_loc(newceq) deallocate(name) nullify(ceq) end subroutine c_tqcceq !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine c_tqselceq(ceqname,c_ceq) & bind(c, name='c_tqselceq') character(kind=c_char), intent(in) :: ceqname type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} character(len=:), allocatable :: name type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) name = c_to_f_string(ceqname) call tqselceq(name,ceq) c_ceq=c_loc(ceq) deallocate(name) nullify(ceq) return end subroutine c_tqselceq !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine c_tqgdmat(phtupx,tpval,xknown,cpot,tyst,nend,mugrad,mobval,consnames,n1,c_ceq) & bind(c, name='c_tqgdmat') integer(kind=c_int), intent(in), value :: phtupx real(kind=c_double), intent(in) :: tpval(2) real(kind=c_double), intent(in) :: xknown(*) real(kind=c_double), intent(out) :: cpot(*) integer(kind=c_int), intent(in), value :: tyst integer(kind=c_int), intent(out) :: nend real(kind=c_double), intent(out) :: mugrad(*) real(kind=c_double), intent(out) :: mobval(*) character(kind=c_char, len=1), intent(out), dimension(maxconst*24) :: consnames integer(kind=c_int), intent(out) :: n1 type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} logical btyst type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fconsnames(maxconst) integer :: i,j,l call c_f_pointer(c_ceq, ceq) if (tyst.eq.1) then btyst=.TRUE. else btyst=.FALSE. endif call tqgdmat(phtupx,tpval,xknown,cpot,btyst,nend,mugrad,mobval,fconsnames,n1,ceq) ! convert the F fconsnames strings to C l = len(fconsnames(1)) do i = 1, n1 do j = 1, l consnames((i-1)*l+j)(1:1) = fconsnames(i)(j:j) end do ! null termination consnames(i*l) = c_null_char end do c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_tqgdmat !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_copy_equilibrium(c_neweq,ceqname,c_ceq) & bind(c, name='c_copy_equilibrium') type(c_ptr), intent(inout) :: c_neweq character(kind=c_char), intent(in) :: ceqname type(c_ptr), intent(in) :: c_ceq !\end{verbatim} character(len=:), allocatable :: fstring type(gtp_equilibrium_data), pointer :: ceq type(gtp_equilibrium_data), pointer :: neweq call c_f_pointer(c_ceq, ceq) fstring = c_to_f_string(ceqname) call copy_equilibrium(neweq,fstring,ceq) c_neweq=c_loc(neweq) deallocate(fstring) nullify(ceq) return end subroutine c_copy_equilibrium !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_selecteq(ieq,c_ceq) bind(c, name='c_selecteq') integer(c_int), intent(in),value :: ieq type(c_ptr), intent(out) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq !call c_f_pointer(c_ceq, ceq) !call selecteq(ieq,ceq) ceq=>eqlista(ieq) c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_selecteq !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_enter_svf(c_tpfun,c_ceq) bind(c, name='c_enter_svf') ! enter a state variable function like CP=H.T; character(kind=c_char), intent(in) :: c_tpfun type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq character(len=:), allocatable :: tpfun integer ip tpfun = c_to_f_string(c_tpfun) ip=1 call c_f_pointer(c_ceq, ceq) call enter_svfun(tpfun,ip,ceq) !call evaluate_all_svfun_old(-1,ceq) ! mandatory ? c_ceq = c_loc(ceq) deallocate(tpfun) return end subroutine c_enter_svf !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_get_value_svf(c_tpfun,c_svfvalue,c_ceq) bind(c, name='c_get_value_svf') ! evaluate all state variable funtions ! actual_arg are names of phases, components or species as @Pi, @Ci and @Si ! (NOT IMPLEMENTED YET see minimizer/matsmin.F90 for more details) ! if mode=1 always evaluate, if mode=0 several options character(kind=c_char), intent(in) :: c_tpfun real(c_double), intent(inout) :: c_svfvalue type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq character(len=:), allocatable :: tpfun character actual_arg(2)*16 double precision value integer ip,mode tpfun = c_to_f_string(c_tpfun) call c_f_pointer(c_ceq, ceq) call capson(tpfun) call find_svfun(tpfun,ip) mode=1 ! always is evaluated (see minimizer/matsmin.F90 for more details) actual_arg = ' ' c_svfvalue=meq_evaluate_svfun(ip,actual_arg,mode,ceq) c_ceq = c_loc(ceq) deallocate(tpfun) return end subroutine c_get_value_svf !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_set_grid_density(ngrid) bind(c, name='c_set_grid_density') !\end{verbatim} integer(c_int), intent(in), value :: ngrid if(ngrid.eq.0) then ! this set GSOGRID, small grid and clears GSXGRID globaldata%status=ibset(globaldata%status,GSOGRID) globaldata%status=ibclr(globaldata%status,GSXGRID) globaldata%status=ibclr(globaldata%status,GSYGRID) ! write(*,*)'Sparse grid set' elseif(ngrid.eq.1) then ! DEFAULT, all gridbits are cleared globaldata%status=ibclr(globaldata%status,GSXGRID) globaldata%status=ibclr(globaldata%status,GSOGRID) globaldata%status=ibclr(globaldata%status,GSYGRID) ! write(*,*)'Normal grid set' elseif(ngrid.eq.2) then ! set GSXGRID (and clear GSOGRID and GSYGRID) globaldata%status=ibclr(globaldata%status,GSOGRID) globaldata%status=ibset(globaldata%status,GSXGRID) globaldata%status=ibclr(globaldata%status,GSYGRID) ! write(*,*)'Dense grid set' elseif(ngrid.eq.3) then ! set GSYGRID (and clear GSXGRID and GSOGRID) globaldata%status=ibclr(globaldata%status,GSOGRID) globaldata%status=ibclr(globaldata%status,GSXGRID) globaldata%status=ibset(globaldata%status,GSYGRID) ! write(*,*)'Very dense grid set' else write(*,*)'Only level 0, 1, 2 and implemented' endif return end subroutine c_set_grid_density !\begin{verbatim} subroutine c_set_status_globaldata() bind(c, name='c_set_status_globaldata') !\end{verbatim} !globaldata%status=ibclr(globaldata%status,GSADV) !globaldata%status=ibclr(globaldata%status,GSNOPAR) !globaldata%status=ibclr(globaldata%status,GSXGRID) globaldata%status=ibclr(globaldata%status,GSNOACS) return end subroutine c_set_status_globaldata !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} integer function c_errors_number() bind(c, name='c_errors_number') !\end{verbatim} c_errors_number=0 if(gx%bmperr.ne.0) then c_errors_number=gx%bmperr endif return end function c_errors_number !\begin{verbatim} subroutine c_reset_errors_number() bind(c, name='c_reset_errors_number') !\end{verbatim} gx%bmperr=0 return end subroutine c_reset_errors_number !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_new_gtp() bind(c, name='c_new_gtp') !\end{verbatim} call new_gtp end subroutine c_new_gtp !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} ! Save OC environment in the c_filename at c_specification format ! c_specification : UNFORMATTED, DIRECT, TDB, MACRO or LaTeX subroutine c_gtpsave(c_filename,c_specification) bind(c, name='c_gtpsave') character(kind=c_char), intent(in) :: c_filename,c_specification !\end{verbatim} character(len=:), allocatable :: filename,specification filename = c_to_f_string(c_filename) specification = c_to_f_string(c_specification) call gtpsaveu(filename,specification) deallocate(filename,specification) end subroutine c_gtpsave !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} ! Read OC environment from the c_filename at c_specification format ! c_specification : UNFORMATTED, DIRECT, TDB, MACRO or LaTeX subroutine c_gtpread(c_filename,c_specification) bind(c, name='c_gtpread') character(kind=c_char), intent(in) :: c_filename,c_specification !\end{verbatim} character(len=:), allocatable :: filename,specification filename = c_to_f_string(c_filename) specification = c_to_f_string(c_specification) call gtpread(filename,specification) deallocate(filename,specification) !CCI call getelem() !CCI end subroutine c_gtpread !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine c_tqcheckphstab(is_stable,c_phtupx,c_ceq) bind(c, name='c_tqcheckphstab') ! check if a phase if stable implicit none logical(c_bool), intent(inout) :: is_stable integer(c_int), intent(in), value :: c_phtupx type(c_ptr), intent(inout) :: c_ceq type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer lokvares call c_f_pointer(c_ceq, ceq) lokvares=phasetuple(c_phtupx)%lokvares if(ceq%phase_varres(lokvares)%phstate.ge.phentstab) then is_stable = .TRUE. endif c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_tqcheckphstab !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine c_tqlr(c_mode,c_ceq) bind(c, name='c_tqlr') ! list the equilibrium results like in OC implicit none type(c_ptr), intent(inout) :: c_ceq integer(c_int), intent(in), value :: c_mode type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer phtupx,iph,ics,lokvares,mode logical once call c_f_pointer(c_ceq, ceq) write(6,10) 10 format(/20('*')/'Start debug output from TQLR: ') call list_conditions(6,ceq) call list_global_results(6,ceq) call list_components_result(6,1,ceq) call list_all_elements(6) call list_all_species(6) call list_all_phases(6,ceq) once=.TRUE. mode=max(0,c_mode) do phtupx=1,nooftup() lokvares=phasetuple(phtupx)%lokvares if(ceq%phase_varres(lokvares)%phstate.ge.phentstab) then iph=phasetuple(phtupx)%ixphase ics=phasetuple(phtupx)%compset call list_phase_results(iph,ics,mode,lut,once,ceq) endif enddo write(6,20) 20 format('End debug output from TQLR'/20('*')/) 1000 continue c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_tqlr !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine c_tqtgsw(i) bind(c, name='c_tqtgsw') integer(c_int), intent(in),value :: i !\end{verbatim} call tqtgsw(i) end subroutine c_tqtgsw !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ end module liboctqisoc ================================================ FILE: OCisoCbinding/octqc.h ================================================ /* * Update proposed by Romain Le Tellier and Clément Introïni */ #if !defined __OCASI__ #define __OCASI__ /* Modification history 160829 Bo Sundman Update 2015-2016 Matthias Stratmann and Cristophe Sigli Modifications 2014 Teslos? First version This contains the structure of TYPE variables in OC needed for the OC/TQ OCASI interface NOTE there is also a c_gtp_equilibrium_data structure defined in liboctqisoc.F90 */ typedef struct { int forcenewcalc; double tpused[2]; double results[6]; } tpfun_parres; typedef struct { int splink, phlink, status; char refstate[16]; int *endmember; double tpref[2]; double chempot[2]; double mass, molat; } gtp_components; typedef struct { int lokph, compset, ixphase, lokvares, nextcs; } gtp_phasetuple; typedef struct { int statevarid, norm, unit, phref, argtyp; int phase, compset, component, constituent; double coeff; int oldstv; } gtp_state_variable; typedef struct { int latd, ndd, tnoofxfr, tnoofyfr, varreslink, totdis; char id; double *dsites; int *nooffr; int *splink; int *y2x; double *dxidyj; double fsites; } gtp_fraction_set; //struct gtp_fraction_set; typedef struct { int nextfree, phlink, status2, phstate,phtupx; double abnorm[3]; char prefix[4], suffix[4]; int *constat; double *yfr; double *mmyfr; double *sites; double *dpqdy; double *d2pqdvay; //struct gtp_fraction_set disfra; double amfu, netcharge, dgm; int nprop; int *listprop; double **gval; double ***dgval; double **d2gval; double curlat[3][3]; double **cinvy; double *cxmol; double **cdxmol; double *addg; } gtp_phase_varres; typedef struct gtp_condition { int noofterms, statev, active, iunit, nid, iref, seqz, experimenttype; int symlink1, symlink2; int **indices; double *condcoeff; double *prescribed, current, uncertainity; // should this be a struct ?? gtp_state_variable *statvar; struct gtp_condition *next, *previous; } gtp_condition; typedef struct { int status, multiuse, eqno, next; char eqname[24], comment[72]; double tpval[2], rtn; double weight; double *svfunres; gtp_condition *lastcondition, *lastexperiment; gtp_components *complist; double **compstoi, **invcompstoi; gtp_phase_varres *phase_varres; tpfun_parres *eq_tpres; double *cmuval; double xconv; double gmindif; int maxiter; char eqextra[80]; int sysmatdim, nfixmu, nfixph; int *fixmu; int *fixph; double **savesysmat; } gtp_equilibrium_data; #endif ================================================ FILE: OCisoCbinding/pyOC/example.ipynb ================================================ { "cells": [ { "cell_type": "code", "execution_count": 1, "metadata": {}, "outputs": [], "source": [ "import os" ] }, { "cell_type": "markdown", "metadata": {}, "source": [ "### Imports for pyOC" ] }, { "cell_type": "code", "execution_count": 2, "metadata": {}, "outputs": [], "source": [ "import pyOC\n", "from pyOC import opencalphad as oc\n", "from pyOC import PhaseStatus as phStat\n", "from pyOC import GridMinimizerStatus as gmStat" ] }, { "cell_type": "markdown", "metadata": {}, "source": [ "### Setting verbosity (True or False - default), if set to yes, in particular, when getters are called the returned values are displayed in a comprehensive way" ] }, { "cell_type": "code", "execution_count": 3, "metadata": {}, "outputs": [], "source": [ "oc.setVerbosity(True)" ] }, { "cell_type": "markdown", "metadata": {}, "source": [ "### reading database (.tdb file)" ] }, { "cell_type": "code", "execution_count": 4, "metadata": {}, "outputs": [ { "name": "stderr", "output_type": "stream", "text": [ "(OpenCalphad being verbose): reading /home/rl211391/develop/OpenCalphad/examples/macros//steel7.TDB\n", "(OpenCalphad being verbose): component (6) names: ['C' 'CR' 'FE' 'MO' 'SI' 'V']\n" ] } ], "source": [ "tdbFile=os.environ.get('OCPUBLICDATA')+'/steel7.TDB'\n", "oc.readtdb(tdbFile)" ] }, { "cell_type": "markdown", "metadata": {}, "source": [ "### Play with phase status" ] }, { "cell_type": "code", "execution_count": 5, "metadata": {}, "outputs": [ { "name": "stderr", "output_type": "stream", "text": [ "(OpenCalphad being verbose): modifying phases * to status PhaseStatus.Suspended\n", "(OpenCalphad being verbose): modifying phases FCC_A1 M23C6 M6C to status PhaseStatus.Entered\n" ] } ], "source": [ "oc.setPhasesStatus(('* ',),phStat.Suspended)\n", "phaseNames=('FCC_A1','M23C6','M6C')\n", "oc.setPhasesStatus(phaseNames,phStat.Entered)" ] }, { "cell_type": "markdown", "metadata": {}, "source": [ "### Set pressure and temperature" ] }, { "cell_type": "code", "execution_count": 6, "metadata": {}, "outputs": [ { "name": "stderr", "output_type": "stream", "text": [ "(OpenCalphad being verbose): setting pressure to 1.00e+05 Pa\n", "(OpenCalphad being verbose): setting temperature to 1173.00 K\n" ] } ], "source": [ "oc.setPressure(1E5)\n", "oc.setTemperature(1173)" ] }, { "cell_type": "markdown", "metadata": {}, "source": [ "### Set element molar amounts" ] }, { "cell_type": "code", "execution_count": 7, "metadata": {}, "outputs": [ { "name": "stderr", "output_type": "stream", "text": [ "(OpenCalphad being verbose): setting molar amount 0.0400 for element C (0)\n", "(OpenCalphad being verbose): setting molar amount 0.0600 for element CR (1)\n", "(OpenCalphad being verbose): setting molar amount 0.0500 for element MO (3)\n", "(OpenCalphad being verbose): setting molar amount 0.0030 for element SI (4)\n", "(OpenCalphad being verbose): setting molar amount 0.0100 for element V (5)\n", "(OpenCalphad being verbose): setting molar amount 0.8370 for element FE (2)\n" ] } ], "source": [ "elementMolarAmounts = {\n", "\t'C' : 0.04,\n", "\t'CR' : 0.06,\n", "\t'MO': 0.05,\n", "\t'SI': 0.003,\n", "\t'V': 0.01,\n", "\t'FE': 1.0-0.04-0.06-0.05-0.003-0.01\n", "}\n", "oc.setElementMolarAmounts(elementMolarAmounts)" ] }, { "cell_type": "markdown", "metadata": {}, "source": [ "### Calculate equilibrium without the grid-minimizer (equilibrium record is 'eq2')" ] }, { "cell_type": "code", "execution_count": 8, "metadata": {}, "outputs": [ { "name": "stderr", "output_type": "stream", "text": [ "(OpenCalphad being verbose): creating and selecting new equilibrium record 'eq2' ('EQ2')\n", "(OpenCalphad being verbose): calculating equilibrium with grid minimizer GridMinimizerStatus.Off\n" ] } ], "source": [ "oc.changeEquilibriumRecord('eq2')\n", "oc.calculateEquilibrium(gmStat.Off)" ] }, { "cell_type": "markdown", "metadata": {}, "source": [ "### Calculate equilibrium with the grid-minimizer (equilibrium record is 'default equilibrium')" ] }, { "cell_type": "code", "execution_count": 9, "metadata": {}, "outputs": [ { "name": "stderr", "output_type": "stream", "text": [ "(OpenCalphad being verbose): selecting equilibrium record 'default equilibrium' ('DEFAULT_EQUILIBRIUM')\n", "(OpenCalphad being verbose): calculating equilibrium with grid minimizer GridMinimizerStatus.On\n" ] } ], "source": [ "oc.changeEquilibriumRecord()\n", "oc.calculateEquilibrium()" ] }, { "cell_type": "markdown", "metadata": {}, "source": [ "### Retrieving Gibbs energies and comparing them" ] }, { "cell_type": "code", "execution_count": 10, "metadata": {}, "outputs": [ { "name": "stderr", "output_type": "stream", "text": [ "(OpenCalphad being verbose): selecting equilibrium record 'default equilibrium' ('DEFAULT_EQUILIBRIUM')\n", "(OpenCalphad being verbose): retrieving G: -5.767378e+04\n", "(OpenCalphad being verbose): selecting equilibrium record 'eq2' ('EQ2')\n", "(OpenCalphad being verbose): retrieving G: -5.760589e+04\n", "(OpenCalphad being verbose): selecting equilibrium record 'default equilibrium' ('DEFAULT_EQUILIBRIUM')\n" ] }, { "name": "stdout", "output_type": "stream", "text": [ "G=-5.767378e+04 (vs. without grid-minimizer: -5.760589e+04)\n" ] } ], "source": [ "oc.changeEquilibriumRecord()\n", "G=oc.getGibbsEnergy() # a scalar\n", "oc.changeEquilibriumRecord('eq2')\n", "G2=oc.getGibbsEnergy() # a scalar\n", "print('G={0:e} (vs. without grid-minimizer: {1:e})'.format(G,G2))\n", "oc.changeEquilibriumRecord()" ] }, { "cell_type": "markdown", "metadata": {}, "source": [ "### Retrieving chemical potentials" ] }, { "cell_type": "code", "execution_count": 11, "metadata": {}, "outputs": [ { "name": "stderr", "output_type": "stream", "text": [ "(OpenCalphad being verbose): retrieving MU:\n", "{\n", " \"C\": -40277.342035801805,\n", " \"CR\": -68893.39293504054,\n", " \"FE\": -55314.718539072106,\n", " \"MO\": -74567.11408055216,\n", " \"SI\": -196024.33490496737,\n", " \"V\": -131423.24634989392\n", "}\n" ] }, { "name": "stdout", "output_type": "stream", "text": [ "mu_FE= -55314.718539072106\n" ] } ], "source": [ "mu=oc.getChemicalPotentials() # a dictionary (keys are element names, values are chemical potentials)\n", "print('mu_FE= ',mu['FE'])" ] }, { "cell_type": "markdown", "metadata": {}, "source": [ "### Retrieving equilibrium phases composition" ] }, { "cell_type": "code", "execution_count": 12, "metadata": {}, "outputs": [ { "name": "stderr", "output_type": "stream", "text": [ "(OpenCalphad being verbose): phases at equilibrium:\n", "phase molar amounts:\n", "{\n", " \"FCC_A1#1\": 0.01920542894617253,\n", " \"M23C6\": 0.02977621280681491,\n", " \"M6C\": 0.09441638360236765,\n", " \"FCC_A1_AUTO#2\": 0.856601974644645\n", "}\n", "phase element composition:\n", "{\n", " \"FCC_A1#1\": {\n", " \"C\": 0.45665297099480046,\n", " \"CR\": 0.03426417107693683,\n", " \"FE\": 0.0020841630748334116,\n", " \"MO\": 0.1443298386826512,\n", " \"SI\": 6.681137603878831e-10,\n", " \"V\": 0.3626688555026644\n", " },\n", " \"M23C6\": {\n", " \"C\": 0.2068965517241379,\n", " \"CR\": 0.3414624222993837,\n", " \"FE\": 0.3838209757158874,\n", " \"MO\": 0.06769132200309422,\n", " \"SI\": 0.0,\n", " \"V\": 0.00012872825749663693\n", " },\n", " \"M6C\": {\n", " \"C\": 0.14285714285714285,\n", " \"CR\": 0.06508399462251023,\n", " \"FE\": 0.38133540345297173,\n", " \"MO\": 0.39191933121811307,\n", " \"SI\": 0.0,\n", " \"V\": 0.018804127849262088\n", " },\n", " \"FCC_A1_AUTO#2\": {\n", " \"C\": 0.013519853563065565,\n", " \"CR\": 0.050232768562391776,\n", " \"FE\": 0.9216963669684142,\n", " \"MO\": 0.009583081354863507,\n", " \"SI\": 0.003502209983129125,\n", " \"V\": 0.001465719568135902\n", " }\n", "}\n", "phase sites:\n", "{\n", " \"FCC_A1#1\": [\n", " 1.0,\n", " 1.0\n", " ],\n", " \"M23C6\": [\n", " 20.0,\n", " 3.0,\n", " 6.0\n", " ],\n", " \"M6C\": [\n", " 2.0,\n", " 2.0,\n", " 2.0,\n", " 1.0\n", " ],\n", " \"FCC_A1_AUTO#2\": [\n", " 1.0,\n", " 1.0\n", " ]\n", "}\n", "phase constituent composition:\n", "{\n", " \"FCC_A1#1\": {\n", " \"sublattice 0\": {\n", " \"CR\": 0.06306130198166399,\n", " \"FE\": 0.0038357862720796564,\n", " \"MO\": 0.26563104420926176,\n", " \"SI\": 1.229626232816835e-09,\n", " \"V\": 0.6674718663073684\n", " },\n", " \"sublattice 1\": {\n", " \"C\": 0.8404444059091938,\n", " \"VA\": 0.15955559409080622\n", " }\n", " },\n", " \"M23C6\": {\n", " \"sublattice 0\": {\n", " \"CR\": 0.4730948138378144,\n", " \"FE\": 0.5268934005119624,\n", " \"V\": 1.1785650223144731e-05\n", " },\n", " \"sublattice 1\": {\n", " \"CR\": 0.14683798997528025,\n", " \"FE\": 0.19764676184049562,\n", " \"MO\": 0.654349446029911,\n", " \"V\": 0.0011658021543131923\n", " },\n", " \"sublattice 2\": {\n", " \"C\": 1.0\n", " }\n", " },\n", " \"M6C\": {\n", " \"sublattice 0\": {\n", " \"FE\": 1.0\n", " },\n", " \"sublattice 1\": {\n", " \"MO\": 1.0\n", " },\n", " \"sublattice 2\": {\n", " \"CR\": 0.2277939811787858,\n", " \"FE\": 0.33467391208540104,\n", " \"MO\": 0.37171765926339584,\n", " \"V\": 0.06581444747241731\n", " },\n", " \"sublattice 3\": {\n", " \"C\": 1.0\n", " }\n", " },\n", " \"FCC_A1_AUTO#2\": {\n", " \"sublattice 0\": {\n", " \"CR\": 0.050921215945224446,\n", " \"FE\": 0.9343283494325632,\n", " \"MO\": 0.00971441887551069,\n", " \"SI\": 0.0035502082791820494,\n", " \"V\": 0.0014858074675196773\n", " },\n", " \"sublattice 1\": {\n", " \"C\": 0.013705145118123152,\n", " \"VA\": 0.9862948548818768\n", " }\n", " }\n", "}\n" ] }, { "name": "stdout", "output_type": "stream", "text": [ "n_C in FCC_A1#1 = 0.45665297099480046\n", "a_i in FCC_A1#1 = [1.0, 1.0]\n", "y_V^0 in liquid = 0.6674718663073684\n" ] } ], "source": [ "phasesAtEquilibrium=oc.getPhasesAtEquilibrium() # a container class defined in pyOC.py\n", "phaseElementComposition=phasesAtEquilibrium.getPhaseElementComposition() # a dictionary (keys are phase names) of dictionaries (keys are the element names, values are molar fractions)\n", "print('n_C in FCC_A1#1 = ',phaseElementComposition['FCC_A1#1']['C'])\n", "phaseSites=phasesAtEquilibrium.getPhaseSites() # a dictionary (keys are phase names, values are arrays of number of sites whose sizes depend on the number of sublattices)\n", "print('a_i in FCC_A1#1 = ',phaseSites['FCC_A1#1'])\n", "phaseConstituentComposition=phasesAtEquilibrium.getPhaseConstituentComposition() # a dictionary (keys are phase names) of dictionaries per sublattice (keys are the constituent names, values are molar fractions)\n", "print('y_V^0 in liquid = ',phaseConstituentComposition['FCC_A1#1']['sublattice 0']['V'])" ] }, { "cell_type": "markdown", "metadata": {}, "source": [ "### Retrieving constituent composition (this info is 'updated' each time the getPhasesAtEquilibrium method is called by adding constituents that were not present before)" ] }, { "cell_type": "code", "execution_count": 13, "metadata": {}, "outputs": [ { "name": "stderr", "output_type": "stream", "text": [ "(OpenCalphad being verbose): constituents description:\n", "{\n", " \"CR\": {\n", " \"mass\": 51.996,\n", " \"charge\": 0.0,\n", " \"elements\": {\n", " \"CR\": 1.0\n", " }\n", " },\n", " \"FE\": {\n", " \"mass\": 55.846999999999994,\n", " \"charge\": 0.0,\n", " \"elements\": {\n", " \"FE\": 1.0\n", " }\n", " },\n", " \"MO\": {\n", " \"mass\": 95.94,\n", " \"charge\": 0.0,\n", " \"elements\": {\n", " \"MO\": 1.0\n", " }\n", " },\n", " \"SI\": {\n", " \"mass\": 28.085,\n", " \"charge\": 0.0,\n", " \"elements\": {\n", " \"SI\": 1.0\n", " }\n", " },\n", " \"V\": {\n", " \"mass\": 50.941,\n", " \"charge\": 0.0,\n", " \"elements\": {\n", " \"V\": 1.0\n", " }\n", " },\n", " \"C\": {\n", " \"mass\": 12.011000000000001,\n", " \"charge\": 0.0,\n", " \"elements\": {\n", " \"C\": 1.0\n", " }\n", " },\n", " \"VA\": {\n", " \"mass\": 0.0,\n", " \"charge\": 0.0,\n", " \"elements\": {}\n", " }\n", "}\n" ] }, { "name": "stdout", "output_type": "stream", "text": [ "m_V = 50.941\n", "q_V = 0.0\n", "stoi^V_V = 1.0\n" ] } ], "source": [ "constituentsDescription = oc.getConstituentsDescription() # a dictionary (keys are the constituent names) of dictionaries (keys are 'mass', 'charge' and 'elements', values are respectively the constituent molar mass, the constituent eletrical charge and a dictionary - keys are element names, values are stoichiometric coefficients)\n", "print('m_V = ',constituentsDescription['V']['mass'])\n", "print('q_V = ',constituentsDescription['V']['charge'])\n", "print('stoi^V_V = ',constituentsDescription['V']['elements']['V'])" ] } ], "metadata": { "kernelspec": { "display_name": "Python 3", "language": "python", "name": "python3" }, "language_info": { "codemirror_mode": { "name": "ipython", "version": 3 }, "file_extension": ".py", "mimetype": "text/x-python", "name": "python", "nbconvert_exporter": "python", "pygments_lexer": "ipython3", "version": "3.7.5" } }, "nbformat": 4, "nbformat_minor": 4 } ================================================ FILE: OCisoCbinding/pyOC/example.py ================================================ #!/usr/bin/env python # coding: utf-8 # In[1]: import os # ### Imports for pyOC # In[2]: import pyOC from pyOC import opencalphad as oc from pyOC import PhaseStatus as phStat from pyOC import GridMinimizerStatus as gmStat # ### Setting verbosity (True or False - default), if set to yes, in particular, when getters are called the returned values are displayed in a comprehensive way # In[3]: oc.setVerbosity(True) # ### reading database (.tdb file) # In[4]: tdbFile=os.environ.get('OCPUBLICDATA')+'/steel7.TDB' oc.readtdb(tdbFile) # ### Play with phase status # In[5]: oc.setPhasesStatus(('* ',),phStat.Suspended) phaseNames=('FCC_A1','M23C6','M6C') oc.setPhasesStatus(phaseNames,phStat.Entered) # ### Set pressure and temperature # In[6]: oc.setPressure(1E5) oc.setTemperature(1173) # ### Set element molar amounts # In[7]: elementMolarAmounts = { 'C' : 0.04, 'CR' : 0.06, 'MO': 0.05, 'SI': 0.003, 'V': 0.01, 'FE': 1.0-0.04-0.06-0.05-0.003-0.01 } oc.setElementMolarAmounts(elementMolarAmounts) # ### Calculate equilibrium without the grid-minimizer (equilibrium record is 'eq2') # In[8]: oc.changeEquilibriumRecord('eq2') oc.calculateEquilibrium(gmStat.Off) # ### Calculate equilibrium with the grid-minimizer (equilibrium record is 'default equilibrium') # In[9]: oc.changeEquilibriumRecord() oc.calculateEquilibrium() # ### Retrieving Gibbs energies and comparing them # In[10]: oc.changeEquilibriumRecord() G=oc.getGibbsEnergy() # a scalar oc.changeEquilibriumRecord('eq2') G2=oc.getGibbsEnergy() # a scalar print('G={0:e} (vs. without grid-minimizer: {1:e})'.format(G,G2)) oc.changeEquilibriumRecord() # ### Retrieving chemical potentials # In[11]: mu=oc.getChemicalPotentials() # a dictionary (keys are element names, values are chemical potentials) print('mu_FE= ',mu['FE']) # ### Retrieving equilibrium phases composition # In[12]: phasesAtEquilibrium=oc.getPhasesAtEquilibrium() # a container class defined in pyOC.py phaseElementComposition=phasesAtEquilibrium.getPhaseElementComposition() # a dictionary (keys are phase names) of dictionaries (keys are the element names, values are molar fractions) print('n_C in FCC_A1#1 = ',phaseElementComposition['FCC_A1#1']['C']) phaseSites=phasesAtEquilibrium.getPhaseSites() # a dictionary (keys are phase names, values are arrays of number of sites whose sizes depend on the number of sublattices) print('a_i in FCC_A1#1 = ',phaseSites['FCC_A1#1']) phaseConstituentComposition=phasesAtEquilibrium.getPhaseConstituentComposition() # a dictionary (keys are phase names) of dictionaries per sublattice (keys are the constituent names, values are molar fractions) print('y_V^0 in liquid = ',phaseConstituentComposition['FCC_A1#1']['sublattice 0']['V']) # ### Retrieving constituent composition (this info is 'updated' each time the getPhasesAtEquilibrium method is called by adding constituents that were not present before) # In[13]: constituentsDescription = oc.getConstituentsDescription() # a dictionary (keys are the constituent names) of dictionaries (keys are 'mass', 'charge' and 'elements', values are respectively the constituent molar mass, the constituent eletrical charge and a dictionary - keys are element names, values are stoichiometric coefficients) print('m_V = ',constituentsDescription['V']['mass']) print('q_V = ',constituentsDescription['V']['charge']) print('stoi^V_V = ',constituentsDescription['V']['elements']['V']) ================================================ FILE: OCisoCbinding/pyOC/pyOC.f90 ================================================ ! This module is simply a 'sanitized' and f90wrapp-compatible version of the different subroutines available in the OCASI interface (liboctq.F90) ! all subroutines of liboctq.F90 'wrapped' into a new subroutine defined here (the subroutine name is the same with a 'py' prefix) ! module RawOpenCalphad use liboctq implicit none type eq_wrapper type(gtp_equilibrium_data), pointer :: ceq end type eq_wrapper type comp_wrapper integer :: n character(24) :: compnames(maxc) end type comp_wrapper ! integer, parameter :: maxel=100,maxsp=1000,maxph=600,maxsubl=10,maxconst=1000 contains function pygeterr() result(errorcode) integer :: errorcode errorcode = gx%bmperr end function pygeterr subroutine pyseterr(errorcode) integer, intent(in) :: errorcode gx%bmperr = errorcode end subroutine pyseterr subroutine pytqini(n,eq) implicit none integer :: n type(eq_wrapper), intent(out) :: eq call tqini(n,eq%ceq) end subroutine pytqini subroutine pytqrfil(filename,eq) implicit none character(*) :: filename type(eq_wrapper) :: eq call tqrfil(filename,eq%ceq) end subroutine pytqrfil subroutine pytqrpfil(filename,nsel,selel,eq) implicit none character(*) :: filename integer :: nsel character(2) :: selel(:) type(eq_wrapper) :: eq call tqrpfil(filename,nsel,selel,eq%ceq) end subroutine pytqrpfil subroutine pytqgcom(comp,eq) implicit none type(comp_wrapper), intent(out) :: comp type(eq_wrapper) :: eq call tqgcom(comp%n,comp%compnames,eq%ceq) end subroutine pytqgcom subroutine pytqgnp(n,eq) implicit none integer, intent(out) :: n type(eq_wrapper) :: eq call tqgnp(n,eq%ceq) end subroutine pytqgnp subroutine pytqgpn(phtupx,phasename,eq) implicit none integer :: phtupx character(*), intent(out) :: phasename type(eq_wrapper) :: eq call tqgpn(phtupx,phasename,eq%ceq) end subroutine pytqgpn subroutine pytqgpi(phtupx,phasename,eq) implicit none integer, intent(out) :: phtupx character(*) :: phasename type(eq_wrapper) :: eq call tqgpi(phtupx,phasename,eq%ceq) end subroutine pytqgpi subroutine pytqgpi2(iph,ics,phasename,eq) implicit none integer, intent(out) :: iph, ics character(*) :: phasename type(eq_wrapper) :: eq call tqgpi2(iph,ics,phasename,eq%ceq) end subroutine pytqgpi2 subroutine pytqgpcn2(n,c,csname) implicit none integer :: n integer :: c character(*), intent(out) :: csname call tqgpcn2(n,c,csname) end subroutine pytqgpcn2 subroutine pytqgpcs(c,nspel,ielno,stoi,smass,qsp) implicit none integer :: c integer, intent(out) :: nspel integer :: ielno(*) double precision :: stoi(*) double precision, intent(out) :: smass, qsp call tqgpcs(c,nspel,ielno,stoi,smass,qsp) end subroutine pytqgpcs subroutine pytqphsts(phtupx,newstat,val,eq) integer :: phtupx,newstat double precision :: val type(eq_wrapper) :: eq call tqphsts(phtupx,newstat,val,eq%ceq) end subroutine pytqphsts subroutine pytqphsts2(phnames,newstat,val,eq) character(*) :: phnames integer :: newstat double precision :: val type(eq_wrapper) :: eq call tqphsts2(phnames,newstat,val,eq%ceq) end subroutine pytqphsts2 subroutine pytqsetc(stavar,nn1,nn2,value,cnum,eq) implicit none integer :: nn1 integer :: nn2 integer, intent(out) :: cnum character(*) :: stavar double precision :: value type(eq_wrapper) :: eq call tqsetc(stavar,nn1,nn2,value,cnum,eq%ceq) end subroutine pytqsetc subroutine pytqtgsw(i) implicit none integer :: i call tqtgsw(i) end subroutine pytqtgsw subroutine pytqce(target,nn1,nn2,value,eq) implicit none integer :: nn1,nn2 character(*) :: target double precision value type(eq_wrapper) :: eq call tqce(target,nn1,nn2,value,eq%ceq) end subroutine pytqce subroutine pytqgetv(stavar,nn1,nn2,nn3in,nn3out,values,eq) implicit none integer :: nn1,nn2,nn3in integer, intent(out) :: nn3out character(*) :: stavar double precision :: values(*) type(eq_wrapper) :: eq nn3out=nn3in call tqgetv(stavar,nn1,nn2,nn3out,values,eq%ceq) end subroutine pytqgetv subroutine pytqgphc1(iph,nsub,cinsub,spix,yfrac,sites,extra,eq) implicit none integer :: iph integer, intent(out) :: nsub integer :: cinsub(*),spix(*) double precision :: sites(*),yfrac(*),extra(*) type(eq_wrapper) :: eq call tqgphc1(iph,nsub,cinsub,spix,yfrac,sites,extra,eq%ceq) end subroutine pytqgphc1 subroutine pytqsphc1(nn1,yfra,extra,eq) implicit none integer :: nn1 double precision :: yfra(*),extra(*) type(eq_wrapper) :: eq call tqsphc1(nn1,yfra,extra,eq%ceq) end subroutine pytqsphc1 subroutine pytqcph1(nn1,nn2,nn3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,eq) implicit none integer :: nn1,nn2,nn3 double precision :: gtp(6),dgdy(*),d2gdydt(*),d2gdydp(*),d2gdy2(*) type(eq_wrapper) :: eq call tqcph1(nn1,nn2,nn3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,eq%ceq) end subroutine pytqcph1 subroutine pytqcph2(nn1,nn2,nn3,nn4,eq) implicit none integer :: nn1,nn2,nn3,nn4 type(eq_wrapper) :: eq call tqcph2(nn1,nn2,nn3,nn4,eq%ceq) endsubroutine pytqcph2 subroutine pytqcph3(nn1,nn2,g,eq) implicit none integer :: nn1,nn2 double precision :: g(*) type(eq_wrapper) :: eq call tqcph3(nn1,nn2,g,eq%ceq) endsubroutine pytqcph3 subroutine pytqdceq(name) implicit none character(24) :: name call tqdceq(name) endsubroutine pytqdceq subroutine pytqcceq(name,nn1,neweq,eq) implicit none character(24) :: name integer, intent(out) :: nn1 type(eq_wrapper), intent(out) :: neweq type(eq_wrapper) :: eq call tqcceq(name,nn1,neweq%ceq,eq%ceq) endsubroutine pytqcceq subroutine pytqselceq(name,eq) implicit none character(24) :: name type(eq_wrapper), intent(out) :: eq call tqselceq(name,eq%ceq) end subroutine pytqselceq subroutine pytqcref(ciel,phase,tpref,eq) implicit none integer :: ciel character(*) :: phase double precision :: tpref(*) type(eq_wrapper) :: eq call tqcref(ciel,phase,tpref,eq%ceq) end subroutine pytqcref subroutine pytqlr(lut,eq) implicit none integer :: lut type(eq_wrapper) :: eq call tqlr(lut,eq%ceq) end subroutine pytqlr subroutine pytqlc(lut,eq) implicit none integer :: lut type(eq_wrapper) :: eq call tqlc(lut,eq%ceq) end subroutine pytqlc subroutine pytqquiet(yes) implicit none logical :: yes call tqquiet(yes) end subroutine pytqquiet end module RawOpenCalphad ================================================ FILE: OCisoCbinding/pyOC/pyOC.py ================================================ import logging, sys import json import numpy as np import rawpyOC from rawpyOC import rawopencalphad as oc from enum import IntEnum class PhaseStatus(IntEnum): Suspended = -3 Dormant = -2 Entered = 0 Fixed = 2 class GridMinimizerStatus(IntEnum): On = 0 Off = -1 class PhasesAtEquilibrium(object): def __init__(self, phaseMolarAmounts, phaseElementComposition, phaseSites, phaseConstituentComposition): self.__phaseMolarAmounts=phaseMolarAmounts self.__phaseElementComposition=phaseElementComposition self.__phaseSites=phaseSites self.__phaseConstituentComposition=phaseConstituentComposition def getPhaseMolarAmounts(self): return self.__phaseMolarAmounts def getPhaseElementComposition(self): return self.__phaseElementComposition def getPhaseSites(self): return self.__phaseSites def getPhaseConstituentComposition(self): return self.__phaseConstituentComposition def __str__(self): return 'phase molar amounts:\n'+json.dumps(self.__phaseMolarAmounts, indent=4)+'\nphase element composition:\n'+json.dumps(self.__phaseElementComposition, indent=4)+'\nphase sites:\n'+json.dumps(self.__phaseSites, indent=4)+'\nphase constituent composition:\n'+json.dumps(self.__phaseConstituentComposition, indent=4) class OpenCalphad(object): _defaultEquilibriumName='default equilibrium' _maxNbPhases=400 _maxNbElements=100 _maxNbSublattices=10 _maxNbConstituents=100 def __init__(self): self.__equilibriumNamesInOC = {} self.__constituentsDescription = {} self.__logger = logging.getLogger('OpenCalphad') self.__logger .setLevel(logging.INFO) ch = logging.StreamHandler() ch.setStream(sys.stderr) ch.setLevel(logging.INFO) formatter = logging.Formatter('(%(name)s being verbose): %(message)s') ch.setFormatter(formatter) self.__logger.addHandler(ch) def setVerbosity(self, isVerbose): if (isVerbose): level= logging.DEBUG else: level = logging.INFO self.__logger.setLevel(level) for handler in self.__logger.handlers: handler.setLevel(level) oc.pytqquiet(~isVerbose) def raw(self): return oc def eq(self): return self.__eq def readtdb(self,tdbFilePath, elements=None): self.__eq = oc.pytqini(1) if self.__logger.getEffectiveLevel() is not logging.DEBUG: oc.pytqquiet(True) self.__eqName = OpenCalphad._defaultEquilibriumName eqNameInOC='%s' % self.__eqName.upper().replace(' ','_') self.__equilibriumNamesInOC[self.__eqName]=eqNameInOC self.__logger.debug('reading %s', tdbFilePath) if elements is None: oc.pytqrfil(tdbFilePath,self.__eq) else: oc.pytqrpfil(tdbFilePath,len(elements),(''.join(['%-2s']*len(elements)))%elements,self.__eq) comp = oc.pytqgcom(self.__eq) self.__componentNames=np.array([comp.compnames[:,i].tostring().decode().strip() for i in range(comp.n)]) self.__nbComponents=comp.n self.__logger.debug('component (%d) names: %s', self.__nbComponents, self.__componentNames) def getComponentNames(self): return self.__componentNames def getConstituentsDescription(self): self.__logger.debug('constituents description:\n'+json.dumps(self.__constituentsDescription, indent=4)) return self.__constituentsDescription def setPhasesStatus(self, phaseNames, phaseStatus, phaseAmount=0.0): phaseList=(' '.join(['%s']*len(phaseNames))) % phaseNames self.__logger.debug('modifying phases %s to status %s', phaseList, phaseStatus) oc.pytqphsts2(phaseList,phaseStatus,phaseAmount,self.__eq) def setTemperature(self,temperature): self.__logger.debug('setting temperature to %5.2f K', temperature) oc.pytqsetc('T',0,0,temperature,self.__eq) def setPressure(self,pressure): self.__logger.debug('setting pressure to %3.2e Pa', pressure) oc.pytqsetc('P',0,0,pressure,self.__eq) def setElementMolarAmounts(self,elementMolarAmounts): for el, n in elementMolarAmounts.items(): i=np.where(self.__componentNames==el)[0] self.__logger.debug('setting molar amount %5.4f for element %s (%d)',n,el,i) oc.pytqsetc('N',i+1,0,n,self.__eq) def changeEquilibriumRecord(self,eqName=None,copiedEqName=None): if eqName is None: eqName=OpenCalphad._defaultEquilibriumName if copiedEqName is None: copiedEqName=OpenCalphad._defaultEquilibriumName eqNameInOC=self.__equilibriumNamesInOC.get(eqName,'') if (eqNameInOC==''): eqNameInOC='%s' % eqName.upper().replace(' ','_') self.__equilibriumNamesInOC[eqName]=eqNameInOC eq=oc.pytqselceq(self.__equilibriumNamesInOC[copiedEqName]) self.__logger.debug('creating and selecting new equilibrium record \'%s\' (\'%s\')', eqName, eqNameInOC) iCopiedEq,self.__eq=oc.pytqcceq(eqNameInOC,eq) else: self.__logger.debug('selecting equilibrium record \'%s\' (\'%s\')', eqName, eqNameInOC) self.__eq=oc.pytqselceq(eqNameInOC) self.__eqName = eqName def calculateEquilibrium(self,gridMinimizerStatus=GridMinimizerStatus.On): self.__logger.debug('calculating equilibrium with grid minimizer %s', gridMinimizerStatus) if (self.__logger.isEnabledFor(level=logging.DEBUG)): oc.pytqlc(6,self.__eq) oc.pytqce('',gridMinimizerStatus,0,0.0,self.__eq) if (self.__logger.isEnabledFor(level=logging.DEBUG)): oc.pytqlr(6,self.__eq) def getErrorCode(self): return oc.pygeterr() def resetErrorCode(self): return oc.pyseterr(0) def getScalarResult(self,symbol): value=np.empty(1) oc.pytqgetv(symbol,0,0,1,value,self.__eq) self.__logger.debug('retrieving %s: %e',symbol,value[0]) return value[0] def getGibbsEnergy(self): return self.getScalarResult('G') def getComponentAssociatedResult(self, symbol): values={} value=np.empty(1) for i in range(self.__nbComponents): oc.pytqgetv(symbol,i+1,0,1,value,self.__eq) values[self.__componentNames[i]] = value[0] self.__logger.debug('retrieving %s:\n%s',symbol,json.dumps(values, indent=4)) return values def getChemicalPotentials(self): return self.getComponentAssociatedResult('MU') def getPhasesAtEquilibrium(self): tmpNbPhases=np.empty(OpenCalphad._maxNbPhases) tmpNbElements=np.empty(OpenCalphad._maxNbElements) tmpiNbElements=np.empty(OpenCalphad._maxNbElements, dtype=np.int32) tmpiNbSublattices=np.empty(OpenCalphad._maxNbSublattices, dtype=np.int32) tmpNbSublattices=np.empty(OpenCalphad._maxNbSublattices) tmpiNbConstituents=np.empty(OpenCalphad._maxNbSublattices*OpenCalphad._maxNbConstituents, dtype=np.int32) tmpNbConstituents=np.empty(OpenCalphad._maxNbSublattices*OpenCalphad._maxNbConstituents) tmp5=np.empty(5) # nbPhases=oc.pytqgetv('NP',-1,0,OpenCalphad._maxNbPhases,tmpNbPhases,self.__eq) phaseMolarAmounts={} phaseElementComposition={} phaseSites={} phaseConstituentComposition={} for i in range(nbPhases): if (tmpNbPhases[i]>0.0): # phaseName=oc.pytqgpn(i+1,self.__eq).decode().strip() phaseMolarAmounts[phaseName] = tmpNbPhases[i] # iph, ics = oc.pytqgpi2(phaseName,self.__eq) # phaseElementComposition[phaseName] = {} nbElements=oc.pytqgetv('X',i+1,-1,OpenCalphad._maxNbElements,tmpNbElements,self.__eq) for j in range(nbElements): phaseElementComposition[phaseName][self.__componentNames[j]]=tmpNbElements[j] # phaseConstituentComposition[phaseName]={} phaseName=oc.pytqgpn(i+1,self.__eq).decode().strip() nbSublattices = oc.pytqgphc1(i+1, tmpiNbSublattices, tmpiNbConstituents, tmpNbConstituents, tmpNbSublattices, tmp5, self.__eq) phaseSites[phaseName] = tmpNbSublattices[0:nbSublattices].tolist() count = 0 for j in range(nbSublattices): sublatticeConstituentComposition = {} offset = count for k in np.nditer(tmpiNbConstituents[offset:offset+tmpiNbSublattices[j]]): constituentName = oc.pytqgpcn2(iph,count+1).decode().strip() sublatticeConstituentComposition[constituentName] = tmpNbConstituents[count] if not constituentName in self.__constituentsDescription: nspel, smass, qsp = oc.pytqgpcs(k, tmpiNbElements, tmpNbElements) self.__constituentsDescription[constituentName] = {} self.__constituentsDescription[constituentName]['mass'] = smass self.__constituentsDescription[constituentName]['charge'] = qsp self.__constituentsDescription[constituentName]['elements'] = { self.__componentNames[tmpiNbElements[l]-1] : tmpNbElements[l] for l in range(nspel) if (tmpiNbElements[l]>0)} count += 1 if (nbSublattices==1): phaseConstituentComposition[phaseName] = sublatticeConstituentComposition else: phaseConstituentComposition[phaseName]["sublattice {0:d}".format(j)] = sublatticeConstituentComposition phasesAtEquilibrium=PhasesAtEquilibrium(phaseMolarAmounts,phaseElementComposition,phaseSites,phaseConstituentComposition) self.__logger.debug('phases at equilibrium:\n%s',phasesAtEquilibrium) return phasesAtEquilibrium opencalphad = OpenCalphad() ================================================ FILE: OCisoCbinding/pyOC/pyOCUnitTest.py ================================================ import unittest import numpy as np import os import pyOC from pyOC import opencalphad as oc from pyOC import PhaseStatus as phStat from pyOC import GridMinimizerStatus as gmStat @unittest.skipUnless(os.path.exists(os.environ.get('OCPRIVATEDATA','')+'/feouzr.tdb'), 'requires feouzr database') class test_feouzr(unittest.TestCase): def setUp(self): oc.setVerbosity(False) # tdb filepath tdbFile=os.environ['OCPRIVATEDATA']+'/feouzr.tdb' # reading tdb elems=('O', 'U', 'ZR') oc.readtdb(tdbFile,elems) # set pressure oc.setPressure(1E5) #Some global data, reference state SER ......................: #T= 3000.00 K ( 2726.85 C), P= 1.0000E+05 Pa, V= 0.0000E+00 m3 #N= 1.0000E+00 moles, B= 1.1041E+02 g, RT= 2.4944E+04 J/mol #GS= -4.67120E+05 J, GS/N=-4.6712E+05 J/mol, HS=-1.0408E+05 J, SS= 1.210E+02 J/K #Some data for components ...................................: #Component name Moles Mole-fr Chem.pot/RT Activities Ref.state #O 4.1492E-01 0.41492 -2.6690E+01 2.5636E-12 SER (default) #U 3.4330E-01 0.34330 -1.4184E+01 6.9174E-07 SER (default) #ZR 2.4178E-01 0.24178 -1.1513E+01 9.9991E-06 SER (default) #Some data for phases .......................................: #Name Status Moles Volume Form.Units Cmp/FU dGm/RT Comp: #LIQUID.................. E 2.832E-01 0.00E+00 2.34E-01 1.21 0.00E+00 X: # U 4.44834E-01 ZR 3.82781E-01 O 1.72385E-01 # Constitution: There are 5 constituents: # U1 4.90503E-01 O2ZR1 5.71591E-02 O1 3.11648E-07 # ZR1 4.05352E-01 O2U1 4.69863E-02 #LIQUID_AUTO#2........... E 7.168E-01 0.00E+00 3.51E-01 2.04 0.00E+00 X: # O 5.10761E-01 U 3.03177E-01 ZR 1.86062E-01 # Constitution: There are 5 constituents: # O2U1 3.87533E-01 U1 2.32157E-01 O1 1.80264E-06 # ZR1 2.45847E-01 O2ZR1 1.34461E-01 def test_LiquidWithMiscibilityGap(self): # set temperature oc.setTemperature(3000) # set element molar amounts elementMolarAmounts = { 'U' : 0.343298, 'O' : 0.414924, 'ZR': 0.241778 } oc.setElementMolarAmounts(elementMolarAmounts) # calculate equilibrium oc.calculateEquilibrium(gmStat.On) # retrieving Gibbs energy G=oc.getGibbsEnergy() np.testing.assert_allclose(G, -4.67120E+05, rtol=1e-5, atol=0) # retrieving mu data mu=oc.getChemicalPotentials() self.assertListEqual(list(mu.keys()), ['O', 'U', 'ZR']) np.testing.assert_array_almost_equal(list(mu.values()), [-2.6690E+01*2.4944E+04, -1.4184E+01*2.4944E+04, -1.1513E+01*2.4944E+04], decimal=-2) # retrieving equilibrium phases composition phasesAtEquilibrium=oc.getPhasesAtEquilibrium() phaseElementComposition=phasesAtEquilibrium.getPhaseElementComposition() self.assertListEqual(list(phaseElementComposition.keys()), ['LIQUID#1', 'LIQUID_AUTO#2']) self.assertListEqual(list(phaseElementComposition['LIQUID#1'].keys()), ['O', 'U', 'ZR']) self.assertListEqual(list(phaseElementComposition['LIQUID_AUTO#2'].keys()), ['O', 'U', 'ZR']) np.testing.assert_array_almost_equal(list(phaseElementComposition['LIQUID#1'].values()), [5.10761E-01,3.03177E-01,1.86062E-01], decimal=6) np.testing.assert_array_almost_equal(list(phaseElementComposition['LIQUID_AUTO#2'].values()), [1.72385E-01,4.44834E-01,3.82781E-01], decimal=6) phaseSites=phasesAtEquilibrium.getPhaseSites() self.assertListEqual(list(phaseSites.keys()), ['LIQUID#1', 'LIQUID_AUTO#2']) np.testing.assert_array_almost_equal(np.array(list(phaseSites.values())).ravel(), [1.0, 1.0], decimal=6) phaseConstituentComposition=phasesAtEquilibrium.getPhaseConstituentComposition() self.assertListEqual(list(phaseConstituentComposition.keys()), ['LIQUID#1', 'LIQUID_AUTO#2']) self.assertListEqual(list(phaseConstituentComposition['LIQUID#1'].keys()), ['O1', 'O2U1', 'O2ZR1', 'U1', 'ZR1']) self.assertListEqual(list(phaseConstituentComposition['LIQUID_AUTO#2'].keys()), ['O1', 'O2U1', 'O2ZR1', 'U1', 'ZR1']) np.testing.assert_array_almost_equal(list(phaseConstituentComposition['LIQUID_AUTO#2'].values()), [3.11648E-07,4.69863E-02,5.71591E-02,4.90503E-01,4.05352E-01], decimal=6) np.testing.assert_array_almost_equal(list(phaseConstituentComposition['LIQUID#1'].values()), [1.80264E-06,3.87533E-01,1.34461E-01,2.32157E-01,2.45847E-01], decimal=6) # retrieving constituent composition constituentsDescription = oc.getConstituentsDescription() ## to be tested #Some global data, reference state SER ......................: #T= 3000.00 K ( 2726.85 C), P= 1.0000E+05 Pa, V= 0.0000E+00 m3 #N= 1.0000E+00 moles, B= 1.1041E+02 g, RT= 2.4944E+04 J/mol #GS= -4.66921E+05 J, GS/N=-4.6692E+05 J/mol, HS=-1.0182E+05 J, SS= 1.217E+02 J/K #Some data for components ...................................: #Component name Moles Mole-fr Chem.pot/RT Activities Ref.state #O 4.1492E-01 0.41492 -2.6734E+01 2.4518E-12 SER (default) #U 3.4330E-01 0.34330 -1.4119E+01 7.3804E-07 SER (default) #ZR 2.4178E-01 0.24178 -1.1495E+01 1.0177E-05 SER (default) #Some data for phases .......................................: #Name Status Moles Volume Form.Units Cmp/FU dGm/RT Comp: #LIQUID.................. E 1.000E+00 0.00E+00 5.85E-01 1.71 0.00E+00 X: # O 4.14924E-01 U 3.43298E-01 ZR 2.41778E-01 # Constitution: There are 5 constituents: # U1 3.35427E-01 O2U1 2.51330E-01 O1 1.03405E-06 # ZR1 3.09983E-01 O2ZR1 1.03259E-01 def test_LiquidWithoutMiscibilityGap(self): # set temperature oc.setTemperature(3000) # set element molar amounts elementMolarAmounts = { 'U' : 0.343298, 'O' : 0.414924, 'ZR': 0.241778 } oc.setElementMolarAmounts(elementMolarAmounts) # keep only liquid phase oc.setPhasesStatus(('* ',),phStat.Suspended) oc.setPhasesStatus(('LIQUID',),phStat.Entered, 1.0) # calculate equilibrium oc.calculateEquilibrium(gmStat.Off) # retrieving Gibbs energy G=oc.getGibbsEnergy() np.testing.assert_allclose(G, -4.66921E+05, rtol=1e-5, atol=0) # retrieving mu data mu=oc.getChemicalPotentials() self.assertListEqual(list(mu.keys()), ['O', 'U', 'ZR']) np.testing.assert_array_almost_equal(list(mu.values()), [-2.6734E+01*2.4944E+04, -1.4119E+01*2.4944E+04, -1.1495E+01*2.4944E+04], decimal=-2) # retrieving equilibrium phases composition phasesAtEquilibrium=oc.getPhasesAtEquilibrium() phaseElementComposition=phasesAtEquilibrium.getPhaseElementComposition() self.assertListEqual(list(phaseElementComposition.keys()), ['LIQUID']) self.assertListEqual(list(phaseElementComposition['LIQUID'].keys()), ['O', 'U', 'ZR']) np.testing.assert_array_almost_equal(list(phaseElementComposition['LIQUID'].values()), [4.14924E-01,3.43298E-01,2.41778E-01], decimal=6) phaseSites=phasesAtEquilibrium.getPhaseSites() self.assertListEqual(list(phaseSites.keys()), ['LIQUID']) np.testing.assert_array_almost_equal(np.array(list(phaseSites.values())).ravel(), [1.0], decimal=6) phaseConstituentComposition=phasesAtEquilibrium.getPhaseConstituentComposition() self.assertListEqual(list(phaseConstituentComposition.keys()), ['LIQUID']) self.assertListEqual(list(phaseConstituentComposition['LIQUID'].keys()), ['O1', 'O2U1', 'O2ZR1', 'U1', 'ZR1']) np.testing.assert_array_almost_equal(list(phaseConstituentComposition['LIQUID'].values()), [1.03405E-06,2.51330E-01,1.03259E-01,3.35427E-01,3.09983E-01], decimal=6) #Some global data, reference state SER ......................: #T= 3000.00 K ( 2726.85 C), P= 1.0000E+05 Pa, V= 0.0000E+00 m3 #N= 1.0000E+00 moles, B= 1.1041E+02 g, RT= 2.4944E+04 J/mol #GS= -4.62227E+05 J, GS/N=-4.6223E+05 J/mol, HS=-8.1712E+04 J, SS= 1.268E+02 J/K #Some data for components ...................................: #Component name Moles Mole-fr Chem.pot/RT Activities Ref.state #O 4.1492E-01 0.41492 -2.6954E+01 1.9681E-12 SER (default) #U 3.4330E-01 0.34330 -1.3372E+01 1.5588E-06 SER (default) #ZR 2.4178E-01 0.24178 -1.1402E+01 1.1178E-05 SER (default) #Some data for phases .......................................: #Name Status Moles Volume Form.Units Cmp/FU dGm/RT Comp: #C1_FCC.................. E 3.461E-01 0.00E+00 1.42E-01 2.43 0.00E+00 X: # O 5.88380E-01 U 3.35030E-01 ZR 7.65900E-02 # Constitution: There are 5 constituents: # O2U1 6.34573E-01 ZR1 1.05930E-01 O1 5.93474E-07 # U1 1.79357E-01 O2ZR1 8.01390E-02 #HCP_A3.................. E 6.539E-01 0.00E+00 4.43E-01 1.48 0.00E+00 X: # U 3.47675E-01 ZR 3.29218E-01 O 3.23107E-01 # Constitution: Sublattice 1 with 2 constituents and 0.500000 sites # O1 9.54677E-01 VA 4.53225E-02 # Sublattice 2 with 2 constituents and 1.000000 sites # U1 5.13633E-01 ZR1 4.86367E-01 def test_SuspendingLiquid(self): # set temperature oc.setTemperature(3000) # set element molar amounts elementMolarAmounts = { 'U' : 0.343298, 'O' : 0.414924, 'ZR': 0.241778 } oc.setElementMolarAmounts(elementMolarAmounts) # keep only liquid phase oc.setPhasesStatus(('LIQUID',),phStat.Suspended) # calculate equilibrium oc.calculateEquilibrium(gmStat.On) # retrieving Gibbs energy G=oc.getGibbsEnergy() np.testing.assert_allclose(G, -4.62227E+05, rtol=1e-5, atol=0) # retrieving mu data mu=oc.getChemicalPotentials() self.assertListEqual(list(mu.keys()), ['O', 'U', 'ZR']) np.testing.assert_array_almost_equal(list(mu.values()), [-2.6954E+01*2.4944E+04, -1.3372E+01*2.4944E+04, -1.1402E+01*2.4944E+04], decimal=-2) # retrieving equilibrium phases composition phasesAtEquilibrium=oc.getPhasesAtEquilibrium() phaseElementComposition=phasesAtEquilibrium.getPhaseElementComposition() self.assertListEqual(list(phaseElementComposition.keys()), ['C1_FCC', 'HCP_A3']) self.assertListEqual(list(phaseElementComposition['C1_FCC'].keys()), ['O', 'U', 'ZR']) np.testing.assert_array_almost_equal(list(phaseElementComposition['C1_FCC'].values()), [5.88380E-01,3.35030E-01,7.65900E-02], decimal=6) self.assertListEqual(list(phaseElementComposition['HCP_A3'].keys()), ['O', 'U', 'ZR']) np.testing.assert_array_almost_equal(list(phaseElementComposition['HCP_A3'].values()), [3.23107E-01,3.47675E-01,3.29218E-01], decimal=6) @unittest.skipUnless(os.path.exists(os.environ.get('OCPUBLICDATA','')+'/steel7.TDB'), 'requires steel7 database') class test_steel7(unittest.TestCase): def setUp(self): oc.setVerbosity(False) # tdb filepath tdbFile=os.environ['OCPUBLICDATA']+'/steel7.TDB' # reading tdb oc.readtdb(tdbFile) # set pressure oc.setPressure(1E5) #Some global data, reference state SER ......................: #T= 1173.00 K ( 899.85 C), P= 1.0000E+05 Pa, V= 6.2399E-06 m3 #N= 1.0000E+00 moles, B= 5.5735E+01 g, RT= 9.7529E+03 J/mol #G= -5.76738E+04 J, G/N=-5.7674E+04 J/mol, H= 3.1856E+04 J, S= 7.633E+01 J/K #Some data for components ...................................: #Component name Moles Mole-fr Chem.pot/RT Activities Ref.state #C 4.0000E-02 0.04000 -4.1298E+00 1.6087E-02 SER (default) #CR 6.0000E-02 0.06000 -7.0639E+00 8.5546E-04 SER (default) #FE 8.3700E-01 0.83700 -5.6716E+00 3.4423E-03 SER (default) #MO 5.0000E-02 0.05000 -7.6456E+00 4.7813E-04 SER (default) #SI 3.0000E-03 0.00300 -2.0099E+01 1.8668E-09 SER (default) #V 1.0000E-02 0.01000 -1.3475E+01 1.4053E-06 SER (default) #Some data for phases .......................................: #Name Status Moles Volume Form.Units Cmp/FU dGm/RT Comp: #FCC_A1#1................ E 1.921E-02 5.45E-09 1.04E-02 1.84 0.00E+00 X: # C 4.56653E-01 MO 1.44330E-01 FE 2.08416E-03 SI 6.67740E-10 # V 3.62669E-01 CR 3.42642E-02 #Constitution: Sublattice 1 with 5 constituents and 1.000000 sites # V 6.67472E-01 CR 6.30613E-02 FE 3.83579E-03 SI 1.22894E-09 # MO 2.65631E-01 # Sublattice 2 with 2 constituents and 1.000000 sites # C 8.40444E-01 VA 1.59556E-01 #FCC_A1_AUTO#2........... E 8.566E-01 6.20E-06 8.45E-01 1.01 0.00E+00 X: # FE 9.21696E-01 C 1.35199E-02 SI 3.50221E-03 V 1.46572E-03 # CR 5.02328E-02 MO 9.58308E-03 #Constitution: Sublattice 1 with 5 constituents and 1.000000 sites # FE 9.34328E-01 MO 9.71442E-03 SI 3.55021E-03 V 1.48581E-03 # CR 5.09212E-02 # Sublattice 2 with 2 constituents and 1.000000 sites # VA 9.86295E-01 C 1.37051E-02 #M23C6................... E 2.978E-02 3.53E-08 1.03E-03 29.00 0.00E+00 X: # FE 3.83821E-01 C 2.06897E-01 V 1.28728E-04 SI 0.00000E+00 # CR 3.41462E-01 MO 6.76913E-02 #Constitution: Sublattice 1 with 3 constituents and 20.000000 sites # FE 5.26893E-01 CR 4.73095E-01 V 1.17857E-05 # Sublattice 2 with 4 constituents and 3.000000 sites # MO 6.54349E-01 FE 1.97647E-01 CR 1.46838E-01 V 1.16580E-03 # Sublattice 3 with 1 constituents and 6.000000 sites # C 1.00000E+00 #M6C..................... E 9.442E-02 0.00E+00 1.35E-02 7.00 0.00E+00 X: # MO 3.91919E-01 C 1.42857E-01 V 1.88041E-02 SI 0.00000E+00 # FE 3.81335E-01 CR 6.50840E-02 #Constitution: Sublattice 1 with 1 constituents and 2.000000 sites # FE 1.00000E+00 # Sublattice 2 with 1 constituents and 2.000000 sites # MO 1.00000E+00 # Sublattice 3 with 4 constituents and 2.000000 sites # MO 3.71718E-01 FE 3.34674E-01 CR 2.27794E-01 V 6.58144E-02 # Sublattice 4 with 1 constituents and 1.000000 sites #C 1.00000E+00 def test_melting(self): # set temperature oc.setTemperature(1173) # set element molar amounts elementMolarAmounts = { 'C' : 0.04, 'CR' : 0.06, 'MO': 0.05, 'SI': 0.003, 'V': 0.01, 'FE': 1.0-0.04-0.06-0.05-0.003-0.01 } oc.setElementMolarAmounts(elementMolarAmounts) # calculate equilibrium oc.calculateEquilibrium(gmStat.On) # retrieving Gibbs energy G=oc.getGibbsEnergy() np.testing.assert_allclose(G, -5.76738E+04, rtol=1e-5, atol=0) # retrieving mu data mu=oc.getChemicalPotentials() self.assertListEqual(list(mu.keys()), ['C', 'CR', 'FE', 'MO', 'SI', 'V']) np.testing.assert_array_almost_equal(list(mu.values()), [-4.1298E+00*9.7529E+03, -7.0639E+00*9.7529E+03, -5.6716E+00*9.7529E+03, -7.6456E+00*9.7529E+03, -2.0099E+01*9.7529E+03, -1.3475E+01*9.7529E+03], decimal=-2) # retrieving equilibrium phases composition phasesAtEquilibrium=oc.getPhasesAtEquilibrium() phaseElementComposition=phasesAtEquilibrium.getPhaseElementComposition() self.assertListEqual(list(phaseElementComposition.keys()), ['FCC_A1#1', 'M23C6', 'M6C', 'FCC_A1_AUTO#2']) self.assertListEqual(list(phaseElementComposition['FCC_A1#1'].keys()), ['C', 'CR', 'FE', 'MO', 'SI', 'V']) self.assertListEqual(list(phaseElementComposition['FCC_A1_AUTO#2'].keys()), ['C', 'CR', 'FE', 'MO', 'SI', 'V']) self.assertListEqual(list(phaseElementComposition['M23C6'].keys()), ['C', 'CR', 'FE', 'MO', 'SI', 'V']) self.assertListEqual(list(phaseElementComposition['M6C'].keys()), ['C', 'CR', 'FE', 'MO', 'SI', 'V']) np.testing.assert_array_almost_equal(list(phaseElementComposition['FCC_A1#1'].values()), [4.56653E-01,3.42642E-02,2.08416E-03,1.44330E-01,6.67740E-10,3.62669E-01], decimal=6) np.testing.assert_array_almost_equal(list(phaseElementComposition['FCC_A1_AUTO#2'].values()), [1.35199E-02,5.02328E-02,9.21696E-01,9.58308E-03,3.50221E-03,1.46572E-03], decimal=6) np.testing.assert_array_almost_equal(list(phaseElementComposition['M23C6'].values()), [2.06897E-01,3.41462E-01,3.83821E-01,6.76913E-02,0.0,1.28728E-04], decimal=6) np.testing.assert_array_almost_equal(list(phaseElementComposition['M6C'].values()), [1.42857E-01,6.50840E-02,3.81335E-01,3.91919E-01,0.0,1.88041E-02], decimal=6) phaseSites=phasesAtEquilibrium.getPhaseSites() self.assertListEqual(list(phaseSites.keys()), ['FCC_A1#1', 'M23C6', 'M6C', 'FCC_A1_AUTO#2']) np.testing.assert_array_almost_equal(phaseSites['FCC_A1#1'], [1.0, 1.0]) np.testing.assert_array_almost_equal(phaseSites['FCC_A1_AUTO#2'], [1.0, 1.0]) np.testing.assert_array_almost_equal(phaseSites['M23C6'], [20.0, 3.0, 6.0]) np.testing.assert_array_almost_equal(phaseSites['M6C'], [2.0, 2.0, 2.0, 1.0]) phaseConstituentComposition=phasesAtEquilibrium.getPhaseConstituentComposition() self.assertListEqual(list(phaseConstituentComposition.keys()), ['FCC_A1#1', 'M23C6', 'M6C', 'FCC_A1_AUTO#2']) self.assertListEqual(list(phaseConstituentComposition['FCC_A1#1'].keys()), ['sublattice 0', 'sublattice 1']) self.assertListEqual(list(phaseConstituentComposition['FCC_A1#1']['sublattice 0'].keys()), ['CR', 'FE', 'MO', 'SI', 'V']) self.assertListEqual(list(phaseConstituentComposition['FCC_A1#1']['sublattice 1'].keys()), ['C', 'VA']) np.testing.assert_array_almost_equal(list(phaseConstituentComposition['FCC_A1#1']['sublattice 0'].values()), [6.30613E-02,3.83579E-03,2.65631E-01,1.22894E-09,6.67472E-01], decimal=6) np.testing.assert_array_almost_equal(list(phaseConstituentComposition['FCC_A1#1']['sublattice 1'].values()), [8.40444E-01,1.59556E-01], decimal=6) self.assertListEqual(list(phaseConstituentComposition['FCC_A1_AUTO#2'].keys()), ['sublattice 0', 'sublattice 1']) self.assertListEqual(list(phaseConstituentComposition['FCC_A1_AUTO#2']['sublattice 0'].keys()), ['CR', 'FE', 'MO', 'SI', 'V']) self.assertListEqual(list(phaseConstituentComposition['FCC_A1_AUTO#2']['sublattice 1'].keys()), ['C', 'VA']) np.testing.assert_array_almost_equal(list(phaseConstituentComposition['FCC_A1_AUTO#2']['sublattice 0'].values()), [5.09212E-02,9.34328E-01,9.71442E-03,3.55021E-03,1.48581E-03], decimal=6) np.testing.assert_array_almost_equal(list(phaseConstituentComposition['FCC_A1_AUTO#2']['sublattice 1'].values()), [1.37051E-02,9.86295E-01], decimal=6) self.assertListEqual(list(phaseConstituentComposition['M23C6'].keys()), ['sublattice 0', 'sublattice 1', 'sublattice 2']) self.assertListEqual(list(phaseConstituentComposition['M23C6']['sublattice 0'].keys()), ['CR', 'FE', 'V']) self.assertListEqual(list(phaseConstituentComposition['M23C6']['sublattice 1'].keys()), ['CR', 'FE', 'MO', 'V']) self.assertListEqual(list(phaseConstituentComposition['M23C6']['sublattice 2'].keys()), ['C']) np.testing.assert_array_almost_equal(list(phaseConstituentComposition['M23C6']['sublattice 0'].values()), [4.73095E-01,5.26893E-01,1.17857E-05], decimal=6) np.testing.assert_array_almost_equal(list(phaseConstituentComposition['M23C6']['sublattice 1'].values()), [1.46838E-01,1.97647E-01,6.54349E-01,1.16580E-03], decimal=6) np.testing.assert_array_almost_equal(list(phaseConstituentComposition['M23C6']['sublattice 2'].values()), [1.0], decimal=6) self.assertListEqual(list(phaseConstituentComposition['M6C'].keys()), ['sublattice 0', 'sublattice 1', 'sublattice 2', 'sublattice 3']) self.assertListEqual(list(phaseConstituentComposition['M6C']['sublattice 0'].keys()), ['FE']) self.assertListEqual(list(phaseConstituentComposition['M6C']['sublattice 1'].keys()), ['MO']) self.assertListEqual(list(phaseConstituentComposition['M6C']['sublattice 2'].keys()), ['CR', 'FE', 'MO', 'V']) self.assertListEqual(list(phaseConstituentComposition['M6C']['sublattice 3'].keys()), ['C']) np.testing.assert_array_almost_equal(list(phaseConstituentComposition['M6C']['sublattice 0'].values()), [1.0], decimal=6) np.testing.assert_array_almost_equal(list(phaseConstituentComposition['M6C']['sublattice 1'].values()), [1.0], decimal=6) np.testing.assert_array_almost_equal(list(phaseConstituentComposition['M6C']['sublattice 2'].values()), [2.27794E-01,3.34674E-01,3.71718E-01,6.58144E-02], decimal=6) np.testing.assert_array_almost_equal(list(phaseConstituentComposition['M6C']['sublattice 3'].values()), [1.0], decimal=6) # retrieving constituent composition constituentsDescription = oc.getConstituentsDescription() ## to be tested # unset temperature oc.raw().pytqsetc('T=NONE',0,0,0.0,oc.eq()) # set liquid phase as fixed at 0.0 oc.setPhasesStatus(('LIQUID',),phStat.Fixed,0.0) # calculate equilibrium associated with melting temperature oc.calculateEquilibrium(gmStat.Off) meltingTemperature=oc.getScalarResult('T') np.testing.assert_allclose(meltingTemperature, 1501.45395, rtol=1e-5, atol=0) if __name__ == '__main__': unittest.main() ================================================ FILE: README.md ================================================ This is the development version of OpenCalphad, normally updated a few times each month. The stable version can be downloaded from http://opencalphad.org either as a zip file or as a precompiled installation for Windows. OpenCalphad is a free thermodynamic software for calculation of multicomponent equilibria, property and phase diagrams and for database development. It has a simple command line interface and an Application Software Interface (OCASI) for integration in simulation software. For simulations it can calculate equilibria in parallel using OpenMP. There is a community room for questions and discussions at https://gitter.im/opencalphad/opencalphad# A third party Graphical User Interface (GUI) of OpenCalphad (named as OpenCalphad CAE) for Windows can be downloaded from this [link](https://www.dropbox.com/sh/48dqcsk861dmulg/AAC7tcrUVLxYOFVF7GIkJ4UVa?dl=0). ================================================ FILE: build_configure ================================================ #!/bin/bash function header { echo "============== Log Start =================" date echo "============ Tools & Path ================" which aclocal echo "...version : "`aclocal --version | head -1` echo " " which libtoolize echo "...version : "`libtoolize --version | head -1` echo " " which automake echo "...version : "`automake --version | head -1` echo " " which autoconf echo "...version : "`autoconf --version | head -1` echo " " } function tools { echo "=========== Now Running Tools ==========" set -x libtoolize --automake --force aclocal -I m4 automake --add-missing --force-missing --foreign autoconf } function sequence { header tools } ######################################## cat configure.ac.1 > configure.ac echo "AC_OUTPUT" >> configure.ac ############## sequence 2>&1 | tee -a build_configure.log ================================================ FILE: configure.ac.1 ================================================ AC_INIT([opencalphad], [master], [clement.introini@cea.fr], [opencalphad]) ### minimum version of autoconf : AC_PREREQ(2.50) AC_CONFIG_MACRO_DIR([m4]) AC_CONFIG_AUX_DIR([config]) dnl Initialize automake. automake < 1.12 didn't have serial-tests and dnl gives an error if it sees this, but for automake >= 1.13 dnl serial-tests is required so we have to include it. Solution is to dnl test for the version of automake (by running an external command) dnl and provide it if necessary. Note we have to do this entirely using dnl m4 macros since automake queries this macro by running dnl 'autoconf --trace ...'. m4_define([serial_tests], [ m4_esyscmd([automake --version | head -1 | awk '{split ($NF,a,"."); if (a[1] == 1 && a[2] >= 12) { print "serial-tests" }}'])]) # Automake specific stuff AM_INIT_AUTOMAKE( foreign dist-bzip2 tar-ustar serial_tests) ### initializes canonical host variables: host, host_cpu, host_vendor and host_os AC_CANONICAL_HOST AC_PROG_MAKE_SET AC_PROG_INSTALL # Checks for programs. # store current user given compiler flags to avoid default setup via AC_PROG_FC #OLD_FFLAGS=$FFLAGS #OLD_FCFLAGS=$FCFLAGS # store current user given compiler flags to avoid default setup via AC_PROG_CXX OLD_CXXFLAGS=$CXXFLAGS AC_PROG_CXXCPP AC_PROG_CXX AC_PROG_FC([gfortran]) AC_LANG(Fortran) AC_PROG_LIBTOOL # reset compiler flags to initial flags CXXFLAGS=$OLD_CXXFLAGS #FFLAGS=$OLD_FFLAGS #FCFLAGS=$OLD_FCFLAGS dnl enable silent rules m4_ifdef([AM_SILENT_RULES],[AM_SILENT_RULES([yes])]) dnl-------------------------------------------------------------------- dnl enable-debug for compilling with debug options (no by default) dnl-------------------------------------------------------------------- AC_ARG_ENABLE([debug], [ --enable-debug Turn on debugging], [case "${enableval}" in yes) debug=true ;; no) debug=false ;; *) AC_MSG_ERROR([bad value ${enableval} for --enable-debug]) ;; esac],[debug=false]) if test "x$debug" = "xtrue" then FCFLAGS=" -g -ggdb -fcheck=all -ffpe-trap=invalid,zero,overflow " fi dnl-------------------------------------------------------------------- dnl enable-openmp for compilling with openmp options (no by default) dnl-------------------------------------------------------------------- AC_ARG_ENABLE([openmp], [ --enable-openmp Turn on debugging], [case "${enableval}" in yes) openmp=true ;; no) openmp=false ;; *) AC_MSG_ERROR([bad value ${enableval} for --enable-openmp]) ;; esac],[openmp=false]) AM_CONDITIONAL([OPENMP], [test x$openmp = xtrue]) if test "x$openmp" = "xtrue" then AC_OPENMP OPENMPLIB="$OPENMP_FCFLAGS" AC_SUBST(OPENMPLIB) if test "x$OPENMPLIB" != "x" then OPENMP_FFLAGS="$OPENMP_FCFLAGS" fi AC_SUBST(OPENMP_FFLAGS) AC_SUBST(OPENMP_FCFLAGS) fi dnl-------------------------------------------------------------------- dnl with-python for compiling python wrapper dnl-------------------------------------------------------------------- pyOC=no AC_ARG_WITH(python, AC_HELP_STRING([--with-python],[compile python wrapper]), [],[withval="no"]) if test "x$withval" == "xyes" ; then pyOC=yes AM_PATH_PYTHON([3.6]) fi AM_CONDITIONAL(WITH_PYTHON, test "x$pyOC" = "xyes") dnl-------------------------------------------------------------------- dnl with-lapack for compiling with user lapack library dnl-------------------------------------------------------------------- lapack=no AC_ARG_WITH(lapack, AC_HELP_STRING([--with-lapack],[compile with user lapack library)]), [],[withval="no"]) if test "x$withval" == "xyes" ; then lapack=yes fi AM_CONDITIONAL(WITH_LAPACK, test "x$lapack" = "xyes") dnl-------------------------------------------------------------------- dnl with-ochelp for compiling with browser help on Linux, command line dnl editing and open files dnl-------------------------------------------------------------------- ocHelp=no AC_ARG_WITH(ochelp, AC_HELP_STRING([--with-ochelp],[compile with browser help on Linux]), [],[withval="no"]) if test "x$withval" == "xyes" ; then ocHelp=yes fi AM_CONDITIONAL(WITH_OCHELP, test "x$ocHelp" = "xyes") dnl-------------------------------------------------------------------- dnl with-xplot for compiling with Gnuplot dnl-------------------------------------------------------------------- xplot=no AC_ARG_WITH(xplot, AC_HELP_STRING([--with-xplot],[compile with Gnuplot]), [],[withval="no"]) if test "x$withval" == "xyes" ; then xplot=yes fi AM_CONDITIONAL(WITH_OCPLOT, test "x$xplot" = "xyes") ##################################################################### # Generate configuration file envOC.sh to set environment for running # tests directly from source and build directory ##################################################################### echo '# This script is generated by configure' > envOC.sh echo '# Use it to set environment for running from build dir' >> envOC.sh BUILDDIR=`pwd` echo "export BUILDDIR=$BUILDDIR" >> envOC.sh SRCDIR=`dirname $0` cd $SRCDIR && SRCDIR=`pwd` && cd $BUILDDIR echo "export SRCDIR=$SRCDIR" >> envOC.sh echo "export OPENCALPHAD_ROOT=$SRCDIR" >> envOC.sh echo "export OCHOME=$SRCDIR/doc/manual/" >> envOC.sh echo "" >> envOC.sh echo 'LD_LIBRARY_PATH=$LD_LIBRARY_PATH:$BUILDDIR/src/.libs:$BUILDDIR/src/utilities/.libs:$BUILDDIR/src/numlib/.libs:$BUILDDIR/src/models/.libs:$BUILDDIR/.libs:$BUILDDIR/src/minimizer/.libs' >> envOC.sh echo 'PATH=$BUILDDIR:$PATH' >> envOC.sh echo "export PATH" >> envOC.sh echo "" >> envOC.sh ################### AC_CONFIG_FILES([ Makefile]) ================================================ FILE: doc/makedok4.F90 ================================================ ! program to extract dokumentation of a Fortran source file ! written by Bo Sundman 2016-2019 ! Program makedok integer, parameter :: maxtab=500 character pfil*64,dfil*64,sfil*64,line*80,dline*80,curfil*64 character beginxverb*18,endxverb*16,ch1*1 character verbbuff(500)*80,lastverb*64,sameverb*64,texverb*64 character verbanew(500)*80 character nounderscore1*80,nounderscore2*40 character tablentries(maxtab)*80,tablefile(maxtab)*40 character sectext*80 integer, dimension(maxtab) :: tabord integer, dimension(3,500) :: nsecverb logical dokfil,once,lend,dend,EOF,merge,newverb,percentplus integer foundverb,includedverb beginxverb='!\begin{verbatim} ' endxverb='!\end{verbatim} ' write(*,*)'ASCII value of backslash: ',ichar('\') write(*,10) texverb=' ' ntablentries=0 includedverb=0 percentplus=.false. ! ! Below the idea is to extract the text between ! 1. the closest \section BEFORE current \verbatim and ! 2. the closest BEFORE THE NEXT \verbatim. ! maybe better change to the text ! 1. the closest \section AFTER THE PREVIOUS \verbatim to ! 2. to closest \section AFTER THE CURRENT \verbatim ! The important thing is to keep text belonging together together ! and not to miss any documentation text ! ! Added that a source file can have (one level) of include files ! ! The extraction stops if the first line after \verbatim in the documentation ! does not fit the first line found in the source code and ask for manual ! editing of this. It turned out to be very complicated to handle when new ! subroutines had been added or shifted place. ! 10 format(///' This is a program to generate and update documentation',& ' of software.'//& ' written by Bo Sundman 2016-2019 for OpenCalphad, version 2',//& 'It expects two files, one with the software code',/& 'and one with existing LaTeX documentation (which can be empty)',//& 'The idea is that "critical" parts of the code should be included ',& 'in the '/& 'documentation and that whenever such a section in the source ',& 'code has been '/& 'updated such changes will be detected by this program and replaced.'/& 'A critical part is typically global data declarations and ',& 'subroutines and '/& 'functions with their arguments.'//& 'Updating the documentation of a developing software is a complex ',& 'task '/& 'and this software tries to help with this. It searches the LaTeX ',& 'and code files '/& 'sequentially comparing the critical parts in the two files:'/& '- If a critical part has changed in the source code ',& 'has changed'/' it is simply replaced in the LaTeX file.'/& '- If an critical part existing in the LaTeX file is missing in ',& 'the source code'/& ' the program stops and demands a manual update of the LaTeX file.'/& '- If a critical part existing in the source code is missing ',& 'in the LaTeX file'/& ' the program stops and demands a manual update of the LaTeX file.'//& 'The critical parts of the software that is included in the',& ' documentation'/'must be enclosed by lines "!\begin{verbatim}"',& ' and "!\end{verbatim}".'/& 'There must be an exact match of the text on the line after the '/& '"\begin{verbatim} ..." line in the LaTeX and code files.'//& 'There can also be a line !\addtotable in the code ',& 'for things '/& '(as subroutines) that should be added to a LaTeX table'//& 'Each critical part must be a separate "\(sub)section" ',& 'in the LaTeX file.'//& '"!\end{verbatim} %+" means the next critical part is ',& 'merged with the current.'//& 'All text in the LaTeX file between ',& 'the preceeding \{sub}..section up to the next '/& '\{sub}..section preceeding the next \begin{verbatim}, '/& 'will be copied to the new LaTeX documentation'/'file.'//& 'If there are differences inside a critical part the old version ',& 'be included as a LaTeX'/& 'coment together with the new in the documentation file.'//& 'The input files will never be changed.'//& 'Program file name (.F90):') lastokverb=0 read(*,20)pfil k=index(pfil,'.') if(k.eq.0) then k=len_trim(pfil) pfil(k+1:)='.F90 ' endif curfil=pfil 20 format(a) write(*,30) 30 format('Current documentation file name (.tex, if none give return):') read(*,20)dfil if(dfil(1:1).eq.' ') then ! no previous documentation file sfil=pfil(1:k)//'.tex' dokfil=.false. write(*,*)'no previous dokfile, writing: ',sfil(1:len_trim(sfil)) else dokfil=.true. k=index(dfil,'.') if(k.eq.0) then sfil=dfil(1:len_trim(dfil))//'_new.tex ' dfil(len_trim(dfil)+1:)='.tex ' else sfil=dfil(1:k-1)//'_new.tex ' endif endif ! source code file lunlevel=1 lunf90=31 open(lunf90,file=pfil,access='sequential',status='old') ! new documentation file write(*,*)'Writing on new documentation file: ',trim(sfil) open(23,file=sfil,access='sequential',status='unknown') nverbsec=0 ! 37 continue if(dokfil) then ! This is the LaTeX file open(22,file=dfil,access='sequential',status='old') ! search for first \begin{verbatim} linoldok=0 dend=.false. idum=-1 call searchverb(22,linoldok,idum,sectext,dend) rewind(22) if(dend) then ! no \begin{verbatim} in current dokumentation ... just ignore old dokfile write(*,*)'No verbatim, old documentation file ignored 1' dokfil=.false. close(22) goto 37 endif ! write(*,*)'Found first \begin{verbatim} at line: ',linoldok ! search for last \{sub}section before first \begin{verbatim} linsec=0 40 continue lastlinsec=linsec-1 call searchsection(22,linsec,.FALSE.,dend) if(dend) then ! no \section{ in current dokumentation ... just ignore old dokfile write(*,*)'Old documentation file ignored 2' dokfil=.false. close(22) goto 37 endif if(linsec.lt.linoldok) goto 40 ! we have bypassed the first \begin{verbatim}, last before is line lastlinsec rewind(22) nw=1 i=1 ! write(*,*)'calling copytonewdoc',lastlinsec nld=lastlinsec+1 call copytonewdoc(22,23,i,lastlinsec,nw,.false.) ! now scan the whole document ! write(*,*)'Calling scandoc at ',nld call scandoc(22,nld,nverb,nsecverb) write(*,44)nld,nverb 44 format('Old documentation has ',i5,' lines with ',i4,' verbatim sections'/) ! do i=1,nverb ! write(*,*)'Lines: ',(nsecverb(j,i),j=1,3) ! enddo else ! no old docfile, write default preamble on new write(23,90) 90 format('\documentclass[12pt]{article}'/'\usepackage[latin1]{inputenc}'/& '\topmargin -1mm'/'\oddsidemargin -1mm'/'\evensidemargin -1mm'/& '\textwidth 155mm'/'\textheight 220mm'/'\parskip 2mm'/& '\parindent 3mm'/'%\pagestyle{empty}'//'\begin{document}'//) endif ! ! stop 'at present' !-------------------------------------------------------------------- ! Now scan the code file to generate a new docfile nw=11 nl=0 merge=.false. 100 continue ! we are looking for a \begin{verbatim} in source file read(lunf90,20,end=900)line nl=nl+1 kink=index(line,'include "') if(kink.gt.0) then lunf90=lunf90+1 kend=index(line,'" ') curfil=line(kink+9:kend-1) write(*,101)line(kink+9:kend-1) 101 format(/' >>> opening include file: ',a/) open(lunf90,file=line(kink+9:kend-1),access='sequential',status='old') lunlevel=lunlevel+1 endif if(line(1:13).eq.'!\addtotable ') then ! an entry to the table of functions and subroutines ntablentries=ntablentries+1 write(*,*)'Add to table: ',trim(line(14:)),ntablentries if(ntablentries.gt.500) then write(*,*)'Too many table entries',ntablentries goto 990 endif tablentries(ntablentries)=line(14:) tablefile(ntablentries)=curfil goto 100 elseif(line(1:18).ne.beginxverb) then goto 100 endif ! we have found a !\begin{verbatim} in source code, remove the "!" ! write(*,*)'Found a critical part',nl,jl,merge newverb=.true. if(.not.merge) then line=line(2:) nbeg=nl ! store text in verbbuff jl=0 else ! write(*,*)'We have a critical part to merge with previous',jl goto 130 endif percentplus=.false. 120 jl=jl+1 if(jl.gt.500) then write(*,*)'Too large verbatim section, source lines: ',nl ! stop goto 990 endif ! save verbatim text in buffer verbbuff(jl)=line ! Here we are reading a critical part until !\end{verbatim} 130 continue read(lunf90,20,end=800)line if(newverb) then ! save the first line after verbatim lastverb=line newverb=.false. endif nl=nl+1 if(line(1:16).ne.endxverb) goto 120 if(line(17:18).eq.'%+') then percentplus=.true. ! if there is a %+ after !\end{verbatim} merge with next verbatim ! insert a line ------------ between jl=jl+1 verbbuff(jl)='---------------' merge=.true. includedverb=includedverb+1 ! write(*,*)' +++ We have to seach for a critical part to add',jl goto 100 else ! write(*,*)'Total lines in critical part: ',jl merge=.false. endif ! we should now search for section in LaTeX file where this fits ! The second line must be idential in the LaTeX file (excluding !) line=line(2:) jl=jl+1 verbbuff(jl)=line if(.not.dokfil) then ! no dokfil just write verbatim text on new dokfile do il=1,jl write(23,20)verbbuff(il)(1:len_trim(verbbuff(il))) nw=nw+1 enddo goto 100 endif ! search in old dokfil for line matching verbbuff(2) rewind(22) nd=0 iskip=0 200 continue ! This is searching in the LaTeX file, nverbsec is last found section ! The new verbatim section must be directly after this foundverb=nverbsec call searchverb(22,nd,foundverb,sectext,dend) if(dend) then ! no matching verbatim text stop and ask user to edit documentation file write(*,201)lastokverb,texverb,& verbbuff(2)(1:len_trim(verbbuff(2))),curfil 201 format(72('*')/& 'New verbatim missing in old documentation after line ',i7,/& 'with verbatim: ',a/& 'New verbatim text: ',a/'Source file: ',a/72('*')/& 'Please edit documentation or source and restart'/& 'Please note OUTPUT FILE IS NOT COMPLETE!!') ! stop goto 990 endif nbegverb=nd read(22,20,end=810)dline nd=nd+1 if(dline.ne.verbbuff(2)) then write(*,207)trim(verbbuff(2)),trim(dline),trim(texverb),trim(sectext) 207 format(/' *** New verbatim in source code with first line: '/a/& 10x,'not equal to next verbatim in the documentation: '/a//& 'Modify documentation after verbatim:'/a/& 'before the section:'/a/& 'or reorganize the source code'/& 'Please note OUTPUT FILE IS NOT COMPLETE!!'/) ! stop goto 990 endif ! remember the last verbatim section with correct first line lastokverb=nd texverb=lastverb nverbsec=nverbsec+1 ! !\begin{verbatim} write(*,217)nverbsec,nd,trim(verbbuff(2)(2:40)) 217 format('Matched verbatim ',i4,' at line: ',i6,': ',a,'...') once=.true. il=2 nbeg=nd 220 continue il=il+1 ! dline is read from the OLD LaTeX file read(22,20,end=810)dline nd=nd+1 ! verbbuff is from new source code, should be jl lines if(il.le.jl .and. dline.eq.verbbuff(il)) then continue elseif(il.lt.jl) then if(once) then ! write(*,*)' *** Some verbatim lines different from old *** ' once=.false. endif nw=nw+1 endif ! write(*,'(a,2i4,a/a)')'vvvv: ',il,jl,dline(1:50),verbbuff(il)(1:50) ! verbbuff(il)=dline if(il.lt.jl) goto 220 ! if(dline(1:15).ne.'\end{verbatim} ') goto 220 250 continue do iverb=1,nverb if(nsecverb(3,iverb).eq.nbegverb) goto 270 enddo write(*,266)nbegverb,nverb,(nsecverb(3,i),i=1,nverb) 266 format('Error searching for preceeding section:'/2i5,2x,10i5) ! stop 'error in scanning old docfile' goto 990 270 continue ! mark that section written on new docfile nsecverb(3,iverb)=-nsecverb(3,iverb) ! this call copies the section INCLUDING THE OLD VERBATIM ! if once is false the old verbatim is commented away with % ! write(*,*)'verbatim?',iverb,nsecverb(1,iverb),nsecverb(2,iverb) call copytonewdoc(22,23,nsecverb(1,iverb),nsecverb(2,iverb),nw,once) ! if once is .false. then add the new verbatim if(.not.once) then write(*,*)' *** Replacing with new verbatim, skipping first line ' do jjj=2,jl write(23,'(a)')trim(verbbuff(jjj)) enddo ! add a } to match {\small and an empty line write(23,280) 280 format('}'/) endif ! endif goto 100 ! all done?? !-------------------------------------- 800 continue write(*,*)'EOF while searching for !\end{verbatim} in source, line: ',nbeg if(lunlevel.gt.1) then close(lunf90) lunf90=lunf90-1 lunlevel=lunlevel-1 goto 130 else ! stop goto 990 endif 810 continue write(*,*)'EOF while searching for \end{verbatim} in old dokfile, line: ',& nbeg ! stop goto 990 !-------------------------------------- ! end of file in source file 900 continue close(lunf90) if(lunlevel.gt.1) then lunf90=lunf90-1 lunlevel=lunlevel-1 ! continue reading from source file goto 100 endif ! check if any old docfile parts not written on new do iverb=1,nverb if(nsecverb(3,iverb).gt.0) then ! write(*,911)iverb,(nsecverb(j,iverb),j=1,3),trim(verbbuff(iverb)) write(*,911)iverb,(nsecverb(j,iverb),j=1,3) 911 format('%!%!%!%!%!%!%!%!%! Section with verbatim missing in code',4i5) write(23,912)(nsecverb(j,iverb),j=1,3) 912 format('%!%!%!%!%!%!%!%!%! Section with verbatim missing in code',3i5) call copytonewdoc(22,23,nsecverb(1,iverb),nsecverb(2,iverb),nw,.true.) endif enddo 990 continue ! finished or terminating due to error if(dokfil) then close(22) endif if(ntablentries.gt.0) then ! write all table entries in alphabetical order tabord=0 ! write(*,*)'Sorting table ',ntablentries call ssort(tablentries,ntablentries,tabord) ! write(*,'(a,(15i4))')'Sorted table ',(tabord(jj),jj=1,ntablentries) write(23,991)ntablentries 991 format('\newpage'/'Tables with ',i5,' functions and subroutines'//& '\begin{tabular}{ll}'/'Name & File \\\hline') kk=0 do jj=1,ntablentries ! table the table entries in alphabetical order nounderscore1=tablentries(tabord(jj)) ! write(*,'(a,2i4,2x,a)')'table: ',jj,tabord(jj),trim(nounderscore1) ! replace any _ by \_ k1=1 980 continue k2=index(nounderscore1(k1:),'_') if(k2.gt.0) then nounderscore1(k1+k2:)=nounderscore1(k1+k2-1:) nounderscore1(k1+k2-1:k1+k2-1)='\' k1=k1+k2+2 ! write(*,'(a,i3,1x,a)')'underscore',k1,trim(nounderscore1) goto 980 endif write(23,992)trim(nounderscore1),trim(tablefile(tabord(jj))) 992 format(a,' & ',a,'\\') kk=kk+1 if(kk.gt.40) then write(23,995) 995 format('\end{tabular}'//'\begin{tabular}{ll}'/& 'Name & File \\\hline') kk=0 endif enddo write(23,993) 993 format('\end{tabular}') write(*,*)'Total number of table entries: ',ntablentries endif write(23,20)'\end{document}' close(23) write(*,500)nl,nw,sfil(1:len_trim(sfil)) 500 format('Read ',i7' lines, written ',i7,' lines on ',a) end Program makedok !/!!\!!/!!\!!/!!\!!/!!\!!/!!\!!/!!\!!/!!\!!/!!\!!/!!\!!/!!\!!/!!\!!/!!\!!/!!\! subroutine skiptoline(lin,linno) ! rewind lin and then skip lino lines character line*80 rewind(lin) nl=0 10 continue if(nl+1.eq.linno) goto 1000 read(lin,20)line 20 format(a) nl=nl+1 goto 10 1000 continue return end subroutine skiptoline subroutine searchverb(lin,linno,lastfound,sectext,EOF) ! searches for a line with \begin{verbatim} from current line ! return the line number in linno ! skp lines less than lastfound character line*80,sectext*(*) logical EOF iseqbeg=0 EOF=.false. 10 continue read(lin,20,end=1100)line 20 format(a) linno=linno+1 ! save last \(sub)section if(line(1:8).eq.'\section' .or. line(1:11).eq.'\subsection' .or.& line(1:14).eq.'\subsubsection') then sectext=line endif if(line(1:17).ne.'\begin{verbatim} ') goto 10 ! skip all lines with verbatim already found if(lastfound.ge.0) then iseqbeg=iseqbeg+1 if(iseqbeg.le.lastfound) goto 10 endif 1000 continue return ! no more \begin{verbatim}, just return last line and set EOF true 1100 continue EOF=.true. goto 1000 end subroutine searchverb subroutine searchsection(lin,linno,NOBEG,EOF) ! searches for a line with \section{... or \subsection{... or \subsub... ! from current line ! return the line number in linno character line*80 logical EOF,NOBEG ! write(*,*)'Enter searchsection: ',linno lin1=linno EOF=.false. 10 continue read(lin,20,end=1100)line 20 format(a) linno=linno+1 ! ASCII value of \ if(ichar(line(1:1)).ne.92) goto 10 ! when searching for first \begin{verbatim} lin1=0 if(NOBEG .and. line(1:17).eq.'\begin{verbatim} ') then write(*,33)lin1,linno 33 format(' *** WARNING, two verbatim sections with no \{sub}section',& ' in between'/' between lines ',i5,' and ',i5) stop 'fix LaTeX file and rerun' endif ! write(*,*)'Al line ',linno,line(1:20) if(line(1:9).eq.'\section{' .or. line(1:12).eq.'\subsection{' .or.& line(1:15).eq.'\subsubsection{' .or. & line(1:18).eq.'\subsubsubsection{') goto 1000 goto 10 1000 continue return ! no \section or \subs... set EOF true 1100 continue EOF=.true. goto 1000 end subroutine searchsection subroutine copytonewdoc(lin,lut,firstline,lastline,nw,sameverb) ! copies old LaTeX file from firstline to lastline in lin to lut integer firstline,lastline ! This line must be long enough to hold a whole paragraph character line*256 logical sameverb,verbic,mark ! sameverb is .false. if old verbatim text should be commented verbic=.true. ! write(*,*)'Enter copytonew',firstline,lastline,nw call skiptoline(lin,firstline) iz=0 lc=firstline-1 mark=.true. 10 continue if(lc.ge.lastline) goto 1000 read(lin,20,end=1100)line 20 format(a) k=len_trim(line) if(k.gt.250) then write(*,21)lc,kc 21 format('Beware, line ,'i4,' longer than 250 characters',i4/& 'output may be truncated') endif if(verbic) then ! start if(.not.sameverb) then if(index(line,'begin{verbatim}').gt.0) then verbic=.false. endif endif ! do not write a line with "\end{document}" if(index(line,'\end{document}').gt.0) then write(*,*)'Skipping origial end of document' else write(lut,20)line(1:k) endif else ! old verbatim as comments, DO NOT WRITE THE \end{verbatim}, it creates trouble if(mark) then write(lut,98) 98 format('%! THE LINES BELOW ARE TO BE DELETED WHEN TEXT UPDATED') 99 format('%! THE LINES ABOVE ARE TO BE DELETED WHEN TEXT UPDATED'/& '%! THE LINES BELOW ARE FROM THE NEW SOURCE CODE') mark=.false. endif if(line(1:14).ne.'\end{verbatim}') then write(lut,23)line(1:k) 23 format('%',a) ! else ! write(*,*)'Skipping commented \end{verbatim}' endif endif lc=lc+1 nw=nw+1 goto 10 1000 continue if(.not.mark) write(lut,99) return ! this should not happen 1100 continue write(*,1110)lc,lastline 1110 format('EOF when copying old docfile to new ',2i7) stop end subroutine copytonewdoc subroutine scandoc(lind,nl,nverb,linsec) ! subroutine to scan old doc file and exrtact "verb" sections and ! the appropriate surrounding {sub}section limits. character line*80 dimension linsec(3,*) logical EOF ! write(*,*)'Enter scandoc at line ',nl nverb=0 nsec=nl 10 continue read(lind,20,end=900)line 20 format(a) nl=nl+1 ! ASCII value of \ is 92. EMACS did not like '\' if(ichar(line(1:1)).ne.92) goto 10 100 continue if(line(1:17).eq.'\begin{verbatim} ') then ! a \begin found, store the line of the section start nverb=nverb+1 nv=nl ! write(*,*)'Found: ',nl,nverb,line(1:len_trim(line)) linsec(1,nverb)=nsec linsec(3,nverb)=nl-1 ! write(*,*)'Storing start ',nverb,nsec 110 continue read(lind,20,end=800)line nl=nl+1 if(line(1:15).eq.'\end{verbatim} ') then lend=nl ! write(*,*)'Calling searchsection ',lend call searchsection(lind,lend,.TRUE.,EOF) linsec(2,nverb)=lend-2 ! write(*,*)'Line for next section after \end{verbatim} ',lend nsec=lend-1 nl=lend if(EOF) goto 1000 else goto 110 endif ! else ! write(*,*)'skipping' endif goto 10 !------------------------ ! EOF here means missing \end{verbatim} 800 continue write(*,*)'Missing \end{verbatim} in old doc file, begin at line: ',nv 900 continue ! this makes last part of file will be written as "unmatched" nverb=nverb+1 linsec(1,nverb)=nsec linsec(2,nverb)=nl-1 linsec(3,nverb)=nl-1 1000 continue return end subroutine scandoc subroutine ssort(CMD,NS,INDEX) !...SORTING characters max 80 characters ! index returns the alphabetical order of CMD, no change in CMD CHARACTER CMD(*)*(*),STR*80 DIMENSION INDEX(*) L=LEN(CMD(1)) ITOP=1 INDEX(ITOP)=1 ! write(*,*)'ssort: ',L,NS 100 ITOP=ITOP+1 IF(ITOP.GT.NS) GOTO 900 STR=CMD(ITOP) IF(STR(1:L).GE.CMD(INDEX(ITOP-1))) THEN INDEX(ITOP)=ITOP GOTO 100 ENDIF ! write(*,*)'find place ',itop J1=1 J2=ITOP J=(J1+J2)/2 200 IF(STR(1:L).LT.CMD(INDEX(J))) THEN J2=J ELSEIF(J.GT.J1) THEN J1=J ELSE J=J2 GOTO 300 ENDIF IF(J1.NE.J2) THEN K=J J=(J1+J2)/2 IF(K.NE.J) GOTO 200 J=J2 ENDIF !...PLACE FOUND 300 CONTINUE MOVE: DO K=ITOP-1,J,-1 INDEX(K+1)=INDEX(K) enddo MOVE INDEX(J)=ITOP GOTO 100 900 RETURN END SUBROUTINE SSORT ================================================ FILE: doc/manual/ochelp.html ================================================

User Guide to the

OpenCalphad software package

version 7.0

DRAFT

Bo Sundman, March 23, 2021

Updates of OC User Guide

Earlier versions of OC had no User Guide

This page intentionally blank

Contents

1 Introduction
2 Some general features
 2.1 Command line user interface
  2.1.1 Command line editing and history
  2.1.2 Popup window for read/save
  2.1.3 On-line help
  2.1.4 Environment and startup macro file
  2.1.5 Macro files
  2.1.6 User interface feedback
 2.2 Names and symbols
 2.3 Elements, species, components, constituents and system
 2.4 Phases, composition sets and phase tuples
 2.5 The use of wildcards for phase names
 2.6 State variables
  2.6.1 Some pecularites of the state variable values
  2.6.2 The driving force
 2.7 Thermodynamic databases
 2.8 Model parameters
  2.8.1 Model Parameter Identifiers
  2.8.2 Constituent array and degrees
  2.8.3 Ternary extrapolations
  2.8.4 The TPFUN expression and bibliographic reference
 2.9 The reference state of a component
 2.10 Equilibrium calculations
 2.11 Property diagrams
 2.12 Phase diagrams
 2.13 Diagrams simulating phase transformations
  2.13.1 Scheil-Gulliver solidification model
  2.13.2 Paraequilibrium calculation
  2.13.3 Tzero calculation
 2.14 Assessment of model parameters for databases
  2.14.1 Entering coefficients to be assessed
  2.14.2 Entering phases and model parameters
  2.14.3 Entering experimental data
  2.14.4 Saving the state of the assessment
  2.14.5 Performing the assessment
 2.15 Application software
3 The command menu
 3.1 Options
4 About
5 Amend
 5.1 Amend assessment result
 5.2 amend Bibliography
 5.3 amend Components
 5.4 amend Constitution
 5.5 amend Element
 5.6 amend Equilirium
 5.7 amend General
 5.8 amend Line
 5.9 amend All optimizing coefficients
 5.10 amend Parameter
 5.11 amend for Phase “phase-name”
  5.11.1 amend phase “phase-name” Addition
  5.11.2 amend phase ... Gaddition
  5.11.3 amend phase ... Aqueous-model
  5.11.4 amend phase ... BCC-permutations
  5.11.5 amend phase ... Composition set
  5.11.6 amend phase ... Default Constitution
  5.11.7 amend phase ... Diffusion
  5.11.8 amend phase ... Disordered fraction sets
  5.11.9 amend phase ... FCC_CVM_tetradrn
  5.11.10 amend phase ... FCC_permutations
  5.11.11 amend phase ... Quasichemical
  5.11.12 amend phase ... Quit
  5.11.13 amend phase ... ternary-extrapolation
  5.11.14 amend phase ... UNIQUAC
 5.12 amend Quit
 5.13 amend redundant-sets
 5.14 amend for Species
 5.15 amend Symbol
 5.16 amend Tpfunction
6 Back
7 Calculate
 7.1 calculate All equilibria
 7.2 calculate Bosses-method or Carefully
 7.3 calculate Equilibrium
 7.4 calculate Global-Gridmin
 7.5 calculate No-Global
 7.6 calculate Paraequilibrium
 7.7 calculate Phase “phase-name”
  7.7.1 calculate phase ... All-Derivatives
  7.7.2 calculate phase ... Constitution_Adjust
  7.7.3 calculate phase ... Diffusion_Coefficients
  7.7.4 calculate phase ... G_and_dGdy
  7.7.5 calculate phase ... Only-G
  7.7.6 calculate phase ... Quit
 7.8 calculate Quit
 7.9 calculate Symbol
 7.10 calculate Tpfun-Symbols
 7.11 calculate Transition
 7.12 calculate Tzero point
 7.13 calculate with check after
8 Debug
 8.1 debug Elasticity
 8.2 debug Free lists
 8.3 debug Map-startpoints
 8.4 debug Symbol value
 8.5 debug Stop_on_Error
9 Delete
 9.1 delete Composition set
 9.2 delete Element
 9.3 delete Equilibrium
 9.4 delete Phase
 9.5 delete Quit
 9.6 delete Species
 9.7 delete Step_Map_Results
10 Enter
 10.1 enter Bibliography
 10.2 enter Comment
 10.3 enter Constitution
 10.4 enter Copy of equilibrium
 10.5 enter Element
 10.6 enter Equilibrium
 10.7 enter Experiment
 10.8 enter GNUPLOT Terminal
 10.9 enter Many Equilibria
 10.10 enter Material
 10.11 enter Optimizing coefficient
 10.12 enter Parameter
 10.13 enter Phase
 10.14 enter Plot_data
 10.15 enter Quit
 10.16 enter Species
 10.17 enter Symbol
 10.18 enter Tpfun_Symbol
11 Exit
12 Fin
13 Help and ?
14 HPcalc
15 Information
16 List
 16.1 list active-equilibria
 16.2 list Axis
 16.3 list Bibliography
 16.4 list Conditions
 16.5 list Data
  16.5.1 list data LaTeX
  16.5.2 list data Macro
  16.5.3 list data PDB
  16.5.4 list data TDB
 16.6 list Equilibria
 16.7 list Error message
 16.8 list Line equilibria
 16.9 list Model parameter identifiers
 16.10 list Model parameter value
 16.11 list optimization
  16.11.1 list optimization coefficients
  16.11.2 list optimization debug
  16.11.3 list optimization correlation_matrix
  16.11.4 list optimization experiments
  16.11.5 list optimization graphics
  16.11.6 list optimization long
  16.11.7 list optimization macro
  16.11.8 list optimization short
 16.12 list Parameter
 16.13 list Phase “phase-name”
  16.13.1 list phase ... Constitution
  16.13.2 list phase ... Data
  16.13.3 list phase ... Model
 16.14 list Quit
 16.15 list Results
 16.16 list Short
 16.17 list State_Variables
 16.18 list Symbols
 16.19 list excell CSV file
 16.20 list Tpfun Symbols
17 Macro
18 Map
19 New
20 Optimize
21 Plot
 21.1 plot Horizontal axis variable
 21.2 plot xaxis Vertical axis variable
 21.3 plot xaxis yaxis Options?/RENDER/
 21.4 plot xaxis yaxis Append
 21.5 plot xaxis yaxis Axis_Labels
 21.6 plot xaxis yaxis Font
 21.7 plot xaxis yaxis Graphics format
 21.8 plot xaxis yaxis Output file
 21.9 plot xaxis yaxis Position of keys
 21.10 plot xaxis yaxis Quit
 21.11 plot xaxis yaxis Render
 21.12 plot xaxis yaxis Scale_Range
 21.13 plot xaxis yaxis Text
  21.13.1 plot xaxis yaxis text Modify existing text?:
  21.13.2 plot xaxis yaxis text Which text index?:
  21.13.3 plot xaxis yaxis text X position
  21.13.4 plot xaxis yaxis text Y position
  21.13.5 plot xaxis yaxis text Fontscale
  21.13.6 plot xaxis yaxis text Angle (degrees)
  21.13.7 plot xaxis yaxis text Do you want to calculate the equilibrium?/Y/
  21.13.8 plot xaxis yaxis text Text:
 21.14 plot xaxis yaxis Title
 21.15 plot xaxis yaxis Extra
  21.15.1 plot xaxis yaxis extra factor
  21.15.2 plot xaxis yaxis extra color
  21.15.3 plot xaxis yaxis extra Gibbs-triangle
  21.15.4 plot xaxis yaxis extra line-with-symbols
  21.15.5 plot xaxis yaxis extra logscale
  21.15.6 plot xaxis yaxis extra manipulate lines
  21.15.7 plot xaxia yaxis extra lower left corner text
  21.15.8 plot xaxia yaxis extra spawn
  21.15.9 plot xaxia yaxis extra no heading
  21.15.10 plot xaxis yaxis extra pause option
  21.15.11 plot xaxis yaxis extra ratios XY
  21.15.12 plot xaxis yaxis extra tie-line
22 Quit
23 Read
 23.1 read Direct
 23.2 read PDB
 23.3 read Quit
 23.4 read selected phases only
 23.5 read TDB
 23.6 read Unformatted
24 Save
 24.1 save Direct
 24.2 save Quit
 24.3 save PDB
 24.4 save TDB
 24.5 save SOLGAS
 24.6 save Unformatted
25 Select
 25.1 select Equilibrium
 25.2 select Graphics
 25.3 select Language
 25.4 select Minimizer
 25.5 select Optimizer
26 Set
 26.1 set Advanced
  26.1.1 set advanced EEC-method
  26.1.2 set advanced equilibrium transfer
  26.1.3 set advanced global-min-onoff
  26.1.4 set advanced grid_density
  26.1.5 set advanced help-popup-off
  26.1.6 set advanced level
  26.1.7 set advanced map-special
  26.1.8 set advanced no-macro-stop
  26.1.9 set advanced open-popup-off
  26.1.10 set advanced quit
  26.1.11 set advanced symbol
  26.1.12 set advanced working-directory
 26.2 set As start equilibrium
 26.3 set Axis
 26.4 set Bit
 26.5 set Condition
 26.6 set Echo
 26.7 set Fixed coefficient
 26.8 set initial_T_and_P
 26.9 set Input-Amounts
 26.10 set Interactive
 26.11 set Log-File
 26.12 set Numeric-Options
 26.13 set Optimizing conditions
 26.14 set system variable
 26.15 set Phase “phase-name”
  26.15.1 set phase ... Amount
  26.15.2 set phase ... Bits
  26.15.3 set phase ... Constitution
  26.15.4 set phase ... Default-constitution
  26.15.5 set phase ... Quit
  26.15.6 set phase ... Status
 26.16 set Quit
 26.17 set Range of experimental equilibria
 26.18 set Reference-State
 26.19 set Scaled coefficient
 26.20 set Status
  26.20.1 set status Constituent
  26.20.2 set status Element
  26.20.3 set status Phases
  26.20.4 set status Species
 26.21 set Units
 26.22 set Variable coefficient
 26.23 set Verbose
 26.24 set Weight
27 Show
 27.1 property:
28 Step
 28.1 step Conditional
 28.2 step Normal
 28.3 step NPLE
 28.4 step paraequilibrium
 28.5 step Quit
 28.6 step Scheil-Gulliver
 28.7 step Separate
 28.8 step Tzero
29 Summary

1 Introduction

The development of the OpenCalphad (OC) sofware was started by a small group of dedicated scientists who wanted to provide an open source multicomponent thermodynamic software. It aims to provide a free high quality software for thermodynamic calculations, including property and phase diagrams, assessment of databases and a thermodynamic library for simulations for inorganic systems i.e. gases. liquids, alloys and other materials using many different kinds of models for the phases. There are three basic papers published about OC [1, 2, 3]. General information about thermodynamic models, calculations and assessments based on the Calphad technique can be found in the book by Lukas et al [4]. This software is provided free with a GNU GPL license.

In OC there is also a framework to store different kinds of materials properties that depend on temperature, pressure and composition when such properties are related to the phases of the system and used in simulations as described in [5]. The OC software can also be used to assess model parameters for such properties from experimental and theoretical values.

Complimentary (and maybe sometimes contradictory, I am not perfect) information about the OC software can be found in getting-started.pdf, news-oc7.pdf and the other parts of the OC documentation.

2 Some general features

The different parts of the OC software are documented separately for each module: thermodynamic models (GTP), equilibrium calculations (HMS), step/map/plot routines (SMP) and the application software interface (OCASI/TQ). With OC version 6 the old utility package metlib, originally written in F77, has been converted completely to the new Fortran standard and is included in the documentation. The documentation of the assessment module is not finished.

OC uses the free numerics packages LAPACK and BLAS and two routines from MINPACK [6], LMDIF and HYBRD developed at Argonne 1980. LMDIF is a least square minimizer used for assessments and HYBRD [6] solves systems of non-linear equations needed to calculate T0 and paraequilibria. For graphics OC generates a command file which can be plotted with the free GNUPLOT [7] software. If GNUPLOT is properly installed GNUPLOT is invoked automatically by OC.

2.1 Command line user interface

OC is operated by commands typed by the user or read from a macro file. The command monitor has a menu of command and each of these usually has sub-menus and finally some questions may be asked like phase names, a value or an expression. In most cases a default answer is provided which can be selected by just pressing the RETURN key or by typing a comma, “,”, on the same line as the command. At all levels the user should be able to type a ? and get some help, usually an extract from this manual, sometimes just a menu or examples of answers.

A command line interface is superiour when it comes to enter complex equilibrium conditions for example to calculate the minimum of a liquidus line defined by the condition “x(liq,cr)-x(bcc,cr)=0” in the Fe-Cr system. To follow a second order transition one can set the difference between the site fractions of the same element, for example “y(bcc-B2,Al)-y(bcc-B2,Al#2)=0.01” as condition.

For the menu commands a single ? will just display the menu, in order to obtain the User Guide type two, ??.

If you prefer a graphical user interface (GUI) there is at least two independent efforts to provide a GUI to OC.

2.1.1 Command line editing and history

On Windows the OS provides history and on-line editing of commands but on Linux and other OS this has to be provided by the software itself. Thus a C routine with an iso-C interface written by Urban S Jost (2009) copied from http://www.urbanjost.altervista.org/LIBRARY/libCLI/Getkey/getkey.html has been added and there is a seperate documentation of this if you want to change anything.

The command history is saved inside OC and by typing “upparrow” (normally ctrl-P but it can be different on different terminals) earlier command can be retrieved and also edited.

2.1.2 Popup window for read/save

To open a file for reading or saving one need a file browser and from OC version 5.018 I have included a routine “TINYFILEDIALOGS” developed by Guillaume Vareille (2014-2018) available at http://tinyfiledialogs.sourceforge.net. This will open a popup window to open a file (for a macro, a database or to save a calculation). In this window you can browse your directories to find the file.

This has some consequencies for editing your macro files which you should be aware of and which are explained below.

You can turn off the open file popup window feature with the command set advanced open_popup_off Y. You can turn it on again with the same command finishing with anything but Y.

Opening files on different directories can be complicated inside OC. For example during assessments you may use many different files for generating graphics and unformatted save files. Preferably you keep all of these on the same directory.

You are welcome to provide feedback on this popup feature and other parts of the user interface.

2.1.3 On-line help

A recent feature added to OC is providing on-line help using a browser window where this user guide is available as a searchable HMTL file.

Whenever the user wants an explation of a question the OC software asks he can type a ? and the OC software will open a separate browser window positioned at the relevant text in the user guide. You can then search the whole user guide for related information.

Whenever the user types ? at a menu level just the menu will be displayed but if you type ?? the user guide will be opened at the relevant menu text with additional explanations.

This feature is new and is still under development. Feedback is helpful. It can be turned off (or on again) by the command set advanced help_popup_off y in section 26.1.5.

For installation of the help system please read the installation guide to create an environment variable OCHOME with a link to the directory with the help file.

2.1.4 Environment and startup macro file

The OC program will look for an environment variable called OCHOME and if it finds this it will look for a file start.OCM which will be executed before the user gets control. This can typically be useful to set some variables like the plot terminals, see section 10.8. If there is no OCHOME environment variable the current “working directory” will be searched.

The ochelp.tex and ochelp.html file should be copied from the directory “manual” in the installation directory to this OCHOME directory.

2.1.5 Macro files

The macro command is very useful for preparing complex calculations and to remember how you did them. A macro file is simplest to create staring from a log file (created by the SET LOG command). See the macros directory for examples.

After a macro command the popup window will allow you to search for the file on all your directories unless you type the name of the file on the same line. In the latter case the macro file must be on you “working directory”, see section 2.1.2

When you open files, such as databases, inside a macro file and you type the file name on the same line as the command as “read tdb ./steel1”, you must prefix the file name, “steel1” with “./” if the tdb file is on the same directory as the macro file. If your command line is just “read tdb” the popup window will be activated and you can specify the file there.

If you open another macro file inside a macro (typically when you do assessments) you must also prefix the name of the macro with “./” unless you want to select the macro using the popup window.

Comments, stops and questions in macro files

It is useful to insert comments in the macro file to explain what it doing. A line starting with “@$” is a comment and will be ignored by the OC software.

You can insert stops in the macro file with “@&” at the beginning of a line. This can be useful to have time to inspect the output. The macro continues after pressing the ENTER/RETURN key. Depending on the graphical driver you use the program will normally pause after each plot and you must click on the graphical window to continue.

You can also, inside the macro, ask the user for values needed for the calculations. For example if you have a complicated calculation you would like to use several times with different values of the compositions or temperature you can, instead of editing the macro each time, insert questions in the macro. The macro will then stop and ask the user to input that value from the keyboard before continuing. In the macro file you can ask for the condition on the temperature in this way: 

  @$ Ask user for the condition on the T
  set cond T
  @?Input-new-temperature

When the macro comes to this point the program will write the text “Input-new-temparature” on the screen and wait for user input. After the value has been typed on the keyboard and ENTER/RETURN pressed OC will set the value as the temperature and continue with the next command in the macro file.

There is no way to insert loops or conditions in the macro file.

A macro file should be terminated with the command SET INTERACTIVE which gives back control to the keyboard (or the calling macro file) otherwise the program may terminate at the end of the macro.

Macro files can be nested 5 levels deep.

2.1.6 User interface feedback

OC has grown organically and although the basic concepts has been quite clear the implementations of several of these has become rather confusing. This will eventually require some cleaning up of the user interface.

A central part of any thermodynamic software is the modeling of the phases. A new PDB format for databases may help a little with the specification of the models. An attempt has been made in this version to clean up the way a model is specified and used. At present you must first ENTER the phase to give a name, basic model, sublattices and constituents. Then use the AMEND command to add magnetism, a disordered fraction set and/or use BCC/FCC permutations. Originally some of these things were set by the command SET PHASE ... BIT and that was not very clear.

Some computational options like for the grid minimizer are still set with several different commands. It is useful for the developers to have some feedback from users to organize this better.

2.2 Names and symbols

There are many symbols and names used in this package. A symbol or name MUST start with a letter A-Z. It usually can contain digits and the underscore character after the initial letter. All names are CASE INSENSITIVE, i.e. fe, FE, fE and Fe is the same. Some special symbols are used:

A name of an element is one or two characters, a species maximum 24 characters (note that a species name does not have to be its stoichiometric formula). A phase name is 24 characters but can also have a pre- and suffix 4 characters long and possibly a composition set number after a hash symbol, #.

State variable symbols and TP-fun symbols can be 16 characters long. TP-funs are expressions used to describe the T and P dependence of model parameters.

For user input it is possible to use abbreviations of names but you must be careful with names that have the same abbreviation and avoid phase names that are abbreviations of another phase!

2.3 Elements, species, components, constituents and system

Much of the confusion using thermodynamics is due to the fact that the user has no clear idea of the terms in the title of this section. A strict definition used in OC is:

A system is defined by its components. Conditions on the amounts or chemical potentials can only be set for the components, not for any arbitrary species. But the chemical potential of a molecule is related to that of the elements at equilibrium. Thus one can use the relation:

μH2O = 2μH + μO (1)
to set a condition on a sum of chemical potential of the elements.

The phases can gave different models and sets of constituents to describe Long Range Ordering (LRO) and Short Range Orderng (SRO). Some phases can exist for a specific composition only or for a limited subset of the components of a system.

2.4 Phases, composition sets and phase tuples

Many come across thermodynamic calculations the first time in chemistry writing chemical reactions. In such reactions the solid and liquid phases are usually treated as stoichiometric and only the gas can have several constituents. In the Calphad approach most phases are treated as solutions with variable composition but with different models for their Gibbs energy functions. But some phases can exist only for a specific or very restricted composition.

Each phase in a system has a name and a thermodynamic model and set of constituents, see section 2.3. The models are explained in a separate documentation. The phases can be entered interactivly or read from a database or a saved file together with the last calculation.

In some cases a phase can be stable with two ore more different compositions for example inside miscibility gaps or when the phase has order/disorder transitions. In such a case you use a composition set index to separate these. The composition set index is appended to the phase name preceeded by a hash “#” character, like liquid#2.

Composition sets can be created manually, see the command AMEND PHASE in section 5.11.5 or automatically by the grid minimizer or application software.

The phase tuple has been introduced to have a single index for both phases and composition sets in application software. The tuple index thus contain both the phase number and the composition set index. The array of tuple indices is updated internally whenever a new composition set is created or deleted.

2.5 The use of wildcards for phase names

In many cases you can use an asterix “*” as a name and this normally means “all”. For setting status of phases you can use the special “*S” for all suspended phase, “*D” for all dormant phases. If you plot the composition of a phase, such as x(liquid,*), values will be listed or plotted only in the range the liquid is stable.

When using “*” for output, for example NP(*) for the amount of all phases it means “all stable”. Thus to plot the driving force for metastable phases, see section 2.6.2, there is a special wildcard “#” which can be used in in DGM(#) for plotting the driving force for all metastable phases. The driving force, DGM, is also included in listing of results for all phases.

2.6 State variables

Table 1: A preliminary table with the state variables and their internal representation. Some model parameter properties are also included. The ”z” used in some symbols like Sz means the optional normalizing symbol M, W, V or F. There is some redundancy, for example NM(FE) is the same as X(FE).
Symbol 
Id
Index
Normalizing Meaning
A z 1 2 suffix
Intensive properties
T 1 - - - - Temperature
P 2 - - - - Pressure
MU 3 - component -/phase - Chemical potential
AC 4 - component -/phase - Activity
LNAC 5 - component -/phase - LN(activity)=MU/RT
Extensive and normallized properties
U 6 1 -/phase#set - - Internal energy for system
UM 6 2 -/phase#set - M Internal energy per mole
UW 6 3 -/phase#set - W Internal energy per mass
UV 6 4 -/phase#set - V Internal energy per m3
UF 6 5 phase#set - F Internal energy per formula unit
Sz 7 * -/phase#set - * entropy
Vz 8 * -/phase#set - * volume
Hz 9 * -/phase#set - * enthalpy
Az 10* -/phase#set - * Helmholtz energy
Gz 11* -/phase#set - * Gibbs energy
NPz 12* phase#set - * Moles of phase
BPz 13* phase#set - * Mass of phase
Qz 14* phase#set - * Stability of phase
DGz 15* phase#set - * Driving force of phase
Nz 16*-/phase#set/comp -/comp * Moles of component
X 17- phase#set/comp -/comp 0 Mole fraction
X% 17- phase#set/comp -/comp 100 Mole per cent
Bz 18*-/phase#set/comp -/comp * Mass of component
W 19- phase#set/comp -/comp 0 Mass fraction
W% 19- phase#set/comp -/comp 100 Mass per cent
Y 20- phase#set const#subl - Constituent fraction
Some model parameter identifiers
TC - - phase#set - - Curie temperature
BMAG - - phase#set - - Aver. Bohr magneton number
MQ&A - - phase#set constituent A - Mobility of A
THET - - phase#set - - Debye temperature

A state variable in a thermodynamic system has a value which at equilibrium is independent of the way the system has reach its current state, it depends only on its current state. All state variables available in OC are listed in Table 1. They are used to set conditions and to obtain results from an equilibrium calculation. It is possible to use state variables also when close to the equilibrium state for example when simulating a phase transformation.

2.6.1 Some pecularites of the state variable values

One has to be careful with the normalizing suffix, thus H means the enthalpy of a system for its current size. HM is the enthalpy for the current system divided by the number of moles of atoms in of the system. This is one can expect but one may be surprised that H(phase) is the enthalpy of “phase” for the current amount of moles of atoms of the phase, which is zero if the phase is not stable. To obtain the value of the enthalpy of “phase” independently of its current amount one must use HM(phase), the enthalpy per mole of atoms in the phase.

The value of a state variable also depend on the reference states of the elements. The user may define this for each element with a command, see section 2.9. The default refernce state is the stable state of the elements at 298.15 K and 1 bar, called SER. Whenever necessary this is indicated by an final suffix “S”, for example ACS(C) indicate the activity of C using the reference state SER whereas AC(C) is always be the activity relative the current reference state, either the default or that set by the user.

If all elements have the same phase as reference then the integral properties will also be refered to that phase, they wll represent an “excess”. If the elements in a system have different reference phases the integral value of the state variable will normally be relative to SER because anything else would be meaningless.

2.6.2 The driving force

Most state variables have a welldefined thermodynamic meaning but the driving force, DGM(phase), is a property related to the stability of the phase at an equilibrium. All stable phases are on a common tangent planne of chemical potentials and have DGM=0. For a metastable phase the value of the DGM variable is the distance in Gibbs energy (normallized by dividing it by the value of RT) between the stable tangent plane and the point on the Gibbs energy surface of the metastable phase that is closest to the tangent plane of the stable phases. DGM is negative for a metastable phase and if is close to zero it means the phase is close to become stable. The only case a phase can have positive DGM is for phases which have the dormant status and it means the phase would be stable if its status is changed to be entered.

2.7 Thermodynamic databases

The use of thermodynamic software depend on assessed model parameters for phases and elements. With the OC software one can make assessments of such model parameters using experimental and theoretical data, see section 2.14.5. However, this user guide does not describe the construction of such databases or how one can obtain them.

2.8 Model parameters

All data is organized relative to a phase and the phase is identified by a name. Each phase can have a different model for the composition dependence but the way to enter model parameters is the same for all models. However, the meaning of a model parameter will depend on the model of the phase.

Many types of data can be stored as explained in the section on parameter identifiers. The parameter also has a constituent specification explained in the constituent array section and possibly a degree, the meaning of which is model dependent and a bibliographic reference.

The basic syntax of a parameter is

“identifier” ( “phase name” , “constituent array” ; “degree” ) “expression” “bibl.ref.”

These parts are explained in more detail below.

2.8.1 Model Parameter Identifiers

The OC thermodynamic package can handle any phase property that depend on T,P and the constitution of the phase using the models implemented. It is easy to extend the number of properties by declaring property identifiers in the source code. If the parameters should have an influence on the Gibbs energy (like the Curie temperature) or a diffusion coefficient (like the mobility) the necessary code to calculate this must be added.

A list of the model parameter identifiers as shown in Table 2 can be obtained by the command LIST MODEL-PARAM-ID

Table 2: Current set of model parameter identifiers
Indx Ident T P Specification                Status Note
   1 G     T P                                   0 Energy
   2 TC    - P                                   2 Combined Curie/Neel T
   3 BMAG  - -                                   1 Average Bohr magneton numb
   4 CTA   - P                                   2 Curie temperature
   5 NTA   - P                                   2 Neel temperature
   6 IBM   - P &<constituent#sublattice>;       12 Individual Bohr magneton num
   7 THET  - P                                   2 Debye or Einstein temp
   8 V0    - -                                   1 Volume at T0, P0
   9 VA    T -                                   4 Thermal expansion
  10 VB    T P                                   0 Bulk modulus
  11 VC    T P                                   0 Alternative volume parameter
  12 VS    T P                                   0 Diffusion volume parameter
  13 MQ    T P &<constituent#sublattice>;       10 Mobility activation energy
  14 MF    T P &<constituent#sublattice>;       10 RT*ln(mobility freq.fact.)
  15 MG    T P &<constituent#sublattice>;       10 Magnetic mobility factor
  16 G2    T P                                   0 Liquid two state parameter
  17 THT2  - P                                   2 Smooth step function T
  18 DCP2  - P                                   2 Smooth step function value
  19 LPX   T P                                   0 Lattice param X axis
  20 LPY   T P                                   0 Lattice param Y axis
  21 LPZ   T P                                   0 Lattice param Z axis
  22 LPTH  T P                                   0 Lattice angle TH
  23 EC11  T P                                   0 Elastic const C11
  24 EC12  T P                                   0 Elastic const C12
  25 EC44  T P                                   0 Elastic const C44
  26 UQT   T P &<constituent#sublattice>;       10 UNIQUAC residual parameter
  27 RHO   T P                                   0 Electric resistivity
  28 VISC  T P                                   0 Viscosity
  29 LAMB  T P                                   0 Thermal conductivity
  30 HMVA  T P                                   0 Enthalpy of vacancy form.
  31 TSCH  - P                                   2 Schottky anomaly T
  32 CSCH  - P                                   2 Schottky anomaly Cp/R.
  33 NONE  T P                                   0 Unused

Several of these identifiers have no supporting software implemented, this is an ongoing project. The columns T P indicate if the parameter may depend on T or P. Some identifiers require additional specification of the constituent and sublattice, like the mobility of a constituent. Currently it is not yet clear if mobilities should depend on the sublattice or not but the notation allows that.

A slightly more detailed explanation of the identifiers are:

The current value of any of these parameter identifiers can be obtaind by the command LIST STATE_VARIABLE using the identifier and appropriate phase and component specifiers, see section 16.17.

For details of the meaning of the model identifier refer to the model documentation. As already mentioned many of the identifiers, like the mobility, does not influence the Gibbs energy but as they depend on the T,P and constitution of the phase it is convenient to model them in the same way as the thermodynamic data.

2.8.2 Constituent array and degrees

A constituent array specifies one or more constituent in each sublattice. A constituent must be entered as a species with fixed stoichiometry. Between constituents in different sublattices you must give a colon, ”:”, between interacting constituents in the same sublattice you must give a comma, ”,” or a space. A constituent array with exactly one constituent in each sublattice is also called an “endmember” as it give the value for a “compound” with fixed stoichiometry. Constituent arrays with one or more interaction constituents describe the composition dependence of the property. Without such parameters the property will vary linearly between the endmembers.

If there are no sublattices, like in the gas, you just give the phase and the constituent

G(GAS,C1O2)

If no degree is specified it is assumed to be zero. For endmembers the degree must be zero but it may sometimes be useful to specify the zero in order to distinguish the parameter from the expression for the calculated value of the property, like the chemical potential of a component. In the gas phase you normally assumes there are no interactions but it is possible to add such parameters. For an fcc phase with 4 sublattice for ordering and one for interstitials an endmember parameter is

G(FCC,AL:NI:NI:NI:VA;0)

This would be the Gibbs energy of an fcc AL1NI3 ordered compound.

An interaction between vacancies and carbon in the austenite is

G(FCC,FE:C,VA;0)

For an interaction parameter you should always specify a degree but also in this case an omitted degree is interpreted as zero.

2.8.3 Ternary extrapolations

The main binary excess model implemented in OC is the symmetric binary Redlish-Kister method combined with the Muggianu ternary extrapolation. Other binary methods, such a polynomial or Legendre polynom can always be converted to a set of Redlich-Kister parameters.

n LA,B = ∑   νLA,B (yA - yB )ν ν=0
where the degree, ν, of the interaction parameter is specified after a semicolon, L(phase,A,B;ν).

For ternary parameters and for reciprocal parameters the Hillert model for composition dependence is implemented, see [4].

You can store many different types of data in OC with different parameter identifier. Some of the parameters are not related to the thermodynamic properties but as they depend on the phase, T, P and composition it is convenient to store them together with the thermodynamic data. For example the mobility of Fe in BCC (including an empty interstitial sublattice) is specified as: MQ&FE(BCC,FE:VA).

An explanation of the identifiers implemented in OC can be found in section 2.8.1. The current list can be obtained by the command LIST MODEL_PARAM_ID. All of them can be composition dependent. Some cannot depend on T or P or neither. Many kinds of the parameters are available but in some cases the software for the models to handle them are not implemented. The value of a model parameter can be obtained using LIST MODEL_PARAM_VAL or simply SHOW. You must specify phase and endmember for the parameter.

From OC version 7 it will be possible to specify differnt ternary extrapolation methods for each a ternary subsystem of a phase. A ternary subsytem in a phase may be assigned a symmetric Kohler or assymetric Toop ternary method together with the Redlich-Kister binary method. See section 5.11.13.

2.8.4 The TPFUN expression and bibliographic reference

The expression for a parameter can be a single value or a function of T and P. It must start with a low temperature limit, usually 298.15 K and must finish with a high temperature limit. These expressions as well as their first an second derivatives will be calculated by the TP-fun package. To simplify that there is a strict syntax for the expression. A term in the expression is

“numeric value” * “name of TP function” *T** “power” *P** “power”

You can construct very complex expression by referring to other functions. If “power” is zero the corresponding *T** or *P** can be omitted. If it is negative it must be surrounded by parenthesis like (-1). If it is unity the **1 can be skipped.

Several terms, seperated by signs, forms an expression and it must be terminated by a semicolon, “;”. After the semicolon there must be a high temperature limit or a breakpoint in temperature. A breakpoint must be followed by the letter “Y” and then a new expression for temperatures above the breakpoint.

It is the responsability of the database manager to ensure the expression is continuous at the breakpoint. If there are jumps in the value at a breakpoint strange things will happen when calculating equilibria.

After the high temperature limit the letter “N” must be given followed by a bibliographic reference for the parameter. Use the commands AMEND or ENTER BIBLIOGRAPHIC to give the reference.

The database manager should always add a bibliographic reference even if it is just his or her name and a date. This avoids people to mistake a value inspired by your experience for a carefully validated parameter.

A term can be used inside a natural logarithm, LN, or exponential, EXP. And the LN or EXP can be multiplied with a term. On the other hand you are not allowed to have any parenthesis, except around powers or arguments to LN and EXP. A valid expression is 

 298.15 -8856.94+157.48*T-26.908*T*LN(T)+.00189435*T**2
        -1.47721E-06*T**3+139250*T**(-1); 2180 Y
        -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6000 N 91Din

where 91Din is the bibliographic reference to the SGTE unary database.

2.9 The reference state of a component

The values of most thermodynamic data must have a defined reference state. By default the reference state for the components is SER (Stable Element Reference) which is the stable state of the element at 298.15 K and 1 bar. (NOTE: the default reference state is defined by the database but today almost all databases have SER as reference state.)

For each component (also for other components than the elements) you can specify a phase at a given temperature and pressure as reference state, see section 26.18. The phase must exist for the component as pure.

A state variable like the chemical potential, MU(O), will refer to the user defined reference state if set. To obtain the value for the SER state you can use a suffix S, i.e. MUS(O) to obtain the chemical potential refered to SER. All state variables are listed in Table 1.

Note that the value of integral properties like Gibbs energy, G, enthalpy, H, etc. may have mixed reference states unless all components have the same phase as reference state. In order to have the enthalpy of mixing of a phase all components must have that phase as reference state. For the volume, V , SER is always used as reference state unless all components have the same reference state.

2.10 Equilibrium calculations

The basic application of OC is to calculate the equilibrium of a system as described in section 7.3. The user can specifying the external conditions like T,P and the composition, see section 7.3.. The minimizing algorithm [2] use Lagrangian multiplier so many different sets of state variables can be used for specifying the external conditions. Each condition is set separately and it is possible to extract phase amounts and compositions after the calculation. By changing the status of the phases it is possible to calculate metastable state.

In order to do any calculation the user must provide a database with the model parameters for his system or enter these manually.

The conditions can also be set using the command set_input_amount, see section 26.9.

2.11 Property diagrams

A property diagram is calculate with the STEP command. First you must set conditions to calculate a single equilibrium and then set set one of the conditions as an axis. After the STEP command, see section 28 you can plot how any state variable varies with the selected axis variable. See the section 21 and the OC macros guide.

2.12 Phase diagrams

A phase diagram show the regions of different sets of stable phases in a system. It can have two or more axis variables, in OC the maximum number of axis is two at present. As for property diagrams you must first calculate a single equilibrium and then select two conditions as axis variables. The command MAP, see section 18, will then trace the lines in your systems where the set of stable phases changes. There is no limit on the number of components for a phase diagram calculation.

After calculating a diagram you can plot it with many different types of axis, see section 21 and the OC macros guide.

2.13 Diagrams simulating phase transformations

Thermodynamics is essential to simulate phase transformations but requires good understanding also of the kinetics such as diffusion and kinetcs. For such applications OC has an Appication Software Interface (OCASI) with subroutines to calculate local driving forces and chemical potentials in various parts of a sample as described in [3, 5]. However, there are a few cases when one can simplify the kinetics sufficently to use the facilities of OC directly.

2.13.1 Scheil-Gulliver solidification model

In a Scheil-Gulliver solidification simulation the diffusion in the solid phases are ignored and the liquid is considered as homogeneous. That is a realistic model for the interdendric reqion during a normal solidification. It can be calculated with a STEP calculation by using small time steps and modify the overall composition to be that of the liquid after each step. The solid formed is removed from the system. In such a simulation the liquid will be stable until it reaches an invariant equilibrium, usually very far from its initital composition, see section 28.6.

2.13.2 Paraequilibrium calculation

In some alloys, most particularly in steels, there are fast diffusing elements such as C or N which can maintain a constant chemical potential during the whole transformation, and thus change their composition in different phases. The other alloying elements may transform to a new phase without changing their fractions. This can be modelled as a paraequilibrium or a “No Partitioning Local Equilibrium” (NPLE) situation and it requires no kinetic data. In OC the CALCUALATE or STEP PARAEQUILIBRIUM simulates such a transformation, see sections 7.6, 28.4.

2.13.3 Tzero calculation

The T0 point, line or rather “hypersurface” between two phases are defined by T where the Gibbs energy of the two phases are the same. Such a point is the limit of a diffusionless transformation of one phase to the other and it is useful to understand for example the martensite transformation. How to calculate the “Tzero” point or line are explaned in sections 7.12 and 28.8.

2.14 Assessment of model parameters for databases

One of the important uses of the OC software is to assess model parameters in the phases of a system using experimental and theoretical data. This is done by recalculating the experimental data from the model and by varying the model parameters a least square routine, LMDIF developed at Argonne National Lab in 1981, is used to find the best set.

Assessments are a very difficult procedure as you must also take into account the extrapolations of the model outside the range of experimental data. So called “First Principles Calculations” or the somewhat simpler “Density Functional Theory” (DFT) which are based on the electronic structure of the elements can provide information for metastable as well as for the stable state. But you must be careful that the result from such calculations does not represent a mechanically unstable state with imaginary phonon frequencies.

Experimental data can be direct measurements of thermodynamic data like enthalpies, chemical potentials, heat capacities, activities, etc but very important are also measurements of phase diagrams, solubilities etc because they are also related to the equilibrium state.

There are several commands related to the assessment procedure in OC but during the assessment you will also use the basic facilities to calculate equilibria for different kinds of conditions as well as many different kinds of diagrams to verify the results.

2.14.1 Entering coefficients to be assessed

The command “enter optimizing coefficients”, see section 10.11 creates symbols A00 up to A99 that can be used as coefficients in the thermodynamic model parameters. Maximum number of coefficients are 100.

2.14.2 Entering phases and model parameters

The elements, species and phases with their appropriate models are entered using the appropriate commands. Normally this is on a macro file in order to have proper documentation. Keep also in mind that an assessment is often revised after a few years when new data become available or you find that the extrapolations of an assessment to a higher order system is not reasonable.

The model parameters are entered using “enter parameter”, see section 10.12 or “enter tpfun”, see section 10.18 as many parameters may share some properties and a TP-function can be used in several parameters. The optimizing coefficents A00 to A99 with different T and P dependence can be used instead of numerical values as their values should be assessed.

2.14.3 Entering experimental data

This is done either by entering single equlibria with conditions and in addition using the command “enter experiment”, see section 10.7 where the experimental data is given with an uncertainty. Each equilibrium with an experiment is given a unique name.

Often there are tables with values and instead of entering each of them there is a command “enter many_equilibria”, see section 10.9 with a simplified syntax.

When all equilibria with experiental data has been entered you have to give the command “set range”, see section 26.17 to give the first and last equilibrium number that should be used in the assessment. If necessary this range can be extended during the assessment.

All the experimental data should also be entered as a mcro file to keep a documentation.

2.14.4 Saving the state of the assessment

Any time during an assessment it is possible to save the values of all assessed parameters and the calculated experimental equilibria by the command “save unform filename”, see section 24.6. With this command the data inside OC will be written as an unformatted Fortran file and this can be saved and later read back into the OC software by the command “read unfomatted filename”, see section 23.6. If these commands are inside a macro file prefix the filename with “./” to read and write on the same directory as the macro file.

These unformatted files are very convenient but beware that they may not be portable to other operating systems or even other versions of OC compiled with different Fortran compilers. It may change in future releases of the OC software. Thus keep printouts and macro files also if you later want to make modifications.

2.14.5 Performing the assessment

There are many decisions to make during the assessment and a general description how to perform an assessment can be found in the book by Lukas et al [4]. It is never possible to try to assess all parameters using all experiments in a single step. Normally the user selects different sets of experimental data by the “set weight” command, see section 26.24 and fits a few model parameters to these using the command “set variable-coeff”, see section 26.22. This can typically an enthalpy of mixing or a heat capacity function for a compound.

The command to run the least square fit is “optimize” followed by the maximum number of iterations, see section 20. If zero is given a single loop is made through all equilibria with nonzero weights within the specified range is made. It is also possible to use the command “calculate all”, see section 7.1, to calculate all non-zero weight equilibria. With the latter command you can turn on the grid minimizer, in the optimize command the grid minimizer is always turned off.

When the optimize command is given with nonzero maximum there will be output on the screen at regular intervals giving the current values of the optimizing coefficients and the value of the sum of squares. When the oprimization is finished there will also be a listing of the errors for all experiments.

With the command “list opt short”, see section 16.11.8, the current values of the optimizing coefficients and all equiliria with the experimental data is listed together with the sum of squares. New selection of equilibria or weights can be made and the values obtained for the optimizing coefficients must also be reasonable but to know what is reasonable is not always easy. These steps are repeated until the user is satisfied or exhausted.

Macro files to calculate and plot of the calculated properties overlayed with the experimental data should be preoared and run regularly as just looking at numbers is not sufficient.

At a later stage solubilities and phase diagram data are used but in many cases reasonable guesses of the start values of model parameters must be made to be able to calculate the equilibrium with the experiment. Great care must be taken that the calculated equilibria for the inital model parameters are reasonably close to the experimental. Parts of the experimental phase diagram may have to be assessed separately and the metastable extrapolations of the different phases checked.

Sometimes a phase appears in a region where it should not be stable and additional fictitious experimental data may have to be added to prevent this to happen.

At the end the assessment should be written up and published.

2.15 Application software

There is a separate guide for using OpenCalphad Application Interface (OCASI) in application software. For such cases it is convenient to have the source code which can be compiled together with the applications software. A special feature is also the possibility to use OpenMP to calculate in parallel.

3 The command menu

The commands in alphabetical order as listed with the ?. The commands with an * has subcommands.

ABOUT EXIT MAP SELECT *
AMEND * FIN NEW SET *
BACK HELP OPTIMIZE  SHOW
CALCULATE * HPCALC PLOT * STEP *
DEBUG * INFORMATION * QUIT
DELETE * LIST * READ *
ENTER * MACRO SAVE *

Many of the commands have “subcommands” and usually OC will provide a default answer (listed within slashes /default/) which is selected by pressing return. You can type commands, subcommands and other parameters (separated by a space) on the same line if you know the order.

To select a default when typing several commands and answers to questions (command arguments) on the same line, you can use a comma,“,” to select the default answer. For example “l,,,,” will list on the screen with the current list options.

Many commands will ask additional questions, all of them are not included in this guide but those which are will be shown in bold. Examples and references to other commands are sometimes in bold, sometimes in italics.

Whenever the program asks a question you do not understand you can type a question mark, “?”, to obtain help. If the online help system is correctly installed, see section 2.1.3, this will open a browser window with this manual and hopefully position the manual at the relevant part. You can browse the whole manual in this window if you need additional help.

3.1 Options

There are some options that can be set for the whole session or for just a single command. The options are identified by a / in front like /output=myfile.dat.

An option must be specified directly after a command for example:

list /out=equil5 result 2

Only a few options are implemented.

4 About

This is OpenCalphad (OC), a free software for thermodynamic calculations as described in B Sundman, U R Kattner, M Palumbo and S G Fries, Integrating Materials and Manuf. Innov. (2015) 4:1; B Sundman, X-G Lu and H Ohtani, Comp Mat Sci, Vol 101 (2015) 127-137 and B Sundman et al., Comp Mat Sci, Vol 125 (2016) 188-196

It is available for download at http://www.opencalphad.org or the sundmanbo/opencalphad repository at http://www.github.com

This software is protected by the GNU General Public License You may freely distribute copies as long as you also provide the source code and use the GNU GPL license also for your own additions and modifications.

The software is provided ”as is” without any warranty of any kind, either expressed or implied. The full license text is provided with the software or can be obtained from the Free Software Foundation http://www.fsf.org

Copyright 2011-2021, Bo Sundman, Gif sur Yvette, France. Contact person Bo Sundman, bo.sundman@gmail.com

5 Amend

Intended to allow changes of already entered data. Only some of the subcommands are implemented.

ASSESSMENT_RESLT ELEMENT OPTIMIZING-COEFS REDUNDANT_SETS
BIBLIOGRAPHY  EQUILBRIUM  PARAMETER  SPECIES
COMPONENTS GENERAL PHASE * SYMBOL
CONSTITUTION  LINES QUIT TPFUN-SYMBOL

The default selection is PHASE.

5.1 Amend assessment result

After assessing a set of parameters for a system each of these has a Relative Standard Deviation (RSD) listed in the result. Using this RSD it is possible to modify one parameter and recalculate how much all the other parameters should change due to this modification without rerunning the actual assessment.

This command allows to calculate such a change and it can be tested be reassessing the parameters using the experiments.

5.2 amend Bibliography

Reference identifier:

The text for bibliographic reference identifier can be amended. The reference identifier is CASE INsensitive.

Reference text, end with “;”:

The text for this reference will be set to the text supplied. It can be several lines terminated with a “;”

5.3 amend Components

Give all new components:

By default the elements are the components. This command can set any orthogonal set of species as components. The number of components cannot be changed by this command. The new components must exist as species and be orthogonal. For example in the system Ca-O-Si one can define CaO SiO2 and O as components.

The components are important as you can only use components to specify compositions, such as x(cao)=.3 is possibly only if CaO is a component. See also set input-amount 26.9.

Note that when you have other components than the elements you may have negative mole fractions and phase amounts (but never negative mass).

5.4 amend Constitution

Phase name:

The program will ask for a phase name and you can set the amount and constitution of the phase. This will be used as initial constitution for a calculation unless the grid minimizer is used.

Amount of phase:

Current (Y), default (D) or new (N) constitution:

Answer Y to keep current constituion, D to set a default constitution (if you have set such a constitution) or N to provide a new constitution.

Fraction of component:

You can specify a value between 0.0 and 1.0. The sum of all constituents must be unity, values below 0.0 or 1.0 are not allowed. If you want the fraction of a constituent the be 1.0-(all the other fractions) you can set its value to REST. Otherwise the last constituent is set to the “rest”.

5.5 amend Element

The data for the element can be amended, not implemented yet.

5.6 amend Equilirium

Not sure what could be amended and anyway not implemented.

5.7 amend General

A number of general settings can be amended by the user:

Note that these and some other general feautures can also be changed by the command SET BIT GLOBAL

5.8 amend Line

After a STEP or MAP command it is possible to give the command LIST LINE to list all calculated equilibria or AMEND LINE which allows you to EXCLUDE lines or INCLUDE lines from the plotting.

Only excluded? /Y/:

Sometimes a line may be excluded from plotting if there was an error while it was calculated. Answering Y will make it possble to restore such a line and also lines you have previously excluded.

Exclude this line? /N/:

For an included line you can exclude from the plot.

Include this line? /N/:

For an excluded lines you can include it in the plot.

5.9 amend All optimizing coefficients

The values of each optimizing coefficients, see section 26.17 can be rescaled (start values set to current values) or recovered (current values set to previous start values).

5.10 amend Parameter

The possible parameters that can be amended depend on the model of the phase. By specifying a parameter you can change its expression.

This is not yet implemented you must use the command ENTER PARAMETER to change the parameter expression.

5.11 amend for Phase “phase-name”

You must first specify the phase name and then you can amend some of the properties of the phase:

If you want to amend something for a composition set you must specify the composition set number together with the phase name after a hash character (#) (like liquid#2).

Phase name:

You must specify the name of the phase you want to amend.

ADDITION * DEFAULT-CONSTIT FCC-PERMUTATIONS TERNARY-EXTRAPOL
AQUEUS-MODEL DIFFUSION QUASICHEM-MODEL  UNIQUAC-MODEL
BCC-PERMUTATIONS DISORDERED-FRACS QUIT
COMPOSITION-SET FCC-CVM-TETRAHDR REMOVE-COMPSETS

5.11.1 amend phase “phase-name” Addition

Additions are used to give a contribution to the Gibbs energy of a phase using more or less physically based model. Usually they require additional model parameters, see section refsc:paramid. The difference between addition and other things that can be amended may not always be very clear. The possible additions are

ELASTIC-MODEL-1 MAGNETIC-CONTRIB  SMOOTH-CP-STEP
GADDITION QUIT TWOSTATE-LIQUID
LOWT-CP-MODEL SCHOTTKY-ANOMALY VOLUME-MODEL1

BEWHERE! The OC software allows you to mix many types of additions for a phase but it is up to YOU as user to defend the physical reasons for this!

Per formula unit?

The theoretical equation for most additions usually gives the value per mole of atoms. As the Gibbs energy is calculated per mole formula unit of the phase in OC (as well as most thermodynamic software) the addition must be multiplied with the number of atoms per formula unit of the phase.

Some of the additions, for example mobilities, are for properties that does not contribute to the thermodynamics but which depend on the phase, T,P and phase constitution in the same way as the Gibbs energy and it is thus convenient to model and store the data together with the thermodynamic data.

amend phase ... addition Elastic_model_1

A contribution to the Gibbs energy due to elastic strain can be added. This also requires values of the elastic constants and lattice parameters, see section 2.8.1.

There is no code to calculate the elastic energy implemented yet.

5.11.2 amend phase ... Gaddition

You can add a constant value of the Gibbs energy to a phase in Joule per formula unit. This is a crude but simple way to implement a for example a nucleation barrier.

Addition to G in J/FU (formula units)/0/:

amend phase ... addition LowT_Cp_model

The Einstein model for heat capacities from 0 K has been implemented. It requires a value of the property Einstein T as listed in section 2.8.1.

amend phase ... addition Magnetic_contrib

The Inden-Hillert and the modified Inden-Qing-Xiong model for the magnetic contribution to the Gibbs energy can be set by this command This depends on model parameters describing the Curie and Neel temperatures and the Bohr magneton number, as listed in model parameters identifiers 2.8.1, for the phase.

You also must also enter model parameters for the constituents of the phase, see the documentation of the model or Lukas [4].

Antiferromagnetic factor:

The Qing-Xiong model is selected by giving zero (0) for the question about the anti-ferromagnetic factor. For the original Inden-Hillert model -3 is used for FCC and HCP whereas -1 is used for BCC.

The Inden-Hillert model is described in Lukas et al [4]. The Inden-Qing-Xiong modified model requires separate values of the Curie and Neel Temperatures and either an “effective” Bohr magneton number or individual Bohr magneton numbers for the constituents of the phase.

amend phase ... addition Quit

You did not really wanted to add any addition.

amend phase ... addition Schottky_anomaly

Some physical phenomena can create a “bump” in the heat capacity for a phase at a certain T and this addition can describe this. It uses two model parameter identifiers, TSCH and CSCH that may depend on the composition. TSCH specify the T for the anomaly and CSCH the maximum contribution to the heat capacity (J/mol/formula unit) divided by R, i.e. as a factor of the gas constant, R.

amend phase ... addition Smooth-Cp-step

The 3rd generation thermodynamic databases extrapolate to 0 K and require that the heat capacity is zero at 0 K. This means it is impossible to use T * ln(T) terms (and also negative powers of T-n) but there may be some physical phenomena that causes an incremental increase of the heat capacity at some temperature. Ignoring the physical reason for such an increase this “smooth_CP _step” addition will provide such this using two parameters, THT2 to specify T and DCP2 to specify the increement in heat capacity. DCP2 is a factor of R. It uses the same mathematical expression as the Einstein heat capacity function but has no enthalpy contribution.

amend phase ... addition Twostate-liquid

The two-state model for the hear capacity for the undercooled liquids can be added. It assumes a low T amorphous state modeled as an Einstein solid and requires an Einstein T. For the liquid transition it uses the model_parameter_ident bf G2, both of which are listed in section 2.8.1.

Is G2 composition dependent? /Y/:

G2 parameters are usually evaluated for thr pure elemenents. Using interaction parameters for the G2 parameter may create unexpected phenomena.

You must specify parameters for THET and G2 for all constituents of the phase and possibly also interaction parameters to specify the composition dependence.

The implementation of this addition is not finished.

5.11.3 amend phase ... Aqueous-model

A model with dilute configurational entropy. Not implemented yet.

5.11.4 amend phase ... BCC-permutations

This is intended for the 4 sublattice CEF model for BCC ordering. Due to crystallographic symmetry several model parameters must be identical such as

G(BCC,AL:FE:FE:FE)=G(BCC,FE:AL:FE:FE)=G(BCC,FE:FE:AL:FE)=G(BCC,FE:FE:FE:AL)

and this command means these parameters need to be entered only once. This affects the data storage and the calculation of the Gibbs energy is slightly more efficient. The same applies for the FCC_permutations but the BCC tetrahedron is asymmetric which makes it a bit more complicated than the FCC. There can be a 5th sublattice with interstitials.

5.11.5 amend phase ... Composition set

Each phase has by default a single composition set. If the same phase can exist as stable (or metastable) with two or more compositions (miscibility gaps or order/disorder transformations) you may have to amend the phase by creating additional composition sets.

Composition sets can also be created automatically by the grid minimizer during an equilibrium calculation. In such a case the composition set will have the suffix _AUTO,

Composition sets of a phase can be created and deleted. Phases with miscibility gaps or which can exist with different chemical ordering like A2 and B2 must be treated as different composition sets. You can specify a prefix and suffix for the composition set. Extra composition sets will always have a suffix #digit where digit is a number between 2 and 9. You cannot have more than 9 composition sets.

The composition set number is given after the phase name and preceeded by a hash character #. In the OCASI interface and some more cases phase tuples are used to identify a phase and a composition set by a single number. As composition sets can be created and deleted a phase tuple index for the 2nd or higher composition set may change between calculations.

In some cases it may be interesting to calculate metastable states inside miscibility gaps and you can prevent the automatic creation of composition sets by turning off the global minimazation using AMEND GENERAL or for an individual phase by SET PHASE ... BIT NO_AUTO_COMP_SET

5.11.6 amend phase ... Default Constitution

The default constitution of a phase can be set. Unless the grid minimizer is used this will be used for the first calculation with the phase and sometimes if there are convergence problems. NOTE that if you want to specify a default constitution for the second or higher composition set of a phase you must specify the composition set with the phase name!

Depending on the minimizing software used the initial constitution can be important to find the correct equilibrium if the phase has ordering or a miscibility gap.

For each constituent you can specify a minimum > or maximum < fraction or give NONE if there are no default.

If a phase has miscibility gaps and you have created composition sets with default constitutions the grid minimizer will try to select the composition set with a composition closest to the default for a stable phase.

To temporarily set a new constitution of a phase use the command AMEND CONSTITUTION <phase> or CALCULATE PHASE ... .

5.11.7 amend phase ... Diffusion

This is to specify how the diffusion coefficient matrix should be calculated when simulating a phase transformation. Normally the mobilities for the constituents of the phase are read from the database but you may use different “depended” and “independent” constituents in the diffusion model and also some other factors. This command is intended for such use. It is not implemeted yet.

There is no intention that OC itself should simulate diffusion but as the diffusion coefficents are strongly dependent on the thermodynamic factor (the Darken stability matrix) which represent the second derivatives of the Gibbs energy it is convenient to include some properties used in a simulation in the thermodynamic software.

5.11.8 amend phase ... Disordered fraction sets

For phases with several sublattices the Gibbs energy of the phase can be divided into two sets of fractions where the second or “disordered” set have only one or two sublattices and the fractions on these represent the sum of fraction on some or all of the first or “ordered” set of sublattices.

There are two different ways to handle the disordered fraction set depending on the fact if the phase can be totally disordered. The latter is the case for phases like B2, L12 etc which can be totally disordered as BCC/A2 or FCC/A1. The calculation of the Gibbs energy in the latter cas will subracted the contribution from the ordered part when the phase is disordered, see for example Lukas et al [4].

This is particularly important to model the Gibbs energy for phases with ordering like FCC, BCC and HCP and for intermediate phases like SIGMA, MU etc.

5.11.9 amend phase ... FCC_CVM_tetradrn

This model is intended for the CVM tetrahedron model for FCC and HCP. Not implemented yet.

5.11.10 amend phase ... FCC_permutations

This is intended for the 4 sublattice CEF model for FCC ordering. Due to crystallographic symmetry several model parameters must be identical such as

G(FCC,AL:FE:FE:FE)=G(FCC,FE:AL:FE:FE)=G(FCC,FE:FE:AL:FE)=G(FCC,FE:FE:FE:AL)

Setting this means that unique model parameters need to be entered only once, the software will take care of all permutations. HCP permutations are also handled with this command as the HCP tetrahedron model is identical to the FCC. There can be a 5th interstitial sublattice.

5.11.11 amend phase ... Quasichemical

There are several quasichemical models for the liquid that only describes the short range ordering (SRO).

None of them are yet implemented.

5.11.12 amend phase ... Quit

Do not amend anything for the phase.

5.11.13 amend phase ... ternary-extrapolation

The default ternary extrapolation is the symmetric Muggianu method which uses the binary excess Gibbs energy closeset to the overall composition, see section 2.8.3. However, there is also a symmetric Kohler method and an ansymmetric Toop method which can be defined separately for each ternary. For this you must specity

Ternary extrapolation (K, T or Q to quit)

If you specify T for Toop you must specify the Toop constituent, othewise just any of the three constituents as the first constituent. After that you will be asked for

Second constituent: and
Third constituent

For each ternary subsytem in the phase this can be specified. Those not specified will use a Muggianu method, see section 2.8.3.

5.11.14 amend phase ... UNIQUAC

The UNIQUAC model for polymers has been implemented and there is a macro “uniquac” showing how it can be used.

5.12 amend Quit

Do not amend anything (more).

5.13 amend redundant-sets

Sometimes a large number of composition sets are created for certain phases and they may create trouble at later calculations. This command will set all metastable composition sets as dormant which may simplify convergence. A dormant compositon set may be set stable by the gridminimizer. It is also possible to delete composition sets but that is fragile and they may anyway be created again by the grid minimizer.

5.14 amend for Species

This is implemented for UNIQUAC species which has a specific volume and area used in the configurational entropy.

UNIQUAC surface area (q) /1/:

UNIQUAC segments (r) /1/:

These two parameters are necessary to calculate the configurational entropy of the UNIQUAC model.

5.15 amend Symbol

For a symbol that is a constant this command means changing the value of symbol.

For some other symbols it is very special. It is intended for use in assessments to specify that a particular symbol must not be evaluated except when specified explicity, or when calculating a specific equilibrium.

The main problem is that a symbol can have an expression using another symbols and thus all symbols are normally evaluated whenever the value of a specific symbol is requested. This is to ensure that all symbol values are consistent and refer to the same calculated equilibrium. But in certain cases you may want to enter a symbol that is only evaluted when referenced explicity or at a specific equilibrium and this can be set with this command.

Symbols representing “dot derivatives”, for example “H.T” for the heat capacity are automatically set to be evaluated only when referenced explicitly. For all other symbols except constants OC will ask:

You can specify:
V for a symbol evaluated only when referenced explicitly
X for a symbol to be evaluated at a particular equilibrium
Please specify V or X /X/:

When you want to compare the value of a thermodynamic property, like the enthalpy, in two equilibria you must be able to store the calculated enthalpy from one equilibrium in a symbol. For example if you have experimental data on the heat difference for a compound at various T. In such a case the enthalpy at the reference T can be stored in a symbol, which has been amended with this command to specify at which equilibrium it should be evaluated. In all other equilibria the value of this symbol will have the value at the specified equilibrium. See also the documentation on the assessment procedure, section 2.14.5.

If you specify X you will be asked

Specify equilibrium number:

5.16 amend Tpfunction

You can replace a TP function with a new expression. If it is a constant you can give a new value.

6 Back

Return back from the command monitor to the application program. In the OC software itself it means terminate the program.

7 Calculate

Many different things can be calculated. The normal thing to calculate is equilibrium, the other things are special.

ALL-EQUILIBRIA GLOBAL-GRIDMIN  PHASE * TRANSITION
BOSSES_METHOD NO-GLOBAL  QUIT TZERO-POINT
CAREFULLY ONLY_GRIDMIN SYMBOL WITH-CHECK-AFTER
EQUILIBRIUM PARAEQUILIBRIUM  TPFUN-SYMBOLS 

7.1 calculate All equilibria

Intended for the assessment procedure. Calculates all equilibria with non-zero weight as set by the command SET RANGE. It can also be used for other purposes, for example testing the parallelization. The equilibria can be entered by the command ENTER MANY_EQUILIB.

This command can be looped to measure calculation times.

7.2 calculate Bosses-method or Carefully

These two ways provide a fairly similar way to handle cases when there are convergence problems, in particulat for multicomponent systems. They require that the conditions are T,P and mass balance so the grid minimizer can be used. The difference is that after the gridminimizer has founc a set of stable phases all other phases are set as suspended and the iterative calculation will just use those phases selected by the gridminimizer, this should normally be successful. Afterwards all suspended phases are set as dormant and a new iterative calculation is made. If no dormant phase has a positive driving force all phases are set as entered and the equilibrium has been calculated.

If one or more dormant phases have a positive driving force these are set as entered one by one followed by an iterative calculation. Normally this will finish when all dormant phases have negative driving force and the equilibrium has been calculated. If it fails it may anyway be possible to identify the phases causing the convergence problems and maybe check its parameters.

7.3 calculate Equilibrium

The normal command to calculate the equilibrium of a system for the current set of conditions and phase status. You can calculate a metastable equilibrium if some phases that should be stable have been set dormant or suspended or if automatic creation of composition sets is not allowed. If the conditions allow, the grid minimizer will be used to find start values unless the grid minimizer is explicitly turned of.

Before this command you must have entered thermodynamic data from a database or interactivly and used the command set condition, section 26.5, to set as many conditions as you have components plus two. The commands set status phase, section 26.20.3, and set input-amount, section 26.9 can also be used to set conditions.

For the first equilibrium calculation it is recommended to set conditions on T,P and the overall composition. Those conditions allow the grid minimizer to be used to find the best set of stable phases and their constitutions that should give the global minimum. However, the density of the grid may in some cases have to be increased to ensure that.

For later equilibria you can use a very flexible set of conditions, see section 26.5 and the gridminimizer may not be able to use the grid minimizer. In such a case OC will use the current set of stable phases and their constitution as start values. If you want to check that such a calculation is the global you can use the command calculate with which will call the grid minimizer called AFTER the equilibrium calculation (if it has converged) to check that it is indeed a global equilibrium.

7.4 calculate Global-Gridmin

Calculate with the global grid minimizer without using this result as a start point for the general minimizer. Used to debug the grid minimizer.

7.5 calculate No-Global

Calculate the equilibrium without using a global grid minimizer to generate start constitutions. The current equilibrium is used as start point. Can be quicker when only small changes of conditions made since previous calculation and this is how equilibria is calculated during STEP and MAP. It means no check of new miscibility gaps.

7.6 calculate Paraequilibrium

The paraequilibrium is described in section 2.13.2.

Matrix phase:

Note all phases except the matrix and growing phase should be suspended. You should provide name of the matrix phase

Growing phase:

Fast diffusing element:

The element that diffuse so fast that its chemical potential is the same in both phases. The other elements will have the same composition in both phases.

7.7 calculate Phase “phase-name”

This is to calculate properties for a single phase independent of the current conditions except the values of T and P.

Phase name:

Amount of phase:

Current (Y), default (D) or new (N) constitution?

You must provide a phase name, the amount of the phase and if you should use the current constitution or enter a new.

The Gibbs energy of a phase and possible derivatives and some other things can be calculated. Mainly for debugging the implementation of models and testing the software.

ALL-DERIVATIVES DIFFUSION-COEFF ONLY-G
CONSTITUTION-ADJ  G-AND-DGDY

7.7.1 calculate phase ... All-Derivatives

The Gibbs energy, all T and P derivatives and all first and second derivatives with respect to constituents for the specified phase for current T,P are calculated and listed.

It is possible to loop this calculation to measure calculation times.

7.7.2 calculate phase ... Constitution_Adjust

You will be asked to enter a new composition of the phase (the current constitution but the current is the default) and this command will then calculate the Gibbs energy and all chemical potentials for the given composition.

For a phase with sublattices the constitution of the phase will be adjusted to have the minimum Gibbs energy for the given composition.

It is useful when one or more components are parts of several constituents, for example in a gas and for phases with order/disorder transitions, in particular when the corresponding subroutine is used in simulations.

7.7.3 calculate phase ... Diffusion_Coefficients

You will be asked to enter a new composition (default is current) of the phase and this command will then calculate the Darken stability matrix

2 --∂-G---- ∂NA ∂NB
for all components (see the documentation of the minimiser) and also all mobility values (if there are any).

7.7.4 calculate phase ... G_and_dGdy

The Gibbs energy, all T and P derivatives and all first derivatives with respect to constituents for the specified phase for current T,P are calculated and listed.

IMPORTANT NOTE: The value of ∂Gm- ∂yi is NOT the chemical potential, μi of component i. The understanding of thermodynamics is often poor and the user is reminded that the chemical potential of a component i is defined as:

( ) μ = -∂G- i ∂Ni T,P,Nj⁄=i
where G is the integral Gibbs energy and all Ni are independent variables. When we model the molar Gibbs energy, Gm as a function of the constituent fractions, yi, these fractions are not independent and for a substitutional model, where yi = xi i.e. the mole fractions, the chemical potential is calculated from Gm using:
( ) ( ) μ = G + ∂Gm-- - ∑ x ∂Gm-- i m ∂xi T,P,xj⁄=i j ∂xj j T,P,Nk⁄=j
because the mole fractions, xi are not independent.

7.7.5 calculate phase ... Only-G

The Gibbs energy and all T and P derivatives calculated and listed for the specified phase for the current values of T,P.

If the phase has additions the Gibbs energy and its first derivatives and its second derivative of T of each addition are also listed

7.7.6 calculate phase ... Quit

Do not calculate anything for the phase.

7.8 calculate Quit

Do not calculate anything at all.

7.9 calculate Symbol

A state variable symbol or function is calculated using the results from the last equilibrium or grid minimizer calculation. It is used in particular for calculation of “dot derivatives” like H.T for the heat capacity.

If a wildcard, “*”, is given as name all symbols, except dot derivatives and symbols that must be specified explicity and those that should be calculated for another specified equilibria. See section 5.15.

7.10 calculate Tpfun-Symbols

All or a specific TPFUN symbol are calculated for current values of T and P.

7.11 calculate Transition

After calculating an equilibrium you can calculate directly when a phase will appear or disappear by releasing one of the conditions you have specified. Typically this is used to calculate the melting temperature of an alloy or a solubility limit.

You specify the phase name and the condition to be released. The program will set this phase as FIXED with zero amount and remove the condition you specified and calculate the equilibrium. The calculation may fail if the phase cannot be set stable with zero amount. If successful the removed condition will be set to the value calculated and the phase set stable with zero amount.

7.12 calculate Tzero point

The T0 (or T zero) point is where two phases have the same Gibbs energy. It is a limit of diffusionless transformation between these phases. This can be calculated by varying T (or a composition) calculating the Gibbs energy for the two phases separatly using the same overall composition. NOTE in many cases there are no such point!

It is particularly interesting in steels to predict the martensite transformation which is normally some 100 K below the T0 point.

7.13 calculate with check after

When the conditions does not allow for the gridminimizer to be used to find an initial set of phases this command can be used to call the gridminimizer after the iterative calculation. If the gridminimizer finds a phase that should be stable the equilibrium will be autmatically recalculated.

This type of calculations is regularly done durig STEP and MAP commands as such calculations normally have a phase as FIX which prevents use of the gridminimizer.

8 Debug

Several possibilities to trace calculations will be implemented in order to find errors but very little is working yet. This command is mainly for the software development.

BROWSER GRID STOP-ON-ERROR TRACE
ELASTICITY  MAP-STARTPOINTS  SYMBOL-VALUE
FREE-LISTS SPECIES TPFUN 

8.1 debug Elasticity

Intended to test the model for strain and stress. Not implemented.

8.2 debug Free lists

Only for experts.

8.3 debug Map-startpoints

An attempt to generate automatic startpoints for mapping a phase diagram.

8.4 debug Symbol value

This is used to in macro files to test if the software calculates the same value of a symbol as when the macro was created. If not there is some new bug introduced (or a bug corrected?). After the symbol the expected value must be given and if the relative difference with the calculated value differ more than 10-6 the program will abort.

8.5 debug Stop_on_Error

The program will stop at the command level after printing the error message if an error has occurred when using macro file. This should make it easier to to find errors occurring when running macro files.

However, it is not implemented.

9 Delete

It is quite difficult to delete anything when the data structure is so involved. In many cases it may be better to enter the data again without the data that should be deleted. But there are a few things that must occationally be deleted.

COMPOSITION_SET EQUILIBRIUM QUIT STEP_MAP_RESULTS
ELEMENTS PHASE SPECIES 

9.1 delete Composition set

The first composition set of a phase cannot be deleted. Otherwise there is usually no problem unless several equilibria are entered because the composition set must be deleted in all equilibria. Composition sets are created and deleted during normal equilibrium calculations to detect miscibility gaps.

9.2 delete Element

Dangerous and will probably never be implemented.

9.3 delete Equilibrium

Dangerous but sometimes necessary. Done automatically at a second STEP or MAP command if you specifies to delete previous results.

9.4 delete Phase

Dangerous and will probably never be implemented.

9.5 delete Quit

Do not delete anything.

9.6 delete Species

Not implemented yet and will probably never be.

9.7 delete Step_Map_Results

This removes all equilibria and saved equilibria associated with STEP and MAP commands. It also deletes the axis.

10 Enter

In most cases data will be read from a database file. But it is possible to enter all thermodynamic data interactively. This should normally start by entering all elements, then all species (the elements will automatically also be species) and then the phases.

A species have a fixed stoichiometry and possibly a charge. The species are the constituents of the phases.

A phase can have sublattices and constituents and also various additions like magnetic, low T heat capacity etc. which are specified by the AMEND command efter entering the phase (but normally before any model parameters for the phase are entered).

TPFUN symbols can be used to describe common parts of model parameters. See section 2.8.4 for an explation.

Each model parameter of a phase is entered separately. You may use TPFUN symbols which are already entered.

At present the multicomponent CEF model and the ionic 2-sublattice liquid model are the only basic models implemented. The CEF model includes as special cases the gas phase, regular solutions with Redlich-Kister Muggianu model and phases with up to 9 sublattices and ionic constituents. These models describe the basic configurational entropy contribution to the phase, models such as the magnetic contribution and low T heat capacity can be added to a phase with the AMEND command.

The enter command is also used to enter bibliographic data, equilibria for assessments and many other things.

The subcommands are:

BIBLIOGRAPHY EQUILIBRIUM OPTIMIZE-COEFF SPECIES
COMMENT EXPERIMENT PARAMETER SYMBOL
CONSTITUTION GNUPLOT-TERMINAL  PHASE TPFUN-SYMBOL
COPY-OF-EQUILIB MANY-EQUILIBRIA PLOT-DATA
ELEMENT MATERIAL QUIT

10.1 enter Bibliography

Each model parameter must have a bibliographic reference to ensure everyone can find the origin of its value. When entering a parameter a bibliographic reference symbol must be given and with this command you can give a full reference text for that, for example a published paper, a report or simply a reason for the value together with the date and your name so the origin of the parameter can be traced.

Reference identifier:

The text for bibliographic reference identifier can be amended. The reference identifier is case insensitive.

Reference text, end with “;”:

The text for this reference will be set to the text supplied. It can be several lines terminated with a “;”

10.2 enter Comment

A line of comment text can be added to the current equilibrium. It is particularly important when entering experimental data to give the reference to the data.

10.3 enter Constitution

The constitution (fraction of all constituents) of a phase can be entered. This is a way to provide start values for an equilibrium calculation (when not using grid minimizer). To calculate the Gibbs energy for a specific phase at a specific constitution use the command CALCULATE PHASE.

10.4 enter Copy of equilibrium

This command creates a copy of the current equilibrium with the same set of conditions and related data.

Must be used with care.

10.5 enter Element

The data for an element is entered. It consists of is symbol, name, reference phase, mass, H298-H0 and S298.

The element symbol must be one or two letters, they will be converted to UPPER case automatically. The element name and reference phase is never used anywhere but included for completeness. The reference phase SER means the Stable Element Reference phase, the phase stable at 298.15 K and 1 bar. The mass is needed for input of amount (using state variable B), mass fractions or mass percent of the element.

The values of H298-H0 and S298 are never used for any calculation but included for completeness.

10.6 enter Equilibrium

You can have several equilibria each with a unique set of conditions including phase status (dormant, suspended, fix or entered) but all with the same components and thermodynamic data. This is useful for compare different states, to simulate transformations and to assess model parameters as each experimental or theoretical information represented as an equilibrium.

All equilibria use the same thermodynamic data but they have an independent set of conditions and result data structure, also for TP functions and symbols, and they can be calculated in parallel.

After entering the equilibrium you can select if your following commands, such as enter condition etc. will apply to the new equilibrium.

10.7 enter Experiment

This is used for assessments, experimental data can be specified for an equilibrium. The experiment is a state variable or symbol which can be set equal to the experimental value followed by a colon, “:” and its uncertainty.

In some cases an experimental value can be an upper or lower limit. In such cases the “>” or “<” can be used. The value of the uncertainty will then be interpreted as a penalty factor if the calculated value is outside the specified limit.

10.8 enter GNUPLOT Terminal

For plotting OC generates a command file for the GNUPLOT [7] software. GNUPLOT can be downloaded free for most OS but depending on your screen and other hardware you may prefer to specify your prefered set of terminals. On Windows the defaults are:

The terminals listed in the table depend on your installation.

Name = GNUPLOT definition
1  SCREEN set terminal wxt size 940,700 font ”arial,16”
2 PS set terminal postscript color solid fontscale 1.2
3 PDF set terminal pdf color solid size 6,5 enhanced font ”arial,16”
4 GIF set terminal gif enhanced fontscale 0.7
5 PNG set terminal png enhanced fontscale 0.7

The text after the > is written on the GNU command file. You can change these or add additional terminals. You can also change these in the source code (userif/pmon6.F90 file) or use a macro file OCHOME/start.OCM file to set them.

10.9 enter Many Equilibria

This command is intended for adding tables of experimental data of the same type. It can also be used for calculation of many equilibria using the calculate all command. The user first enters a TABLE HEAD giving the necessary phase status, conditions, experiments etc. In this “head” some values of text can be referred to columns in the following table using the “@” character followed by a digit 1 to 9, where the digit is the column number.

The prompt for input to the table head is “table head::”
In the examples below, taken from the parallel2.OCM macro file, user input is in bold and explanations in italics.

For the rows in the table the user must first provide a unique name for each equilibrium (that is counted as column 0 (zero)) and values for all columns referenced in the table head like:
Table row: EQ1 1573 BCC 0.3 0.05 0.12 0.28
Table row: EQ2 1623 BCC 0.3 0.10 0.18 0.24

The table is finished by an empty line or
Table row: table_end

10.10 enter Material

The user will be asked for a name of the material and possibly a database. Then he can give elements and their amount in mass percent or mole fraction. Finish with an empty line.

Finally he can specify the temperature and the program will automatically make a calculation at 1 bar with the given composition. For example: 

OC4:enter mat
Database:steel7
Elements: C , MO, V , CR, FE, SI,
Major element or material:fe
Input in mass percent? /Y/:
Input expected in mass percent

First alloying element:c
Mass percent: /1/:
Second alloying element:cr
Mass percent: /1/: 5
Third alloying element:mo
Mass percent: /1/: 8
Next alloying element:v
Mass percent: /1/:
Next alloying element:
 3E reading a TDB file
 3D em:  W%(C)=1  W%(CR)=5  W%(MO)=8  W%(V)=1   N=1
Temperature /1000/:
 3Y Constitution of metastable phases set
 3Y Composition set(s) created:            1
Gridmin:   18846 points   6.25E-02 s and      78 clockcycles, T= 1000.00
Phase change: its/add/remove:     5    0   21
Equilibrium calculation   19 its,   6.2500E-02 s and      94 clockcycles

The user can use the same command to specify another composition of the alloy or use other commands such as SET CONDITION and CALCULATE or calculate diagrams using SET AXIS and then STEP or MAP.

10.11 enter Optimizing coefficient

The number of TP symbols for the coefficients to be optimized are entered. They have the names A00 to A99. They are used in model parameters and can be varied by the optimization procedure to minimize the difference between the experimental data and the same property calculated from the models of the phases.

You can also specify the size of the workspace needed for the optimization. The default value, 2500, is usually sufficient.

10.12 enter Parameter

A model parameter is defined by its identifier, the phase and constituent array and the degree. A parameter can be a constant or depend on T and P. The parameter will be multiplied with the fractions of the constituents given by its constituent array. See the documentation of the GTP model package or the book by Lukas et al[4] for more information about thermodynamic models.

For example G(LIQUID,CR) is the Gibbs energy of liquid Cr relative to its reference state, normally the stable state of Cr at 298.15 K and 1 bar, and called an endmember.

For a gas molecule the parameter G(GAS,C1O2) is also an endmember and represent the Gibbs energy of the C1O2 molecule relative to the reference states of C (carbon) and O (oxygen).

For interaction parameters the components are separated by a comma “,” as in G(LIQUID,CR,FE).

For phases with sublattices the constituents in each sublattice are separated by a colon, “:” and interacting constituents in the same sublattice by a comma, “,”. For example:
G(FCC,FE:C,VA) is the interaction between C (carbon) and VA (vacant interstitial sites) in the FCC phase.

Different ternary extrapolation methods can be used, see section 2.8.3.

10.13 enter Phase

The user must specify a unique phase name:

Phase name:

All thermodynamic data are connected to a phase as defined by its parameters, see enter parameter. A phase has a name with can contain letters, digits and the underscore character. It must start with a letter.

Phase model:

After the phase name you must specify a model. The model specfication is implemented in a rather rudimentary way. The only recognized models are

This list may be extended in a future version of OC. Many other model features like magnetism, quasichemical etc are specified with the AMEND PHASE command, see section 5.11. The AMEND PHASE command is also used to specify disordered fraction set, low temperature CP model and many other things.

Number of sublattices:

For a phase with Long Range Orderng (LRO) you must specify the number of sublattices. After that you have for each sublattice specify the number of sites and consttuents. Even if you have just one lattice you must specify the number of atoms on that lattice per formula unit.

For most models OC will ask for the number of sublattices and a phase can have 1 to 9 sublattices and you must specify the number of sites on each. Preferably use small integer values, if fractions are used at least 6 digits should be provided.

Number of sites on a sublattice

For some models, like the ionic liquid model, the number of sites may change with the composition of the phase so the number specified is irrelevant. See the book by Lukas et al [4] for more details on models.

Models with bonds

Some models depend on the number of nonds between atoms, such as the quasichemical model. The modified quasichemical model have a single sublattice and include additional species to decribe the Short Range Ordering (SRO).

For each sublattice you must specify the constituents on the sublattice. A constituent that is not an element must already have been entered as a species, see section 10.16.

You may have to use the AMEND PHASE command, see section 5.11, for some additional model features like magnetism, low T heat capacity or permutations.

10.14 enter Plot_data

This is when entering experimental data for assessments when combining experimental data in single equilibria with those entered in tables using the command “MANY_EQUILIBRIA”.

You can add points to a dataset 1 to 9 to be plotted the current equilibrum. The dataset must already have created by a PLOT command inside a ENTER MANY_EQUILIB command, see section 10.9.

10.15 enter Quit

Quit entering things.

10.16 enter Species

A species consists of a name and a stoichiometric formula. It can have a valence or charge. The name is often the stoichiometric formula but it does not have to be that. Examples:

Single letter element names must be followed by a stoichiometric factor unless it is the last element when 1 is assumed. Two-letter element names have by default the stoichiometric factor 1.

There can be a problem with ambiguity with a species name like h2o if there is also a species h2o2. In such cases use a final unity, i.e. h2o1.

The species name is important as it is the name, not the stoichiometry, that is used when referring to the species elsewhere like as a phase constituent. It is of course convenient to choose a species name similar to its stoichiometric formula but as shown above, that is not always sufficient.

Species symbol:

The symbol must start with a letter, A-Z, and contain just letters, digits and the special characters “_” (underscore), “-” (minus), “+” (plus) and “/” (slash).

Species stoichiometry:

The stoichiometry must contain element symbols followed by a stoichiometry factor. The stoichiometry factor 1 can be omitted for two-letter element symbols. The charge is given as “/-” or “/+” followed by a stoichiometric factor.

10.17 enter Symbol

The OC package has both “symbols” and “tpfun_symbols”, the latter has a very special syntax and can be used when entering parameters.

The symbols are designed to handle relations between state variables, you can define expressions like
enter symbol KLBCR = X(LIQUID,CR)/X(BCC,CR);
where KLBCR is set to the partition of the Cr mole fractions between liquid and bcc.

The symbols also include “dot derivatives” like H.T which is the second derivative of the Gibbs energy with respect to the for the current system at the given set of conditions.

enter symbol CP = H.T;

If T and P are conditions and all other conditions are mass balance conditions CP is the heat capacity. It also takes account of the change of configurational entropy.

Currently H.T is the only dot derivatives allowed but more will be added as soon as possible.

10.18 enter Tpfun_Symbol

This symbol is a special type of expression depending on T and P that can be used when entering parameters. A TPfun can refer to another TPfun but not any other state variable or symbol.

The program requests a name and if the symbol should be a FUNCTION, CONSTANT or a TABLE (tables not implemented).

If it is a FUNCTION you must specify a low T limit, and expression consisting of simple terms (signed coefficients multiplied with T and P possibly raised to powers).

A term may also be multiplied with another TP function or with LN(FX) for the natural logarithm of “FX” or EXP(FX) for the exponential of the expression of function “FX”.

The “FX” inside the parenthesis of an LN or EXP may refer to another TP function or it can be a coefficient multiplied with powers of T or P.

It is not allowed to use parenthesis except around arguments of LN and EXP or around negative powers such as T **(-1).

A very special unary function is INTEIN(THETA) which calculates

1.5* R *F X + 3 *R * T *LN (EXP (- T HET A∕T )+ 1) (2)
and first and second derivatives of that with respect to T. It is the Einstein heat capacity function integrated to a Gibbs energy. The argument THETA should the the Einsten themperature and must be a positive constant.

The expression must be terminated by a semicolon followed by an upper T limit. After the upper T limit you must specify either N or Y. If you give Y it means there is another expression above this T limit. The last T-range limit must be followed by N and a bibliographic reference, see section 10.1.

TPFUNs have a strict syntax because the software must be able calculate not only its value but also its first and second derivatives with respect to T and P millions of times during a phase diagram calculations, see section 2.8.4.

11 Exit

Terminate the OC software in Swedish, Ha en bra dag.

12 Fin

Terminate the OC software in French, Au revoir.

13 Help and ?

Which command:

Can give a list if commands or subcommands or parts of this help text. The user guide is also available as a searchable HMTL file.

For a submenu question a single ? will give the menu and two ?? will give an extract of this user guide. Then the question will be asked again.

14 HPcalc

Start the reverse polish calculator.

15 Information

on the following topics:

CHANGES ELEMENTS PHASE-DIAGRAM  STATE-VARIABLES
COMPOSITION-SET  EQUILIBRIUM  PROPERTY-DIAGRAM 
CONDITIONS HELP-SYSTEM QUIT-INFO
DATABASES PHASE SPECIES

This command is still not fully implemented.

The intention is to provide the on-line help to users who does not like to read manuals. But it is not yet implemented.

Topic? /CHANGES/:

Will list the most recent changes in the OC software from the changes.txt file (if it can be found). Stop listing by a q.

You can explore different parts of this User Guide online by selecting other topics.

Give QUIT or press return to go back to top level.

16 List

Many things can be listed. Output is normally on the screen unless it is redirected by the /output=file name or /append=file name option, see 3.1.

ACTIVE_EQUILIBR EQUILIBRIA OPTIMIZATIONSTATE_VARIABLES 
AXIS ERROR-MESSAGE PARAMETER  SYMBOLS
BIBLIOGRAPHY  EXCELL-CSV-FILE PHASE TPFUN_SYMBOLS
CONDITIONS LINE-EQUILIBRIA  QUIT
DATA MODEL-PARAM-ID RESULTS
ELEMENTS MODEL-PARAM-VAL  SHORT

16.1 list active-equilibria

This is used during assessment to list equilibria with non-zero weights.

16.2 list Axis

Lists the axis set by you.

16.3 list Bibliography

List the bibliographic references for the data.

16.4 list Conditions

Lists the current set of conditions set by you. If the degrees of freedoms are zero you can calculate an equilibrium.

16.5 list Data

Lists all thermodynamic data. The default is on SCREEN but you can also choose among the formats: LaTeX, MACRO, PDB and TDB.

The only format implemented at present is SCREEN.

16.5.1 list data LaTeX

The thermodynamic data will be formatted according to LaTeX for later inclusion in publications. Not implemented.

16.5.2 list data Macro

The thermodynamic data will be written as a macro file that can later be read back into the OC software. Not implemented.

16.5.3 list data PDB

A “Phase related Data Format” similar to the TDB file format adapted for OC. Not yet implemented.

16.5.4 list data TDB

A variant of the TDB file format with Thermo-Calc flavor. Not implemented.

16.6 list Equilibria

Lists the equilibria entered. To list the results of the calculation of an equilibrium use list result.

16.7 list Error message

The message associated with an error code generated by OC can be listed

16.8 list Line equilibria

Lists the equilibria calculated during STEP or MAP commands. See also the command AMEND LINE-EQUILIBRIA.

16.9 list Model parameter identifiers

Lists the model parameter identifiers available in the current version of OC, see section 2.8.1.

16.10 list Model parameter value

The current value of a model parameter identifier can be listed. Note that the value is always phase dependent and may also depend on the composition set.

16.11 list optimization

Lists results of an optimization, several sub-options will be implemented but currently there is a short version only. To save this on a file use the option /output= or /append=, see 3.1.

COEFFICIENTS DEBUG GRAPHICS MACRO
CORRELATION_MTRX  EXPERIMENTS  LONG SHORT
16.11.1 list optimization coefficients

This gives a list of the coefficients and their values.

16.11.2 list optimization debug

Not implemented yet.

16.11.3 list optimization correlation_matrix

Not implemented yet.

16.11.4 list optimization experiments

List of experiments in the equilibria with non-zero weights.

16.11.5 list optimization graphics

A figure with the experimental values on the X axis and calculated values on the Y axis for all experiments. Not implemented yet.

16.11.6 list optimization long

Not implemented yet

16.11.7 list optimization macro

A listing of all thermodynamic data and current values of model parameter and experimental data with current weight. This can be read back as a start of a re-assessment and an important documentation of the current state of the assessment. But not yet implemented.

16.11.8 list optimization short

This specifies tha data and hour of the listing and first a table with the optimizing coefficents with name, current value, start value, scaling factor and its relative standard deviation.

In the first table all the optimizing coefficents with non-zero values are listed together with the current values, the start values and their scaling factor (usually ths same as the start value). In the column “RSD” the Relative Standard Deviation” should appear but it is not yet calculated correctly. Last column is the name of the TP symbol(s) where the coefficient is used.

After that all equilibria with non-sero weights are listed together with their experimental data, both the prescribed value, the uncertainy and the currently calculated one. In the last column the error is listed. 

Listing of optimization results: date 2018.08.20 : 12h47

List of coefficients with non-zero values
Name  Current value  Start value   Scaling factor RSD          Used in
A11     3.46818E+02   4.00095E+02   4.00095E+02   1.25070E-06  _GFCCAB0
A12    -5.66234E+01  -6.52871E+01  -6.52871E+01   1.33802E-06
A13    -2.10028E-02  -1.30393E-02  -1.30393E-02   8.97167E-06  _GFCCAB0

List of     4 equilibria with     8 experimental data values
  No Equil name    Weight Experiment $ calculated                   Error
   2 FCC1_ZA        1.00 SM=17:1 $ 17                               9.8995E-09
   2                1.00 CP1=18:1 $ 17.28685                        7.1315E-01
   3 FCC2_ZB        1.00 HDIFF=9000:500 $ 9997.813                 -1.9956E+00
   3                1.00 CP1=20:DCP $ 22.55698                     -2.5570E-02
   4 FCC3_ZC        1.00 HDIFF=15000:500 $ 14719.24                 5.6152E-01
   4                1.00 CP1=22:DCP $ 24.65726                     -2.6573E-02
   5 FCC4_ZD        1.00 HDIFF=20000:500 $ 19860.72                 2.7856E-01
   5                1.00 CP1=24:DCP $ 26.75754                     -2.7575E-02

Final sum of squared errors:      4.88614E+00 using    8 experiments and
  3 coefficient(s).  Degrees of freedom:    5, normalized error:    9.7723E-01

In the list of equilibria with non-zero weight the first column is a sequential equilibrium number assigned by the software. Then the name of the equilibrium assigned by the user. The third column is the weight, only equilibria with nonzero weight are listed. Then comes a columm with the experimental property and value and after the dollar sign its calculated value with the present set of coefficients. The rightmost column gives the difference for each experiment i,qi that should be as close to zero as possible:
exp calc qi = zi----z---wi σi
(3)

where i, ziexp is the experimental property, zicalc is the same property calculated from the model and σi is the experimental uncertanty and wi is the weight assigned to equilibria with the experiment. If wi = 1 and qi is between -1 and 1 the experiment has been fitted within the experimental uncertanty.

The least square routine tries to determine coefficients to make the sum of all qi2 as small as possible.

At the end of the listing ∑ iqi2 is listed. The degrees of freedom is the number of experiments minus the number of coefficients.

16.12 list Parameter

List a specific parameter.

16.13 list Phase “phase-name”

You must first specify the phase name. Then you can specify if you want the phase CONSTITUTION, DATA or some MODEL information. To write on a file use the options /output= or /append=, see 3.1.

16.13.1 list phase ... Constitution

List the constitution of the phase.

16.13.2 list phase ... Data

List the model and model parameter expressions.

16.13.3 list phase ... Model

List some model data for example if there is a disordered fraction set.

16.14 list Quit

You did not really want to list anyting.

16.15 list Results

List the results of an equilibrium calculation. This is the most frequent list command. The listing will contain the current set of conditions, a table with global data, a table with component specific data and then a list of stable phases with amounts, compositions and possibly constitutions. It is possible to list also unstable phases.

There are 9 options for the formatting:

For each phase the name, its status (S=suspended/D=dormant/E=entered/F=fix), moles (or mass), volume, number of formula units, atoms per formula units and driving force (in dimensionless units) is given on one line.

The moles of a phase is the number of formula unit multiplied with atoms per formula units. The gas phase and phases with interstitials and vacancies have a varying amount of moles of atoms per formula units. The composition of the phase can be in value order or alphabetical order.

To write the output on a file use /output= or /append=, see 3.1.

16.16 list Short

There are 4 options: A/C/M/P

The A option lists a single line for each element, species and phases with some essential data.

The C option lists one line for each component.

The M option lists the models and constitution for all phases.

The P option lists one line for each stable phase and then one line for some of the remaining phases in decreasing order of stability.

16.17 list State_Variables

Values of individual state variables like G, HM(LIQUID), X(LIQUID,CR) etc. can be listed. Terminate the command by an empty line. Note that the values of symbols and TP functions cannot be listed here, they are calculated by the CALCULATE SYMBOL or CALCULATE TP command.

The current values of parameter identifiers, see section 2.8.1 can be listed with the command, like TC(BCC) will give the calculated Curie temperature for BCC. A symbol like MQ&FE(FCC) will give the logarithm of the mobility of Fe in the FCC phase.

This command is the same as the SHOW command, section 27.

16.18 list Symbols

All state variable symbols listed but not their values, they are calculated by the CALCULATE SYMBOL command. 

List of all state variable symbols
 No Special Name= expression ;
  1         R= 8.31451;
  2         RT= R*T;
  3         T_C= T-273.15;
  4      D  CP= HM.T;
  5      C  DCP= 1
  6     7X  H298= HM;

In the “special” column the “D” means the symbol that is a “dot derivative” which is calculated only when explicitly specified, “C” means a numeric value that can be amended. The special 7X means a symbol that is evaluated only at equilibrium 7 which means you can refer to the value of this symbol calculated at the specified equilibrium in other equilibria. See also section 5.15.

16.19 list excell CSV file

The result from a STEP calculation can be listed in a file using the Commma Separated Value (CSV) format. This can be read by Excell or similar software for later processing. One may use other state variables for the table than used for the step command as one can do for plotting.

Independent variable:

The independent variable must be a single valued state variable, for example T.

Dependent variable(s):

The dependent variable may have multiple values, for example phase amounts, NP(*), or the driving force, DGM(#).

Output file:

16.20 list Tpfun Symbols

All or some TPFUN expressions listed. By giving * all are listed, bu giving the g* all TP functions starting with G are listed.

Note that all parameters are also TP functions, they can be listed by giving “_*” as name. The abbreviation “_g*” will list the function for all parameters with identifiers starting with G.

To obtain the values of TP functions use the calculate TP command.

17 Macro

By specifying a file name commands will be read from that file. The default extension is OCM. A macro file can open another macro file (max 5 levels). When a macro file finish with SET INTERACTIVE the calling macro file will continue or the user can continue interactively. See section 2.1.5.

When you start OC you can give a macro file name on the same line and the program will drictly start reading from this file.

With the popup window facility there are some special things. If you open the macro file with the popup window OC will save the directory where the macro file was found. If there are references to other files such as datbases or other macro files inside the macro and these file names are on the same line as the command read tdb ./steel1 the file name must be preceeded by a “./”, otherwise OC will try to open the file on its “working directory”, see section 2.1.2.

18 Map

For phase diagram calculations. You must first set two axis with state variables which are already set as conditions.

Reinitiate?

If you give several MAP commands you can choose to erase or keep the previous results at each command.

During mapping each calculated equilibria is saved and for plotting any state variable can be used.

19 New

To remove all data and calculated results to enter a new system. It is fragile.

The user must confirm with UPPER CASE Y.

20 Optimize

The command is part of the facility to assess model parameters for thermodynamic databases. You have already entered elements, phases and model parameters with coefficients to be assessed and all the experimental data yu can find. Estimated and theoretical data calculated by DFT can also be entered as experimental data.

The model parameters to optimized are selected by SET VARIABLE_COEFF and there is a least square routine LMDIF which will vary these to obtain the best least fit the experimental data provided.

As already state you must have entered the thermodynamic descriptions of the phases with model parameters depending on optimizing coefficients and the experimental data before this command. You must also set the weights of the experiments and which coefficents to be variable.

You provide a maximum number of iterations allowed. If you give zero a “dry run” will be made with the current values of the optimizing coefficients. This is useful to check that there are no problems calculating the equilibria. Usually you have to change the set of model parameters, weights of the experimental data and other criteria many times before you get a satisfactory result.

Developing better assessment software is one of the main aspects of the OC software. There will be more options to this and related commands.

21 Plot

Plot the result from a STEP or MAP calculation. A simple interface to GNUPLOT [7] has been implemented in OC. This generates a command file which is automatically plotted using GNUPLOT after the “render” command.

In OC you must first specify the state variable on the horizontal (x-axis) and vertical (y-axis) axis. Then you can give several of the options below, finish with RENDER or QUIT.

21.1 plot Horizontal axis variable

Specify the state variable or symbol to be plotted on the horizontal axis.

Note that if you plot a phase diagram with ”tie-lines in the plane” you should specify a fraction variable as X(*,C) and not X(C) because you want the carbon content in all stable phases.

21.2 plot xaxis Vertical axis variable

Specify the state variable or symbol to be plotted on the vertical axis.

Note that if you plot a phase diagram with ”tie-lines in the plane” you should specify a fraction variable as X(*,C) and not X(C) because you want the carbon content in all stable phases.

21.3 plot xaxis yaxis Options?/RENDER/

You can choose various options before plotting. Typing a ? gives a menu, typing ?? will give this text of the online help is correctly installed. The menu here is not very clear and will be reorganized. The default option is RENDER meaning to plot when you specified all your options.

The simplest way to generate a complex plot to be saved as PDF or PNG format is to first select the approriate axis and then set a few options like scaling, axis texts and text labels and plot on the screen. If you are not satified you can plot again (without changing the axis variables, if you change these all options you have set will be cleared) and add or modify the options. When you are satisfied with the plot on the screen you plot a final time and set the GRAPHICS-FORMAT option and plot in the desired format on a file. Or you can select to plot on a file in the GNUPLOT window. Note that some texts and formats may not be exactly identical to those you see on the screen.

Default plotfile is “ocgnu.plt”. On this file all the GNUPLOT commands and data will be written to be executed by GNUPLOT. If GNUPLOT is correctly installed then OC will start GNUPLOT and generate the graphics output when you RENDER the plot.

You can change the name of the plotfile before plotting with the command “output file”. Whenever you set a new terminal you can also set the output file name. Or you can rename the file after the RENDER command and before you generate a new plot.

GNUPLOT is a very powerful graphics software, only a few of its facilities are available within OC. The gnuplot command file generated by OC can be edited to exploit additional facilities in GNUPLOT.

APPEND FONT POSITION_OF_KEYS SCALE_RANGES 
AXIS_LABELS  GRAPHICS_FORMAT  QUIT TEXT_LABEL
EXTRA OUTPUT_FILE RENDER TITLE

A short summary:

The EXTRA command provides less used options:

AXIS_FACTOR LINE_TYPE NO_HEADING SPAWN
COLOR LOGSCALE PAUSE_OPTION TIE_LINES
GIBBS_TRIANGLE LOWER_LEFT_TEXT QUIT
GRID MANIPULATE_LINES RATIOS_XY

21.4 plot xaxis yaxis Append

A GNUPLOT file prevously generated by OC with possible manually changes or any file following the GNUPLOT standard can be specified to be overlayed on the current plot.

21.5 plot xaxis yaxis Axis_Labels

You specify for the X or Y axis the axis labels. By default the state variable or symbol plotted will be used as label.

For X or Y axis?

Specify the axis for which you want to enter the label

Axis label:

The default label is given in the question.

21.6 plot xaxis yaxis Font

21.7 plot xaxis yaxis Graphics format

The GNUPLOT terminals entered in section 10.8 can be used. For other formats than SCREEN you can also specify an output file which will be written for the specified format.

Graphics format index:

The default terminal indices are:

Name = GNUPLOT definition
1  SCREEN set terminal wxt size 940,700 font ”arial,16”
2 PS set terminal postscript color solid fontscale 1.2
3 PDF set terminal pdf color solid size 6,5 enhanced font ”arial,16”
4 GIF set terminal gif enhanced fontscale 0.7
5 PNG set terminal png enhanced fontscale 0.7

You can change these or enter more graphics formats with the enter gnuplot command. 10.8. The SCREEN driver is usually “wxt” for Windows and “Qt” for Linux but can be selected in the Makefile for the pmon6.F90 file.

If SCREEN is not selected the you can specify the name of the file where OC will save the commandfile for GNUPLOT as well as the final graphics file created by GNUPLOT. It will have the appropriate extention depending on the format. By default OC saves the GNUPLOT command file on the file “ocgnu.plt”. This can be renamed and edited if you want to keep it for later processing.

Plot file:

In addition to the GNUPLOT command file the graphics a file with the specified format will be generated.

21.8 plot xaxis yaxis Output file

By default plotting will generate a ocgnu.plt file for GNUPLOT. You can specify other name here. If you plot on other terminals than SCREEN there will be an additional file with extension “.ps” for Postscript, “.pdf” for Adobe PDF or “.gif” for GIF format.

If the file already exists the user must confirm it it should be overwritten.

21.9 plot xaxis yaxis Position of keys

The identification (labels) of the curves in the plot can be positioned with this command. See the GNUPLOT manual [7] for information.

21.10 plot xaxis yaxis Quit

No plot generated.

21.11 plot xaxis yaxis Render

Press return to plot using all the option set. Otherwise you can select any of these options:

APPEND FONT POSITION_OF_KEYS SCALE_RANGES 
AXIS_LABELS  GRAPHICS_FORMAT  QUIT TEXT_LABEL
EXTRA OUTPUT_FILE RENDER TITLE

21.12 plot xaxis yaxis Scale_Range

You specify for the X or Y axis the minimum and maximum range. The automatic (default) scaling range can always be restored.

21.13 plot xaxis yaxis Text

This is a facility to add a text to a plot at an arbitrary position.

21.13.1 plot xaxis yaxis text Modify existing text?:

If there is already a text item you must first answer if you wants modify an already existing one. If so all the texts are listed and you can select which one you wants to change.

21.13.2 plot xaxis yaxis text Which text index?:

You must provide the index of an existing text to change.

For a new or changed text you must give:

21.13.3 plot xaxis yaxis text X position

The X coordinate of the text (in the plot scale)

21.13.4 plot xaxis yaxis text Y position

The Y coordinate of the text (in the plot scale)

21.13.5 plot xaxis yaxis text Fontscale

A relative size factor, default is 0.8. The size of the text will be scaled accordingly.

21.13.6 plot xaxis yaxis text Angle (degrees)

The text will be written with the specified angle. Zero means horisontally, negative valus slopes downward, positive upwards. An ange of 180 means the text will be upside down.

21.13.7 plot xaxis yaxis text Do you want to calculate the equilibrium?/Y/

If you are plotting a phase diagram you can select to calculate an equilibrium at the specified coordinates. The names of the stable phases will be proposed as text.

The calculation may fail and you can anyway add a text. Note that the axis values you sepcified will refer to the axis used when calculating the diagram. If you are plotting using other variables there may be some surprises.

21.13.8 plot xaxis yaxis text Text:

The text to be added to the plot. The text will start at the coordinates given. On Postscript and PDF a greek character can be given as “/Symbol m” for μ.

21.14 plot xaxis yaxis Title

The default is the date and the conditions. You can add a text of your own here. You can remove the title altogether with EXTRA NO_HEADING. That will make the figure slightly larger.

21.15 plot xaxis yaxis Extra

Less common options for the plotting is available here. For really nice plotting it is recommended to edit the output file from OC as GNUPLOT has too many facilities to be made available here.

The EXTRA commands provides more obscure options:

AXIS_FACTOR LOGSCALE PAUSE_OPTIONTIE_LINES
COLOR LOWER_LEFT_TEXT  QUIT
GIBBS_TRIANGLE MANIPULATE_LINES RATIOS_XY
LINE_TYPE NO_HEADING SPAWN

21.15.1 plot xaxis yaxis extra factor

You can select a factor for each plot axis to convert from J to kJ for example.

21.15.2 plot xaxis yaxis extra color

You can select color of monovariant equilibria and tie-lines.

21.15.3 plot xaxis yaxis extra Gibbs-triangle

Gibbs triangle plots should only be used for isothermal sections. A trial implementation is available which can generate equiaxial triangular isothermal diagrams.

If you already set this option you can set it again to plot on a square.

21.15.4 plot xaxis yaxis extra line-with-symbols

Not implemented yet

21.15.5 plot xaxis yaxis extra logscale

You can set logarithimic scale on X or Y axis (or both).

21.15.6 plot xaxis yaxis extra manipulate lines

This is not implemented. It is intended to allow specification of the color of the curves in the plot.

21.15.7 plot xaxia yaxis extra lower left corner text

You can set a short text in the lower left corner of the plot

21.15.8 plot xaxia yaxis extra spawn

You can spawn the plot window and continue working looking at it.

21.15.9 plot xaxia yaxis extra no heading

Remove the text above the plot with date and title. The plot is slightly larger this way.

21.15.10 plot xaxis yaxis extra pause option

When you plot on the screen the last command on the file to GNUPLOT is “pause mouse”. You can change this with this command.

21.15.11 plot xaxis yaxis extra ratios XY

The relative ratios of the X and Y axis can be specied.

21.15.12 plot xaxis yaxis extra tie-line

Tie-lines in isothermal ternary phase diagram can be plotted. You can specify the density of the tie-lines by

Tie-line plot increment?

The increment is related to the actual equilibria calculated. 0 means no tie-lines plotted, 3 means to plot a tie-line at every 3rd calculated equilibria and so on.

22 Quit

Terminate the OC software in English, have a nice day.

23 Read

It is possible to read a (non-encrypted) TDB file but it should be not too different from what is normally generated by the LIST_DATA command in TC.

DIRECT QUIT  TDB
PDB SELECTED-PHASESUNFORMATTED

23.1 read Direct

File name:

In the future it will be possible to save results on a random access (DIRECT) file.

23.2 read PDB

File name:

A PDB file (with extension PDB) should be specified. The file should be un the Portable phase dependent Data Base format.

The user can select to read the whole file or select elements.

23.3 read Quit

You did not really want to read anything.

23.4 read selected phases only

This is to select a subset of elements and phases from a database. Normally all phases which can be formed by the elements are included. With this command one can first select the elements and after that one can specify the phases to be included. If one specifies an abbreviation of a phase name all phases which fit this abbreviation will be selected.

Database format:

Can be TDB or PDB.

File name:

It is also possible to read all phases and later suspend those which are not interesting.

23.5 read TDB

A TDB file (with extension TDB) should be specified. The TDB file must not deviate very much from the standard output from Thermo-Calc.

File name:

If you do not use the popup window for opening files you must specify the database file name. The file must be on the working directory (where you started the OC program, see section 2.1.2) or you must provide the path.

After opening the file the program will list the elements and ask:

Select elements /all/:

If you give RETURN the data for all elements will be read. If you answer q or quit nothing will be read. If you specify one or more elements the data for those will be read and if you selected a subset you will have the question:

Select elements /no more/:

And you can select some more or just give RETURN (or type quit). All phases that can be formed by the elements selected will be read, you cannot select the phases here but inside OC you can suspend those phases you are not interested in.

Error reading TDB file

In some cases there non-fatal errors or warnings reading TDB files created by different groups because the TDB format varies a lot. The user should carefully check if there are any data missing but can continue using the data he read if he is confident it is correct. The TDB file should be corrected manually.

23.6 read Unformatted

File name:

For use to read a file created with a SAVE UNFORMATTED command. It may not always work to read an old unformatted file as the data structure is still changing.

24 Save

There are several forms of save, three forms write a text file that can be read and modified with a normal editor. Two forms are unformatted, either on a sequential file or a direct (random access) file.

DIRECT SOLGAS UNFORMATTED
QUIT TDB PDB

24.1 save Direct

It will eventually be possible to save the result of STEP and MAP commands on a random access file for later processing.

24.2 save Quit

You did not want to save anything.

24.3 save PDB

Saves current set of model parameters and functions on a file in the Portable phase dependant Data Base format.

24.4 save TDB

Saves current set of model parameters and functions on a file in TDB format. Same as the command list data tdb.

24.5 save SOLGAS

Saves current set of model parameters and functions on a file in a format that (hopefully) can be read by the FactSage software.

24.6 save Unformatted

With this command you can save the current status of the calculations on a file and then resume the calculations by reading this file. Note that the Fortran unformatted files may not be portable, they depend on the compiler, the operating system and the hardware.

25 Select

There are a few things that can be selected, most important which equilibrium the following commands will operate on.

25.1 select Equilibrium

As you can enter several equilibria with different conditions this command allows him to select the current eqilibria.

25.2 select Graphics

Only GNUPLOT citegnuplot available.

25.3 select Language

Only English implemented (except a few French exclamations).

25.4 select Minimizer

Only Hillert’s algorithm implemented in matsmin [2] available.

25.5 select Optimizer

The LMDIF [6] least square fitting software is the only one implemented.

26 Set

Many things can be set. Things to be “set” and “amended” sometimes overlap.

ADVANCED FIXED_COEFF OPTIMIZING_COND  STATUS
AS_START_EQUILIB  INITIAL_T_AND_P  PHASE SYSTEM_VARIABLE
AXIS INPUT_AMOUNTS QUIT UNITS
BIT INTERACTIVE RANGE_EXP_EQUIL VARIABLE_COEFF
CONDITION LOG_FILE REFERENCE_STATE VERBOSE
ECHO NUMERIC_OPTIONS  SCALED_COEFF WEIGHT

26.1 set Advanced

A few options implemented

EEC_METHOD HELP-POPUP-OFF OPEN-POPUP-OFF  WORKING-DIRECTRY
EQUILIB-TRANSF  LEVEL QUIT
GLOBAL-MIN-ONOFF MAP-SPECIALS SMALL-GRID-ONOFF 
GRID-DENSITY NO-MACRO-STOP SYMBOL

26.1.1 set advanced EEC-method

In a recent paper[8] a method the compare the entropy of the liquid and a solid phase can be used to supress the formation of a solid phase at high T if its entropy is higher than the liquid, the Equi-Entropy Criteria (EEC). This simplifies the extrapolation of the Gibbs energy of solids at high T.

This command will activate or deactivate this check.

26.1.2 set advanced equilibrium transfer

This is only for experts who know what they are doing.

26.1.3 set advanced global-min-onoff

Turn on or off the use of the global gridminimizer.

26.1.4 set advanced grid_density

At present the grid density cannot be fine tuned. For some phases it is fixed for others you can select a more or less dense grid.

Note that phases with option F or B (4 sublattice order/disorder) there is a special grid minimizer and also for solids with ionic constituents and for the 2-sublattice ionic liquid.

26.1.5 set advanced help-popup-off

The user can turn off or on the HTML popup help feature. He can also change the browser and help file.

Turn off popup help? /Y/:

If the user answers N he will be asked for the browser and HTML file. These are normally set when compiling the OC software and their current values are proposed as default within slashes /../.

Browser including full path //usr/local/firefox/:

HTML help file includig full path //home/user/.ochelp/ochelp.html/:

26.1.6 set advanced level

You can specify if you are beginner or expert. You may have to declare youself as expert to execute some commands. The intention of the beginners status is to provide more help but that is not yet implemented.

26.1.7 set advanced map-special

Not implemented yet.

26.1.8 set advanced no-macro-stop

This command makes it possible to ignore the “@&” used to stop the execution of a macro file. Used when testing the software.

26.1.9 set advanced open-popup-off

Any other answer than Y will turn off popup windows for opening files. By answering Y you turn on popup windows for opening files (the default) provided the program is linked with this facility.

26.1.10 set advanced quit

You did not want to set anything advanced.

26.1.11 set advanced symbol

Not implemented yet.

26.1.12 set advanced working-directory

The name of the working directory (where OC was started) is listed. It cannot be changed at present. It is related to the popup windows for opening files, see section 2.1.2.

26.2 set As start equilibrium

The current equilibrium will be copied to the list of start equilibria for STEP and MAP commands.

26.3 set Axis

To set an axis you must first has set the conditions necessary to calculate an equilibrium and also calculated this.

Axis number:

The axis are numbered 1, 2 etc and you must set them in sequential order. To change an axis variable just give the number of the axis to change.

Condition to vary along the axis:

You can set select one of the condition to vary between a min and max value along the axis. If you has just one axis you can use STEP to calculate a property diagram, i.e. how the system properties varies with a single variable. Typically a phase fraction plot or how the heat capacity varies with the independent axis variable.

Minimal/maximal value of the axis:

The calculation will start with the current value and calculate in both directions.

Increment:

By default the increment is 1/40 of the difference beteen max and min.

If you set two or more axis (current limit is 2) the OC software will map the phase diagram, i.e. follow the lines where the set of phases changes. This means OC will replace one axis condition with a condition that a phase should be stable with zero amount.

To calculate a diagram you must then give a STEP command (if you have one axis) or a MAP command (if you have 2 or more axis). For the STEP command 28, there are several options.

26.4 set Bit

Many records have status words where the bits are used to signify different things. An advanced user can set these bits for the global, equilibrium and phase records, but only if you know what it means.

26.5 set Condition

Most of the text here also applies to enter experiment.

State variable:

A condition is a value assigned to a state variable or an expression of state variables. All state variables are listed in Table 1 in section refsc:statevar

By setting the status of a phase to fix you have also set a condition. For example

set cond t=1273 p=1e5 n=1 x(cr)=0.1 w%(c)=1

Three cases of expressions can be used as conditions, for example a relation between mole fraction like
set condition x(liq,o)-x(c1_mo2,o)=0
means that the oxygen content in liquid and c1_mo2 phases should be the same. That is useful to calculate the congruent melting of c1_mo2.

Another case is if the total anount if some components has a relation, for example:
set condition n(u)+n(zr)=1
means that the total number of moles of the components U and Zr should be unity.

A third case is y(B2,Al)-y(B2,Al#2)=0.01 to calculate a send order transition line when the B2 ordered phase is on the limit of disorder as the fractions of Al on the two sublattices are almost equal.

Value:

A numeric value or a symbol representing a constant value is expected.

26.6 set Echo

This is useful command in macro files or when demonstrating the program.

26.7 set Fixed coefficient

One or more optimizing coefficients are assigned a fixed value. The index 0 to 99 is used to indicate the coefficients A00 to A99. One can use a range as 15-19 to set all variable cofficients in the range to their current values.

26.8 set initial_T_and_P

Local values of T and P can be set. These are not conditions but are used for commands like CALCULATE PHASE ....

26.9 set Input-Amounts

This command allows you to specify a system by giving a redundant amount of various species in the system. The software will transform this to conditions on the amounts of the components.

Species and amount as N(..)= or B(...)= :

An example: 

--->OC5:read tdb cho-gas
--->OC5:set input
Species and amount as N(..)= or B(...)= : n(c1o2)
Amount: 10
--->OC5:set input n(c1h4)=5
--->OC5:l c
Conditions for equilibrium:   1, DEFAULT_EQUILIBRIUM
  1:N(C)=45, 2:N(O)=80, 3:N(H)=30
 Degrees of freedom are   2

The amounts of the species has been split on the components. Setting input amounts is just another way to set these directly. If we set a T and P we can calculate the equilibrium fraction of all the species. 

--->OC5:set c t=1000 p=1e5
--->OC5:l c
Conditions for equilibrium:   1, DEFAULT_EQUILIBRIUM
  1:N(C)=45, 2:N(O)=80, 3:N(H)=30, 4:T=1000, 5:P=100000
 Degrees of freedom are   0
--->OC5:c e
 3Y Constitution of metastable phases set
Gridmin:      85 points   1.56E-02 s and       0 clockcycles, T= 1000.00
Phase change: its/add/remove:     5   11    0
Phase change: its/add/remove:    12   12    0
Phase change: its/add/remove:    17    0   12
Phase change: its/add/remove:    53    0   11
Equilibrium calculation   79 its,   7.8125E-02 s and      93 clockcycles
--->OC5:l
LIST what? /RESULTS/:
Results output mode: /1/:

Output for equilibrium:   1, DEFAULT_EQUILIBRIUM          2018.08.21
Conditions .................................................:
  1:N(C)=45, 2:N(O)=80, 3:N(H)=30, 4:T=1000, 5:P=100000
 Degrees of freedom are   0

Some global data, reference state SER ......................:
T=   1000.00 K (   726.85 C), P=  1.0000E+05 Pa, V=  4.9872E+00 m3
N=   1.5500E+02 moles, B=   1.8507E+03 g, RT=   8.3145E+03 J/mol
GS= -2.80411E+07 J, GS/N=-1.8091E+05 J/mol, HS=-1.2914E+07 J, SS= 1.513E+04 J/K

Some data for components ...................................:
Component name    Moles      Mole-fr  Chem.pot/RT  Activities  Ref.state
C                 4.5000E+01  0.29032 -3.7354E+00  2.3863E-02  SER (default)
H                 3.0000E+01  0.19355 -9.8098E+00  5.4910E-05  SER (default)
O                 8.0000E+01  0.51613 -3.6377E+01  1.5911E-16  SER (default)

Some data for phases .......................................:
Name                Status Moles      Volume    Form.Units Cmp/FU dGm/RT  Comp:
GAS..................... E  1.550E+02  4.99E+00  6.00E+01    2.58  0.00E+00  X:
 O      5.16129E-01  C      2.90323E-01  H      1.93548E-01
 Constitution: There are    73 constituents:
 C1O2         4.54395E-01  C2H3         8.67456E-17  C4H10_1      2.73242E-23
 C1O1         2.95682E-01  C3H4_2       3.04922E-17  C4H10_2      1.38822E-23
 H2O1         1.29270E-01  C3H8         2.73523E-17  C4H2         8.16657E-24
 H2           1.20501E-01  C3H6O1       1.94895E-17  H1O2         4.37267E-24
 C1H4         1.52786E-04  C3H4_1       8.18695E-18  C4H6_5       1.44915E-24
 C1H2O2_CIS   4.04887E-08  C1H3O1_CH3O  3.87833E-18  C4H8         1.04297E-25
 C1H2O1       2.01368E-08  C2H4O1_OXIRA 1.64221E-19  C2H1         7.79712E-26
 C1H2O2_TRANS 5.82767E-09  C1H2         3.98656E-20  C4H8_4       6.39692E-26
 H            7.88542E-10  H2O2         3.27068E-20  C6H6O1       3.00598E-26
 C1H4O1       1.27636E-10  O            1.46838E-20  C1H1         1.81712E-27
 C2H4         1.05140E-10  C2H6O2       1.19305E-20  C3H1         1.68523E-28
                                                                                            
                                                                                            
 C2H6         3.44726E-11  O2           8.71930E-21  C4H4_1_3     7.73762E-29
 C1H3         1.83302E-11  C4H6_2       5.73533E-21  C1H2O2_DIOXI 4.04963E-30
 C1H1O1       7.24719E-12  C2O1         1.72590E-21  C4H1         1.00000E-30
 C2H4O1_ACETA 2.00054E-12  C4H8_5       9.38081E-22  C2H4O2_DIOXE 1.00000E-30
 H1O1         1.86354E-12  C4H8_3       5.91323E-22  C4           1.00000E-30
 C2H2         1.82837E-12  C4H8_1       4.75317E-22  C2H4O3_123TR 1.00000E-30
 C1H1O2       1.57298E-12  C4H8_2       4.17043E-22  C2H4O3_124TR 1.00000E-30
 C2H4O2_ACETI 7.65642E-13  C2H2O1       1.47405E-22  C2           1.00000E-30
 C1H3O1_CH2OH 1.64978E-15  C4H6_4       8.47392E-23  C60          1.00000E-30
 C3O2         1.11079E-15  C6H6         8.21607E-23  C3           1.00000E-30
 C3H6_2       7.21243E-16  C4H4         5.46648E-23  C5           1.00000E-30
 C3H6         7.13743E-16  C4H6_1       5.05773E-23  O3           1.00000E-30
 C2H6O1       6.22811E-16  C4H6_3       2.87604E-23
 C2H5         4.72671E-16  C4H10_1      2.73242E-23

--->OC5:

The calculation shows that mixing 10 moles of CO2 with 5 moles of CH4 at 1000 K and 1 bar gives a gas with 45% CO2, 30% CO, 13% H2O and the rest H2

26.10 set Interactive

The last command on a macro file. Gives command back to the keyboard of the user, or to the calling macro file. Without this the program will just terminate when the macro is finished.

26.11 set Log-File

A useful command to save all interactive input while running OC. The log file can easily be transformed to a macro file. All bug reports should be accompanied by a log file which reproduces the bug.

26.12 set Numeric-Options

The default number of iterations and accuracy can be specified. Default values are 500 and 10-6.

Some more obscure values may also be asked for, they should never be changed.

26.13 set Optimizing conditions

A few variables used to guide the optimization of model parameters can be set.

26.14 set system variable

This is a new idea to have global variables. No idea how to use it yet.

26.15 set Phase “phase-name”

You must specify a phase name. Some phase specific things can be set, also for the model. Some subcommands allow wildcard “*” as name.

26.15.1 set phase ... Amount

You can specify the amount of the phase which is used as initial value for an equilibrium calculation.

26.15.2 set phase ... Bits

Some of the models and use of data storage depend on the bits of the phase. Most of them are set automatically by the software and other commands like AMEND PHASE. Changing them with this command will not have the expected effect and may cause the program to fail.

The bits that can be changed are:

26.15.3 set phase ... Constitution

This is the same as amend phase constitution. The amount of the phase can also be set. You can specify the constituent fraction of each constituent. A fraction must be larger than zero and less than unity.

As the sum of fractions must be unity the last constituent in each sublattice will not be asked for unless you specify the fraction for one of the constitents as “rest”. The fraction of that will then be set as “the rest” i.e. one minus the sum of the other fractions.

This is also be used for the command calculate phase to calculate properties for a single phase.

26.15.4 set phase ... Default-constitution

Same as amend phase default_constit.

26.15.5 set phase ... Quit

You did not want to set anything for the phase.

26.15.6 set phase ... Status

Use the SET STATUS PHASE command to set the status of one or several phases. The different status are explained for that command, section 26.20.3.

A phase with the status FIX must also have an amount specified. For a phase with the status ENTERED the amount is also requested but normally it should be set to zero. A nonzero value means the user assumes the phase should be stable.

26.16 set Quit

You did not really want to set anything.

26.17 set Range of experimental equilibria

For an assessment several consequtive equilibria with experimental data must be entered. This command specifies the first and last of those equilibria. It possible to add more equilibria later one by one (not yet though).

First equilibrium number: /2/:

Last equilibrium number:

The equilibria are assigned the weight one by default. The weight can be changed with the SET WEIGHT command. The weight zero means the equilibrium is not calculated.

26.18 set Reference-State

By default the reference state for the components is SER (Stable Element Reference) which is the stable state of the element at 298.15 K and 1 bar. (NOTE: in principle SER is defined by the database but today almost all databases have SER as reference state.)

Component name:

Reference phase:

For each component (also for other components than the elements) you can specify a phase at a given temperature and pressure as reference state. The phase must exist for the component as pure.

Temperature:

Instead of a fixed T you can give a *, indicating current T, if you calculates at different values of T.

Pressure:

Example:

set reference O gas * 1e5

Note that state variables like the chemical potential, MU(O), will refer to the user defined reference state. To obtain the value for the SER state you can use the suffix S, i.e. MUS(O) will give the chemical potential refered to SER.

IMPORTANT NOTE: the value of integral properties like Gibbs energy, G, enthalpy, H, etc. will also be affected by the change of the reference state of an element. If all elements have the same phase as reference state the value of the enthalpy obtained by H for that phase will be the enthalpy of mixing. If not it is only confusing.

In order to have use SER as reference state use a suffix S. The enthalpy relative to SER is HS independent of any reference state set for the elements by the user.

26.19 set Scaled coefficient

A coefficient for optimization can be specified with a start value, scaling factor and a minimum and maximum value. The set VARIABLE command sets the scaling factor equal to the start value and have no min or max values.

Not implemented yet.

26.20 set Status

The status of elements, constituents, species or phases can be changed. Only phases are implemented.

26.20.1 set status Constituent

A constituent of a phase can be suspended. Not yet implemented.

26.20.2 set status Element

An element can be ENTERED or SUSPENDED. If an element is suspended all species with this element is automatically suspended. If such a species is the single constituent of a phase that phase is also suspended.

Not yet implemented.

26.20.3 set status Phases

Phase name(s):

A phase can have one of 4 different status

You can use a list of phase names or a wildcard for the phase name and the must give an equal sign, “=”, before the new status. You can also use the special “*S” for all suspended phase, “*D” for all dormant phases.

Changing the phase status does not affect anything except the phase itself. For a single phase you can use SET PHASE ... STATUS <status>.

Setting a stable phase as dormant or suspended and calculate the equilibrium will give you a metastable equilibrium.

Setting a phase status as FIXED means it is a condition that this phase should be stable. Setting the liquid fix with the amount zero is a quick way to calculate the melting temperature of a system if there is no condition on the T. For entered phases the amount is used as a start value.

Amount: /0/:

26.20.4 set status Species

A species can be ENTERED or SUSPENDED. If a species is suspended all phases that have this as single constituent in a sublattice will be automatically suspended. Not yet implemented.

26.21 set Units

For each property the unit can be specified like Kelvin, Farenheit or Celsius for temperature. Not implemented yet.

26.22 set Variable coefficient

One or more coefficients for optimization, A00 to A99, can be set as variable to be optimized against the selected experimental data.

A single variable index, 0 to 99, can be used with a start value provided. Or a range such as 15-19 which will set all nonzero variables A15 to A19 as variable.

26.23 set Verbose

Not implemented yet.

26.24 set Weight

Intended for assessments. A weight is zero or a positive value. Equilibria with weight zero will be ignored in an optimization.

You can specify the current equilibrium or give an abbreviation that will set the weight of all equilibria with a name for which the abbreviation fits. Or you can give a range of equilibria by giving two numbers separated by a hyphen like 63-106.

If an abbreviation or a range is given the software will list how many equilibra that had the weight set to the new value.

27 Show

This command shows a value of a property, the property can be a state variable like T, G etc or a user detfined symbol containing several state variable or a model parameter identifier (which must always have a phase specification) like the Curie temperature.

The state variables can contain wildcards like X(FCC,*) means all mole fractions of the FCC phase. Several properties can be specified on the same line, SEPARATED BY A SPACE CHARACTER, do not use “,”.

It is the same as the command LIST state-variables, see section 16.17

27.1 property:

The value of one or more properties or symbols can be shown: DO NOT USE “,” between the properties! 

--->OC5:show t g tc(bcc) x(bcc,cr) mu(cr) cp
 T=  1.2000000E+03
 G= -5.9565761E+04
 TC(BCC_A2)=  1.0272646E+03
 X(BCC_A2,CR)=  3.100000E-2
 MU(CR)= -7.2489667E+04
CP=   4.08487869E+01

28 Step

Requires that a single axis is set. If a second step command is given you have the choice of deleting or keeping the previous results.

There are 5 variants of the STEP command, CONDITIONS and NPLE are not implemented:

CONDITIONAL  NPLE QUI SEPARATE
NORMAL PARAEQUILIBRIUM  SCHEIL-GULLIVER  TZERO

Delete previous results?

Any previous results from the STEP or MAP commands can be deleted or kept. If kept the previous results can be plotted together with the results from the new STEP command. The PLOT command also allows appending previous diagams calculated and plotted by OC.

28.1 step Conditional

A specified symbol is evaluated at each step, not implemented.

28.2 step Normal

Calculates equilibria from the low axis limit to the high at each increment. The exact axis value for any phase changes is calculated.

28.3 step NPLE

Step NPLE is similar to step paraequilibrium.

28.4 step paraequilibrium

Paraequilibrium describes a metastable equilibrium with a fast diffusing element. It is described in section 2.13.2. You should make a calculate paraequilibrium command, see section 7.6, before this step command and you must again specify a matrix phase and a growing phase and the fast diffusing element.

Matrix phase:

Note all phases except the matrix and growing phase should be suspended. You should provide name of the matrix phase

Growing phase:

Fast diffusing element:

The element that diffuse so fast that its chemical potential is the same in both phases. The other alloying elements will have the same composition in both phases.

28.5 step Quit

You did not want to step.

28.6 step Scheil-Gulliver

The Scheil-Gulliver solidification simulation is described in section 2.13.1. It simulates a solidification with no diffusion in the solid phases and a homogeneous liquid.

28.7 step Separate

This command calculates equilibria for each phase separately along the axis. It is typically used to separately calculate and plot together the Gibbs energy curves for a number of phases across a composition range.

28.8 step Tzero

This will calculate a line with the fraction of the selected element on one axis and the T on the other and the line is defined by the fact that the two phases have the same Gibbs energy with the same composition and at the same T. This is the limit of a diffusionless transformation. T0 or Tzero lines are described in section 2.13.3 and 7.12. Before this step command you must have calculated a Tzero point.

First phase:

Second phase:

Note all phases except the two phases should be suspended. You should provide name of the matrix phase

Release condition number:

Normally the step axis is the fast diffusing element and the condition released is the T. The fast diffusing element will have the same chemical potential is both phases, the other alloying elements will have the same composition in both phases.

29 Summary

That’s all and I hope enough (when all is implemented). Have fun and report all errors or problems providing a macro file and the necessary data.

References

[1]   B Sundman, U R Kattner, M Palumbo and S G Fries, OpenCalphad - a free thermodynamic software, in Integrating Materials and Manufacturing Innovation, 4:1 (2015), open access

[2]   B Sundman, X-L Liu and H Ohtani, The implementation of an algorithm to calculate thermodynamic equilibria for multi-component systems with non-ideal phases in a free software, Computational Materials Science, 101 (2015) 127–137

[3]   B Sundman, U R Kattner, C Sigli, M Stratmann, R Le Tellier, M Palumbo and S G Fries, The OpenCalphad thermodynamic software interface, Comp Mat Sci, 125 (2016) 188–196

[4]   H L Lukas, S G Fries and B Sundman, Computational Thermodynamics, the CALPHAD method, Cambridge Univ Press 2007.

[5]   J Herrnring, B Sundman and B Klusemann, Diffusion-driven microstructure evolution in OpenCalphad, Computational Materials Science, 175, (2020) 109236

[6]   https://www.math.utah.edu/software/minpack/minpack/lmdif.html

[7]   http://www.gnuplot.info/documentation.html

[8]   B Sundman, U R Kattner, M Hillert, M Selleby, J gren, S Bigdeli, Q Chen, A Dinsdale, B Hallstedt, A Khvan, H Mao and R Otis, A Method for handling the extrapolation of solid crystalline phases to temperatures far above their melting point, Calphad, 68 101737

================================================ FILE: doc/manual/ochelp.tex ================================================ \documentclass[11pt]{article} \usepackage[utf8]{inputenc} % NEXT LINE is needed for generate a HTML file with targets (hyperref) \usepackage{hyperref} % % This is a file for a printable PDF and HTML versions of the user guide % AND as on-line help, either directly or processed to remove LaTeX specials % % The PDF file is generated by pdflatex ochelp6.tex % % I have made this user guide also available for on-line help % as an HTML file. That is very nice but a bit complicated. % %======================================================= % To generate the HTML file use the program ``htlatex'' %======================================================= % % the package \usepackage{hyperref} % creates possibilities to find text inside the HTML file % using \hypertarget{labeltext}{shown text} (the shown text can be empty) % written in the LaTeX file. % % I have written a program listhyper % extracts relevant hypertagets from the software to help entering these % in this user guide % % The idea is that the user can type a ? to have help at any question. % All questions by the OC software is asked by a GPARxyz routine and % in this routine the programmer (me) can provide a text for a hypertarget. % When the user types a ? this hypertarget is used to find a relevant % help text in the HTML version and this is displayed in a separate % browser window. The user can the scroll and search % the whole manual in this window % % Some additional problemns with this explained below ... % \topmargin -5mm \oddsidemargin -1mm \evensidemargin -1mm \textwidth 170mm \textheight 225mm \parskip 2mm \parindent 3mm % THIS WATERMARK IS REMOVED AS IT IS NO LONGER SUPPORTED %\usepackage[firstpage]{draftwatermark} %\SetWatermarkScale{4} % this should allow \subsubsubsection ... \newcommand{\subsubsubsection}[1]{\paragraph{#1}\mbox{}\\} \setcounter{secnumdepth}{4} \setcounter{tocdepth}{4} %\pagestyle{empty} % LOOK for ALERT: for checks how the source code behaves!! % % HYPERTEXT provides browser access to ochelp HTML: % in a LaTeX file \hypertarget{labeltext} % is written in the html file as: % NOTE: Case does not seem to matter, Enter or ENTER is OK % BUT NO TRAILING SPACES!! % % Problem when opening the HTML file inside OC to list the help text: % OLD: This is in the metlib3.F90 file, the q1help subroutine % This is in the metlib4.F90 file, the q4help subroutine % on WINDOWS: SPECIAL CHARACTER PROBLEM with " (doublequote) % to find an labeltext from OC help file using system command: % "C:\program files\mozilla firefox\firefox.exe" -file ./manual/ochelp/html/ochemp5.html#labeltext % the above does not work (on Windows 10) BUT the following command works: % "C:\program files\mozilla firefox\firefox.exe" "file://c:\users\bosse\documents\oc\oc\src\manual\ochelp\html\ochemp5.html#labeltext" % BUT it does NOT work when called through execute_command_line(command) % It seems a problem having 4 doublequotes in the same line ... why? % BUT AGAIN, using ``8.3'' Windows file names for Explorer this works: % C:\progra~1\intern~1\iexplore.exe ``file:/C:\user\bosse\ochome\ochemp.html#labeltext % on Linux using firefox this works: % /usr/bin/firefox "file:/home/bosse/ochome/ochelp.html#labeltext" % % USE OF HYPERTARGET % From OC version 5+ a modified online help system using \hypertarget{}{} % Now the hypertaget is specified in PMON and the GPARxyz routinines % replacing the subroutine name! % This works very nicely. The only problem is with menu and submenu commands % because these should just list the menu when the user types ? % and display the user guide only when the user types ?? % But this seems to work now using a special '?TOPHLP' as ``target'' % when using a gparxyz routine to ask for a command or subcommand. % % I am not sure if the hypertext targets are case sensitve but I assume so % and thus this has to be standardized. First letter capitalm rest lower case % unless there is a reason, for example TDB is in upper case. % the listhyper will now detect missing targets in UG % but there are also questions with targets in the gtp routines ... % % NOTE: To make it easier to find all \hypertargets{}{} used in the % source code I have added a question mark ? as first character of % the argument in the gparxyz file, for example: % % call gparcx('Symbol name: ',cline,last,1,name1,' ','?Amend something') % % which will search for the \hypertarget{Amend symbol}{} in the HTML file % The ? will be stripped before searching. The ? is not mandatory, just % an attempt to simplify updates and maintaining the help system. % %--------------------------------------------------- % % The current version of this guide is generated manually but maybe a % software program should be developed to update this automatically whenever % the software is changed % %--------------------------------------------------- % % SOME IMPORTANT ADVICE: % % The commands and subcommands are arranged alphabetically % % It will be difficult to update the help text for the % questions after the commands and subcommands as they are sometimes % not part of the command monitor. % % The _ used in many commands should be replaced by \_ or just - % %--------------------------------------------------- % % GUIDE how to add searchable items in the help file for online help % ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ % The online help is based on using a browser like firefox or explorer % If the user types ``?'' as answer to a question the subroutine % asking the question, GPARxyz, has a character variable as its last % argument which is a ``hypertarget'' in the HTML version of % the user guide. The HTML file opened with this character as a hypertarget % % htmlhelp=trim(ochelp%browser)//' "file:'//& % trim(ochelp%htmlfile)//'#'//ochelp%target(1:kk)//'" &' % % where browser and htmlfile are set when the program starts. kk is used % to strip the target of irrelevant parts which may be set by the user. % % The user guide will open in a separate window at a text indicated by % the hypertarget which should be relevant for the question. The user can % scroll the guide in this window for other parts if he needs more help. % % Special care is taken for menu commands and for these a single ? % will just display the menu. Only a ?? will open the HTML file. % The hypertarget for menu help is the first 3 words of the promt for % the menu. Thus any variable part of the promt should be preceeded % by at lset 3 words, for example: % % Amend for phase LIQUID what? /COMPOSITION_SET/: ?? % % will use as hypertarget ``Amend for phase'' ignoring the variable ``LIQUID'' % % Updating the software and the user guide in parallel can be complicated. % To help with this I have added a ? at each searchable hypertarget in the % source code. Thus one can search for ``'?'' to find a hypertarget for % any question and check it is identical to the hypertarget in the % user guide. UPPER or lower case does not seem to matter. % But trailing spaces inside \hypertarget matter! % %--------------------------------------------------- % \begin{document} \begin{center} {\Huge \bf User Guide to the OpenCalphad software package version 7.0 } \bigskip {\Large DRAFT} \bigskip Bo Sundman, \today \end{center} \vspace{25mm} Updates of OC User Guide \begin{itemize} \item version 7, 2021-04-01 prerelease \item version 6, 2019-11-11 prerelease \item version 5, 2018-09-19 first use of hypertargets \item version 4, 2016-10-06 \item version 3, 2016-01-01 \end{itemize} Earlier versions of OC had no User Guide \newpage This page intentionally blank \newpage \tableofcontents \newpage \section{Introduction} The development of the OpenCalphad (OC) sofware was started by a small group of dedicated scientists who wanted to provide an open source multicomponent thermodynamic software. It aims to provide a free high quality software for thermodynamic calculations, including property and phase diagrams, assessment of databases and a thermodynamic library for simulations for inorganic systems i.e. gases. liquids, alloys and other materials using many different kinds of models for the phases. There are three basic papers published about OC~\cite{15Sun1,15Sun2,16Sun}. General information about thermodynamic models, calculations and assessments based on the Calphad technique can be found in the book by Lukas et al~\cite{07Luk}. This software is provided free with a GNU GPL license. In OC there is also a framework to store different kinds of materials properties that depend on temperature, pressure and composition when such properties are related to the phases of the system and used in simulations as described in~\cite{20Her}. The OC software can also be used to assess model parameters for such properties from experimental and theoretical values. Complimentary (and maybe sometimes contradictory, I am not perfect) information about the OC software can be found in getting-started.pdf, news-oc7.pdf and the other parts of the OC documentation. \section{Some general features} The different parts of the OC software are documented separately for each module: thermodynamic models (GTP), equilibrium calculations (HMS), step/map/plot routines (SMP) and the application software interface (OCASI/TQ). With OC version 6 the old utility package metlib, originally written in F77, has been converted completely to the new Fortran standard and is included in the documentation. The documentation of the assessment module is not finished. OC uses the free numerics packages LAPACK and BLAS and two routines from MINPACK~\cite{lmdif}, LMDIF and HYBRD developed at Argonne 1980. LMDIF is a least square minimizer used for assessments and HYBRD~\cite{lmdif} solves systems of non-linear equations needed to calculate $T_0$ and paraequilibria. For graphics OC generates a command file which can be plotted with the free GNUPLOT~\cite{gnuplot} software. If GNUPLOT is properly installed GNUPLOT is invoked automatically by OC. \subsection{Command line user interface} OC is operated by commands typed by the user or read from a macro file. The command monitor has a menu of command and each of these usually has sub-menus and finally some questions may be asked like phase names, a value or an expression. In most cases a default answer is provided which can be selected by just pressing the RETURN key or by typing a comma, ``,'', on the same line as the command. At all levels the user should be able to type a ? and get some help, usually an extract from this manual, sometimes just a menu or examples of answers. A command line interface is superiour when it comes to enter complex equilibrium conditions for example to calculate the minimum of a liquidus line defined by the condition ``x(liq,cr)-x(bcc,cr)=0'' in the Fe-Cr system. To follow a second order transition one can set the difference between the site fractions of the same element, for example ``y(bcc-B2,Al)-y(bcc-B2,Al\#2)=0.01'' as condition. For the menu commands a single ? will just display the menu, in order to obtain the User Guide type two, ??. If you prefer a graphical user interface (GUI) there is at least two independent efforts to provide a GUI to OC. \subsubsection{Command line editing and history} On Windows the OS provides history and on-line editing of commands but on Linux and other OS this has to be provided by the software itself. Thus a C routine with an iso-C interface written by Urban S Jost (2009) copied from http://www.urbanjost.altervista.org/LIBRARY/libCLI/Getkey/getkey.html has been added and there is a seperate documentation of this if you want to change anything. The command history is saved inside OC and by typing ``upparrow'' (normally ctrl-P but it can be different on different terminals) earlier command can be retrieved and also edited. \subsubsection{Popup window for read/save}\label{sc:popup} To open a file for reading or saving one need a file browser and from OC version 5.018 I have included a routine ``TINYFILEDIALOGS'' developed by Guillaume Vareille (2014-2018) available at http://tinyfiledialogs.sourceforge.net. This will open a popup window to open a file (for a macro, a database or to save a calculation). In this window you can browse your directories to find the file. This has some consequencies for editing your macro files which you should be aware of and which are explained below. You can turn off the open file popup window feature with the command {\bf set~advanced~open\_popup\_off~Y}. You can turn it on again with the same command finishing with anything but Y. \begin{itemize} \item The directory where you start the session with OC is called the ``working directory''. On a linux system you can find this directory by typing ``pwd'' before starting OC (or if you type {\em @pwd} inside OC). On a Windows system you can see the working directory and its files if you type {\em @dir} inside OC. \item When the popup window is opened the directories and files matching the ``filter'' in the working directory should be listed. If not you can select a directory inside the popup window. The filter when open a macro file is ``OCM'' and when opening a database file it is ``TDB'' which means only files with these extensions are listed. You can change the directory in the popup window to select the file you want and you can read a file with another extension. OC will save internally the directory where you start the macro. \item Inside a macro file you normally read a TDB file and if you do not specify the name of the database on the same line as the command {\em read tdb} the popup window will open so you can specify the file in this window. \item But normally you know which database you want to use inside the macro and if you give the file name on the same line as the commad: {\em read tdb filename} the popup window will not open and OC will search for the specified database file starting from the ``working directory''. But if the database file is in the same directory as the macro file you MUST prefix ``filename'' with ``./'', i.e. {\em read tdb ./filename}. You may include directories in ``filename'', (including ``../'' to go to the directory above). OC will replace the ``./'' by the directory where you started the macro or prefix ``../'' by this directory. \item In the macro file you can give the full path to the file to be opened but that is rather clumsy. \item When you open a file for write inside a macro, like output from a plot, you can also specify the file name in the command prefixed by ``./'' if you want to save the file on the same directory as the macro file. Otherwise it will be saved at the working directory. \item If you use the switch ``/output='' or ``/append='' after a command to redirect output from the command you can also use the popup window to specify the file name or use a filename with or without the prefix ``./''. The default extension in this case is ``DAT''. \end{itemize} Opening files on different directories can be complicated inside OC. For example during assessments you may use many different files for generating graphics and unformatted save files. Preferably you keep all of these on the same directory. You are welcome to provide feedback on this popup feature and other parts of the user interface. \hypertarget{Info helpsystem}{} \subsubsection{On-line help}\label{sc:on-line-help} A recent feature added to OC is providing on-line help using a browser window where this user guide is available as a searchable HMTL file. Whenever the user wants an explation of a question the OC software asks he can type a ? and the OC software will open a separate browser window positioned at the relevant text in the user guide. You can then search the whole user guide for related information. Whenever the user types ? at a menu level just the menu will be displayed but if you type ?? the user guide will be opened at the relevant menu text with additional explanations. This feature is new and is still under development. Feedback is helpful. It can be turned off (or on again) by the command {\bf set~advanced~help\_popup\_off~y} in section~\ref{sc:help-popup}. For installation of the help system please read the installation guide to create an environment variable OCHOME with a link to the directory with the help file. \subsubsection{Environment and startup macro file} The OC program will look for an environment variable called OCHOME and if it finds this it will look for a file start.OCM which will be executed before the user gets control. This can typically be useful to set some variables like the plot terminals, see section~\ref{sc:gnuterm}. If there is no OCHOME environment variable the current ``working directory'' will be searched. The ochelp.tex and ochelp.html file should be copied from the directory ``manual'' in the installation directory to this OCHOME directory. \subsubsection{Macro files}\label{sc:macro} The macro command is very useful for preparing complex calculations and to remember how you did them. A macro file is simplest to create staring from a log file (created by the {\bf SET LOG} command). See the macros directory for examples. After a macro command the popup window will allow you to search for the file on all your directories unless you type the name of the file on the same line. In the latter case the macro file must be on you ``working directory'', see section~\ref{sc:popup} When you open files, such as databases, inside a macro file and you type the file name on the same line as the command as ``read tdb ./steel1'', you must prefix the file name, ``steel1'' with ``./'' if the tdb file is on the same directory as the macro file. If your command line is just ``read tdb'' the popup window will be activated and you can specify the file there. If you open another macro file inside a macro (typically when you do assessments) you must also prefix the name of the macro with ``./'' unless you want to select the macro using the popup window. \hypertarget{Macro comments}{} \subsubsubsection{Comments, stops and questions in macro files}\label{sc:macroadd} It is useful to insert comments in the macro file to explain what it doing. A line starting with ``@\$'' is a comment and will be ignored by the OC software. You can insert stops in the macro file with ``@\&'' at the beginning of a line. This can be useful to have time to inspect the output. The macro continues after pressing the ENTER/RETURN key. Depending on the graphical driver you use the program will normally pause after each plot and you must click on the graphical window to continue. You can also, inside the macro, ask the user for values needed for the calculations. For example if you have a complicated calculation you would like to use several times with different values of the compositions or temperature you can, instead of editing the macro each time, insert questions in the macro. The macro will then stop and ask the user to input that value from the keyboard before continuing. In the macro file you can ask for the condition on the temperature in this way: \begin{verbatim} @$ Ask user for the condition on the T set cond T @?Input-new-temperature \end{verbatim} When the macro comes to this point the program will write the text ``Input-new-temparature'' on the screen and wait for user input. After the value has been typed on the keyboard and ENTER/RETURN pressed OC will set the value as the temperature and continue with the next command in the macro file. There is no way to insert loops or conditions in the macro file. A macro file should be terminated with the command {\bf SET INTERACTIVE} which gives back control to the keyboard (or the calling macro file) otherwise the program may terminate at the end of the macro. Macro files can be nested 5 levels deep. \subsubsection{User interface feedback} OC has grown organically and although the basic concepts has been quite clear the implementations of several of these has become rather confusing. This will eventually require some cleaning up of the user interface. A central part of any thermodynamic software is the modeling of the phases. A new PDB format for databases may help a little with the specification of the models. An attempt has been made in this version to clean up the way a model is specified and used. At present you must first ENTER the phase to give a name, basic model, sublattices and constituents. Then use the AMEND command to add magnetism, a disordered fraction set and/or use BCC/FCC permutations. Originally some of these things were set by the command SET PHASE ... BIT and that was not very clear. Some computational options like for the grid minimizer are still set with several different commands. It is useful for the developers to have some feedback from users to organize this better. \subsection{Names and symbols} There are many symbols and names used in this package. A symbol or name MUST start with a letter A-Z. It usually can contain digits and the underscore character after the initial letter. All names are CASE INSENSITIVE, i.e. fe, FE, fE and Fe is the same. Some special symbols are used: \begin{itemize} \item /- is used to denote the electron. /+ or /- -1 can be used for a positive charge. \item * can be used to mean ``all'' or ``all stable''. \item \# are used to identify composition sets after a phase name or sublattice after a constituent name. It is also used as wildcard to obtain the DGM of all phases including metastable ones. \item \& are used in some parameter identifiers to specify the constituent for the parameter, like for mobilities, the mobility of Fe in the BCC phase is denoted MQ\&FE(BCC). \end{itemize} A name of an element is one or two characters, a species maximum 24 characters (note that a species name does not have to be its stoichiometric formula). A phase name is 24 characters but can also have a pre- and suffix 4 characters long and possibly a composition set number after a hash symbol, \#. State variable symbols and TP-fun symbols can be 16 characters long. TP-funs are expressions used to describe the $T$ and $P$ dependence of model parameters. For user input it is possible to use abbreviations of names but you must be careful with names that have the same abbreviation and avoid phase names that are abbreviations of another phase! \hypertarget{Info elements}{} \hypertarget{Info species}{} \subsection{Elements, species, components, constituents and system}\label{sc:elements} Much of the confusion using thermodynamics is due to the fact that the user has no clear idea of the terms in the title of this section. A strict definition used in OC is: \begin{itemize} \item An element is from the periodic chart. The user can also enter fictitious elements. \item A species is a molecularlike aggregate of elements with fixed ratios. It can also have a charge and be called an ion. The vacancy, representing an empty lattice site, is also a species. \item The constituents of a phase is a subset of the species. \item The set of components limits the composition of the system. By default the elements are the components but the user can enter any orthogonal set of species as components by a command, see section~\ref{sc:amendcomp}. \end{itemize} A system is defined by its components. Conditions on the amounts or chemical potentials can only be set for the components, not for any arbitrary species. But the chemical potential of a molecule is related to that of the elements at equilibrium. Thus one can use the relation: \begin{eqnarray} \mu_{\rm H_2O} &=& 2\mu_{\rm H}+\mu_{\rm O} \end{eqnarray} to set a condition on a sum of chemical potential of the elements. The phases can gave different models and sets of constituents to describe Long Range Ordering (LRO) and Short Range Orderng (SRO). Some phases can exist for a specific composition only or for a limited subset of the components of a system. \hypertarget{Info phases}{} \subsection{Phases, composition sets and phase tuples} Many come across thermodynamic calculations the first time in chemistry writing chemical reactions. In such reactions the solid and liquid phases are usually treated as stoichiometric and only the gas can have several constituents. In the Calphad approach most phases are treated as solutions with variable composition but with different models for their Gibbs energy functions. But some phases can exist only for a specific or very restricted composition. Each phase in a system has a name and a thermodynamic model and set of constituents, see section~\ref{sc:elements}. The models are explained in a separate documentation. The phases can be entered interactivly or read from a database or a saved file together with the last calculation. \hypertarget{Info compset}{} In some cases a phase can be stable with two ore more different compositions for example inside miscibility gaps or when the phase has order/disorder transitions. In such a case you use a composition set index to separate these. The composition set index is appended to the phase name preceeded by a hash ``\#'' character, like liquid\#2. Composition sets can be created manually, see the command {\bf AMEND PHASE} in section~\ref{sc:amend_phase_cs} or automatically by the grid minimizer or application software. The phase tuple has been introduced to have a single index for both phases and composition sets in application software. The tuple index thus contain both the phase number and the composition set index. The array of tuple indices is updated internally whenever a new composition set is created or deleted. \subsection{The use of wildcards for phase names} In many cases you can use an asterix ``*'' as a name and this normally means ``all''. For setting status of phases you can use the special ``*S'' for all suspended phase, ``*D'' for all dormant phases. If you plot the composition of a phase, such as x(liquid,*), values will be listed or plotted only in the range the liquid is stable. When using ``*'' for output, for example NP(*) for the amount of all phases it means ``all stable''. Thus to plot the driving force for metastable phases, see section~\ref{sc:dgm}, there is a special wildcard ``\#'' which can be used in in DGM(\#) for plotting the driving force for all metastable phases. The driving force, DGM, is also included in listing of results for all phases. \hypertarget{Info statevariables}{} \subsection{State variables}\label{sc:statevar} \begin{table}[!ht] \caption{A preliminary table with the state variables and their internal representation. Some model parameter properties are also included. The "z" used in some symbols like Sz means the optional normalizing symbol M, W, V or F. There is some redundancy, for example NM(FE) is the same as X(FE).}\label{tab:statev} {\small \begin{tabular}{|lllcccl|}\hline Symbol~&\multicolumn{2}{c}{Id}&\multicolumn{2}{c}{Index}&Normalizing~&Meaning\\ & A & z & 1 & 2 & suffix & \\\hline \multicolumn{7}{|c|}{Intensive properties}\\\hline T & 1 &- & - & - & - & Temperature\\ P & 2 &- & - & - & - & Pressure\\ MU & 3 &- & component & -/phase & - & Chemical potential\\ AC & 4 &- & component & -/phase & - & Activity\\ LNAC & 5 &- & component & -/phase & - & LN(activity)=MU/RT\\\hline \multicolumn{7}{|c|}{Extensive and normallized properties}\\\hline U & 6 & 1 & -/phase\#set & - & - & Internal energy for system\\ UM & 6 & 2 & -/phase\#set & - & M & Internal energy per mole\\ UW & 6 & 3 & -/phase\#set & - & W & Internal energy per mass\\ UV & 6 & 4 & -/phase\#set & - & V & Internal energy per m$^3$\\ UF & 6 & 5 & phase\#set & - & F & Internal energy per formula unit\\ Sz & 7 & * & -/phase\#set & - & * & entropy\\ Vz & 8 & * & -/phase\#set & - & * & volume\\ Hz & 9 & * & -/phase\#set & - & * & enthalpy\\ Az & 10 & * & -/phase\#set & - & * & Helmholtz energy\\ Gz & 11 & * & -/phase\#set & - & * & Gibbs energy\\ NPz & 12 & * & phase\#set & - & * & Moles of phase\\ BPz & 13 & * & phase\#set & - & * & Mass of phase\\ Qz & 14 & * & phase\#set & - & * & Stability of phase\\ DGz & 15 & * & phase\#set & - & * & Driving force of phase\\ Nz & 16 & * & -/phase\#set/comp & -/comp & * & Moles of component\\ X & 17 & - & phase\#set/comp & -/comp & 0 & Mole fraction\\ X\% & 17 & - & phase\#set/comp & -/comp & 100 & Mole per cent\\ Bz & 18 & * & -/phase\#set/comp & -/comp & * & Mass of component\\ W & 19 & - & phase\#set/comp & -/comp & 0 & Mass fraction\\ W\% & 19 & - & phase\#set/comp & -/comp & 100 & Mass per cent\\ Y & 20 &- & phase\#set & const\#subl & -& Constituent fraction\\\hline \multicolumn{7}{|c|}{Some model parameter identifiers}\\\hline TC & - &- &phase\#set & - & - & Curie temperature\\ BMAG & - &- & phase\#set & - & - & Aver. Bohr magneton number\\ MQ\&A & - &- & phase\#set & constituent A & - & Mobility of A\\ THET & - &- & phase\#set & - & - & Debye temperature\\\hline \end{tabular} } \end{table} A state variable in a thermodynamic system has a value which at equilibrium is independent of the way the system has reach its current state, it depends only on its current state. All state variables available in OC are listed in Table~\ref{tab:statev}. They are used to set conditions and to obtain results from an equilibrium calculation. It is possible to use state variables also when close to the equilibrium state for example when simulating a phase transformation. \subsubsection{Some pecularites of the state variable values} One has to be careful with the normalizing suffix, thus H means the enthalpy of a system for its current size. HM is the enthalpy for the current system divided by the number of moles of atoms in of the system. This is one can expect but one may be surprised that H(phase) is the enthalpy of ``phase'' for the current amount of moles of atoms of the phase, which is zero if the phase is not stable. To obtain the value of the enthalpy of ``phase'' independently of its current amount one must use HM(phase), the enthalpy per mole of atoms in the phase. The value of a state variable also depend on the reference states of the elements. The user may define this for each element with a command, see section~\ref{sc:refstate}. The default refernce state is the stable state of the elements at 298.15~K and 1~bar, called SER. Whenever necessary this is indicated by an final suffix ``S'', for example ACS(C) indicate the activity of C using the reference state SER whereas AC(C) is always be the activity relative the current reference state, either the default or that set by the user. If all elements have the same phase as reference then the integral properties will also be refered to that phase, they wll represent an ``excess''. If the elements in a system have different reference phases the integral value of the state variable will normally be relative to SER because anything else would be meaningless. \hypertarget{Info dgm}{} \subsubsection{The driving force}\label{sc:dgm} Most state variables have a welldefined thermodynamic meaning but the driving force, DGM(phase), is a property related to the stability of the phase at an equilibrium. All stable phases are on a common tangent planne of chemical potentials and have DGM=0. For a metastable phase the value of the DGM variable is the distance in Gibbs energy (normallized by dividing it by the value of $RT$) between the stable tangent plane and the point on the Gibbs energy surface of the metastable phase that is closest to the tangent plane of the stable phases. DGM is negative for a metastable phase and if is close to zero it means the phase is close to become stable. The only case a phase can have positive DGM is for phases which have the dormant status and it means the phase would be stable if its status is changed to be entered. \hypertarget{Info databases}{} \subsection{Thermodynamic databases}\label{sc:databases} The use of thermodynamic software depend on assessed model parameters for phases and elements. With the OC software one can make assessments of such model parameters using experimental and theoretical data, see section~\ref{sc:assess}. However, this user guide does not describe the construction of such databases or how one can obtain them. \subsection{Model parameters} All data is organized relative to a phase and the phase is identified by a name. Each phase can have a different model for the composition dependence but the way to enter model parameters is the same for all models. However, the meaning of a model parameter will depend on the model of the phase. Many types of data can be stored as explained in the section on parameter identifiers. The parameter also has a constituent specification explained in the constituent array section and possibly a degree, the meaning of which is model dependent and a bibliographic reference. The basic syntax of a parameter is ``identifier'' ( ``phase name'' , ``constituent array'' ; ``degree'' ) ``expression'' ``bibl.ref.'' These parts are explained in more detail below. \subsubsection{Model Parameter Identifiers}\label{sc:paramid} The OC thermodynamic package can handle any phase property that depend on $T, P$ and the constitution of the phase using the models implemented. It is easy to extend the number of properties by declaring property identifiers in the source code. If the parameters should have an influence on the Gibbs energy (like the Curie temperature) or a diffusion coefficient (like the mobility) the necessary code to calculate this must be added. A list of the model parameter identifiers as shown in Table~\ref{tab:mpis} can be obtained by the command {\bf LIST MODEL-PARAM-ID} \begin{table}[!h] \caption{Current set of model parameter identifiers}\label{tab:mpis} {\small \begin{verbatim} Indx Ident T P Specification Status Note 1 G T P 0 Energy 2 TC - P 2 Combined Curie/Neel T 3 BMAG - - 1 Average Bohr magneton numb 4 CTA - P 2 Curie temperature 5 NTA - P 2 Neel temperature 6 IBM - P &; 12 Individual Bohr magneton num 7 THET - P 2 Debye or Einstein temp 8 V0 - - 1 Volume at T0, P0 9 VA T - 4 Thermal expansion 10 VB T P 0 Bulk modulus 11 VC T P 0 Alternative volume parameter 12 VS T P 0 Diffusion volume parameter 13 MQ T P &; 10 Mobility activation energy 14 MF T P &; 10 RT*ln(mobility freq.fact.) 15 MG T P &; 10 Magnetic mobility factor 16 G2 T P 0 Liquid two state parameter 17 THT2 - P 2 Smooth step function T 18 DCP2 - P 2 Smooth step function value 19 LPX T P 0 Lattice param X axis 20 LPY T P 0 Lattice param Y axis 21 LPZ T P 0 Lattice param Z axis 22 LPTH T P 0 Lattice angle TH 23 EC11 T P 0 Elastic const C11 24 EC12 T P 0 Elastic const C12 25 EC44 T P 0 Elastic const C44 26 UQT T P &; 10 UNIQUAC residual parameter 27 RHO T P 0 Electric resistivity 28 VISC T P 0 Viscosity 29 LAMB T P 0 Thermal conductivity 30 HMVA T P 0 Enthalpy of vacancy form. 31 TSCH - P 2 Schottky anomaly T 32 CSCH - P 2 Schottky anomaly Cp/R. 33 NONE T P 0 Unused \end{verbatim} } \end{table} Several of these identifiers have no supporting software implemented, this is an ongoing project. The columns T P indicate if the parameter may depend on $T$ or $P$. Some identifiers require additional specification of the constituent and sublattice, like the mobility of a constituent. Currently it is not yet clear if mobilities should depend on the sublattice or not but the notation allows that. A slightly more detailed explanation of the identifiers are: \begin{itemize} \item G, the Gibbs energy parameter for an endmember or an interaction. G(LIQUID,FE;0) is the Gibbs energy for pure liquid Fe. Note that the parameter will be used also below the melting temperature of Fe for a liquid phase containing Fe. G(LIQUID,CR,FE;0) is the regular parameter for Cr and Fe in the liquid. \item TC, a parameter for the critical temperature for ferro or antiferro magnetic ordering using the Inden model. \item BMAG, a parameter for the average Bohr magneton number using the Inden model. \item CTA, a parameter for the Curie temperature for ferromagnetic ordering using a modified Inden model. \item NTA, a parameter for the Neel temperature for antiferromagnetic ordering using a modified Inden model. \item IBM\&C, a parameter for the individual Bohr magneton number for constituent C using a modified Inden model. For example IBM\&FE(BCC,FE) is the Bohr magneton number for BCC Fe. The identifier IBM\&FE(BCC,CR) means the Bohr magneton number of a single Fe atom in BCC Cr. An identifier IBM\&FE(BCC,CR,FE) can be used to decribe the composition dependence of the Bohr magneton number for Fe in BCC. \item THET, a parameter for the Debye or Einstein temperature. \item V0, a parameter for the volume at 298.15~K and 1 bar. \item VA, a parameter for the integrated thermal expansion. \item VB, a parameter for the Bulk modulus. \item G2, a parameter for the two-state liquid model. \item LAMB, a parameter for the thermal conductivity. \item MQ\&C, a parameter for the logarithm of the frequency factor of the mobility of constituent C. \item MF\&C, a parameter for the activition energy of the mobility of constituent C. \item MG\&C, a parameter for the magnetic factor of the mobility of constituent C. \item THT2, The T for a smooth change of C$_P$ \item DCP2, The value of the smooth change in J/mol \item VISC, a parameter for the viscosity. \item LPX, a parameter the lattice parameter in X direction. \item LPY, a parameter the lattice parameter in Y direction. \item LPZ, a parameter the lattice parameter in Z direction. \item LPTH, a parameter the angle between lattice directions. \item EC11, a parameter for the elastic constant C11. \item EC12, a parameter for the elastic constant C12. \item EC44, a parameter for the elastic constant C44. \item UQT\&C, a parameter for the UNIQUAC residual energy for species C \item RHO, a parameter for the electrical resistivity. \item HMVA, a parameter for the enthalpy of vacancy formation. \item TSCH, the T for a Schottky anomaly. \item CSCH, the Schottky anomaly $\Delta C_P$. \item QCZ, the bond number in the FactSage quasichemical model. \end{itemize} The current value of any of these parameter identifiers can be obtaind by the command {\bf LIST STATE\_VARIABLE} using the identifier and appropriate phase and component specifiers, see section~\ref{sc:list_statevar}. For details of the meaning of the model identifier refer to the model documentation. As already mentioned many of the identifiers, like the mobility, does not influence the Gibbs energy but as they depend on the $T, P$ and constitution of the phase it is convenient to model them in the same way as the thermodynamic data. \subsubsection{Constituent array and degrees} A constituent array specifies one or more constituent in each sublattice. A constituent must be entered as a species with fixed stoichiometry. Between constituents in different sublattices you must give a colon, ":", between interacting constituents in the same sublattice you must give a comma, "," or a space. A constituent array with exactly one constituent in each sublattice is also called an ``endmember'' as it give the value for a ``compound'' with fixed stoichiometry. Constituent arrays with one or more interaction constituents describe the composition dependence of the property. Without such parameters the property will vary linearly between the endmembers. If there are no sublattices, like in the gas, you just give the phase and the constituent G(GAS,C1O2) If no degree is specified it is assumed to be zero. For endmembers the degree must be zero but it may sometimes be useful to specify the zero in order to distinguish the parameter from the expression for the calculated value of the property, like the chemical potential of a component. In the gas phase you normally assumes there are no interactions but it is possible to add such parameters. For an fcc phase with 4 sublattice for ordering and one for interstitials an endmember parameter is G(FCC,AL:NI:NI:NI:VA;0) This would be the Gibbs energy of an fcc AL1NI3 ordered compound. An interaction between vacancies and carbon in the austenite is G(FCC,FE:C,VA;0) For an interaction parameter you should always specify a degree but also in this case an omitted degree is interpreted as zero. \subsubsection{Ternary extrapolations}\label{sc:excessparameters} The main binary excess model implemented in OC is the symmetric binary Redlish-Kister method combined with the Muggianu ternary extrapolation. Other binary methods, such a polynomial or Legendre polynom can always be converted to a set of Redlich-Kister parameters. \begin{eqnarray*} L_{\rm A,B} = \sum_{\nu=0}^n ~^{\nu}L_{\rm A,B} (y_{\rm A} - y_{\rm B})^{\nu} \end{eqnarray*} where the degree, $\nu$, of the interaction parameter is specified after a semicolon, L(phase,A,B;$\nu$). For ternary parameters and for reciprocal parameters the Hillert model for composition dependence is implemented, see~\cite{07Luk}. You can store many different types of data in OC with different parameter identifier. Some of the parameters are not related to the thermodynamic properties but as they depend on the phase, T, P and composition it is convenient to store them together with the thermodynamic data. For example the mobility of Fe in BCC (including an empty interstitial sublattice) is specified as: MQ\&FE(BCC,FE:VA). An explanation of the identifiers implemented in OC can be found in section~\ref{sc:paramid}. The current list can be obtained by the command {\bf LIST MODEL\_PARAM\_ID}. All of them can be composition dependent. Some cannot depend on $T$ or $P$ or neither. Many kinds of the parameters are available but in some cases the software for the models to handle them are not implemented. The value of a model parameter can be obtained using {\bf LIST MODEL\_PARAM\_VAL} or simply {\bf SHOW}. You must specify phase and endmember for the parameter. From OC version 7 it will be possible to specify differnt ternary extrapolation methods for each a ternary subsystem of a phase. A ternary subsytem in a phase may be assigned a symmetric Kohler or assymetric Toop ternary method together with the Redlich-Kister binary method. See section~\ref{sc:kohler-toop2}. \subsubsection{The TPFUN expression and bibliographic reference}\label{sc:tpfun} The expression for a parameter can be a single value or a function of $T$ and $P$. It must start with a low temperature limit, usually 298.15~K and must finish with a high temperature limit. These expressions as well as their first an second derivatives will be calculated by the TP-fun package. To simplify that there is a strict syntax for the expression. A term in the expression is ``numeric value'' * ``name of TP function'' *T** ``power'' *P** ``power'' You can construct very complex expression by referring to other functions. If ``power'' is zero the corresponding *T** or *P** can be omitted. If it is negative it must be surrounded by parenthesis like (-1). If it is unity the **1 can be skipped. Several terms, seperated by signs, forms an expression and it must be terminated by a semicolon, ``;''. After the semicolon there must be a high temperature limit or a breakpoint in temperature. A breakpoint must be followed by the letter ``Y'' and then a new expression for temperatures above the breakpoint. {\bf It is the responsability of the database manager to ensure the expression is continuous at the breakpoint. If there are jumps in the value at a breakpoint strange things will happen when calculating equilibria.} After the high temperature limit the letter ``N'' must be given followed by a bibliographic reference for the parameter. Use the commands AMEND or ENTER BIBLIOGRAPHIC to give the reference. {\bf The database manager should always add a bibliographic reference even if it is just his or her name and a date. This avoids people to mistake a value inspired by your experience for a carefully validated parameter.} A term can be used inside a natural logarithm, LN, or exponential, EXP. And the LN or EXP can be multiplied with a term. On the other hand you are not allowed to have any parenthesis, except around powers or arguments to LN and EXP. A valid expression is \begin{verbatim} 298.15 -8856.94+157.48*T-26.908*T*LN(T)+.00189435*T**2 -1.47721E-06*T**3+139250*T**(-1); 2180 Y -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6000 N 91Din \end{verbatim} where 91Din is the bibliographic reference to the SGTE unary database. \subsection{The reference state of a component}\label{sc:refstate} The values of most thermodynamic data must have a defined reference state. By default the reference state for the components is SER (Stable Element Reference) which is the stable state of the element at 298.15~K and 1~bar. (NOTE: the default reference state is defined by the database but today almost all databases have SER as reference state.) For each component (also for other components than the elements) you can specify a phase at a given temperature and pressure as reference state, see section~\ref{sc:setref}. The phase must exist for the component as pure. A state variable like the chemical potential, MU(O), will refer to the user defined reference state if set. To obtain the value for the SER state you can use a suffix S, i.e. MUS(O) to obtain the chemical potential refered to SER. All state variables are listed in Table~\ref{tab:statev}. Note that the value of integral properties like Gibbs energy, $G$, enthalpy, $H$, etc. may have mixed reference states unless all components have the same phase as reference state. In order to have the enthalpy of mixing of a phase all components must have that phase as reference state. For the volume, $V$, SER is always used as reference state unless all components have the same reference state. \hypertarget{Info equilibrium}{} \subsection{Equilibrium calculations} The basic application of OC is to calculate the equilibrium of a system as described in section~\ref{sc:calceq}. The user can specifying the external conditions like $T, P$ and the composition, see section~\ref{sc:calceq}.. The minimizing algorithm~\cite{15Sun2} use Lagrangian multiplier so many different sets of state variables can be used for specifying the external conditions. Each condition is set separately and it is possible to extract phase amounts and compositions after the calculation. By changing the status of the phases it is possible to calculate metastable state. In order to do any calculation the user must provide a database with the model parameters for his system or enter these manually. The conditions can also be set using the command {\em set\_input\_amount}, see section~\ref{sc:setinpuam}. \hypertarget{Info propertydiagram}{} \subsection{Property diagrams} A property diagram is calculate with the STEP command. First you must set conditions to calculate a single equilibrium and then set set one of the conditions as an axis. After the STEP command, see section~\ref{sc:step} you can plot how any state variable varies with the selected axis variable. See the section~\ref{sc:plot} and the OC macros guide. \hypertarget{Info phasediagram}{} \subsection{Phase diagrams} A phase diagram show the regions of different sets of stable phases in a system. It can have two or more axis variables, in OC the maximum number of axis is two at present. As for property diagrams you must first calculate a single equilibrium and then select two conditions as axis variables. The command MAP, see section~\ref{sc:map}, will then trace the lines in your systems where the set of stable phases changes. There is no limit on the number of components for a phase diagram calculation. After calculating a diagram you can plot it with many different types of axis, see section~\ref{sc:plot} and the OC macros guide. \subsection{Diagrams simulating phase transformations} Thermodynamics is essential to simulate phase transformations but requires good understanding also of the kinetics such as diffusion and kinetcs. For such applications OC has an Appication Software Interface (OCASI) with subroutines to calculate local driving forces and chemical potentials in various parts of a sample as described in~\cite{16Sun,20Her}. However, there are a few cases when one can simplify the kinetics sufficently to use the facilities of OC directly. \subsubsection{Scheil-Gulliver solidification model}\label{sc:scheil1} In a Scheil-Gulliver solidification simulation the diffusion in the solid phases are ignored and the liquid is considered as homogeneous. That is a realistic model for the interdendric reqion during a normal solidification. It can be calculated with a STEP calculation by using small time steps and modify the overall composition to be that of the liquid after each step. The solid formed is removed from the system. In such a simulation the liquid will be stable until it reaches an invariant equilibrium, usually very far from its initital composition, see section~\ref{sc:scheil2}. \subsubsection{Paraequilibrium calculation}\label{sc:paraeq1} In some alloys, most particularly in steels, there are fast diffusing elements such as C or N which can maintain a constant chemical potential during the whole transformation, and thus change their composition in different phases. The other alloying elements may transform to a new phase without changing their fractions. This can be modelled as a paraequilibrium or a ``No Partitioning Local Equilibrium'' (NPLE) situation and it requires no kinetic data. In OC the CALCUALATE or STEP PARAEQUILIBRIUM simulates such a transformation, see sections~\ref{sc:paraeq2}, \ref{sc:paraeq3}. \subsubsection{Tzero calculation}\label{sc:tzero1} The $T_0$ point, line or rather ``hypersurface'' between two phases are defined by $T$ where the Gibbs energy of the two phases are the same. Such a point is the limit of a diffusionless transformation of one phase to the other and it is useful to understand for example the martensite transformation. How to calculate the ``Tzero'' point or line are explaned in sections~\ref{sc:tzero2} and \ref{sc:tzero3}. \subsection{Assessment of model parameters for databases} One of the important uses of the OC software is to assess model parameters in the phases of a system using experimental and theoretical data. This is done by recalculating the experimental data from the model and by varying the model parameters a least square routine, LMDIF developed at Argonne National Lab in 1981, is used to find the best set. Assessments are a very difficult procedure as you must also take into account the extrapolations of the model outside the range of experimental data. So called ``First Principles Calculations'' or the somewhat simpler ``Density Functional Theory'' (DFT) which are based on the electronic structure of the elements can provide information for metastable as well as for the stable state. But you must be careful that the result from such calculations does not represent a mechanically unstable state with imaginary phonon frequencies. Experimental data can be direct measurements of thermodynamic data like enthalpies, chemical potentials, heat capacities, activities, etc but very important are also measurements of phase diagrams, solubilities etc because they are also related to the equilibrium state. There are several commands related to the assessment procedure in OC but during the assessment you will also use the basic facilities to calculate equilibria for different kinds of conditions as well as many different kinds of diagrams to verify the results. \subsubsection{Entering coefficients to be assessed} The command ``enter optimizing coefficients'', see section~\ref{sc:optcoeff} creates symbols A00 up to A99 that can be used as coefficients in the thermodynamic model parameters. Maximum number of coefficients are 100. \subsubsection{Entering phases and model parameters} The elements, species and phases with their appropriate models are entered using the appropriate commands. Normally this is on a macro file in order to have proper documentation. Keep also in mind that an assessment is often revised after a few years when new data become available or you find that the extrapolations of an assessment to a higher order system is not reasonable. The model parameters are entered using ``enter parameter'', see section~\ref{sc:enterparam} or ``enter tpfun'', see section~\ref{sc:entertpf} as many parameters may share some properties and a TP-function can be used in several parameters. The optimizing coefficents A00 to A99 with different T and P dependence can be used instead of numerical values as their values should be assessed. \subsubsection{Entering experimental data} This is done either by entering single equlibria with conditions and in addition using the command ``enter experiment'', see section~\ref{sc:enterexp} where the experimental data is given with an uncertainty. Each equilibrium with an experiment is given a unique name. Often there are tables with values and instead of entering each of them there is a command ``enter many\_equilibria'', see section~\ref{sc:entermany} with a simplified syntax. When all equilibria with experiental data has been entered you have to give the command ``set range'', see section~\ref{sc:setrange} to give the first and last equilibrium number that should be used in the assessment. If necessary this range can be extended during the assessment. All the experimental data should also be entered as a mcro file to keep a documentation. \subsubsection{Saving the state of the assessment} Any time during an assessment it is possible to save the values of all assessed parameters and the calculated experimental equilibria by the command ``save unform {\em filename}'', see section~\ref{sc:saveunf}. With this command the data inside OC will be written as an unformatted Fortran file and this can be saved and later read back into the OC software by the command ``read unfomatted {\em filename}'', see section~\ref{sc:readunf}. If these commands are inside a macro file prefix the filename with ``./'' to read and write on the same directory as the macro file. These unformatted files are very convenient but beware that they may not be portable to other operating systems or even other versions of OC compiled with different Fortran compilers. It may change in future releases of the OC software. Thus keep printouts and macro files also if you later want to make modifications. \subsubsection{Performing the assessment}\label{sc:assess} There are many decisions to make during the assessment and a general description how to perform an assessment can be found in the book by Lukas et al~\cite{07Luk}. It is never possible to try to assess all parameters using all experiments in a single step. Normally the user selects different sets of experimental data by the ``set weight'' command, see section~\ref{sc:setw} and fits a few model parameters to these using the command ``set variable-coeff'', see section~\ref{sc:setvar}. This can typically an enthalpy of mixing or a heat capacity function for a compound. The command to run the least square fit is ``optimize'' followed by the maximum number of iterations, see section~\ref{sc:optim}. If zero is given a single loop is made through all equilibria with nonzero weights within the specified range is made. It is also possible to use the command ``calculate all'', see section~\ref{sc:calcall}, to calculate all non-zero weight equilibria. With the latter command you can turn on the grid minimizer, in the optimize command the grid minimizer is always turned off. When the optimize command is given with nonzero maximum there will be output on the screen at regular intervals giving the current values of the optimizing coefficients and the value of the sum of squares. When the oprimization is finished there will also be a listing of the errors for all experiments. With the command ``list opt short'', see section~\ref{sc:listoptshort}, the current values of the optimizing coefficients and all equiliria with the experimental data is listed together with the sum of squares. New selection of equilibria or weights can be made and the values obtained for the optimizing coefficients must also be reasonable but to know what is reasonable is not always easy. These steps are repeated until the user is satisfied or exhausted. Macro files to calculate and plot of the calculated properties overlayed with the experimental data should be preoared and run regularly as just looking at numbers is not sufficient. At a later stage solubilities and phase diagram data are used but in many cases reasonable guesses of the start values of model parameters must be made to be able to calculate the equilibrium with the experiment. Great care must be taken that the calculated equilibria for the inital model parameters are reasonably close to the experimental. Parts of the experimental phase diagram may have to be assessed separately and the metastable extrapolations of the different phases checked. Sometimes a phase appears in a region where it should not be stable and additional fictitious experimental data may have to be added to prevent this to happen. At the end the assessment should be written up and published. \subsection{Application software} There is a separate guide for using OpenCalphad Application Interface (OCASI) in application software. For such cases it is convenient to have the source code which can be compiled together with the applications software. A special feature is also the possibility to use OpenMP to calculate in parallel. \newpage % below the commands are documented in alphabetical order \hypertarget{All commands}{} \section{The command menu} The commands in alphabetical order as listed with the ?. The commands with an * has subcommands. % NOTE the ~ used for the long commands needed for the HTML output \begin{tabular}{llll} ABOUT & EXIT & MAP & SELECT * \\ AMEND * & FIN & NEW & SET * \\ BACK & HELP & OPTIMIZE~ & SHOW \\ CALCULATE *~ & HPCALC & PLOT * & STEP * \\ DEBUG * & INFORMATION *~ & QUIT \\ DELETE * & LIST * & READ * \\ ENTER * & MACRO & SAVE *\\ \end{tabular} Many of the commands have ``subcommands'' and usually OC will provide a default answer (listed within slashes /default/) which is selected by pressing return. You can type commands, subcommands and other parameters (separated by a space) on the same line if you know the order. To select a default when typing several commands and answers to questions (command arguments) on the same line, you can use a comma,``,'' to select the default answer. For example ``l,,,,'' will list on the screen with the current list options. Many commands will ask additional questions, all of them are not included in this guide but those which are will be {\bf shown in bold}. Examples and references to other commands are sometimes in {\bf bold}, sometimes in {\em italics}. Whenever the program asks a question you do not understand you can type a question mark, ``?'', to obtain help. If the online help system is correctly installed, see section~\ref{sc:on-line-help}, this will open a browser window with this manual and hopefully position the manual at the relevant part. You can browse the whole manual in this window if you need additional help. \hypertarget{Command options}{} \subsection{Options}\label{sc:options} There are some options that can be set for the whole session or for just a single command. The options are identified by a / in front like /output=myfile.dat. An option must be specified directly after a command for example: {\bf list /out=equil5 result 2} Only a few options are implemented. \begin{itemize} \item /OUTPUT={\em file name} open a file and write on it. Note that if you have popup windows enabled this will open unless you type the file name (with path) on the same line as the command. In a macro file must prefix the file name with ``./'' to have the output (or append) on the same directory as the macro file. See also section~\ref{sc:popup} and \ref{sc:macro}. \item /APPEND={\em file name} append output to a file, any previous content is kept. \item /ALL apply for all. \item /FORCE override normal restrictions. \item /VERBOSE write information while executing. \item /SILENT do not write anything except fatal error messages. \end{itemize} %=================================================================== % The online help will not print lines starting with % or \ \hypertarget{About}{} \section{About} This is OpenCalphad (OC), a free software for thermodynamic calculations as described in B Sundman, U R Kattner, M Palumbo and S G Fries, Integrating Materials and Manuf. Innov. (2015) 4:1; B Sundman, X-G Lu and H Ohtani, Comp Mat Sci, Vol 101 (2015) 127-137 and B Sundman et al., Comp Mat Sci, Vol 125 (2016) 188-196 It is available for download at http://www.opencalphad.org or the sundmanbo/opencalphad repository at http://www.github.com This software is protected by the GNU General Public License You may freely distribute copies as long as you also provide the source code and use the GNU GPL license also for your own additions and modifications. The software is provided "as is" without any warranty of any kind, either expressed or implied. The full license text is provided with the software or can be obtained from the Free Software Foundation http://www.fsf.org Copyright 2011-2021, Bo Sundman, Gif sur Yvette, France. Contact person Bo Sundman, bo.sundman@gmail.com %=================================================================== \hypertarget{Amend}{} \section{Amend} Intended to allow changes of already entered data. Only some of the subcommands are implemented. \begin{tabular}{llll} ASSESSMENT\_RESLT~ & ELEMENT & OPTIMIZING-COEFS~ & REDUNDANT\_SETS \\ BIBLIOGRAPHY~ & EQUILBRIUM~ & PARAMETER~ & SPECIES\\ COMPONENTS & GENERAL & PHASE * & SYMBOL \\ CONSTITUTION~ & LINES & QUIT & TPFUN-SYMBOL\\ \end{tabular} The default selection is PHASE. %-------------------------------- \hypertarget{Amend assess result}{} \subsection{Amend assessment result} After assessing a set of parameters for a system each of these has a Relative Standard Deviation (RSD) listed in the result. Using this RSD it is possible to modify one parameter and recalculate how much all the other parameters should change due to this modification without rerunning the actual assessment. This command allows to calculate such a change and it can be tested be reassessing the parameters using the experiments. %-------------------------------- \hypertarget{Amend bibliography}{} \subsection{{\em amend} Bibliography} {\bf Reference identifier:} The text for bibliographic reference identifier can be amended. The reference identifier is CASE INsensitive. {\bf Reference text, end with ``;'':} The text for this reference will be set to the text supplied. It can be several lines terminated with a ``;'' %-------------------------------- \hypertarget{Amend components}{} \subsection{{\em amend} Components}\label{sc:amendcomp} {\bf Give all new components:} By default the elements are the components. This command can set any orthogonal set of species as components. The number of components cannot be changed by this command. The new components must exist as species and be orthogonal. For example in the system Ca-O-Si one can define CaO SiO2 and O as components. The components are important as you can only use components to specify compositions, such as x(cao)=.3 is possibly only if CaO is a component. See also {\bf set input-amount}~\ref{sc:setinpuam}. Note that when you have other components than the elements you may have negative mole fractions and phase amounts (but never negative mass). %-------------------------------- \hypertarget{Amend constitution}{} \subsection{{\em amend} Constitution} % There will be several questions ``Phase name:'' in various part of the % software, the initial ``Amend const'' here is to locate THIS question \hypertarget{Amend const phase name}{{\bf Phase name:}} The program will ask for a phase name and you can set the amount and constitution of the phase. This will be used as initial constitution for a calculation unless the grid minimizer is used. \hypertarget{Amend const amount}{{\bf Amount of phase:}} % This command should be moved to AMEND PHASE ... {\bf Current (Y), default (D) or new (N) constitution:} Answer Y to keep current constituion, D to set a default constitution (if you have set such a constitution) or N to provide a new constitution. {\bf Fraction of component: } You can specify a value between 0.0 and 1.0. The sum of all constituents must be unity, values below 0.0 or 1.0 are not allowed. If you want the fraction of a constituent the be 1.0-(all the other fractions) you can set its value to REST. Otherwise the last constituent is set to the ``rest''. %-------------------------------- \hypertarget{Amend element}{} \subsection{{\em amend} Element} The data for the element can be amended, not implemented yet. %-------------------------------- \hypertarget{Amend equilibrium}{} \subsection{{\em amend} Equilirium} Not sure what could be amended and anyway not implemented. %-------------------------------- \hypertarget{Amend general}{} \subsection{{\em amend} General} A number of general settings can be amended by the user: \begin{itemize} \item The name of the system. \item The level of the user (beginner, frequent user, expert). This may affect the behavior of the program (not implemented yet). \item If global minimization is allowed or not. \item If the grid minimizer is allowed to merge gridpoints in the same phase after global minimization. \item If the grid minimizer can automatic create composition sets is allowed or not. \item If redundant composition sets can be deleted automatically after an equilibrium calculaion. \end{itemize} Note that these and some other general feautures can also be changed by the command {\bf SET BIT GLOBAL} %-------------------------------- \hypertarget{Amend line}{} \subsection{{\em amend} Line} After a STEP or MAP command it is possible to give the command LIST LINE to list all calculated equilibria or AMEND LINE which allows you to EXCLUDE lines or INCLUDE lines from the plotting. {\bf Only excluded? /Y/:} Sometimes a line may be excluded from plotting if there was an error while it was calculated. Answering Y will make it possble to restore such a line and also lines you have previously excluded. {\bf Exclude this line? /N/:} For an included line you can exclude from the plot. {\bf Include this line? /N/:} For an excluded lines you can include it in the plot. %-------------------------------- \hypertarget{Amend optim coeffs}{} \subsection{{\em amend} All optimizing coefficients} The values of each optimizing coefficients, see section~\ref{sc:setrange} can be rescaled (start values set to current values) or recovered (current values set to previous start values). %-------------------------------- \hypertarget{Amend parameter}{} \subsection{{\em amend} Parameter} The possible parameters that can be amended depend on the model of the phase. By specifying a parameter you can change its expression. This is not yet implemented you must use the command {\bf ENTER PARAMETER} to change the parameter expression. %-------------------------------- % we need to add these for the seach on the help file ... suck \hypertarget{Amend for phase}{} \hypertarget{Amend phase}{} \subsection{{\em amend} for Phase ``phase-name''}\label{sc:amendph} You must first specify the phase name and then you can amend some of the properties of the phase: If you want to amend something for a composition set you must specify the composition set number together with the phase name after a hash character (\#) (like liquid\#2). {\bf Phase name:} You must specify the name of the phase you want to amend. {\small \begin{tabular}{llll} ADDITION * & DEFAULT-CONSTIT & FCC-PERMUTATIONS~ & TERNARY-EXTRAPOL\\ AQUEUS-MODEL & DIFFUSION & QUASICHEM-MODEL~ & UNIQUAC-MODEL \\ BCC-PERMUTATIONS~ & DISORDERED-FRACS & QUIT \\ COMPOSITION-SET & FCC-CVM-TETRAHDR~ & REMOVE-COMPSETS\\ \end{tabular} } %-------------------------------- \hypertarget{Amend addition}{} \subsubsection{{\em amend} phase ``phase-name'' Addition } Additions are used to give a contribution to the Gibbs energy of a phase using more or less physically based model. Usually they require additional model parameters, see section~ref{sc:paramid}. The difference between addition and other things that can be amended may not always be very clear. The possible additions are {\small \begin{tabular}{llll} ELASTIC-MODEL-1~ & MAGNETIC-CONTRIB~ & SMOOTH-CP-STEP \\ GADDITION & QUIT & TWOSTATE-LIQUID\\ LOWT-CP-MODEL & SCHOTTKY-ANOMALY~ & VOLUME-MODEL1\\ \end{tabular} } BEWHERE! The OC software allows you to mix many types of additions for a phase but it is up to YOU as user to defend the physical reasons for this! \hypertarget{Add per formula unit}{{\bf Per formula unit?}} The theoretical equation for most additions usually gives the value per mole of atoms. As the Gibbs energy is calculated per mole formula unit of the phase in OC (as well as most thermodynamic software) the addition must be multiplied with the number of atoms per formula unit of the phase. Some of the additions, for example mobilities, are for properties that does not contribute to the thermodynamics but which depend on the phase, $T, P$ and phase constitution in the same way as the Gibbs energy and it is thus convenient to model and store the data together with the thermodynamic data. %. . . . . . . . . . . . \hypertarget{Amend elastic-model-1}{} \subsubsubsection{{\em amend phase ... addition} Elastic\_model\_1} A contribution to the Gibbs energy due to elastic strain can be added. This also requires values of the elastic constants and lattice parameters, see section~\ref{sc:paramid}. There is no code to calculate the elastic energy implemented yet. %......................... \hypertarget{Amend Gaddition}{} \subsubsection{{\em amend phase} ... Gaddition} You can add a constant value of the Gibbs energy to a phase in Joule per formula unit. This is a crude but simple way to implement a for example a nucleation barrier. {\bf Addition to G in J/FU (formula units)/0/:} %. . . . . . . . . . . . \hypertarget{Amend lowt-Cp-model}{} \subsubsubsection{{\em amend phase ... addition} LowT\_Cp\_model} The Einstein model for heat capacities from 0~K has been implemented. It requires a value of the property Einstein T as listed in section~\ref{sc:paramid}. %. . . . . . . . . . . . \hypertarget{Amend magnetism}{} \subsubsubsection{{\em amend phase ... addition} Magnetic\_contrib} The Inden-Hillert and the modified Inden-Qing-Xiong model for the magnetic contribution to the Gibbs energy can be set by this command This depends on model parameters describing the Curie and Neel temperatures and the Bohr magneton number, as listed in model parameters identifiers~\ref{sc:paramid}, for the phase. You also must also enter model parameters for the constituents of the phase, see the documentation of the model or Lukas~\cite{07Luk}. {\bf Antiferromagnetic factor:} The Qing-Xiong model is selected by giving zero (0) for the question about the anti-ferromagnetic factor. For the original Inden-Hillert model -3 is used for FCC and HCP whereas -1 is used for BCC. The Inden-Hillert model is described in Lukas et al~\cite{07Luk}. The Inden-Qing-Xiong modified model requires separate values of the Curie and Neel Temperatures and either an ``effective'' Bohr magneton number or individual Bohr magneton numbers for the constituents of the phase. %. . . . . . . . . . . . \hypertarget{Amend addition quit}{} \subsubsubsection{{\em amend phase ... addition} Quit} You did not really wanted to add any addition. %. . . . . . . . . . . . \hypertarget{Amend Schottky-anomaly}{} \subsubsubsection{{\em amend phase ... addition} Schottky\_anomaly} Some physical phenomena can create a ``bump'' in the heat capacity for a phase at a certain $T$ and this addition can describe this. It uses two model parameter identifiers, TSCH and CSCH that may depend on the composition. TSCH specify the T for the anomaly and CSCH the maximum contribution to the heat capacity (J/mol/formula unit) divided by $R$, i.e. as a factor of the gas constant, $R$. %. . . . . . . . . . . . \hypertarget{Amend smooth-Cp-step}{} \subsubsubsection{{\em amend phase ... addition} Smooth-Cp-step} The 3rd generation thermodynamic databases extrapolate to 0~K and require that the heat capacity is zero at 0~K. This means it is impossible to use $T*\ln(T)$ terms (and also negative powers of $T^{-n}$) but there may be some physical phenomena that causes an incremental increase of the heat capacity at some temperature. Ignoring the physical reason for such an increase this ``smooth\_$C_P$\_step'' addition will provide such this using two parameters, THT2 to specify $T$ and DCP2 to specify the increement in heat capacity. DCP2 is a factor of $R$. It uses the same mathematical expression as the Einstein heat capacity function but has no enthalpy contribution. %. . . . . . . . . . . . \hypertarget{Amend twostate liquid}{} \subsubsubsection{{\em amend phase ... addition} Twostate-liquid} The two-state model for the hear capacity for the undercooled liquids can be added. It assumes a low T amorphous state modeled as an Einstein solid and requires an Einstein T. For the liquid transition it uses the model\_parameter\_ident {bf G2}, both of which are listed in section~\ref{sc:paramid}. {\bf Is G2 composition dependent? /Y/:} G2 parameters are usually evaluated for thr pure elemenents. Using interaction parameters for the G2 parameter may create unexpected phenomena. You must specify parameters for THET and G2 for all constituents of the phase and possibly also interaction parameters to specify the composition dependence. The implementation of this addition is not finished. %--------------------------------- end of amend phase ... addition \hypertarget{Addition aqueus-model}{} \subsubsection{{\em amend phase} ... Aqueous-model} A model with dilute configurational entropy. Not implemented yet. %......................... \hypertarget{Amend BCC-permutations}{} \subsubsection{{\em amend phase} ... BCC-permutations} This is intended for the 4 sublattice CEF model for BCC ordering. Due to crystallographic symmetry several model parameters must be identical such as G(BCC,AL:FE:FE:FE)=G(BCC,FE:AL:FE:FE)=G(BCC,FE:FE:AL:FE)=G(BCC,FE:FE:FE:AL) and this command means these parameters need to be entered only once. This affects the data storage and the calculation of the Gibbs energy is slightly more efficient. The same applies for the FCC\_permutations but the BCC tetrahedron is asymmetric which makes it a bit more complicated than the FCC. There can be a 5th sublattice with interstitials. %......................... \hypertarget{Add new cs}{} \subsubsection{{\em amend phase} ... Composition set}\label{sc:amend_phase_cs} Each phase has by default a single composition set. If the same phase can exist as stable (or metastable) with two or more compositions (miscibility gaps or order/disorder transformations) you may have to amend the phase by creating additional composition sets. Composition sets can also be created automatically by the grid minimizer during an equilibrium calculation. In such a case the composition set will have the suffix \_AUTO, Composition sets of a phase can be created and deleted. Phases with miscibility gaps or which can exist with different chemical ordering like A2 and B2 must be treated as different composition sets. You can specify a prefix and suffix for the composition set. Extra composition sets will always have a suffix \#digit where digit is a number between 2 and 9. You cannot have more than 9 composition sets. The composition set number is given after the phase name and preceeded by a hash character \#. In the OCASI interface and some more cases phase tuples are used to identify a phase and a composition set by a single number. As composition sets can be created and deleted a phase tuple index for the 2nd or higher composition set may change between calculations. In some cases it may be interesting to calculate metastable states inside miscibility gaps and you can prevent the automatic creation of composition sets by turning off the global minimazation using {\bf AMEND GENERAL} or for an individual phase by {\bf SET PHASE ... BIT NO\_AUTO\_COMP\_SET} %......................... \hypertarget{Amend phase default constit}{} \subsubsection{{\em amend phase} ... Default Constitution} The default constitution of a phase can be set. Unless the grid minimizer is used this will be used for the first calculation with the phase and sometimes if there are convergence problems. NOTE that if you want to specify a default constitution for the second or higher composition set of a phase you must specify the composition set with the phase name! Depending on the minimizing software used the initial constitution can be important to find the correct equilibrium if the phase has ordering or a miscibility gap. For each constituent you can specify a minimum $>$ or maximum $<$ fraction or give NONE if there are no default. If a phase has miscibility gaps and you have created composition sets with default constitutions the grid minimizer will try to select the composition set with a composition closest to the default for a stable phase. To temporarily set a new constitution of a phase use the command {\bf AMEND CONSTITUTION} $<$phase$>$ or {\bf CALCULATE PHASE ... }. %......................... % UNFINISHED \hypertarget{Add diffusion}{} \subsubsection{{\em amend phase} ... Diffusion} This is to specify how the diffusion coefficient matrix should be calculated when simulating a phase transformation. Normally the mobilities for the constituents of the phase are read from the database but you may use different ``depended'' and ``independent'' constituents in the diffusion model and also some other factors. This command is intended for such use. It is not implemeted yet. There is no intention that OC itself should simulate diffusion but as the diffusion coefficents are strongly dependent on the thermodynamic factor (the Darken stability matrix) which represent the second derivatives of the Gibbs energy it is convenient to include some properties used in a simulation in the thermodynamic software. %......................... \hypertarget{Amend phase disordfrac}{} \subsubsection{{\em amend phase} ... Disordered fraction sets} For phases with several sublattices the Gibbs energy of the phase can be divided into two sets of fractions where the second or ``disordered'' set have only one or two sublattices and the fractions on these represent the sum of fraction on some or all of the first or ``ordered'' set of sublattices. There are two different ways to handle the disordered fraction set depending on the fact if the phase can be totally disordered. The latter is the case for phases like B2, L1$_2$ etc which can be totally disordered as BCC/A2 or FCC/A1. The calculation of the Gibbs energy in the latter cas will subracted the contribution from the ordered part when the phase is disordered, see for example Lukas et al~\cite{07Luk}. This is particularly important to model the Gibbs energy for phases with ordering like FCC, BCC and HCP and for intermediate phases like SIGMA, MU etc. %......................... % UNFINISHED no question? \hypertarget{Amend FCC-CVM-tetradrn}{} \subsubsection{{\em amend phase} ... FCC\_CVM\_tetradrn} This model is intended for the CVM tetrahedron model for FCC and HCP. Not implemented yet. %......................... \hypertarget{Amend FCC-permutations}{} \subsubsection{{\em amend phase} ... FCC\_permutations} This is intended for the 4 sublattice CEF model for FCC ordering. Due to crystallographic symmetry several model parameters must be identical such as G(FCC,AL:FE:FE:FE)=G(FCC,FE:AL:FE:FE)=G(FCC,FE:FE:AL:FE)=G(FCC,FE:FE:FE:AL) Setting this means that unique model parameters need to be entered only once, the software will take care of all permutations. HCP permutations are also handled with this command as the HCP tetrahedron model is identical to the FCC. There can be a 5th interstitial sublattice. %......................... \hypertarget{Amend quasichemical}{} \subsubsection{{\em amend phase} ... Quasichemical} There are several quasichemical models for the liquid that only describes the short range ordering (SRO). None of them are yet implemented. %......................... \hypertarget{Amend phase ... quit}{} \subsubsection{{\em amend phase} ... Quit} Do not amend anything for the phase. %......................... \hypertarget{Amend phase ternary extrapol}{} \subsubsection{{\em amend phase} ... ternary-extrapolation}\label{sc:kohler-toop2} The default ternary extrapolation is the symmetric Muggianu method which uses the binary excess Gibbs energy closeset to the overall composition, see section~\ref{sc:excessparameters}. However, there is also a symmetric Kohler method and an ansymmetric Toop method which can be defined separately for each ternary. For this you must specity {\bf Ternary extrapolation (K, T or Q to quit)} If you specify T for Toop you must specify the Toop constituent, othewise just any of the three constituents as the {\bf first constituent}. After that you will be asked for {\bf Second constituent:} and\\ {\bf Third constituent} For each ternary subsytem in the phase this can be specified. Those not specified will use a Muggianu method, see section~\ref{sc:excessparameters}. %......................... \hypertarget{Amend phase UNIQUAC}{} \subsubsection{{\em amend phase} ... UNIQUAC} The UNIQUAC model for polymers has been implemented and there is a macro ``uniquac'' showing how it can be used. %-------------------------------- end of amend phase \hypertarget{Amend quit}{} \subsection{{\em amend} Quit} Do not amend anything (more). %-------------------------------- \hypertarget{Amend redundant-sets}{} \subsection{{\em amend} redundant-sets} Sometimes a large number of composition sets are created for certain phases and they may create trouble at later calculations. This command will set all metastable composition sets as dormant which may simplify convergence. A dormant compositon set may be set stable by the gridminimizer. It is also possible to delete composition sets but that is fragile and they may anyway be created again by the grid minimizer. %-------------------------------- \hypertarget{Amend species}{} \subsection{{\em amend} for Species} This is implemented for UNIQUAC species which has a specific volume and area used in the configurational entropy. {\bf UNIQUAC surface area (q) /1/:} {\bf UNIQUAC segments (r) /1/:} These two parameters are necessary to calculate the configurational entropy of the UNIQUAC model. %-------------------------------- \hypertarget{Amend symbol}{} \subsection{{\em amend} Symbol}\label{sc:amendsym} For a symbol that is a constant this command means changing the value of symbol. For some other symbols it is very special. It is intended for use in assessments to specify that a particular symbol must not be evaluated except when specified explicity, or when calculating a specific equilibrium. The main problem is that a symbol can have an expression using another symbols and thus all symbols are normally evaluated whenever the value of a specific symbol is requested. This is to ensure that all symbol values are consistent and refer to the same calculated equilibrium. But in certain cases you may want to enter a symbol that is only evaluted when referenced explicity or at a specific equilibrium and this can be set with this command. Symbols representing ``dot derivatives'', for example ``H.T'' for the heat capacity are automatically set to be evaluated only when referenced explicitly. For all other symbols except constants OC will ask: {\bf You can specify:\\ V for a symbol evaluated only when referenced explicitly\\ X for a symbol to be evaluated at a particular equilibrium\\ Please specify V or X /X/:} When you want to compare the value of a thermodynamic property, like the enthalpy, in two equilibria you must be able to store the calculated enthalpy from one equilibrium in a symbol. For example if you have experimental data on the heat difference for a compound at various $T$. In such a case the enthalpy at the reference $T$ can be stored in a symbol, which has been amended with this command to specify at which equilibrium it should be evaluated. In all other equilibria the value of this symbol will have the value at the specified equilibrium. See also the documentation on the assessment procedure, section~\ref{sc:assess}. If you specify X you will be asked {\bf Specify equilibrium number:} %-------------------------------- \hypertarget{Amend TPfun}{} \subsection{{\em amend} Tpfunction} You can replace a TP function with a new expression. If it is a constant you can give a new value. %ALERT: Check that this forces new calculation of all TP functions. %=================================================================== \hypertarget{Back}{} \section{Back } Return back from the command monitor to the application program. In the OC software itself it means terminate the program. %=================================================================== % Two calculate needed for help at command level ?? \hypertarget{Calculate}{} \section{Calculate } Many different things can be calculated. The normal thing to calculate is {\bf equilibrium}, the other things are special. {\small \begin{tabular}{llll} ALL-EQUILIBRIA~ & GLOBAL-GRIDMIN~ & PHASE * & TRANSITION \\ BOSSES\_METHOD & NO-GLOBAL~ & QUIT & TZERO-POINT \\ CAREFULLY & ONLY\_GRIDMIN & SYMBOL & WITH-CHECK-AFTER\\ EQUILIBRIUM & PARAEQUILIBRIUM~ & TPFUN-SYMBOLS~ \\ \end{tabular} } %-------------------------------- \hypertarget{Calculate all}{} \subsection{{\em calculate} All equilibria}\label{sc:calcall} Intended for the assessment procedure. Calculates all equilibria with non-zero weight as set by the command {\bf SET RANGE}. It can also be used for other purposes, for example testing the parallelization. The equilibria can be entered by the command {\bf ENTER MANY\_EQUILIB}. This command can be looped to measure calculation times. %-------------------------------- \hypertarget{Calculate Bosses-method}{} \hypertarget{Calculate carefully}{} \subsection{{\em calculate} Bosses-method or Carefully}\label{sc:calcbosse}\label{sc:calccare} These two ways provide a fairly similar way to handle cases when there are convergence problems, in particulat for multicomponent systems. They require that the conditions are $T, P$ and mass balance so the grid minimizer can be used. The difference is that after the gridminimizer has founc a set of stable phases all other phases are set as suspended and the iterative calculation will just use those phases selected by the gridminimizer, this should normally be successful. Afterwards all suspended phases are set as dormant and a new iterative calculation is made. If no dormant phase has a positive driving force all phases are set as entered and the equilibrium has been calculated. If one or more dormant phases have a positive driving force these are set as entered one by one followed by an iterative calculation. Normally this will finish when all dormant phases have negative driving force and the equilibrium has been calculated. If it fails it may anyway be possible to identify the phases causing the convergence problems and maybe check its parameters. %-------------------------------- \hypertarget{Calculate equilibrium}{} \subsection{{\em calculate} Equilibrium}\label{sc:calceq} The normal command to calculate the equilibrium of a system for the current set of conditions and phase status. You can calculate a metastable equilibrium if some phases that should be stable have been set dormant or suspended or if automatic creation of composition sets is not allowed. If the conditions allow, the grid minimizer will be used to find start values unless the grid minimizer is explicitly turned of. Before this command you must have entered thermodynamic data from a database or interactivly and used the command {\bf set condition}, section~\ref{sc:setcond}, to set as many conditions as you have components plus two. The commands {\bf set status phase}, section~\ref{sc:set-status-phase}, and {\bf set input-amount}, section~\ref{sc:setinpuam} can also be used to set conditions. For the first equilibrium calculation it is recommended to set conditions on $T, P$ and the overall composition. Those conditions allow the grid minimizer to be used to find the best set of stable phases and their constitutions that should give the global minimum. However, the density of the grid may in some cases have to be increased to ensure that. For later equilibria you can use a very flexible set of conditions, see section~\ref{sc:setcond} and the gridminimizer may not be able to use the grid minimizer. In such a case OC will use the current set of stable phases and their constitution as start values. If you want to check that such a calculation is the global you can use the command {\em calculate with} which will call the grid minimizer called AFTER the equilibrium calculation (if it has converged) to check that it is indeed a global equilibrium. %-------------------------------- \subsection{{\em calculate} Global-Gridmin} \hypertarget{Calculate global-gridmin}{} Calculate with the global grid minimizer without using this result as a start point for the general minimizer. Used to debug the grid minimizer. %-------------------------------- \hypertarget{Calculate no-global}{} \subsection{{\em calculate} No-Global} Calculate the equilibrium without using a global grid minimizer to generate start constitutions. The current equilibrium is used as start point. Can be quicker when only small changes of conditions made since previous calculation and this is how equilibria is calculated during STEP and MAP. It means no check of new miscibility gaps. %-------------------------------- \hypertarget{Calculate paraeq2}{} \subsection{{\em calculate} Paraequilibrium}\label{sc:paraeq2} The paraequilibrium is described in section~\ref{sc:paraeq1}. %hypertarget{Calculate para2}{{\bf Matrix phase:}} {\bf Matrix phase:} Note all phases except the matrix and growing phase should be suspended. You should provide name of the matrix phase %hypertarget{Calculate para2}{{\bf Growing phase:}} {\bf Growing phase:} %hypertarget{Calculate para2}{{\bf Fast diffusing element:}} {\bf Fast diffusing element:} The element that diffuse so fast that its chemical potential is the same in both phases. The other elements will have the same composition in both phases. %-------------------------------- \hypertarget{Calculate what for}{} \hypertarget{Calculate phase}{} \subsection{{\em calculate} Phase ``phase-name''} This is to calculate properties for a single phase independent of the current conditions except the values of $T$ and $P$. %hypertarget{Calculate phase}{{\bf Phase name:}} {\bf Phase name:} %hypertarget{Calculate phase}{{\bf Amount of phase:}} {\bf Amount of phase:} %hypertarget{Calculate phase current constitution}{{\bf Current (Y), default (D) or new (N) constitution?}} {\bf Current (Y), default (D) or new (N) constitution?} You must provide a phase name, the amount of the phase and if you should use the current constitution or enter a new. %hypertarget{Calculate Phase}{} The Gibbs energy of a phase and possible derivatives and some other things can be calculated. Mainly for debugging the implementation of models and testing the software. {\small \begin{tabular}{lll} ALL-DERIVATIVES & DIFFUSION-COEFF~ & ONLY-G \\ CONSTITUTION-ADJ~ & G-AND-DGDY \\ \end{tabular} } \hypertarget{Calculate phase ... all-derivatives}{} \hypertarget{Calculate phase ... loop}{} \subsubsection{{\em calculate phase} ... All-Derivatives} The Gibbs energy, all $T$ and $P$ derivatives and all first and second derivatives with respect to constituents for the specified phase for current $T,P$ are calculated and listed. It is possible to loop this calculation to measure calculation times. \hypertarget{Calculate phase adjust}{} \subsubsection{{\em calculate phase} ... Constitution\_Adjust} You will be asked to enter a new composition of the phase (the current constitution but the current is the default) and this command will then calculate the Gibbs energy and all chemical potentials for the given composition. For a phase with sublattices the constitution of the phase will be adjusted to have the minimum Gibbs energy for the given composition. It is useful when one or more components are parts of several constituents, for example in a gas and for phases with order/disorder transitions, in particular when the corresponding subroutine is used in simulations. \hypertarget{Calculate phase ... diffusion-coeff}{} \subsubsection{{\em calculate phase} ... Diffusion\_Coefficients} You will be asked to enter a new composition (default is current) of the phase and this command will then calculate the Darken stability matrix \begin{eqnarray*} \frac{\partial^2 G}{\partial N_{\rm A}\partial N_{\rm B}} \end{eqnarray*} for all components (see the documentation of the minimiser) and also all mobility values (if there are any). \hypertarget{calculate phase ... G-and-dGdy}{} \subsubsection{{\em calculate phase} ... G\_and\_dGdy} The Gibbs energy, all $T$ and $P$ derivatives and all first derivatives with respect to constituents for the specified phase for current $T,P$ are calculated and listed. IMPORTANT NOTE: The value of $\frac{\partial G_m}{\partial y_i}$ is NOT the chemical potential, $\mu_i$ of component $i$. The understanding of thermodynamics is often poor and the user is reminded that the chemical potential of a component $i$ is defined as: \begin{eqnarray*} \mu_i &=& \left(\frac{\partial G}{\partial N_i}\right)_{T,P,N_{j\ne i}} \end{eqnarray*} where $G$ is the integral Gibbs energy and all $N_i$ are independent variables. When we model the molar Gibbs energy, $G_m$ as a function of the constituent fractions, $y_i$, these fractions are not independent and for a substitutional model, where $y_i=x_i$ i.e. the mole fractions, the chemical potential is calculated from $G_m$ using: \begin{eqnarray*} \mu_i &=& G_m + \left(\frac{\partial G_m}{\partial x_i}\right)_{T,P,x_{j\ne i}} - \sum_j x_j \left(\frac{\partial G_m}{\partial x_j}\right)_{T,P,N_{k\ne j}} \end{eqnarray*} because the mole fractions, $x_i$ are not independent. \hypertarget{calculate phase ... only-G}{} \subsubsection{{\em calculate phase} ... Only-G} The Gibbs energy and all $T$ and $P$ derivatives calculated and listed for the specified phase for the current values of $T,P$. If the phase has additions the Gibbs energy and its first derivatives and its second derivative of T of each addition are also listed \hypertarget{Calculate phase ... quit}{} \subsubsection{{\em calculate phase} ... Quit} Do not calculate anything for the phase. %-------------------------------- \hypertarget{Calculate quit}{} \subsection{{\em calculate} Quit} Do not calculate anything at all. %-------------------------------- \hypertarget{Calculate symbol}{} \subsection{{\em calculate} Symbol} A state variable symbol or function is calculated using the results from the last equilibrium or grid minimizer calculation. It is used in particular for calculation of ``dot derivatives'' like $H.T$ for the heat capacity. If a wildcard, ``*'', is given as name all symbols, except dot derivatives and symbols that must be specified explicity and those that should be calculated for another specified equilibria. See section~\ref{sc:amendsym}. %-------------------------------- \hypertarget{Calculate TPfun}{} \subsection{{\em calculate} Tpfun-Symbols} All or a specific TPFUN symbol are calculated for current values of $T$ and $P$. %-------------------------------- \hypertarget{Calculate transform}{} \subsection{{\em calculate} Transition} After calculating an equilibrium you can calculate directly when a phase will appear or disappear by releasing one of the conditions you have specified. Typically this is used to calculate the melting temperature of an alloy or a solubility limit. You specify the phase name and the condition to be released. The program will set this phase as FIXED with zero amount and remove the condition you specified and calculate the equilibrium. The calculation may fail if the phase cannot be set stable with zero amount. If successful the removed condition will be set to the value calculated and the phase set stable with zero amount. %-------------------------------- \hypertarget{Tzero}{} \subsection{{\em calculate} Tzero point}\label{sc:tzero2} The T0 (or T zero) point is where two phases have the same Gibbs energy. It is a limit of diffusionless transformation between these phases. This can be calculated by varying T (or a composition) calculating the Gibbs energy for the two phases separatly using the same overall composition. NOTE in many cases there are no such point! It is particularly interesting in steels to predict the martensite transformation which is normally some 100~K below the T0 point. %-------------------------------- \hypertarget{Calculate with check}{} \subsection{{\em calculate} with check after} When the conditions does not allow for the gridminimizer to be used to find an initial set of phases this command can be used to call the gridminimizer after the iterative calculation. If the gridminimizer finds a phase that should be stable the equilibrium will be autmatically recalculated. This type of calculations is regularly done durig STEP and MAP commands as such calculations normally have a phase as FIX which prevents use of the gridminimizer. %=================================================================== \hypertarget{Debug}{} \section{Debug } Several possibilities to trace calculations will be implemented in order to find errors but very little is working yet. This command is mainly for the software development. {\small \begin{tabular}{llll} BROWSER & GRID & STOP-ON-ERROR~ & TRACE \\ ELASTICITY~ & MAP-STARTPOINTS~ & SYMBOL-VALUE \\ FREE-LISTS & SPECIES & TPFUN~ \\ \end{tabular} } %--------------------------------------------------------------- \hypertarget{Debug elasticity}{} \subsection{{\em debug} Elasticity} Intended to test the model for strain and stress. Not implemented. %--------------------------------------------------------------- \hypertarget{Debug free_lists}{} \subsection{{\em debug} Free lists} Only for experts. %--------------------------------------------------------------- \hypertarget{Debug map_startpoints}{} \subsection{{\em debug} Map-startpoints} An attempt to generate automatic startpoints for mapping a phase diagram. %--------------------------------------------------------------- \hypertarget{Debug symbol value}{} \subsection{{\em debug} Symbol value} This is used to in macro files to test if the software calculates the same value of a symbol as when the macro was created. If not there is some new bug introduced (or a bug corrected?). After the symbol the expected value must be given and if the relative difference with the calculated value differ more than $10^{-6}$ the program will abort. %--------------------------------------------------------------- \hypertarget{Debug stop-on-error}{} \subsection{{\em debug} Stop\_on\_Error} The program will stop at the command level after printing the error message if an error has occurred when using macro file. This should make it easier to to find errors occurring when running macro files. However, it is not implemented. %=================================================================== \hypertarget{Delete}{} \section{Delete } It is quite difficult to delete anything when the data structure is so involved. In many cases it may be better to enter the data again without the data that should be deleted. But there are a few things that must occationally be deleted. {\small \begin{tabular}{llll} COMPOSITION\_SET~ & EQUILIBRIUM~ & QUIT & STEP\_MAP\_RESULTS\\ ELEMENTS & PHASE & SPECIES~\\ \end{tabular} } %------------------------------------------------------ \hypertarget{Delete composition set}{} \subsection{{\em delete} Composition set} The first composition set of a phase cannot be deleted. Otherwise there is usually no problem unless several equilibria are entered because the composition set must be deleted in all equilibria. Composition sets are created and deleted during normal equilibrium calculations to detect miscibility gaps. %------------------------------------------------------ \hypertarget{Delete element}{} \subsection{{\em delete} Element} Dangerous and will probably never be implemented. %------------------------------------------------------ \hypertarget{Delete equilibrium}{} \subsection{{\em delete} Equilibrium} Dangerous but sometimes necessary. Done automatically at a second STEP or MAP command if you specifies to delete previous results. %------------------------------------------------------ \hypertarget{Delete phase}{} \subsection{{\em delete} Phase} Dangerous and will probably never be implemented. %------------------------------------------------------ \hypertarget{Delete quit}{} \subsection{{\em delete} Quit} Do not delete anything. %------------------------------------------------------ \hypertarget{Delete species}{} \subsection{{\em delete} Species} Not implemented yet and will probably never be. %------------------------------------------------------ \hypertarget{Delete step-map-results}{} \subsection{{\em delete} Step\_Map\_Results} This removes all equilibria and saved equilibria associated with STEP and MAP commands. It also deletes the axis. %=================================================================== \hypertarget{Enter}{} \section{Enter } In most cases data will be read from a database file. But it is possible to enter all thermodynamic data interactively. This should normally start by entering all elements, then all species (the elements will automatically also be species) and then the phases. A species have a fixed stoichiometry and possibly a charge. The species are the constituents of the phases. A phase can have sublattices and constituents and also various additions like magnetic, low T heat capacity etc. which are specified by the {\bf AMEND} command efter entering the phase (but normally before any model parameters for the phase are entered). TPFUN symbols can be used to describe common parts of model parameters. See section~\ref{sc:tpfun} for an explation. Each model parameter of a phase is entered separately. You may use TPFUN symbols which are already entered. At present the multicomponent CEF model and the ionic 2-sublattice liquid model are the only basic models implemented. The CEF model includes as special cases the gas phase, regular solutions with Redlich-Kister Muggianu model and phases with up to 9 sublattices and ionic constituents. These models describe the basic configurational entropy contribution to the phase, models such as the magnetic contribution and low T heat capacity can be added to a phase with the {\bf AMEND} command. The enter command is also used to enter bibliographic data, equilibria for assessments and many other things. The subcommands are: {\small \begin{tabular}{llll} BIBLIOGRAPHY & EQUILIBRIUM & OPTIMIZE-COEFF~ & SPECIES\\ COMMENT & EXPERIMENT & PARAMETER & SYMBOL\\ CONSTITUTION & GNUPLOT-TERMINAL~ & PHASE & TPFUN-SYMBOL\\ COPY-OF-EQUILIB~ & MANY-EQUILIBRIA & PLOT-DATA\\ ELEMENT & MATERIAL & QUIT\\ \end{tabular} } %-------------------------------- \hypertarget{Enter bibliography}{} \subsection{{\em enter} Bibliography}\label{sc:bibref} Each model parameter must have a bibliographic reference to ensure everyone can find the origin of its value. When entering a parameter a bibliographic reference symbol must be given and with this command you can give a full reference text for that, for example a published paper, a report or simply a reason for the value together with the date and your name so the origin of the parameter can be traced. {\bf Reference identifier:} The text for bibliographic reference identifier can be amended. The reference identifier is case insensitive. {\bf Reference text, end with ``;'':} The text for this reference will be set to the text supplied. It can be several lines terminated with a ``;'' %-------------------------------- \hypertarget{Enter comment}{} \subsection{{\em enter} Comment} A line of comment text can be added to the current equilibrium. It is particularly important when entering experimental data to give the reference to the data. %-------------------------------- \hypertarget{Enter constitution}{} \subsection{{\em enter} Constitution} The constitution (fraction of all constituents) of a phase can be entered. This is a way to provide start values for an equilibrium calculation (when not using grid minimizer). To calculate the Gibbs energy for a specific phase at a specific constitution use the command {\bf CALCULATE PHASE}. %-------------------------------- \hypertarget{Enter copyof}{} \subsection{{\em enter} Copy of equilibrium} This command creates a copy of the current equilibrium with the same set of conditions and related data. Must be used with care. %-------------------------------- \hypertarget{Enter element}{} \subsection{{\em enter} Element} The data for an element is entered. It consists of is symbol, name, reference phase, mass, H298-H0 and S298. The element symbol must be one or two letters, they will be converted to UPPER case automatically. The element name and reference phase is never used anywhere but included for completeness. The reference phase SER means the Stable Element Reference phase, the phase stable at 298.15~K and 1~bar. The mass is needed for input of amount (using state variable B), mass fractions or mass percent of the element. The values of H298-H0 and S298 are never used for any calculation but included for completeness. %-------------------------------- \hypertarget{Enter equilibrium}{} \subsection{{\em enter} Equilibrium} You can have several equilibria each with a unique set of conditions including phase status (dormant, suspended, fix or entered) but all with the same components and thermodynamic data. This is useful for compare different states, to simulate transformations and to assess model parameters as each experimental or theoretical information represented as an equilibrium. All equilibria use the same thermodynamic data but they have an independent set of conditions and result data structure, also for TP functions and symbols, and they can be calculated in parallel. After entering the equilibrium you can select if your following commands, such as {\em enter condition} etc. will apply to the new equilibrium. %-------------------------------- \hypertarget{Enter experiment}{} \subsection{{\em enter} Experiment}\label{sc:enterexp} This is used for assessments, experimental data can be specified for an equilibrium. The experiment is a state variable or symbol which can be set equal to the experimental value followed by a colon, ``:'' and its uncertainty. In some cases an experimental value can be an upper or lower limit. In such cases the ``$>$'' or ``$<$'' can be used. The value of the uncertainty will then be interpreted as a penalty factor if the calculated value is outside the specified limit. %-------------------------------- \hypertarget{Enter GNUTERM}{} \subsection{{\em enter} GNUPLOT Terminal}\label{sc:gnuterm} For plotting OC generates a command file for the GNUPLOT~\cite{gnuplot} software. GNUPLOT can be downloaded free for most OS but depending on your screen and other hardware you may prefer to specify your prefered set of terminals. On Windows the defaults are: % IMPORTANT if table changed here also change in % \subsection{{\em plot xaxis yaxis} Graphics format} {\bf The terminals listed in the table depend on your installation.} \begin{tabular}{rlcl} & Name &=~& GNUPLOT definition\\ 1~& SCREEN & & set terminal wxt size 940,700 font "arial,16"\\ 2~& PS & & set terminal postscript color solid fontscale 1.2\\ 3~& PDF & & set terminal pdf color solid size 6,5 enhanced font "arial,16"\\ 4~& GIF & & set terminal gif enhanced fontscale 0.7\\ 5~& PNG & & set terminal png enhanced fontscale 0.7\\ \end{tabular} The text after the $>$ is written on the GNU command file. You can change these or add additional terminals. You can also change these in the source code (userif/pmon6.F90 file) or use a macro file OCHOME/start.OCM file to set them. %-------------------------------- \hypertarget{Enter many equil}{} \subsection{{\em enter} Many Equilibria}\label{sc:entermany} This command is intended for adding tables of experimental data of the same type. It can also be used for calculation of many equilibria using the {\bf calculate all} command. The user first enters a TABLE HEAD giving the necessary phase status, conditions, experiments etc. In this ``head'' some values of text can be referred to columns in the following table using the ``@'' character followed by a digit 1 to 9, where the digit is the column number. The prompt for input to the table head is ``table head::''\\ In the examples below, taken from the parallel2.OCM macro file, user input is {\bf in bold} and explanations {\em in italics}. \begin{itemize} \item By default all phases are suspended so the user must forst specify the phases with dormant, entered of fixed status (including amount) like\\ Table head: {\bf entered 0 *} {\em all phases should be entered}\\ Table head: {\bf fix 0 liquid} {\em liquid should be fix with 0 moles}\\ Table head: {\bf fix 1 @2} {\em the phase in column 2 should be fix with 1 moles} \item The conditions can be given using the @ character to indicate vaules that are given in the specified column in table to follow.\\ Table head: {\bf condition t=@1 p=1e5 n=1 w(cr)=@3 w(mo)=@4 } \item Optional calculations of entered symbols\\ Table head: {\bf calculate cp} \item Optional listing of state variables\\ Table head: {\bf list HM tc(bcc)} \item Optional experimental data\\ Table head: {\bf experiment x(liquid,cr)=@5:.01, x(bcc,cr)=@6:.02} \item Optional reference state\\ The reference state for a component can be set. Table head: {\bf reference O gas * 1e5}\\ The reference state for the component O will be gas at the current $T$ and 1 bar. \item Optional plot\_data specifying a dataset number and coordinates to be plotted and a symbol. The coordinates can be table columns. Use the dataset numbers to have data of the same type together like enthalpies, phase diagram data etc.\\ Table head: {\bf plot 1 @1 @2 5} \item Optional comment\\ Table head: {\bf comment experimental data from Kubaschewski 1955} \item The table head is finished by an empty line or ``table\_start'' \end{itemize} \hypertarget{Enter table row}{} For the rows in the table the user must first provide a unique name for each equilibrium (that is counted as column 0 (zero)) and values for all columns referenced in the table head like:\\ Table row: {\bf EQ1 1573 BCC 0.3 0.05 0.12 0.28}\\ Table row: {\bf EQ2 1623 BCC 0.3 0.10 0.18 0.24}\\ The table is finished by an empty line or\\ Table row: {\bf table\_end} %-------------------------------- \hypertarget{Enter material}{} \subsection{{\em enter} Material} The user will be asked for a name of the material and possibly a database. Then he can give elements and their amount in mass percent or mole fraction. Finish with an empty line. Finally he can specify the temperature and the program will automatically make a calculation at 1 bar with the given composition. For example: \begin{verbatim} OC4:enter mat Database:steel7 Elements: C , MO, V , CR, FE, SI, Major element or material:fe Input in mass percent? /Y/: Input expected in mass percent First alloying element:c Mass percent: /1/: Second alloying element:cr Mass percent: /1/: 5 Third alloying element:mo Mass percent: /1/: 8 Next alloying element:v Mass percent: /1/: Next alloying element: 3E reading a TDB file 3D em: W%(C)=1 W%(CR)=5 W%(MO)=8 W%(V)=1 N=1 Temperature /1000/: 3Y Constitution of metastable phases set 3Y Composition set(s) created: 1 Gridmin: 18846 points 6.25E-02 s and 78 clockcycles, T= 1000.00 Phase change: its/add/remove: 5 0 21 Equilibrium calculation 19 its, 6.2500E-02 s and 94 clockcycles \end{verbatim} The user can use the same command to specify another composition of the alloy or use other commands such as {\bf SET CONDITION} and {\bf CALCULATE} or calculate diagrams using {\bf SET AXIS} and then {\bf STEP} or {\bf MAP}. %-------------------------------- \hypertarget{Enter coeffs}{} \subsection{{\em enter} Optimizing coefficient}\label{sc:optcoeff} The number of TP symbols for the coefficients to be optimized are entered. They have the names A00 to A99. They are used in model parameters and can be varied by the optimization procedure to minimize the difference between the experimental data and the same property calculated from the models of the phases. You can also specify the size of the workspace needed for the optimization. The default value, 2500, is usually sufficient. %-------------------------------- \hypertarget{Enter parameter}{} \subsection{{\em enter} Parameter}\label{sc:enterparam} A model parameter is defined by its identifier, the phase and constituent array and the degree. A parameter can be a constant or depend on T and P. The parameter will be multiplied with the fractions of the constituents given by its constituent array. See the documentation of the GTP model package or the book by Lukas et al\cite{07Luk} for more information about thermodynamic models. For example G(LIQUID,CR) is the Gibbs energy of liquid Cr relative to its reference state, normally the stable state of Cr at 298.15 K and 1 bar, and called an endmember. For a gas molecule the parameter G(GAS,C1O2) is also an endmember and represent the Gibbs energy of the C1O2 molecule relative to the reference states of C (carbon) and O (oxygen). For interaction parameters the components are separated by a comma ``,'' as in G(LIQUID,CR,FE). For phases with sublattices the constituents in each sublattice are separated by a colon, ``:'' and interacting constituents in the same sublattice by a comma, ``,''. For example:\\ G(FCC,FE:C,VA) is the interaction between C (carbon) and VA (vacant interstitial sites) in the FCC phase. Different ternary extrapolation methods can be used, see section~\ref{sc:excessparameters}. %-------------------------------- \hypertarget{Enter phase}{} \hypertarget{enter phase name}{} \subsection{{\em enter} Phase} The user must specify a unique phase name: {\bf Phase name:} All thermodynamic data are connected to a phase as defined by its parameters, see {\bf enter parameter}. A phase has a name with can contain letters, digits and the underscore character. It must start with a letter. %................................... \hypertarget{Enter phase model}{{\bf Phase model:}} After the phase name you must specify a model. The model specfication is implemented in a rather rudimentary way. The only recognized models are \begin{itemize} \item IDEAL for a single lattice phase without interactions (like GAS) \item RKM for a substitutional phase with interactions (like metallic liquid) \item I2SL for the ionic liquid phase (2 sublattices with variable site ratios). If the phase name is IONIC\_LIQUID this prompted as the default model. \item CQC means the ``Corrected Quasichemical model'' for liquids. \item CEF for any other phase with two or more sublattices \end{itemize} This list may be extended in a future version of OC. Many other model features like magnetism, quasichemical etc are specified with the {\bf AMEND PHASE} command, see section~\ref{sc:amendph}. The AMEND PHASE command is also used to specify disordered fraction set, low temperature CP model and many other things. %................................... \hypertarget{Enter phase subl}{{\bf Number of sublattices:}} For a phase with Long Range Orderng (LRO) you must specify the number of sublattices. After that you have for each sublattice specify the number of sites and consttuents. Even if you have just one lattice you must specify the number of atoms on that lattice per formula unit. For most models OC will ask for the number of sublattices and a phase can have 1 to 9 sublattices and you must specify the number of sites on each. Preferably use small integer values, if fractions are used at least 6 digits should be provided. \hypertarget{Enter phase sites}{{\bf Number of sites on a sublattice }} For some models, like the ionic liquid model, the number of sites may change with the composition of the phase so the number specified is irrelevant. See the book by Lukas et al~\cite{07Luk} for more details on models. \hypertarget{Enter phase bonds}{Models with bonds} Some models depend on the number of nonds between atoms, such as the quasichemical model. The modified quasichemical model have a single sublattice and include additional species to decribe the Short Range Ordering (SRO). %................................... \hypertarget{Enter phase constituents}{} For each sublattice you must specify the constituents on the sublattice. A constituent that is not an element must already have been entered as a species, see section~\ref{sc:entersp}. You may have to use the {\bf AMEND PHASE} command, see section~\ref{sc:amendph}, for some additional model features like magnetism, low $T$ heat capacity or permutations. %-------------------------------- \hypertarget{Enter plot data}{} \subsection{{\em enter} Plot\_data} This is when entering experimental data for assessments when combining experimental data in single equilibria with those entered in tables using the command ``MANY\_EQUILIBRIA''. You can add points to a dataset 1 to 9 to be plotted the current equilibrum. The dataset must already have created by a PLOT command inside a {\bf ENTER MANY\_EQUILIB} command, see section~\ref{sc:entermany}. %-------------------------------- \hypertarget{Enter quit}{} \subsection{{\em enter} Quit} Quit entering things. %-------------------------------- \hypertarget{Enter species}{} \subsection{{\em enter} Species}\label{sc:entersp} A species consists of a name and a stoichiometric formula. It can have a valence or charge. The name is often the stoichiometric formula but it does not have to be that. Examples: \begin{itemize} \item enter species water h2o \item enter species c2h2cl2\_trans c2h2cl2 \item enter species c2h2cl2\_cis c2h2cl2 \item enter species h+ h1/- -1 \end{itemize} Single letter element names must be followed by a stoichiometric factor unless it is the last element when 1 is assumed. Two-letter element names have by default the stoichiometric factor~1. There can be a problem with ambiguity with a species name like h2o if there is also a species h2o2. In such cases use a final unity, i.e. h2o1. \begin{itemize} \item enter species carbonmonoxide c1o1 \item enter species cobaltoxide coo \item enter species carbondioxide c1o2 \item DO NOT USE enter species co c1o1 \end{itemize} The species name is important as it is the name, not the stoichiometry, that is used when referring to the species elsewhere like as a phase constituent. It is of course convenient to choose a species name similar to its stoichiometric formula but as shown above, that is not always sufficient. {\bf Species symbol:} The symbol must start with a letter, A-Z, and contain just letters, digits and the special characters ``\_'' (underscore), ``-'' (minus), ``+'' (plus) and ``/'' (slash). {\bf Species stoichiometry:} The stoichiometry must contain element symbols followed by a stoichiometry factor. The stoichiometry factor 1 can be omitted for two-letter element symbols. The charge is given as ``/-'' or ``/+'' followed by a stoichiometric factor. %-------------------------------- \hypertarget{Enter symbol}{} \subsection{{\em enter} Symbol} The OC package has both ``symbols'' and ``tpfun\_symbols'', the latter has a very special syntax and can be used when entering parameters. The symbols are designed to handle relations between state variables, you can define expressions like \\ {\bf enter symbol KLBCR = X(LIQUID,CR)/X(BCC,CR);}\\ where KLBCR is set to the partition of the Cr mole fractions between liquid and bcc. The symbols also include ``dot derivatives'' like $H.T$ which is the second derivative of the Gibbs energy with respect to the for the current system at the given set of conditions. {\bf enter symbol CP = H.T;} If $T$ and $P$ are conditions and all other conditions are mass balance conditions CP is the heat capacity. It also takes account of the change of configurational entropy. Currently $H.T$ is the only dot derivatives allowed but more will be added as soon as possible. %-------------------------------- \hypertarget{Enter TPfun}{} \subsection{{\em enter} Tpfun\_Symbol}\label{sc:entertpf} This symbol is a special type of expression depending on $T$ and $P$ that can be used when entering parameters. A TPfun can refer to another TPfun but not any other state variable or symbol. The program requests a name and if the symbol should be a FUNCTION, CONSTANT or a TABLE (tables not implemented). If it is a FUNCTION you must specify a low $T$ limit, and expression consisting of simple terms (signed coefficients multiplied with $T$ and $P$ possibly raised to powers). A term may also be multiplied with another TP function or with LN(FX) for the natural logarithm of ``FX'' or EXP(FX) for the exponential of the expression of function ``FX''. The ``FX'' inside the parenthesis of an LN or EXP may refer to another TP function or it can be a coefficient multiplied with powers of T or P. It is not allowed to use parenthesis except around arguments of LN and EXP or around negative powers such as $T**(-1)$. A very special unary function is INTEIN(THETA) which calculates \begin{eqnarray} 1.5*R*FX + 3*R*T*LN(EXP(-THETA/T) + 1) \end{eqnarray} and first and second derivatives of that with respect to $T$. It is the Einstein heat capacity function integrated to a Gibbs energy. The argument THETA should the the Einsten themperature and must be a positive constant. The expression must be terminated by a semicolon followed by an upper $T$ limit. After the upper $T$ limit you must specify either N or Y. If you give Y it means there is another expression above this T limit. The last T-range limit must be followed by N and a bibliographic reference, see section~\ref{sc:bibref}. TPFUNs have a strict syntax because the software must be able calculate not only its value but also its first and second derivatives with respect to $T$ and $P$ millions of times during a phase diagram calculations, see section~\ref{sc:tpfun}. %=================================================================== \hypertarget{Exit}{} \section{Exit} Terminate the OC software in Swedish, Ha en bra dag. %=================================================================== \hypertarget{Fin}{} \section{Fin} Terminate the OC software in French, Au revoir. %=================================================================== \hypertarget{Help}{} \hypertarget{Help for which *}{} \section{Help and ?} {\bf Which command:} Can give a list if commands or subcommands or parts of this help text. The user guide is also available as a searchable HMTL file. For a submenu question a single ? will give the menu and two ?? will give an extract of this user guide. Then the question will be asked again. %=================================================================== \section{HPcalc } Start the reverse polish calculator. %=================================================================== \hypertarget{Info}{} % this hypertarget is because changes is the default ... \hypertarget{Topic?changes}{} % This hypertaget when answering ?? for Topic?/QUIT/: \hypertarget{Topic?quit}{} \section{Information } on the following topics: \begin{tabular}{llll} CHANGES & ELEMENTS & PHASE-DIAGRAM~ & STATE-VARIABLES\\ COMPOSITION-SET~& EQUILIBRIUM~ & PROPERTY-DIAGRAM~\\ CONDITIONS & HELP-SYSTEM & QUIT-INFO\\ DATABASES & PHASE & SPECIES\\ \end{tabular} This command is still not fully implemented. The intention is to provide the on-line help to users who does not like to read manuals. But it is not yet implemented. {\bf Topic? /CHANGES/:} Will list the most recent changes in the OC software from the changes.txt file (if it can be found). Stop listing by a q. You can explore different parts of this User Guide online by selecting other topics. Give QUIT or press return to go back to top level. %=================================================================== \hypertarget{List}{} \section{List } Many things can be listed. Output is normally on the screen unless it is redirected by the /output={\em file name} or /append={\em file name} option, see~\ref{sc:options}. {\small \begin{tabular}{llll} ACTIVE\_EQUILIBR~ & EQUILIBRIA & OPTIMIZATION & STATE\_VARIABLES~\\ AXIS & ERROR-MESSAGE & PARAMETER~ & SYMBOLS\\ BIBLIOGRAPHY~ & EXCELL-CSV-FILE & PHASE & TPFUN\_SYMBOLS\\ CONDITIONS & LINE-EQUILIBRIA~ & QUIT \\ DATA & MODEL-PARAM-ID & RESULTS \\ ELEMENTS & MODEL-PARAM-VAL~ & SHORT \\ \end{tabular} } %-------------------------------- \hypertarget{List active}{} \subsection{{\em list} active-equilibria} This is used during assessment to list equilibria with non-zero weights. %-------------------------------- \hypertarget{List axis}{} \subsection{{\em list} Axis} Lists the axis set by you. %-------------------------------- \hypertarget{List biblio}{} \subsection{{\em list} Bibliography} List the bibliographic references for the data. %-------------------------------- \hypertarget{List conditions}{} \subsection{{\em list} Conditions} Lists the current set of conditions set by you. If the degrees of freedoms are zero you can calculate an equilibrium. %-------------------------------- \hypertarget{Output format for screen}{} \hypertarget{Output format}{} \hypertarget{List data}{} \subsection{{\em list} Data} Lists all thermodynamic data. The default is on SCREEN but you can also choose among the formats: LaTeX, MACRO, PDB and TDB. The only format implemented at present is SCREEN. %............................... \hypertarget{List data LaTeX}{} \subsubsection{{\em list data} LaTeX} The thermodynamic data will be formatted according to LaTeX for later inclusion in publications. Not implemented. %.................................... \hypertarget{List data macro}{} \subsubsection{{\em list data} Macro} The thermodynamic data will be written as a macro file that can later be read back into the OC software. Not implemented. %.................................... \hypertarget{List data PDB}{} \subsubsection{{\em list data} PDB} A ``Phase related Data Format'' similar to the TDB file format adapted for OC. Not yet implemented. %.................................... \hypertarget{List data TDB}{} \subsubsection{{\em list data} TDB} A variant of the TDB file format with Thermo-Calc flavor. Not implemented. %-------------------------------- \hypertarget{list equilibria}{} \subsection{{\em list} Equilibria} Lists the equilibria entered. To list the results of the calculation of an equilibrium use {\bf list result}. %-------------------------------- \hypertarget{List error msg}{} \subsection{{\em list} Error message} The message associated with an error code generated by OC can be listed %-------------------------------- \hypertarget{List line-equilibria}{} \subsection{{\em list} Line equilibria} Lists the equilibria calculated during STEP or MAP commands. See also the command {\bf AMEND LINE-EQUILIBRIA}. %-------------------------------- \hypertarget{List model parameter id}{} \subsection{{\em list} Model parameter identifiers} Lists the model parameter identifiers available in the current version of OC, see section~\ref{sc:paramid}. %-------------------------------- \hypertarget{List model parameter val}{} \subsection{{\em list} Model parameter value} The current value of a model parameter identifier can be listed. Note that the value is always phase dependent and may also depend on the composition set. %-------------------------------- \hypertarget{List Optimization}{} \subsection{{\em list} optimization} Lists results of an optimization, several sub-options will be implemented but currently there is a short version only. To save this on a file use the option /output= or /append=, see~\ref{sc:options}. {\small \begin{tabular}{llll} COEFFICIENTS & DEBUG & GRAPHICS~ & MACRO \\ CORRELATION\_MTRX~ & EXPERIMENTS~ & LONG & SHORT \\ \end{tabular} } %..................................... \hypertarget{List optimization coefficiets}{} \subsubsection{{\em list optimization} coefficients} This gives a list of the coefficients and their values. %..................................... \hypertarget{list optimization debug}{} \subsubsection{{\em list optimization} debug} Not implemented yet. %..................................... \hypertarget{List Optimization correlation-mtrx}{} \subsubsection{{\em list optimization} correlation\_matrix} Not implemented yet. %..................................... \hypertarget{list optimization experiments}{} \subsubsection{{\em list optimization} experiments} List of experiments in the equilibria with non-zero weights. %..................................... \hypertarget{List optimization graphics}{} \subsubsection{{\em list optimization} graphics} A figure with the experimental values on the X axis and calculated values on the Y axis for all experiments. Not implemented yet. %..................................... \hypertarget{List optimization long}{} \subsubsection{{\em list optimization} long} Not implemented yet %..................................... \hypertarget{List optimization macro}{} \subsubsection{{\em list optimization} macro} A listing of all thermodynamic data and current values of model parameter and experimental data with current weight. This can be read back as a start of a re-assessment and an important documentation of the current state of the assessment. But not yet implemented. %..................................... \hypertarget{List optimization short}{} \subsubsection{{\em list optimization} short}\label{sc:listoptshort} This specifies tha data and hour of the listing and first a table with the optimizing coefficents with name, current value, start value, scaling factor and its relative standard deviation. In the first table all the optimizing coefficents with non-zero values are listed together with the current values, the start values and their scaling factor (usually ths same as the start value). In the column ``RSD'' the Relative Standard Deviation'' should appear but it is not yet calculated correctly. Last column is the name of the TP symbol(s) where the coefficient is used. After that all equilibria with non-sero weights are listed together with their experimental data, both the prescribed value, the uncertainy and the currently calculated one. In the last column the error is listed. \begin{verbatim} Listing of optimization results: date 2018.08.20 : 12h47 List of coefficients with non-zero values Name Current value Start value Scaling factor RSD Used in A11 3.46818E+02 4.00095E+02 4.00095E+02 1.25070E-06 _GFCCAB0 A12 -5.66234E+01 -6.52871E+01 -6.52871E+01 1.33802E-06 A13 -2.10028E-02 -1.30393E-02 -1.30393E-02 8.97167E-06 _GFCCAB0 List of 4 equilibria with 8 experimental data values No Equil name Weight Experiment $ calculated Error 2 FCC1_ZA 1.00 SM=17:1 $ 17 9.8995E-09 2 1.00 CP1=18:1 $ 17.28685 7.1315E-01 3 FCC2_ZB 1.00 HDIFF=9000:500 $ 9997.813 -1.9956E+00 3 1.00 CP1=20:DCP $ 22.55698 -2.5570E-02 4 FCC3_ZC 1.00 HDIFF=15000:500 $ 14719.24 5.6152E-01 4 1.00 CP1=22:DCP $ 24.65726 -2.6573E-02 5 FCC4_ZD 1.00 HDIFF=20000:500 $ 19860.72 2.7856E-01 5 1.00 CP1=24:DCP $ 26.75754 -2.7575E-02 Final sum of squared errors: 4.88614E+00 using 8 experiments and 3 coefficient(s). Degrees of freedom: 5, normalized error: 9.7723E-01 \end{verbatim} In the list of equilibria with non-zero weight the first column is a sequential equilibrium number assigned by the software. Then the name of the equilibrium assigned by the user. The third column is the weight, only equilibria with nonzero weight are listed. Then comes a columm with the experimental property and value and after the dollar sign its calculated value with the present set of coefficients. The rightmost column gives the difference for each experiment $i, q_i$ that should be as close to zero as possible: \begin{equation} q_i = \frac{z^{\rm exp}_i - z^{\rm calc}}{\sigma_i} w_i \end{equation} where $i$, $z_i^{\rm exp}$ is the experimental property, $z_i^{\rm calc}$ is the same property calculated from the model and $\sigma_i$ is the experimental uncertanty and $w_i$ is the weight assigned to equilibria with the experiment. If $w_i = 1$ and $q_i$ is between -1 and 1 the experiment has been fitted within the experimental uncertanty. The least square routine tries to determine coefficients to make the sum of all $q_i^2$ as small as possible. At the end of the listing $\sum_i q_i^2$ is listed. The degrees of freedom is the number of experiments minus the number of coefficients. %-------------------------------- \hypertarget{List parameter}{} \subsection{{\em list} Parameter} List a specific parameter. %-------------------------------- \hypertarget{List phase}{} \hypertarget{List what for}{} \subsection{{\em list} Phase ``phase-name''} You must first specify the phase name. Then you can specify if you want the phase CONSTITUTION, DATA or some MODEL information. To write on a file use the options /output= or /append=, see~\ref{sc:options}. %................... \subsubsection{{\em list phase} ... Constitution} List the constitution of the phase. %................... \subsubsection{{\em list phase} ... Data} List the model and model parameter expressions. %................... \subsubsection{{\em list phase} ... Model} List some model data for example if there is a disordered fraction set. %-------------------------------- \subsection{{\em list} Quit} You did not really want to list anyting. %-------------------------------- \hypertarget{List results}{} % when user asks ?? on command level the help system will search % for command and default in UPPER CASE \hypertarget{LIST RESULTS}{} \subsection{{\em list} Results} List the results of an equilibrium calculation. This is the most frequent list command. The listing will contain the current set of conditions, a table with global data, a table with component specific data and then a list of stable phases with amounts, compositions and possibly constitutions. It is possible to list also unstable phases. There are 9 options for the formatting: \begin{itemize} \item 1 Output in mole fractions, phase constituents in value order (constituent with highest fraction first). \item 2 as 1 but include also the phase constitution (sublattices and their fractions) in value order. \item 3 as 1 with the phase composition in alphabetical order \item 4 Output in mass fractions, phase composition in value order. \item 5 as 4 with the phase composition in alphabetical order. \item 6 as 4 and also include the phase constitutions in value order. \item 7 Output all phases will with composition in mass fractions and in value order. Unstable phases will have a negative driving force. \item 8 Output all phases will with composition in mole fraction and constitution in alphabetic order. Unstable phases will have a negative driving force. \item 9 as 8 but in in value order. \end{itemize} For each phase the name, its status (S=suspended/D=dormant/E=entered/F=fix), moles (or mass), volume, number of formula units, atoms per formula units and driving force (in dimensionless units) is given on one line. The moles of a phase is the number of formula unit multiplied with atoms per formula units. The gas phase and phases with interstitials and vacancies have a varying amount of moles of atoms per formula units. The composition of the phase can be in value order or alphabetical order. To write the output on a file use /output= or /append=, see~\ref{sc:options}. %-------------------------------- \hypertarget{List short}{} \subsection{{\em list} Short} There are 4 options: A/C/M/P The A option lists a single line for each element, species and phases with some essential data. The C option lists one line for each component. The M option lists the models and constitution for all phases. The P option lists one line for each stable phase and then one line for some of the remaining phases in decreasing order of stability. %-------------------------------- \hypertarget{List state variables}{} \subsection{{\em list} State\_Variables}\label{sc:list_statevar} Values of individual state variables like G, HM(LIQUID), X(LIQUID,CR) etc. can be listed. Terminate the command by an empty line. Note that the values of symbols and TP functions cannot be listed here, they are calculated by the CALCULATE SYMBOL or CALCULATE TP command. The current values of parameter identifiers, see section~\ref{sc:paramid} can be listed with the command, like TC(BCC) will give the calculated Curie temperature for BCC. A symbol like MQ\&FE(FCC) will give the logarithm of the mobility of Fe in the FCC phase. This command is the same as the SHOW command, section~\ref{sc:show}. %-------------------------------- \hypertarget{List symbols}{} \subsection{{\em list} Symbols} All state variable symbols listed but not their values, they are calculated by the CALCULATE SYMBOL command. \begin{verbatim} List of all state variable symbols No Special Name= expression ; 1 R= 8.31451; 2 RT= R*T; 3 T_C= T-273.15; 4 D CP= HM.T; 5 C DCP= 1 6 7X H298= HM; \end{verbatim} In the ``special'' column the ``D'' means the symbol that is a ``dot derivative'' which is calculated only when explicitly specified, ``C'' means a numeric value that can be amended. The special 7X means a symbol that is evaluated only at equilibrium 7 which means you can refer to the value of this symbol calculated at the specified equilibrium in other equilibria. See also section~\ref{sc:amendsym}. %-------------------------------- \hypertarget{List excell CSV}{} \subsection{{\em list} excell CSV file} The result from a STEP calculation can be listed in a file using the Commma Separated Value (CSV) format. This can be read by Excell or similar software for later processing. One may use other state variables for the table than used for the step command as one can do for plotting. {\bf Independent variable:} The independent variable must be a single valued state variable, for example $T$. {\bf Dependent variable(s):} The dependent variable may have multiple values, for example phase amounts, NP(*), or the driving force, DGM(\#). {\bf Output file:} %-------------------------------- \hypertarget{List TPfun}{} \subsection{{\em list} Tpfun Symbols} All or some TPFUN expressions listed. By giving * all are listed, bu giving the g* all TP functions starting with G are listed. Note that all parameters are also TP functions, they can be listed by giving ``\_*'' as name. The abbreviation ``\_g*'' will list the function for all parameters with identifiers starting with G. To obtain the values of TP functions use the {\bf calculate TP} command. %=================================================================== \hypertarget{Macro}{} \section{Macro } By specifying a file name commands will be read from that file. The default extension is OCM. A macro file can open another macro file (max 5 levels). When a macro file finish with SET INTERACTIVE the calling macro file will continue or the user can continue interactively. See section~\ref{sc:macro}. When you start OC you can give a macro file name on the same line and the program will drictly start reading from this file. With the popup window facility there are some special things. If you open the macro file with the popup window OC will save the directory where the macro file was found. If there are references to other files such as datbases or other macro files inside the macro and these file names are on the same line as the command {\bf read tdb ./steel1} the file name must be preceeded by a ``./'', otherwise OC will try to open the file on its ``working directory'', see section~\ref{sc:popup}. %=================================================================== \hypertarget{Map}{} \hypertarget{Map old data}{} \section{Map }\label{sc:map} For phase diagram calculations. You must first set two axis with state variables which are already set as conditions. {\bf Reinitiate?} If you give several MAP commands you can choose to erase or keep the previous results at each command. During mapping each calculated equilibria is saved and for plotting any state variable can be used. %=================================================================== \section{New } \hypertarget{New}{} To remove all data and calculated results to enter a new system. It is fragile. The user must confirm with UPPER CASE Y. %=================================================================== \hypertarget{Optimize}{} \section{Optimize}\label{sc:optim} The command is part of the facility to assess model parameters for thermodynamic databases. You have already entered elements, phases and model parameters with coefficients to be assessed and all the experimental data yu can find. Estimated and theoretical data calculated by DFT can also be entered as experimental data. The model parameters to optimized are selected by SET VARIABLE\_COEFF and there is a least square routine LMDIF which will vary these to obtain the best least fit the experimental data provided. As already state you must have entered the thermodynamic descriptions of the phases with model parameters depending on optimizing coefficients and the experimental data before this command. You must also set the weights of the experiments and which coefficents to be variable. You provide a maximum number of iterations allowed. If you give zero a ``dry run'' will be made with the current values of the optimizing coefficients. This is useful to check that there are no problems calculating the equilibria. Usually you have to change the set of model parameters, weights of the experimental data and other criteria many times before you get a satisfactory result. Developing better assessment software is one of the main aspects of the OC software. There will be more options to this and related commands. %=================================================================== \hypertarget{Plot command}{} \section{Plot }\label{sc:plot} Plot the result from a STEP or MAP calculation. A simple interface to GNUPLOT~\cite{gnuplot} has been implemented in OC. This generates a command file which is automatically plotted using GNUPLOT after the ``render'' command. In OC you must first specify the state variable on the horizontal (x-axis) and vertical (y-axis) axis. Then you can give several of the options below, finish with RENDER or QUIT. %---------------------------------------------------- \hypertarget{Horizontal axis variable}{} \subsection{{\em plot} Horizontal axis variable} Specify the state variable or symbol to be plotted on the horizontal axis. Note that if you plot a phase diagram with "tie-lines in the plane" you should specify a fraction variable as X(*,C) and not X(C) because you want the carbon content in all stable phases. %---------------------------------------------------- \hypertarget{Vertical axis variable}{} \subsection{{\em plot xaxis} Vertical axis variable} Specify the state variable or symbol to be plotted on the vertical axis. Note that if you plot a phase diagram with "tie-lines in the plane" you should specify a fraction variable as X(*,C) and not X(C) because you want the carbon content in all stable phases. %---------------------------------------------------- \hypertarget{Plot}{} \hypertarget{Plot options}{} \subsection{{\em plot xaxis yaxis} Options?/RENDER/} You can choose various options before plotting. Typing a ? gives a menu, typing ?? will give this text of the online help is correctly installed. The menu here is not very clear and will be reorganized. The default option is RENDER meaning to plot when you specified all your options. The simplest way to generate a complex plot to be saved as PDF or PNG format is to first select the approriate axis and then set a few options like scaling, axis texts and text labels and plot on the screen. If you are not satified you can plot again (without changing the axis variables, if you change these all options you have set will be cleared) and add or modify the options. When you are satisfied with the plot on the screen you plot a final time and set the GRAPHICS-FORMAT option and plot in the desired format on a file. Or you can select to plot on a file in the GNUPLOT window. Note that some texts and formats may not be exactly identical to those you see on the screen. Default plotfile is ``ocgnu.plt''. On this file all the GNUPLOT commands and data will be written to be executed by GNUPLOT. If GNUPLOT is correctly installed then OC will start GNUPLOT and generate the graphics output when you RENDER the plot. You can change the name of the plotfile before plotting with the command ``output file''. Whenever you set a new terminal you can also set the output file name. Or you can rename the file after the RENDER command and before you generate a new plot. GNUPLOT is a very powerful graphics software, only a few of its facilities are available within OC. The gnuplot command file generated by OC can be edited to exploit additional facilities in GNUPLOT. \bigskip {\small \begin{tabular}{llll} APPEND & FONT & POSITION\_OF\_KEYS~ & SCALE\_RANGES~ \\ AXIS\_LABELS~ & GRAPHICS\_FORMAT~ & QUIT & TEXT\_LABEL \\ EXTRA & OUTPUT\_FILE & RENDER & TITLE\\ \end{tabular} } A short summary: \begin{itemize} \item APPEND means overlay the current plot with another GNUPLOT file \item AXIS-LABELS you can specify the label on X or Y axis \item EXTRA provides less frequent plot options \item FONT select the font for all texts, depend on what GNUPLOT has istalled \item GRAPHICS-FORMAT to select the GNUPLOT output device (PS, PDF, PNG etc) In GNUPLOT plot window there is also an option to save on file. \item OUTPUT-FILE the GNUPLOT file is saved on this file (default ocgnu.plt) \item POSITION\_OF\_KEYS, the identification labels for the curves \item QUIT no plot generated \item RENDER finally plot \item SCALE-RANGES for X and Y axis you can specify min and max value plotted \item TEXT-LABEL you can place a text inside the plot \item TITLE the heading of the plot (can be suppressed, see EXTRA) \end{itemize} The EXTRA command provides less used options: {\small \begin{tabular}{llll} AXIS\_FACTOR & LINE\_TYPE & NO\_HEADING & SPAWN \\ COLOR & LOGSCALE & PAUSE\_OPTION & TIE\_LINES \\ GIBBS\_TRIANGLE~ & LOWER\_LEFT\_TEXT~ & QUIT \\ GRID & MANIPULATE\_LINES~ & RATIOS\_XY \\ \end{tabular} } %---------------------------------------------------- \hypertarget{Plot append}{} \subsection{{\em plot xaxis yaxis} Append} A GNUPLOT file prevously generated by OC with possible manually changes or any file following the GNUPLOT standard can be specified to be overlayed on the current plot. %---------------------------------------------------- \hypertarget{Plot axis labels}{} \subsection{{\em plot xaxis yaxis} Axis\_Labels} You specify for the X or Y axis the axis labels. By default the state variable or symbol plotted will be used as label. {\bf For X or Y axis?} Specify the axis for which you want to enter the label {\bf Axis label:} The default label is given in the question. %---------------------------------------------------- \hypertarget{Plot fonts}{} \subsection{{\em plot xaxis yaxis} Font} %---------------------------------------------------- \hypertarget{Plot formats}{} \subsection{{\em plot xaxis yaxis} Graphics format} The GNUPLOT terminals entered in section~\ref{sc:gnuterm} can be used. For other formats than SCREEN you can also specify an output file which will be written for the specified format. Graphics format index: The default terminal indices are: % IMPORTANT if table changed here also change in % \subsection{{\em enter} GNUPLOT Terminal}\label{sc:gnuterm} \begin{tabular}{rlcl} & Name &=~ & GNUPLOT definition\\ 1~& SCREEN & & set terminal wxt size 940,700 font "arial,16"\\ 2~& PS & & set terminal postscript color solid fontscale 1.2\\ 3~& PDF & & set terminal pdf color solid size 6,5 enhanced font "arial,16"\\ 4~& GIF & & set terminal gif enhanced fontscale 0.7\\ 5~& PNG & & set terminal png enhanced fontscale 0.7\\ \end{tabular} You can change these or enter more graphics formats with the {\bf enter gnuplot} command. \ref{sc:gnuterm}. The SCREEN driver is usually ``wxt'' for Windows and ``Qt'' for Linux but can be selected in the Makefile for the pmon6.F90 file. If SCREEN is not selected the you can specify the name of the file where OC will save the commandfile for GNUPLOT as well as the final graphics file created by GNUPLOT. It will have the appropriate extention depending on the format. By default OC saves the GNUPLOT command file on the file ``ocgnu.plt''. This can be renamed and edited if you want to keep it for later processing. Plot file: In addition to the GNUPLOT command file the graphics a file with the specified format will be generated. %---------------------------------------------------- \hypertarget{Plot file}{} \subsection{{\em plot xaxis yaxis} Output file} By default plotting will generate a ocgnu.plt file for GNUPLOT. You can specify other name here. If you plot on other terminals than SCREEN there will be an additional file with extension ``.ps'' for Postscript, ``.pdf'' for Adobe PDF or ``.gif'' for GIF format. If the file already exists the user must confirm it it should be overwritten. %---------------------------------------------------- \hypertarget{Plot keys}{} \subsection{{\em plot xaxis yaxis} Position of keys} The identification (labels) of the curves in the plot can be positioned with this command. See the GNUPLOT manual~\cite{gnuplot} for information. %---------------------------------------------------- \hypertarget{Plot quit}{} \subsection{{\em plot xaxis yaxis} Quit} No plot generated. %---------------------------------------------------- \hypertarget{Plot render}{} \hypertarget{Render}{} \subsection{{\em plot xaxis yaxis} Render} Press return to plot using all the option set. Otherwise you can select any of these options: {\small \begin{tabular}{llll} APPEND & FONT & POSITION\_OF\_KEYS~ & SCALE\_RANGES~ \\ AXIS\_LABELS~ & GRAPHICS\_FORMAT~ & QUIT & TEXT\_LABEL \\ EXTRA & OUTPUT\_FILE & RENDER & TITLE\\ \end{tabular} } %---------------------------------------------------- \hypertarget{Plot limits}{} \subsection{{\em plot xaxis yaxis} Scale\_Range} You specify for the X or Y axis the minimum and maximum range. The automatic (default) scaling range can always be restored. %---------------------------------------------------- \hypertarget{Plot texts}{} \subsection{{\em plot xaxis yaxis} Text} This is a facility to add a text to a plot at an arbitrary position. \subsubsection{{\em plot xaxis yaxis text} Modify existing text?:} If there is already a text item you must first answer if you wants modify an already existing one. If so all the texts are listed and you can select which one you wants to change. \subsubsection{{\em plot xaxis yaxis text} Which text index?:} You must provide the index of an existing text to change. For a new or changed text you must give: \subsubsection{{\em plot xaxis yaxis text} X position} The X coordinate of the text (in the plot scale) \subsubsection{{\em plot xaxis yaxis text} Y position} The Y coordinate of the text (in the plot scale) \subsubsection{{\em plot xaxis yaxis text} Fontscale} A relative size factor, default is 0.8. The size of the text will be scaled accordingly. \subsubsection{{\em plot xaxis yaxis text} Angle (degrees)} The text will be written with the specified angle. Zero means horisontally, negative valus slopes downward, positive upwards. An ange of 180 means the text will be upside down. \subsubsection{{\em plot xaxis yaxis text} Do you want to calculate the equilibrium?/Y/} If you are plotting a phase diagram you can select to calculate an equilibrium at the specified coordinates. The names of the stable phases will be proposed as text. The calculation may fail and you can anyway add a text. Note that the axis values you sepcified will refer to the axis used when calculating the diagram. If you are plotting using other variables there may be some surprises. \subsubsection{{\em plot xaxis yaxis text} Text: } The text to be added to the plot. The text will start at the coordinates given. On Postscript and PDF a greek character can be given as ``{/Symbol m}'' for $\mu$. %---------------------------------------------------- \hypertarget{Plot title}{} \subsection{{\em plot xaxis yaxis} Title} The default is the date and the conditions. You can add a text of your own here. You can remove the title altogether with EXTRA NO\_HEADING. That will make the figure slightly larger. %---------------------------------------------------- \hypertarget{Extra}{} \hypertarget{Plot extra}{} \hypertarget{Extra Gibbs_triangle}{} \subsection{{\em plot xaxis yaxis} Extra } Less common options for the plotting is available here. For really nice plotting it is recommended to edit the output file from OC as GNUPLOT has too many facilities to be made available here. \hypertarget{Extra options}{} The EXTRA commands provides more obscure options: {\small \begin{tabular}{llll} AXIS\_FACTOR & LOGSCALE & PAUSE\_OPTION & TIE\_LINES \\ COLOR & LOWER\_LEFT\_TEXT~ & QUIT \\ GIBBS\_TRIANGLE~ & MANIPULATE\_LINES~ & RATIOS\_XY \\ LINE\_TYPE & NO\_HEADING & SPAWN \\ \end{tabular} } \begin{itemize} \item AXIS\_FACTOR means all values on an axis will be multiplied with this. For example it can be useful to plot in kJ rather than the default J. \item COLOR you can select some colors \item GIBBS-TRIANGLE means an equilateral triangular diagram \item LINE-TYPE means dashed lines or lines with symbols \item LOGSCALE you can specify that X or Y axis is logaritmic \item LOWER-LEFT-TEXT you can set a text in the lower left corner \item MANIPULATE-LINES does not work \item NO-HEADING means remove title all text above the plot \item PAUSE-OPTION to select how GNUPLOT should behave after plotting \item QUIT no extra option selected \item RATIOS-XY will change the relative length of X and Y axis \item SPAWN will allow you to contine calculating with the plot window open \item TIE-LINES if you have tie-lines in the plane you can plot some of them \end{itemize} %---------------------------------------------------- \hypertarget{Plot extra factor}{} \subsubsection{{\em plot xaxis yaxis extra} factor} You can select a factor for each plot axis to convert from J to kJ for example. %---------------------------------------------------- \hypertarget{Plot color}{} \subsubsection{{\em plot xaxis yaxis extra} color} You can select color of monovariant equilibria and tie-lines. %---------------------------------------------------- \hypertarget{Plot Gibbs triangle}{} \subsubsection{{\em plot xaxis yaxis extra} Gibbs-triangle} Gibbs triangle plots should only be used for isothermal sections. A trial implementation is available which can generate equiaxial triangular isothermal diagrams. If you already set this option you can set it again to plot on a square. %---------------------------------------------------- \hypertarget{Plot line symbols}{} \subsubsection{{\em plot xaxis yaxis extra} line-with-symbols} Not implemented yet %---------------------------------------------------- \hypertarget{Plot logax}{} \subsubsection{{\em plot xaxis yaxis extra} logscale} You can set logarithimic scale on X or Y axis (or both). %---------------------------------------------------- \hypertarget{Extra line-colors}{} \subsubsection{{\em plot xaxis yaxis extra} manipulate lines} This is not implemented. It is intended to allow specification of the color of the curves in the plot. %---------------------------------------------------- \hypertarget{Extra lower-left-corner}{} \subsubsection{{\em plot xaxia yaxis extra} lower left corner text} You can set a short text in the lower left corner of the plot %---------------------------------------------------- \hypertarget{Plot spawn}{} \subsubsection{{\em plot xaxia yaxis extra} spawn} You can spawn the plot window and continue working looking at it. %---------------------------------------------------- \hypertarget{Plot no heading}{} \subsubsection{{\em plot xaxia yaxis extra} no heading} Remove the text above the plot with date and title. The plot is slightly larger this way. %---------------------------------------------------- \hypertarget{Plot pause}{} \subsubsection{{\em plot xaxis yaxis extra} pause option} When you plot on the screen the last command on the file to GNUPLOT is ``pause mouse''. You can change this with this command. %---------------------------------------------------- \hypertarget{Plot ratios}{} \subsubsection{{\em plot xaxis yaxis extra} ratios XY} The relative ratios of the X and Y axis can be specied. %---------------------------------------------------- \hypertarget{Plot tieline}{} \subsubsection{{\em plot xaxis yaxis extra} tie-line} Tie-lines in isothermal ternary phase diagram can be plotted. You can specify the density of the tie-lines by Tie-line plot increment? The increment is related to the actual equilibria calculated. 0 means no tie-lines plotted, 3 means to plot a tie-line at every 3rd calculated equilibria and so on. %=================================================================== \hypertarget{Quit}{} \section{Quit } Terminate the OC software in English, have a nice day. %=================================================================== \hypertarget{Read}{} \section{Read } It is possible to read a (non-encrypted) TDB file but it should be not too different from what is normally generated by the LIST\_DATA command in TC. \begin{tabular}{lll} DIRECT~ & QUIT~ & TDB\\ PDB & SELECTED-PHASES & UNFORMATTED \\ \end{tabular} %-------------------------------- \hypertarget{Read direct}{} \subsection{{\em read} Direct} {\bf File name:} In the future it will be possible to save results on a random access (DIRECT) file. %-------------------------------- \hypertarget{Read PDB}{} \subsection{{\em read} PDB} {\bf File name:} A PDB file (with extension PDB) should be specified. The file should be un the Portable phase dependent Data Base format. The user can select to read the whole file or select elements. %-------------------------------- \hypertarget{Read quit}{} \subsection{{\em read} Quit} You did not really want to read anything. %-------------------------------- \hypertarget{Read select phase}{} \subsection{{\em read} selected phases only} This is to select a subset of elements and phases from a database. Normally all phases which can be formed by the elements are included. With this command one can first select the elements and after that one can specify the phases to be included. If one specifies an abbreviation of a phase name all phases which fit this abbreviation will be selected. {\bf Database format:} Can be TDB or PDB. {\bf File name:} It is also possible to read all phases and later suspend those which are not interesting. %-------------------------------- \hypertarget{Read TDB}{} % on command level the subcommand may be lower case!! \hypertarget{Read tdb}{} \subsection{{\em read} TDB} A TDB file (with extension TDB) should be specified. The TDB file must not deviate very much from the standard output from Thermo-Calc. \hypertarget{File name:}{{\bf File name:}} If you do not use the popup window for opening files you must specify the database file name. The file must be on the working directory (where you started the OC program, see section~\ref{sc:popup}) or you must provide the path. \hypertarget{Select element}{} After opening the file the program will list the elements and ask: {\bf Select elements /all/:} If you give RETURN the data for all elements will be read. If you answer q or quit nothing will be read. If you specify one or more elements the data for those will be read and if you selected a subset you will have the question: {\bf Select elements /no more/:} And you can select some more or just give RETURN (or type quit). All phases that can be formed by the elements selected will be read, you cannot select the phases here but inside OC you can suspend those phases you are not interested in. \hypertarget{Read TDB error}{{\bf Error reading TDB file}} In some cases there non-fatal errors or warnings reading TDB files created by different groups because the TDB format varies a lot. The user should carefully check if there are any data missing but can continue using the data he read if he is confident it is correct. The TDB file should be corrected manually. %-------------------------------- \hypertarget{Read unformatted}{} \subsection{{\em read} Unformatted}\label{sc:readunf} {\bf File name:} For use to read a file created with a SAVE UNFORMATTED command. It may not always work to read an old unformatted file as the data structure is still changing. %=================================================================== \hypertarget{Save}{} \section{Save } There are several forms of save, three forms write a text file that can be read and modified with a normal editor. Two forms are unformatted, either on a sequential file or a direct (random access) file. \begin{tabular}{llll} DIRECT~ & SOLGAS~ & UNFORMATTED\\ QUIT & TDB & PDB \\ \end{tabular} %-------------------------------- \hypertarget{Save direct}{} \subsection{{\em save} Direct} It will eventually be possible to save the result of STEP and MAP commands on a random access file for later processing. %-------------------------------- \hypertarget{Save quit}{} \subsection{{\em save} Quit} You did not want to save anything. %-------------------------------- \hypertarget{Save PDB}{} \subsection{{\em save} PDB} Saves current set of model parameters and functions on a file in the Portable phase dependant Data Base format. %-------------------------------- \hypertarget{Save TDB}{} \subsection{{\em save} TDB} Saves current set of model parameters and functions on a file in TDB format. Same as the command {\bf list data tdb}. %-------------------------------- \hypertarget{Save SOLGAS}{} \subsection{{\em save} SOLGAS} Saves current set of model parameters and functions on a file in a format that (hopefully) can be read by the FactSage software. %-------------------------------- \hypertarget{Save unformatted}{} \subsection{{\em save} Unformatted}\label{sc:saveunf} With this command you can save the current status of the calculations on a file and then resume the calculations by reading this file. Note that the Fortran unformatted files may not be portable, they depend on the compiler, the operating system and the hardware. %=================================================================== \hypertarget{Select}{} \section{Select } There are a few things that can be selected, most important which equilibrium the following commands will operate on. %-------------------------------- \hypertarget{Select equilibrium}{} \subsection{{\em select} Equilibrium} As you can enter several equilibria with different conditions this command allows him to select the current eqilibria. %-------------------------------- \hypertarget{Select graphics}{} \subsection{{\em select} Graphics} Only GNUPLOT~cite{gnuplot} available. %-------------------------------- \hypertarget{Select language}{} \subsection{{\em select} Language} Only English implemented (except a few French exclamations). %-------------------------------- \hypertarget{Select minimizer}{} \subsection{{\em select} Minimizer} Only Hillert's algorithm implemented in matsmin~\cite{15Sun2} available. %-------------------------------- \hypertarget{Select optimizer}{} \subsection{{\em select} Optimizer} The LMDIF~\cite{lmdif} least square fitting software is the only one implemented. %######### >>> edit limit 2018.01.10 %=================================================================== \hypertarget{Set}{} \section{Set } Many things can be set. Things to be ``set'' and ``amended'' sometimes overlap. {\small \begin{tabular}{llll} ADVANCED & FIXED\_COEFF & OPTIMIZING\_COND~ & STATUS\\ AS\_START\_EQUILIB~&INITIAL\_T\_AND\_P~ & PHASE & SYSTEM\_VARIABLE\\ AXIS & INPUT\_AMOUNTS & QUIT & UNITS\\ BIT & INTERACTIVE & RANGE\_EXP\_EQUIL~ & VARIABLE\_COEFF\\ CONDITION & LOG\_FILE & REFERENCE\_STATE & VERBOSE\\ ECHO & NUMERIC\_OPTIONS~ & SCALED\_COEFF & WEIGHT\\\\ \end{tabular} } %-------------------------------- \hypertarget{Advanced command}{} \subsection{{\em set} Advanced} A few options implemented {\small \begin{tabular}{llll} EEC\_METHOD & HELP-POPUP-OFF~& OPEN-POPUP-OFF~ & WORKING-DIRECTRY\\ EQUILIB-TRANSF~ & LEVEL & QUIT\\ GLOBAL-MIN-ONOFF~& MAP-SPECIALS & SMALL-GRID-ONOFF~\\ GRID-DENSITY & NO-MACRO-STOP & SYMBOL \\ \end{tabular} } %............................................................. \hypertarget{Set adv EEC-method}{} \subsubsection{{\em set advanced} EEC-method}\label{sc:eec-method} In a recent paper\cite{20Sun} a method the compare the entropy of the liquid and a solid phase can be used to supress the formation of a solid phase at high $T$ if its entropy is higher than the liquid, the Equi-Entropy Criteria (EEC). This simplifies the extrapolation of the Gibbs energy of solids at high $T$. This command will activate or deactivate this check. %............................................................. \hypertarget{Set adv transfer}{} \subsubsection{{\em set advanced} equilibrium transfer} This is only for experts who know what they are doing. %............................................................. \hypertarget{Set adv global onoff}{} \subsubsection{{\em set advanced} global-min-onoff} Turn on or off the use of the global gridminimizer. %............................................................. \hypertarget{Set adv grid-density}{} \subsubsection{{\em set advanced} grid\_density} At present the grid density cannot be fine tuned. For some phases it is fixed for others you can select a more or less dense grid. Note that phases with option F or B (4 sublattice order/disorder) there is a special grid minimizer and also for solids with ionic constituents and for the 2-sublattice ionic liquid. %............................................................. \hypertarget{Set adv help popup}{} \subsubsection{{\em set advanced} help-popup-off}\label{sc:help-popup} The user can turn off or on the HTML popup help feature. He can also change the browser and help file. {\bf Turn off popup help? /Y/:} If the user answers N he will be asked for the browser and HTML file. These are normally set when compiling the OC software and their current values are proposed as default within slashes /../. {\bf Browser including full path //usr/local/firefox/:} {\bf HTML help file includig full path //home/user/.ochelp/ochelp.html/:} %............................................................. \hypertarget{Set adv level}{} \subsubsection{{\em set advanced} level} You can specify if you are beginner or expert. You may have to declare youself as expert to execute some commands. The intention of the beginners status is to provide more help but that is not yet implemented. %............................................................. %\hypertarget{SET Advanced map-special}{} \subsubsection{{\em set advanced} map-special} Not implemented yet. %............................................................. \hypertarget{Set adv no-macro-stop}{} \subsubsection{{\em set advanced} no-macro-stop} This command makes it possible to ignore the ``@\&'' used to stop the execution of a macro file. Used when testing the software. %............................................................. \hypertarget{Set adv open popup}{} \subsubsection{{\em set advanced} open-popup-off} Any other answer than Y will turn off popup windows for opening files. By answering Y you turn on popup windows for opening files (the default) provided the program is linked with this facility. %............................................................. \hypertarget{Set adv quit}{} \subsubsection{{\em set advanced} quit} You did not want to set anything advanced. %............................................................. \hypertarget{Set adv symbol}{} \subsubsection{{\em set advanced} symbol} Not implemented yet. %............................................................. \hypertarget{Set adv workdir}{} \subsubsection{{\em set advanced} working-directory} The name of the working directory (where OC was started) is listed. It cannot be changed at present. It is related to the popup windows for opening files, see section~\ref{sc:popup}. %-------------------------------- \hypertarget{Set as start equil}{} \subsection{{\em set} As start equilibrium} The current equilibrium will be copied to the list of start equilibria for STEP and MAP commands. %-------------------------------- \hypertarget{Set axis}{} \subsection{{\em set} Axis}\label{sc:setaxis} To set an axis you must first has set the conditions necessary to calculate an equilibrium and also calculated this. {\bf Axis number:} The axis are numbered 1, 2 etc and you must set them in sequential order. To change an axis variable just give the number of the axis to change. {\bf Condition to vary along the axis:} You can set select one of the condition to vary between a min and max value along the axis. If you has just one axis you can use STEP to calculate a property diagram, i.e. how the system properties varies with a single variable. Typically a phase fraction plot or how the heat capacity varies with the independent axis variable. {\bf Minimal/maximal value of the axis:} The calculation will start with the current value and calculate in both directions. {\bf Increment:} By default the increment is 1/40 of the difference beteen max and min. If you set two or more axis (current limit is 2) the OC software will map the phase diagram, i.e. follow the lines where the set of phases changes. This means OC will replace one axis condition with a condition that a phase should be stable with zero amount. To calculate a diagram you must then give a STEP command (if you have one axis) or a MAP command (if you have 2 or more axis). For the STEP command~\ref{sc:step}, there are several options. %-------------------------------- \hypertarget{Set which status}{} \subsection{{\em set} Bit} %%% ??? \hypertarget{helphere}{} %%% ??? \hypertarget{Set status bit}{} \hypertarget{Global status bits}{} Many records have status words where the bits are used to signify different things. An advanced user can set these bits for the global, equilibrium and phase records, but only if you know what it means. \begin{itemize} \item The GLOBAL record bits are listed below. Most of them are set or reset automatically by the software or by other commands. \begin{itemize} \item 0 you are a beginner \item 1 you are experienced (default) \item 2 you are an expert \item 3 gridminimizer must not be used \item 4 gridminimizer must not merge comp.sets. \item 5 there are no data (cleread automatically) \item 6 there are no phases (cleared automatically) \item 7 comp.sets must not be created automatically \item 8 comp.sets must not be deleted automatically \item 9 data has changed since last save (set automtically) \item 10 means verbose is on (not implemented) \item 11 means verbose is permanently on (not implemented) \item 12 means be silent (supress warnings) \item 13 no cleanup after an equilibrium calculation \item 14 use denser grid in grid minimizer (see also SET ADVANCED) \item 15 calculations in parallel is not allowed \item 16 no global test at node point during STEP/MAP \item 17 the components are not the elements \item 18 global test of equilibrium AFTER calculation \item 19 use old (less dense) grid minimizer \item 20 do not recalculate if global test AFTER fails \item 21 use old MAP algorithm \item 22-31 not yet used \end{itemize} %-------------------------------------------------------------- \item The EQUILIBRIUM record bits are listed below \begin{itemize} \item 0 No threads allowed (no parallel calculation) \item 1 No global minimization allowed for this equilibrium \item 2 No equilibrium has been calculated (there are no results) \item 3 Conditions and results not consistent \item 4 Last equilibrium calculation failed \item 5 No automatic generation of composition sets \item 6 Equilibrium tested by grid minimizer \item 7 Current results are from a grid minimization \end{itemize} %-------------------------------------------------------------- \item To change the phase status word use SET PHASE ... bit \end{itemize} %-------------------------------- % the default is set condition \hypertarget{Info conditions}{} \hypertarget{Set condition}{} \subsection{{\em set} Condition}\label{sc:setcond} Most of the text here also applies to {\bf enter experiment}. {\bf State variable:} A condition is a value assigned to a state variable or an expression of state variables. All state variables are listed in Table~\ref{tab:statev} in section~ref{sc:statevar} By setting the status of a phase to fix you have also set a condition. For example {\em set cond t=1273 p=1e5 n=1 x(cr)=0.1 w\%(c)=1} Three cases of expressions can be used as conditions, for example a relation between mole fraction like\\ {\bf set condition x(liq,o)-x(c1\_mo2,o)=0}\\ means that the oxygen content in liquid and c1\_mo2 phases should be the same. That is useful to calculate the congruent melting of c1\_mo2. Another case is if the total anount if some components has a relation, for example:\\ {\bf set condition n(u)+n(zr)=1}\\ means that the total number of moles of the components U and Zr should be unity. A third case is {\bf y(B2,Al)-y(B2,Al\#2)=0.01} to calculate a send order transition line when the B2 ordered phase is on the limit of disorder as the fractions of Al on the two sublattices are almost equal. %subsubsection{value} {\bf Value:} A numeric value or a symbol representing a constant value is expected. %-------------------------------- \hypertarget{Set echo}{} \subsection{{\em set} Echo} This is useful command in macro files or when demonstrating the program. %-------------------------------- \hypertarget{Set fix coeff}{} \subsection{{\em set} Fixed coefficient} One or more optimizing coefficients are assigned a fixed value. The index 0 to 99 is used to indicate the coefficients A00 to A99. One can use a range as 15-19 to set all variable cofficients in the range to their current values. %-------------------------------- \hypertarget{Set initial TP}{} \subsection{{\em set} initial\_T\_and\_P} Local values of T and P can be set. These are not conditions but are used for commands like {\bf CALCULATE PHASE ...}. %-------------------------------- \hypertarget{Set input amounts}{} \subsection{{\em set} Input-Amounts}\label{sc:setinpuam} This command allows you to specify a system by giving a redundant amount of various species in the system. The software will transform this to conditions on the amounts of the components. \hypertarget{Species and amounts}{} Species and amount as N(..)= or B(...)= : An example: {\small \begin{verbatim} --->OC5:read tdb cho-gas --->OC5:set input Species and amount as N(..)= or B(...)= : n(c1o2) Amount: 10 --->OC5:set input n(c1h4)=5 --->OC5:l c Conditions for equilibrium: 1, DEFAULT_EQUILIBRIUM 1:N(C)=45, 2:N(O)=80, 3:N(H)=30 Degrees of freedom are 2 \end{verbatim} } The amounts of the species has been split on the components. Setting input amounts is just another way to set these directly. If we set a $T$ and $P$ we can calculate the equilibrium fraction of all the species. {\small \begin{verbatim} --->OC5:set c t=1000 p=1e5 --->OC5:l c Conditions for equilibrium: 1, DEFAULT_EQUILIBRIUM 1:N(C)=45, 2:N(O)=80, 3:N(H)=30, 4:T=1000, 5:P=100000 Degrees of freedom are 0 --->OC5:c e 3Y Constitution of metastable phases set Gridmin: 85 points 1.56E-02 s and 0 clockcycles, T= 1000.00 Phase change: its/add/remove: 5 11 0 Phase change: its/add/remove: 12 12 0 Phase change: its/add/remove: 17 0 12 Phase change: its/add/remove: 53 0 11 Equilibrium calculation 79 its, 7.8125E-02 s and 93 clockcycles --->OC5:l LIST what? /RESULTS/: Results output mode: /1/: Output for equilibrium: 1, DEFAULT_EQUILIBRIUM 2018.08.21 Conditions .................................................: 1:N(C)=45, 2:N(O)=80, 3:N(H)=30, 4:T=1000, 5:P=100000 Degrees of freedom are 0 Some global data, reference state SER ......................: T= 1000.00 K ( 726.85 C), P= 1.0000E+05 Pa, V= 4.9872E+00 m3 N= 1.5500E+02 moles, B= 1.8507E+03 g, RT= 8.3145E+03 J/mol GS= -2.80411E+07 J, GS/N=-1.8091E+05 J/mol, HS=-1.2914E+07 J, SS= 1.513E+04 J/K Some data for components ...................................: Component name Moles Mole-fr Chem.pot/RT Activities Ref.state C 4.5000E+01 0.29032 -3.7354E+00 2.3863E-02 SER (default) H 3.0000E+01 0.19355 -9.8098E+00 5.4910E-05 SER (default) O 8.0000E+01 0.51613 -3.6377E+01 1.5911E-16 SER (default) Some data for phases .......................................: Name Status Moles Volume Form.Units Cmp/FU dGm/RT Comp: GAS..................... E 1.550E+02 4.99E+00 6.00E+01 2.58 0.00E+00 X: O 5.16129E-01 C 2.90323E-01 H 1.93548E-01 Constitution: There are 73 constituents: C1O2 4.54395E-01 C2H3 8.67456E-17 C4H10_1 2.73242E-23 C1O1 2.95682E-01 C3H4_2 3.04922E-17 C4H10_2 1.38822E-23 H2O1 1.29270E-01 C3H8 2.73523E-17 C4H2 8.16657E-24 H2 1.20501E-01 C3H6O1 1.94895E-17 H1O2 4.37267E-24 C1H4 1.52786E-04 C3H4_1 8.18695E-18 C4H6_5 1.44915E-24 C1H2O2_CIS 4.04887E-08 C1H3O1_CH3O 3.87833E-18 C4H8 1.04297E-25 C1H2O1 2.01368E-08 C2H4O1_OXIRA 1.64221E-19 C2H1 7.79712E-26 C1H2O2_TRANS 5.82767E-09 C1H2 3.98656E-20 C4H8_4 6.39692E-26 H 7.88542E-10 H2O2 3.27068E-20 C6H6O1 3.00598E-26 C1H4O1 1.27636E-10 O 1.46838E-20 C1H1 1.81712E-27 C2H4 1.05140E-10 C2H6O2 1.19305E-20 C3H1 1.68523E-28 C2H6 3.44726E-11 O2 8.71930E-21 C4H4_1_3 7.73762E-29 C1H3 1.83302E-11 C4H6_2 5.73533E-21 C1H2O2_DIOXI 4.04963E-30 C1H1O1 7.24719E-12 C2O1 1.72590E-21 C4H1 1.00000E-30 C2H4O1_ACETA 2.00054E-12 C4H8_5 9.38081E-22 C2H4O2_DIOXE 1.00000E-30 H1O1 1.86354E-12 C4H8_3 5.91323E-22 C4 1.00000E-30 C2H2 1.82837E-12 C4H8_1 4.75317E-22 C2H4O3_123TR 1.00000E-30 C1H1O2 1.57298E-12 C4H8_2 4.17043E-22 C2H4O3_124TR 1.00000E-30 C2H4O2_ACETI 7.65642E-13 C2H2O1 1.47405E-22 C2 1.00000E-30 C1H3O1_CH2OH 1.64978E-15 C4H6_4 8.47392E-23 C60 1.00000E-30 C3O2 1.11079E-15 C6H6 8.21607E-23 C3 1.00000E-30 C3H6_2 7.21243E-16 C4H4 5.46648E-23 C5 1.00000E-30 C3H6 7.13743E-16 C4H6_1 5.05773E-23 O3 1.00000E-30 C2H6O1 6.22811E-16 C4H6_3 2.87604E-23 C2H5 4.72671E-16 C4H10_1 2.73242E-23 --->OC5: \end{verbatim} } The calculation shows that mixing 10 moles of CO$_2$ with 5 moles of CH$_4$ at 1000~K and 1~bar gives a gas with 45\% CO$_2$, 30\% CO, 13\% H$_2$O and the rest H$_2$ %-------------------------------- \hypertarget{Set interactive}{} \subsection{{\em set} Interactive} The last command on a macro file. Gives command back to the keyboard of the user, or to the calling macro file. Without this the program will just terminate when the macro is finished. %-------------------------------- \hypertarget{Set logfile}{} \subsection{{\em set} Log-File} A useful command to save all interactive input while running OC. The log file can easily be transformed to a macro file. All bug reports should be accompanied by a log file which reproduces the bug. %-------------------------------- \hypertarget{Set numeric}{} \subsection{{\em set} Numeric-Options} The default number of iterations and accuracy can be specified. Default values are 500 and 10$^{-6}$. Some more obscure values may also be asked for, they should never be changed. %-------------------------------- \hypertarget{Set optimizer conditions}{} \subsection{{\em set} Optimizing conditions} A few variables used to guide the optimization of model parameters can be set. %-------------------------------- \hypertarget{Set system variable}{} \subsection{{\em set} system variable} This is a new idea to have global variables. No idea how to use it yet. %-------------------------------- \hypertarget{Set phase}{} \hypertarget{Set for phase}{} \subsection{{\em set} Phase ``phase-name''} You must specify a phase name. Some phase specific things can be set, also for the model. Some subcommands allow wildcard ``*'' as name. %.................... \hypertarget{Set phase amount}{} \subsubsection{{\em set phase} ... Amount} You can specify the amount of the phase which is used as initial value for an equilibrium calculation. %.................... \hypertarget{Set phase bits}{} \subsubsection{{\em set phase} ... Bits} Some of the models and use of data storage depend on the bits of the phase. Most of them are set automatically by the software and other commands like AMEND PHASE. Changing them with this command will not have the expected effect and may cause the program to fail. The bits that can be changed are: \hypertarget{Extra-dense-grid}{} \begin{itemize} \item EXTRA\_DENSE\_GRID makes it possible to have a larger number of gridpoints calculated by the gridminimizer for the specified phase. %. . . . . . . . . . \hypertarget{No-auto-comp-set}{} \item NO\_AUTO\_COMP\_SET. This makes it possible to prevent that the specific phase has automatic composition set created during calculations. %. . . . . . . . . . \hypertarget{Set bit quit}{} \item QUIT, do not set any more bits. \end{itemize} %.................... \subsubsection{{\em set phase} ... Constitution} \hypertarget{Amend phase constit}{} \hypertarget{Set phase constitution}{} This is the same as {\bf amend phase constitution}. The amount of the phase can also be set. You can specify the constituent fraction of each constituent. A fraction must be larger than zero and less than unity. As the sum of fractions must be unity the last constituent in each sublattice will not be asked for unless you specify the fraction for one of the constitents as ``rest''. The fraction of that will then be set as ``the rest'' i.e. one minus the sum of the other fractions. This is also be used for the command {\bf calculate phase} to calculate properties for a single phase. %.................... \hypertarget{Set phase ... default-constitu}{} \subsubsection{{\em set phase} ... Default-constitution} Same as {\bf amend phase default\_constit}. %.................... \hypertarget{Set phase ... quit}{} \subsubsection{{\em set phase} ... Quit} You did not want to set anything for the phase. %.................... \hypertarget{Set phase status}{} \subsubsection{{\em set phase} ... Status}\label{sc:setphstat} Use the SET STATUS PHASE command to set the status of one or several phases. The different status are explained for that command, section~\ref{sc:set-status-phase}. A phase with the status FIX must also have an amount specified. For a phase with the status ENTERED the amount is also requested but normally it should be set to zero. A nonzero value means the user assumes the phase should be stable. %-------------------------------- \hypertarget{Set quit}{} \subsection{{\em set} Quit} You did not really want to set anything. %-------------------------------- \hypertarget{Set range}{} \subsection{{\em set} Range of experimental equilibria}\label{sc:setrange} For an assessment several consequtive equilibria with experimental data must be entered. This command specifies the first and last of those equilibria. It possible to add more equilibria later one by one (not yet though). \hypertarget{First equilibrium number:}{{\bf First equilibrium number: /2/:}} {\bf Last equilibrium number:} The equilibria are assigned the weight one by default. The weight can be changed with the SET WEIGHT command. The weight zero means the equilibrium is not calculated. %-------------------------------- \hypertarget{Set reference phase}{} \subsection{{\em set} Reference-State}\label{sc:setref} By default the reference state for the components is SER (Stable Element Reference) which is the stable state of the element at 298.15~K and 1~bar. (NOTE: in principle SER is defined by the database but today almost all databases have SER as reference state.) {\bf Component name:} {\bf Reference phase:} For each component (also for other components than the elements) you can specify a phase at a given temperature and pressure as reference state. The phase must exist for the component as pure. {\bf Temperature:} Instead of a fixed $T$ you can give a *, indicating current $T$, if you calculates at different values of $T$. {\bf Pressure:} Example: {\em set reference O gas * 1e5} Note that state variables like the chemical potential, MU(O), will refer to the user defined reference state. To obtain the value for the SER state you can use the suffix S, i.e. MUS(O) will give the chemical potential refered to SER. IMPORTANT NOTE: the value of integral properties like Gibbs energy, $G$, enthalpy, $H$, etc. will also be affected by the change of the reference state of an element. If all elements have the same phase as reference state the value of the enthalpy obtained by $H$ for that phase will be the enthalpy of mixing. If not it is only confusing. In order to have use SER as reference state use a suffix S. The enthalpy relative to SER is $HS$ independent of any reference state set for the elements by the user. %-------------------------------- \hypertarget{Set scaled coefficient}{} \subsection{{\em set} Scaled coefficient} A coefficient for optimization can be specified with a start value, scaling factor and a minimum and maximum value. The {\em set} VARIABLE command sets the scaling factor equal to the start value and have no min or max values. Not implemented yet. %-------------------------------- \hypertarget{Set status}{} \subsection{{\em set} Status} The status of elements, constituents, species or phases can be changed. Only phases are implemented. %.................... \hypertarget{Set status constituent}{} \subsubsection{{\em set status} Constituent} A constituent of a phase can be suspended. Not yet implemented. %.................... \hypertarget{Set status element}{} \subsubsection{{\em set status} Element} An element can be ENTERED or SUSPENDED. If an element is suspended all species with this element is automatically suspended. If such a species is the single constituent of a phase that phase is also suspended. Not yet implemented. %.................... \subsubsection{{\em set status} Phases}\label{sc:set-status-phase} \hypertarget{Set status phase}{} \hypertarget{Status phase}{{\bf Phase name(s):}} A phase can have one of 4 different status \begin{itemize} \item ENTERED, this is the default. The phase will be stable if that would give the most stable state for the current conditions. The user can give a tentative amount. \item SUSPENDED, the phase will not be included in any calculations. \item DORMANT, the phase will be included in the calculations but will not be allowed to become stable even if that would give the most stable equilibrium. In such a case the phase will have a positive driving force. \item FIXED means that it is a condition that the phase is stable with the specified amount. Note that for solution phases the composition is not known. \end{itemize} You can use a list of phase names or a wildcard for the phase name and the must give an equal sign, ``='', before the new status. You can also use the special ``*S'' for all suspended phase, ``*D'' for all dormant phases. Changing the phase status does not affect anything except the phase itself. For a single phase you can use SET PHASE ... STATUS $<$status$>$. \hypertarget{Set status phase amount}{} Setting a stable phase as dormant or suspended and calculate the equilibrium will give you a metastable equilibrium. Setting a phase status as FIXED means it is a condition that this phase should be stable. Setting the liquid fix with the amount zero is a quick way to calculate the melting temperature of a system if there is no condition on the T. For entered phases the amount is used as a start value. {\bf Amount: /0/}: %.................... \hypertarget{Set status species}{} \subsubsection{{\em set status} Species} A species can be ENTERED or SUSPENDED. If a species is suspended all phases that have this as single constituent in a sublattice will be automatically suspended. Not yet implemented. %-------------------------------- \hypertarget{Set units}{} \subsection{{\em set} Units} For each property the unit can be specified like Kelvin, Farenheit or Celsius for temperature. Not implemented yet. %-------------------------------- \hypertarget{Set variable coeff}{} \subsection{{\em set} Variable coefficient}\label{sc:setvar} One or more coefficients for optimization, A00 to A99, can be set as variable to be optimized against the selected experimental data. A single variable index, 0 to 99, can be used with a start value provided. Or a range such as 15-19 which will set all nonzero variables A15 to A19 as variable. %-------------------------------- \hypertarget{Set verbose}{} \subsection{{\em set} Verbose} Not implemented yet. %-------------------------------- \hypertarget{Set weight}{} \subsection{{\em set} Weight}\label{sc:setw} Intended for assessments. A weight is zero or a positive value. Equilibria with weight zero will be ignored in an optimization. You can specify the current equilibrium or give an abbreviation that will set the weight of all equilibria with a name for which the abbreviation fits. Or you can give a range of equilibria by giving two numbers separated by a hyphen like 63-106. If an abbreviation or a range is given the software will list how many equilibra that had the weight set to the new value. %=================================================================== \hypertarget{Show property}{} \section{Show }\label{sc:show} This command shows a value of a property, the property can be a state variable like T, G etc or a user detfined symbol containing several state variable or a model parameter identifier (which must always have a phase specification) like the Curie temperature. The state variables can contain wildcards like X(FCC,*) means all mole fractions of the FCC phase. Several properties can be specified on the same line, SEPARATED BY A SPACE CHARACTER, do not use ``,''. It is the same as the command {\em LIST state-variables}, see section~\ref{sc:list_statevar} \hypertarget{property:}{} \subsection{property:} The value of one or more properties or symbols can be shown: DO NOT USE ``,'' between the properties! {\small \begin{verbatim} --->OC5:show t g tc(bcc) x(bcc,cr) mu(cr) cp T= 1.2000000E+03 G= -5.9565761E+04 TC(BCC_A2)= 1.0272646E+03 X(BCC_A2,CR)= 3.100000E-2 MU(CR)= -7.2489667E+04 CP= 4.08487869E+01 \end{verbatim} } %=================================================================== \hypertarget{Step}{} \section{Step }\label{sc:step} Requires that a single axis is set. If a second step command is given you have the choice of deleting or keeping the previous results. There are 5 variants of the STEP command, CONDITIONS and NPLE are not implemented: \begin{tabular}{llll} CONDITIONAL~~ & NPLE & QUI & SEPARATE\\ NORMAL & PARAEQUILIBRIUM~~ & SCHEIL-GULLIVER~~& TZERO \end{tabular} \hypertarget{Step old data}{{\bf Delete previous results?}} Any previous results from the STEP or MAP commands can be deleted or kept. If kept the previous results can be plotted together with the results from the new STEP command. The PLOT command also allows appending previous diagams calculated and plotted by OC. %-------------------------------- \hypertarget{Step conditional}{} \subsection{{\em step} Conditional} A specified symbol is evaluated at each step, not implemented. %-------------------------------- \hypertarget{Step normal}{} \subsection{{\em step} Normal} Calculates equilibria from the low axis limit to the high at each increment. The exact axis value for any phase changes is calculated. %-------------------------------- \hypertarget{Step NPLE}{} \subsection{{\em step} NPLE} Step NPLE is similar to step paraequilibrium. %-------------------------------- \hypertarget{Step paraequilibrium}{} \subsection{{\em step} paraequilibrium}\label{sc:paraeq3} Paraequilibrium describes a metastable equilibrium with a fast diffusing element. It is described in section~\ref{sc:paraeq1}. You should make a calculate paraequilibrium command, see section~\ref{sc:paraeq2}, before this step command and you must again specify a matrix phase and a growing phase and the fast diffusing element. {\bf Matrix phase:} Note all phases except the matrix and growing phase should be suspended. You should provide name of the matrix phase {\bf Growing phase:} {\bf Fast diffusing element:} The element that diffuse so fast that its chemical potential is the same in both phases. The other alloying elements will have the same composition in both phases. %-------------------------------- \hypertarget{Step Quit}{} \subsection{{\em step} Quit} You did not want to {\em step}. %-------------------------------- \hypertarget{Step Scheil}{} \subsection{{\em step} Scheil-Gulliver}\label{sc:scheil2} The Scheil-Gulliver solidification simulation is described in section~\ref{sc:scheil1}. It simulates a solidification with no diffusion in the solid phases and a homogeneous liquid. %-------------------------------- \hypertarget{Step separate}{} \subsection{{\em step} Separate} This command calculates equilibria for each phase separately along the axis. It is typically used to separately calculate and plot together the Gibbs energy curves for a number of phases across a composition range. %-------------------------------- \hypertarget{Step Tzero}{} \subsection{{\em step} Tzero}\label{sc:tzero3} This will calculate a line with the fraction of the selected element on one axis and the $T$ on the other and the line is defined by the fact that the two phases have the same Gibbs energy with the same composition and at the same $T$. This is the limit of a diffusionless transformation. $T_0$ or Tzero lines are described in section~\ref{sc:tzero1} and \ref{sc:tzero2}. Before this step command you must have calculated a Tzero point. {\bf First phase:} {\bf Second phase:} Note all phases except the two phases should be suspended. You should provide name of the matrix phase {\bf Release condition number:} Normally the step axis is the fast diffusing element and the condition released is the $T$. The fast diffusing element will have the same chemical potential is both phases, the other alloying elements will have the same composition in both phases. %=================================================================== % Using this file for on-line help there must be a section after last command \hypertarget{Summary}{} \section{Summary } That's all and I hope enough (when all is implemented). Have fun and report all errors or problems providing a macro file and the necessary data. \begin{thebibliography}{77zzz} \bibitem{15Sun1} B Sundman, U R Kattner, M Palumbo and S G Fries, {\em OpenCalphad - a free thermodynamic software}, in Integrating Materials and Manufacturing Innovation, {\bf 4:1} (2015), open access \bibitem{15Sun2} B Sundman, X-L Liu and H Ohtani, {\em The implementation of an algorithm to calculate thermodynamic equilibria for multi-component systems with non-ideal phases in a free software}, Computational Materials Science, {\bf 101} (2015) 127--137 \bibitem{16Sun} B Sundman, U R Kattner, C Sigli, M Stratmann, R Le Tellier, M Palumbo and S G Fries, {\em The OpenCalphad thermodynamic software interface}, Comp Mat Sci, {\bf 125} (2016) 188--196 \bibitem{07Luk} H L Lukas, S G Fries and B Sundman, {\em Computational Thermodynamics, the CALPHAD method}, Cambridge Univ Press 2007. \bibitem{20Her} J Herrnring, B Sundman and B Klusemann, {\em Diffusion-driven microstructure evolution in OpenCalphad}, Computational Materials Science, {\bf 175}, (2020) 109236 \bibitem{lmdif} https://www.math.utah.edu/software/minpack/minpack/lmdif.html \bibitem{gnuplot} http://www.gnuplot.info/documentation.html \bibitem{20Sun} B Sundman, U R Kattner, M Hillert, M Selleby, J {\AA}gren, S Bigdeli, Q Chen, A Dinsdale, B Hallstedt, A Khvan, H Mao and R Otis, {\em A Method for handling the extrapolation of solid crystalline phases to temperatures far above their melting point}, Calphad, {\bf 68} 101737 \end{thebibliography} \end{document} Old state variable table \begin{table}[!ht] \caption{A preliminary table with the state variables and their internal representation. Some model parameter properties are also included. The "z" used in some symbols like Sz means the optional normalizing symbol M, W, V or F.}\label{tab:statevold} {\small \begin{tabular}{|llcccl|}\hline Symbol~ & Id & \multicolumn{2}{c}{Index} & Normalizing~ & Meaning\\ & & 1 & 2 & suffix & \\\hline \multicolumn{6}{|c|}{Intensive properties}\\\hline T & 1 & - & - & - & Temperature\\ P & 2 & - & - & - & Pressure\\ MU & 3 & component & -/phase & - & Chemical potential\\ AC & 4 & component & -/phase & - & Activity\\ LNAC & 5 & component & -/phase & - & LN(activity)\\\hline \multicolumn{6}{|c|}{Extensive and normallized properties}\\\hline U & 10 & -/phase\#set & - & - & Internal energy for system\\ UM & 11 & -/phase\#set & - & M & Internal energy per mole\\ UW & 12 & -/phase\#set & - & W & Internal energy per mass\\ UV & 13 & -/phase\#set & - & V & Internal energy per m$^3$\\ UF & 14 & phase\#set & - & F & Internal energy per formula unit\\ Sz & 2z & -/phase\#set & - & - & entropy\\ Vz & 3z & -/phase\#set & - & - & volume\\ Hz & 4z & -/phase\#set & - & - & enthalpy\\ Az & 5z & -/phase\#set & - & - & Helmholtz energy\\ Gz & 6z & -/phase\#set & - & - & Gibbs energy\\ NPz & 7z & phase\#set & - & - & Moles of phase\\ BPz & 8z & phase\#set & - & - & Mass of phase\\ Qz & 9z & phase\#set & - & - & Stability of phase\\ DGz & 10z & phase\#set & - & - & Driving force of phase\\ Nz & 11z & -/phase\#set/comp & -/comp & - & Moles of component\\ X & 111 & phase\#set/comp & -/comp & 0 & Mole fraction\\ X\% & 111 & phase\#set/comp & -/comp & 100 & Mole per cent\\ Bz & 12z & -/phase\#set/comp & -/comp & - & Mass of component\\ W & 122 & phase\#set/comp & -/comp & 0 & Mass fraction\\ W\% & 122 & phase\#set/comp & -/comp & 100 & Mass per cent\\ Y & 130 & phase\#set & const\#subl & -& Constituent fraction\\\hline \multicolumn{6}{|c|}{Some model parameter identifiers}\\\hline TC & - & phase\#set & - & - & Curie temperature\\ BMAG & - & phase\#set & - & - & Aver. Bohr magneton number\\ MQ\&X & - & phase\#set & constituent & - & Mobility of X\\ THET & - & phase\#set & - & - & Debye temperature\\\hline \end{tabular} } \end{table} ================================================ FILE: examples/TQ4lib/Cpp/Makefile ================================================ all: # Example written in C++ using ISO-C-Binding make -C ./Matthias clean: make -C ./Matthias clean ================================================ FILE: examples/TQ4lib/Cpp/Matthias/FECRMNC.TDB ================================================ $ Database file written 14- 5-11 $ ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT C GRAPHITE 1.2011E+01 1.0540E+03 5.7400E+00! ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01! ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! ELEMENT MN CBCC_A12 5.4938E+01 4.9960E+03 3.2008E+01! SPECIES CR+2 CR1/+2! SPECIES CR+3 CR1/+3! SPECIES FE+2 FE1/+2! SPECIES FE+3 FE1/+3! SPECIES FE+4 FE1/+4! SPECIES MN+2 MN1/+2! SPECIES MN+3 MN1/+3! SPECIES MN+4 MN1/+4! FUNCTION GHSERCR 2.98140E+02 -8856.94+157.48*T-26.908*T*LN(T) +.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2.18000E+03 Y -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6.00000E+03 N ! FUNCTION GHSERBB 2.98140E+02 -7735.284+107.111864*T-15.6641*T*LN(T) -.006864515*T**2+6.18878E-07*T**3+370843*T**(-1); 1.10000E+03 Y -16649.474+184.801744*T-26.6047*T*LN(T)-7.9809E-04*T**2-2.556E-08*T**3 +1748270*T**(-1); 2.34800E+03 Y -36667.582+231.336244*T-31.5957527*T*LN(T)-.00159488*T**2 +1.34719E-07*T**3+11205883*T**(-1); 3.00000E+03 Y -21530.653+222.396264*T-31.4*T*LN(T); 6.00000E+03 N ! FUNCTION GCRM23B6 2.98150E+02 -460000+23*GHSERCR#+6*GHSERBB#; 6.00000E+03 N ! FUNCTION GHSERFE 2.98140E+02 +1225.7+124.134*T-23.5143*T*LN(T) -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6.00000E+03 N ! FUNCTION GFEM23B6 2.98150E+02 -490000+134*T+23*GHSERFE#+6*GHSERBB#; 6.00000E+03 N ! FUNCTION GHSERMN 2.98140E+02 -8115.28+130.059*T-23.4582*T*LN(T) -.00734768*T**2+69827*T**(-1); 1.51900E+03 Y -28733.41+312.2648*T-48*T*LN(T)+1.656847E+30*T**(-9); 2.00000E+03 N ! FUNCTION GMNM23B6 2.98150E+02 +23*GHSERMN#+6*GHSERBB#; 6.00000E+03 N ! FUNCTION GHSERNI 2.98140E+02 -5179.159+117.854*T-22.096*T*LN(T) -.0048407*T**2; 1.72800E+03 Y -27840.655+279.135*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 3.00000E+03 N ! FUNCTION GNIM23B6 2.98150E+02 +23*GHSERNI#+6*GHSERBB#; 6.00000E+03 N ! FUNCTION GBHCP 2.98150E+02 +50208-9.706*T+GHSERBB#; 6.00000E+03 N ! FUNCTION UALFE 2.98150E+02 -4000+T; 6.00000E+03 N ! FUNCTION GALFE3 2.98150E+02 +3*UALFE#-4000; 6.00000E+03 N ! FUNCTION GAL2FE2 2.98150E+02 +4*UALFE#; 6.00000E+03 N ! FUNCTION GAL3FE 2.98150E+02 +3*UALFE#+9000; 6.00000E+03 N ! FUNCTION SROALFE 2.98150E+02 +UALFE#; 6.00000E+03 N ! FUNCTION LFALFE0 2.98150E+02 -104700+30.65*T; 6.00000E+03 N ! FUNCTION LFALFE1 2.98150E+02 22600; 6.00000E+03 N ! FUNCTION LFALFE2 2.98150E+02 +29100-13*T; 6.00000E+03 N ! FUNCTION UKALFEC 2.98150E+02 -1600-16.8*T; 6.00000E+03 N ! FUNCTION GKALFE3C 2.98150E+02 +3*UKALFEC#; 6.00000E+03 N ! FUNCTION GKAL2FE2 2.98150E+02 +4*UKALFEC#-5200; 6.00000E+03 N ! FUNCTION GKAL3FEC 2.98150E+02 +3*UKALFEC#; 6.00000E+03 N ! FUNCTION SROKALFE 2.98150E+02 +UKALFEC#; 6.00000E+03 N ! FUNCTION B2ALVA 2.98150E+02 +10000-T; 6.00000E+03 N ! FUNCTION LB2ALVA 2.98150E+02 100000; 6.00000E+03 N ! FUNCTION GB2ALFE 2.98150E+02 -10876+2.6*T; 6.00000E+03 N ! FUNCTION DGBALFE 2.98150E+02 -4530+2.5*T; 6.00000E+03 N ! FUNCTION DT0ALFE 2.98150E+02 -250; 6.00000E+03 N ! FUNCTION DB0ALFE 2.98150E+02 -1.2; 6.00000E+03 N ! FUNCTION ZERO 298.15 0.0; 6000.00 N ! FUNCTION RTLN25 2.98150E+02 -.562335*R#*T; 6.00000E+03 N ! FUNCTION GHSERCU 2.98140E+02 -7770.458+130.485235*T-24.112392*T*LN(T) -.00265684*T**2+1.29223E-07*T**3+52478*T**(-1); 1.35777E+03 Y -13542.026+183.803828*T-31.38*T*LN(T)+3.64167E+29*T**(-9); 3.20000E+03 N ! FUNCTION GHSERSS 2.98140E+02 -5228.956+55.417762*T-11.007*T*LN(T) -.026529*T**2+7.754333E-06*T**3; 3.68300E+02 Y -6513.769+94.692922*T-17.941839*T*LN(T)-.010895125*T**2 +1.402558E-06*T**3+39910*T**(-1); 1.30000E+03 N ! FUNCTION GDIGENIT 2.98150E+02 -62053-105.461*T+8.1715*T*LN(T)+2*GHSERCU# +GHSERSS#; 6.00000E+03 N ! FUNCTION F10383T 2.98150E+02 +211801.621+24.4989821*T-20.78611*T*LN(T); 6.00000E+03 N ! FUNCTION F10711T 2.98140E+02 +130854.682+30.5267876*T-34.25937*T*LN(T) +.00583824*T**2-1.79746E-06*T**3-33304.895*T**(-1); 7.00000E+02 Y +133769.365-23.7043906*T-25.65337*T*LN(T)-.0042003385*T**2 +2.51694667E-07*T**3-174588.25*T**(-1); 2.20000E+03 Y +140179.423-26.622816*T-25.86682*T*LN(T)-.00276017*T**2 +9.24508333E-08*T**3-3805126*T**(-1); 6.00000E+03 N ! FUNCTION F10784T 2.98140E+02 -9522.9741+78.5273879*T-31.35707*T*LN(T) +.0027589925*T**2-7.46390667E-07*T**3+56582.3*T**(-1); 1.00000E+03 Y +180.108664-15.6128256*T-17.84857*T*LN(T)-.00584168*T**2 +3.14618667E-07*T**3-1280036*T**(-1); 2.10000E+03 Y -18840.1663+92.3120255*T-32.05082*T*LN(T)-.0010728235*T**2 +1.14281783E-08*T**3+3561002.5*T**(-1); 6.00000E+03 N ! FUNCTION F11002T 2.98140E+02 -28637.4628-29.7124458*T-25.37431*T*LN(T) -.012230205*T**2+6.62201E-07*T**3-86459.2*T**(-1); 9.00000E+02 Y -38442.2654+51.1969052*T-36.54058*T*LN(T)-.007461545*T**2 +4.40338167E-07*T**3+1395975*T**(-1); 2.20000E+03 Y -65256.7666+203.938596*T-56.66161*T*LN(T)-6.40182E-04*T**2 +2.14147833E-09*T**3+8250950*T**(-1); 6.00000E+03 N ! FUNCTION F11007T 2.98140E+02 -1716.28163+84.8441289*T-51.37952*T*LN(T) -.00808767*T**2+210246*T**(-1); 1.00000E+03 N ! FUNCTION F14852T 2.98140E+02 +269797.373+2.2810296*T-25.70471*T*LN(T) +.003751372*T**2-5.48887167E-07*T**3+3450.3165*T**(-1); 1.00000E+03 Y +273925.002-38.4958652*T-19.81748*T*LN(T)-2.300353E-04*T**2 -1.18709967E-08*T**3-570436.5*T**(-1); 3.40000E+03 Y +257401.532-.943966729*T-24.05931*T*LN(T)-5.98546E-07*T**2 +2.02961167E-09*T**3+9368165*T**(-1); 1.00000E+04 N ! FUNCTION F14964T 2.98140E+02 +117374.548+2.98629624*T-34.09678*T*LN(T) -.002325464*T**2+1.85480167E-07*T**3+128593.6*T**(-1); 1.00000E+03 Y +117352.438+2.50383325*T-34.04744*T*LN(T)-.0021150245*T**2 +9.16602333E-08*T**3+175718.45*T**(-1); 3.40000E+03 Y +124361.091+14.5182901*T-36.1923*T*LN(T)-5.930925E-04*T**2 -7.54259333E-09*T**3-7484105*T**(-1); 6.00000E+03 N ! FUNCTION F15022T 2.98140E+02 +126744.315+83.8435689*T-52.94561*T*LN(T) -.0043385055*T**2+6.68300333E-07*T**3+276938.3*T**(-1); 1.00000E+03 Y +123958.871+118.720436*T-58.16242*T*LN(T)-7.29079E-06*T**2 +2.42566833E-10*T**3+558805*T**(-1); 6.00000E+03 N ! FUNCTION F15041T 2.98140E+02 +109847.438+203.904963*T-72.67966*T*LN(T) -.009041155*T**2+1.47148883E-06*T**3+505278*T**(-1); 9.00000E+02 Y +104526.08+272.793563*T-83.05028*T*LN(T)-1.828101E-05*T**2 +6.19803333E-10*T**3+1023588.5*T**(-1); 6.00000E+03 N ! FUNCTION F15047T 2.98140E+02 +106276.072+170.263399*T-74.99022*T*LN(T) -.035336475*T**2+5.76872833E-06*T**3+227070.6*T**(-1); 9.00000E+02 Y +75139.8847+544.891054*T-130.537*T*LN(T)+.007879015*T**2 -4.32610333E-07*T**3+3425257*T**(-1); 2.80000E+03 Y +114904.753+339.945759*T-103.9801*T*LN(T)+2.25877E-05*T**2 -7.925025E-10*T**3-7832715*T**(-1); 6.00000E+03 N ! FUNCTION F15052T 2.98140E+02 +57214.7948+523.24074*T-130.1838*T*LN(T) -4.152356E-04*T**2-4.27131667E-07*T**3+779118.5*T**(-1); 1.60000E+03 Y +8925.72335+728.509037*T-155.3363*T*LN(T)+.002031178*T**2 -1.776135E-08*T**3+14908280*T**(-1); 4.20000E+03 Y +43158.7838+657.511854*T-147.3935*T*LN(T)+.0015928905*T**2 -3.34608333E-08*T**3-8046775*T**(-1); 6.00000E+03 N ! FUNCTION F15057T 2.98140E+02 +59623.0027+634.182529*T-153.2939*T*LN(T) -.003102847*T**2+3.66153167E-07*T**3+940068*T**(-1); 1.50000E+03 Y +56671.3245+666.288106*T-157.9591*T*LN(T)-2.441417E-06*T**2 +7.28532E-11*T**3+1284129.5*T**(-1); 6.00000E+03 N ! FUNCTION F15061T 2.98140E+02 +45619.0277+695.996674*T-166.1987*T*LN(T) -.0109886*T**2-1.38875683E-06*T**3+753634*T**(-1); 8.00000E+02 Y +22301.584+822.41812*T-181.0091*T*LN(T)-.020252625*T**2 +3.04543E-06*T**3+4785936*T**(-1); 1.50000E+03 Y +28125.3352+992.470207*T-208.7199*T*LN(T)+.006139635*T**2 -2.57977667E-07*T**3-2943090*T**(-1); 3.90000E+03 Y +82396.4096+766.112131*T-180.3439*T*LN(T)-2.580219E-04*T**2 +5.17172833E-09*T**3-21845450*T**(-1); 6.00000E+03 N ! FUNCTION GCLIQ 2.98150E+02 +117369-24.63*T+GHSERCC#; 6.00000E+03 N ! FUNCTION GPCLIQ 2.98150E+02 +YCLIQ#*EXP(ZCLIQ#); 6.00000E+03 N ! FUNCTION GCRLIQ 2.98140E+02 +24339.955-11.420225*T+2.37615E-21*T**7 +GHSERCR#; 2.18000E+03 Y -16459.984+335.616316*T-50*T*LN(T); 6.00000E+03 N ! FUNCTION GPCRLIQ 2.98150E+02 +YCRLIQ#*EXP(ZCRLIQ#); 6.00000E+03 N ! FUNCTION GFELIQ 2.98140E+02 +12040.17-6.55843*T-3.6751551E-21*T**7 +GHSERFE#; 1.81100E+03 Y -10838.83+291.302*T-46*T*LN(T); 6.00000E+03 N ! FUNCTION GPFELIQ 2.98150E+02 +YFELIQ#*EXP(ZFELIQ#); 6.00000E+03 N ! FUNCTION GMNLIQ 2.98140E+02 +17859.91-12.6208*T-4.41929E-21*T**7 +GHSERMN#; 1.51900E+03 Y +18739.51-13.2288*T-1.656847E+30*T**(-9)+GHSERMN#; 2.00000E+03 N ! FUNCTION GPCRBCC 2.98150E+02 +YCRBCC#*EXP(ZCRBCC#); 6.00000E+03 N ! FUNCTION GHSERCC 2.98150E+02 -17368.441+170.73*T-24.3*T*LN(T) -4.723E-04*T**2+2562600*T**(-1)-2.643E+08*T**(-2)+1.2E+10*T**(-3); 6.00000E+03 N ! FUNCTION GPCGRA 2.98150E+02 +YCGRA#*EXP(ZCGRA#); 6.00000E+03 N ! FUNCTION GPFEBCC 2.98150E+02 +YFEBCC#*EXP(ZFEBCC#); 6.00000E+03 N ! FUNCTION GMNBCC 2.98140E+02 -3235.3+127.85*T-23.7*T*LN(T) -.00744271*T**2+60000*T**(-1); 1.51900E+03 Y -23188.83+307.7043*T-48*T*LN(T)+1.265152E+30*T**(-9); 2.00000E+03 N ! FUNCTION GCRFCC 2.98150E+02 +7284+.163*T+GHSERCR#; 6.00000E+03 N ! FUNCTION GFEFCC 2.98140E+02 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2 +GHSERFE#; 1.81100E+03 Y -1713.815+.94001*T+4.9251E+30*T**(-9)+GHSERFE#; 6.00000E+03 N ! FUNCTION GPFEFCC 2.98150E+02 +YFEFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! FUNCTION GPCFCC 2.98150E+02 +YCFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! FUNCTION GMNFCC 2.98140E+02 -3439.3+131.884*T-24.5177*T*LN(T) -.006*T**2+69600*T**(-1); 1.51900E+03 Y -26070.1+309.6664*T-48*T*LN(T)+3.86196E+30*T**(-9); 2.00000E+03 N ! FUNCTION GPFEHCP 2.98150E+02 +YFEHCP#*EXP(ZFEHCP#); 6.00000E+03 N ! FUNCTION GFECEM 2.98150E+02 -10745+706.04*T-120.6*T*LN(T)+GPCEM1#; 6.00000E+03 N ! FUNCTION GCRM23C6 2.98150E+02 -521983+3622.24*T-620.965*T*LN(T) -.126431*T**2; 6.00000E+03 N ! FUNCTION GFEM23C6 2.98150E+02 +7.666667*GFECEM#-1.666667*GHSERCC#+66920 -40*T; 6.00000E+03 N ! FUNCTION GMNM23C6 2.98150E+02 -308065+50.966*T+23*GHSERMN#+6*GHSERCC#; 6.00000E+03 N ! FUNCTION GCRM3C2 2.98150E+02 -100823.8+530.66989*T-89.6694*T*LN(T) -.0301188*T**2; 6.00000E+03 N ! FUNCTION GCRM7C3 2.98150E+02 -201690+1103.128*T-190.177*T*LN(T) -.0578207*T**2; 6.00000E+03 N ! FUNCTION GS_NIVNI 2.98140E+02 -161645.05+3532.8443*T-671.032*T*LN(T) -.1382502*T**2+4.87E-07*T**3+277840*T**(-1); 7.90000E+02 Y -161794.7+3572.6245*T-678.096*T*LN(T)-.1256082*T**2-2.72E-06*T**3; 1.72800E+03 N ! FUNCTION GS_NIVV 2.98140E+02 -663330.65+4012.7719*T-707.716*T*LN(T) -.1068816*T**2+2.6785E-06*T**3+1528120*T**(-1); 7.90000E+02 Y -664153.72+4231.5628*T-746.568*T*LN(T)-.0373506*T**2-1.496E-05*T**3; 1.72800E+03 N ! FUNCTION GPSIG1 2.98150E+02 +1.09E-04*P; 6.00000E+03 N ! FUNCTION GPSIG2 2.98150E+02 +1.117E-04*P; 6.00000E+03 N ! FUNCTION YCLIQ 2.98150E+02 +VCLIQ#*EXP(-ECLIQ#); 6.00000E+03 N ! FUNCTION ZCLIQ 2.98150E+02 +1*LN(XCLIQ#); 6.00000E+03 N ! FUNCTION YCRLIQ 2.98150E+02 +VCRLIQ#*EXP(-ECRLIQ#); 6.00000E+03 N ! FUNCTION ZCRLIQ 2.98150E+02 +1*LN(XCRLIQ#); 6.00000E+03 N ! FUNCTION YFELIQ 2.98150E+02 +VFELIQ#*EXP(-EFELIQ#); 6.00000E+03 N ! FUNCTION ZFELIQ 2.98150E+02 +1*LN(XFELIQ#); 6.00000E+03 N ! FUNCTION YCRBCC 2.98150E+02 +VCRBCC#*EXP(-ECRBCC#); 6.00000E+03 N ! FUNCTION ZCRBCC 2.98150E+02 +1*LN(XCRBCC#); 6.00000E+03 N ! FUNCTION YCGRA 2.98150E+02 +VCGRA#*EXP(-ECGRA#); 6.00000E+03 N ! FUNCTION ZCGRA 2.98150E+02 +1*LN(XCGRA#); 6.00000E+03 N ! FUNCTION YFEBCC 2.98150E+02 +VFEBCC#*EXP(-EFEBCC#); 6.00000E+03 N ! FUNCTION ZFEBCC 2.98150E+02 +1*LN(XFEBCC#); 6.00000E+03 N ! FUNCTION YFEFCC 2.98150E+02 +VFEFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! FUNCTION ZFEFCC 2.98150E+02 +1*LN(XFEFCC#); 6.00000E+03 N ! FUNCTION YCFCC 2.98150E+02 +VCFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! FUNCTION YFEHCP 2.98150E+02 +VFEHCP#*EXP(-EFEHCP#); 6.00000E+03 N ! FUNCTION ZFEHCP 2.98150E+02 +1*LN(XFEHCP#); 6.00000E+03 N ! FUNCTION GPCEM1 2.98150E+02 +VCEM1#*P; 6.00000E+03 N ! FUNCTION VCLIQ 2.98150E+02 +7.626E-06*EXP(ACLIQ#); 6.00000E+03 N ! FUNCTION ECLIQ 2.98150E+02 +1*LN(CCLIQ#); 6.00000E+03 N ! FUNCTION XCLIQ 2.98150E+02 +1*EXP(.5*DCLIQ#)-1; 6.00000E+03 N ! FUNCTION VCRLIQ 2.98150E+02 +7.653E-06*EXP(ACRLIQ#); 6.00000E+03 N ! FUNCTION ECRLIQ 2.98150E+02 +1*LN(CCRLIQ#); 6.00000E+03 N ! FUNCTION XCRLIQ 2.98150E+02 +1*EXP(.8*DCRLIQ#)-1; 6.00000E+03 N ! FUNCTION VFELIQ 2.98150E+02 +6.46677E-06*EXP(AFELIQ#); 6.00000E+03 N ! FUNCTION EFELIQ 2.98150E+02 +1*LN(CFELIQ#); 6.00000E+03 N ! FUNCTION XFELIQ 2.98150E+02 +1*EXP(.8484467*DFELIQ#)-1; 6.00000E+03 N ! FUNCTION VCRBCC 2.98150E+02 +7.188E-06*EXP(ACRBCC#); 6.00000E+03 N ! FUNCTION ECRBCC 2.98150E+02 +1*LN(CCRBCC#); 6.00000E+03 N ! FUNCTION XCRBCC 2.98150E+02 +1*EXP(.8*DCRBCC#)-1; 6.00000E+03 N ! FUNCTION VCGRA 2.98150E+02 +5.259E-06*EXP(ACGRA#); 6.00000E+03 N ! FUNCTION ECGRA 2.98150E+02 +1*LN(CCGRA#); 6.00000E+03 N ! FUNCTION XCGRA 2.98150E+02 +1*EXP(.9166667*DCGRA#)-1; 6.00000E+03 N ! FUNCTION VFEBCC 2.98150E+02 +7.042095E-06*EXP(AFEBCC#); 6.00000E+03 N ! FUNCTION EFEBCC 2.98150E+02 +1*LN(CFEBCC#); 6.00000E+03 N ! FUNCTION XFEBCC 2.98150E+02 +1*EXP(.7874195*DFEBCC#)-1; 6.00000E+03 N ! FUNCTION VFEFCC 2.98150E+02 +6.688726E-06*EXP(AFEFCC#); 6.00000E+03 N ! FUNCTION EFEFCC 2.98150E+02 +1*LN(CFEFCC#); 6.00000E+03 N ! FUNCTION XFEFCC 2.98150E+02 +1*EXP(.8064454*DFEFCC#)-1; 6.00000E+03 N ! FUNCTION VCFCC 2.98150E+02 +1.031E-05*EXP(ACFCC#); 6.00000E+03 N ! FUNCTION VFEHCP 2.98150E+02 +6.59121E-06*EXP(AFEHCP#); 6.00000E+03 N ! FUNCTION EFEHCP 2.98150E+02 +1*LN(CFEHCP#); 6.00000E+03 N ! FUNCTION XFEHCP 2.98150E+02 +1*EXP(.8064454*DFEHCP#)-1; 6.00000E+03 N ! FUNCTION VCEM1 2.98150E+02 +2.339E-05*EXP(ACEM1#); 6.00000E+03 N ! FUNCTION ACLIQ 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 N ! FUNCTION CCLIQ 2.98150E+02 1.6E-10; 6.00000E+03 N ! FUNCTION DCLIQ 2.98150E+02 +1*LN(BCLIQ#); 6.00000E+03 N ! FUNCTION ACRLIQ 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N ! FUNCTION CCRLIQ 2.98150E+02 3.72E-11; 6.00000E+03 N ! FUNCTION DCRLIQ 2.98150E+02 +1*LN(BCRLIQ#); 6.00000E+03 N ! FUNCTION AFELIQ 2.98150E+02 +1.135E-04*T; 6.00000E+03 N ! FUNCTION CFELIQ 2.98150E+02 +4.22534787E-12+2.71569924E-14*T; 6.00000E+03 N ! FUNCTION DFELIQ 2.98150E+02 +1*LN(BFELIQ#); 6.00000E+03 N ! FUNCTION ACRBCC 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N ! FUNCTION CCRBCC 2.98150E+02 2.08E-11; 6.00000E+03 N ! FUNCTION DCRBCC 2.98150E+02 +1*LN(BCRBCC#); 6.00000E+03 N ! FUNCTION ACGRA 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 N ! FUNCTION CCGRA 2.98150E+02 3.3E-10; 6.00000E+03 N ! FUNCTION DCGRA 2.98150E+02 +1*LN(BCGRA#); 6.00000E+03 N ! FUNCTION AFEBCC 2.98150E+02 +2.3987E-05*T+1.2845E-08*T**2; 6.00000E+03 N ! FUNCTION CFEBCC 2.98150E+02 +2.20949565E-11+2.41329523E-16*T; 6.00000E+03 N ! FUNCTION DFEBCC 2.98150E+02 +1*LN(BFEBCC#); 6.00000E+03 N ! FUNCTION AFEFCC 2.98150E+02 +7.3097E-05*T; 6.00000E+03 N ! FUNCTION CFEFCC 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; 6.00000E+03 N ! FUNCTION DFEFCC 2.98150E+02 +1*LN(BFEFCC#); 6.00000E+03 N ! FUNCTION ACFCC 2.98150E+02 +1.44E-04*T; 6.00000E+03 N ! FUNCTION AFEHCP 2.98150E+02 +7.3646E-05*T; 6.00000E+03 N ! FUNCTION CFEHCP 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; 6.00000E+03 N ! FUNCTION DFEHCP 2.98150E+02 +1*LN(BFEHCP#); 6.00000E+03 N ! FUNCTION ACEM1 2.98150E+02 -1.36E-05*T+4E-08*T**2; 6.00000E+03 N ! FUNCTION BCLIQ 2.98150E+02 +1+3.2E-10*P; 6.00000E+03 N ! FUNCTION BCRLIQ 2.98150E+02 +1+4.65E-11*P; 6.00000E+03 N ! FUNCTION BFELIQ 2.98150E+02 +1+4.98009787E-12*P+3.20078924E-14*T*P; 6.00000E+03 N ! FUNCTION BCRBCC 2.98150E+02 +1+2.6E-11*P; 6.00000E+03 N ! FUNCTION BCGRA 2.98150E+02 +1+3.6E-10*P; 6.00000E+03 N ! FUNCTION BFEBCC 2.98150E+02 +1+2.80599565E-11*P+3.06481523E-16*T*P; 6.00000E+03 N ! FUNCTION BFEFCC 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; 6.00000E+03 N ! FUNCTION BFEHCP 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; 6.00000E+03 N ! FUNCTION UN_ASS 298.15 0; 300 N ! TYPE_DEFINITION % SEQ *! DEFINE_SYSTEM_DEFAULT SPECIE 2 ! DEFAULT_COMMAND DEF_SYS_ELEMENT VA ! PHASE LIQUID:L % 1 1.0 ! CONSTITUENT LIQUID:L :C,CR,FE,MN : ! PARAMETER G(LIQUID,C;0) 2.98150E+02 +GCLIQ#+GPCLIQ#; 6.00000E+03 N REF:279 ! PARAMETER G(LIQUID,CR;0) 2.98150E+02 +GCRLIQ#+GPCRLIQ#; 6.00000E+03 N REF:279 ! PARAMETER G(LIQUID,FE;0) 2.98150E+02 +GFELIQ#+GPFELIQ#; 6.00000E+03 N REF:279 ! PARAMETER G(LIQUID,MN;0) 2.98140E+02 +GMNLIQ#; 2.00000E+03 N REF:279 ! PARAMETER G(LIQUID,C,CR;0) 2.98150E+02 -90526-25.9116*T; 6.00000E+03 N REF:97 ! PARAMETER G(LIQUID,C,CR;1) 2.98150E+02 80000; 6.00000E+03 N REF:97 ! PARAMETER G(LIQUID,C,CR;2) 2.98150E+02 80000; 6.00000E+03 N REF:97 ! PARAMETER G(LIQUID,C,CR,FE;0) 2.98150E+02 -514037; 6.00000E+03 N REF:322 ! PARAMETER G(LIQUID,C,CR,FE;1) 2.98150E+02 73286; 6.00000E+03 N REF:322 ! PARAMETER G(LIQUID,C,CR,FE;2) 2.98150E+02 66921; 6.00000E+03 N REF:322 ! PARAMETER G(LIQUID,C,FE;0) 2.98150E+02 -124320+28.5*T; 6.00000E+03 N REF:186 ! PARAMETER G(LIQUID,C,FE;1) 2.98150E+02 19300; 6.00000E+03 N REF:186 ! PARAMETER G(LIQUID,C,FE;2) 2.98150E+02 +49260-19*T; 6.00000E+03 N REF:186 ! PARAMETER G(LIQUID,C,FE,MN;0) 2.98150E+02 -45675; 6.00000E+03 N REF:263 ! PARAMETER G(LIQUID,C,FE,MN;1) 2.98150E+02 -12379; 6.00000E+03 N REF:263 ! PARAMETER G(LIQUID,C,FE,MN;2) 2.98150E+02 -12379; 6.00000E+03 N REF:263 ! PARAMETER G(LIQUID,C,MN;0) 2.98150E+02 -168240+35.635*T; 6.00000E+03 N REF:263 ! PARAMETER G(LIQUID,C,MN;1) 2.98150E+02 -91760+50*T; 6.00000E+03 N REF:263 ! PARAMETER G(LIQUID,CR,FE;0) 2.98150E+02 -17737+7.996546*T; 6.00000E+03 N REF:322 ! PARAMETER G(LIQUID,CR,FE;1) 2.98150E+02 -1331; 6.00000E+03 N REF:322 ! PARAMETER G(LIQUID,CR,FE,MN;0) 2.98150E+02 2378; 6.00000E+03 N REF:323 ! PARAMETER G(LIQUID,CR,MN;0) 2.98150E+02 -15009+13.6587*T; 6.00000E+03 N REF:323 ! PARAMETER G(LIQUID,CR,MN;1) 2.98150E+02 +504+.9479*T; 6.00000E+03 N REF:323 ! PARAMETER G(LIQUID,FE,MN;0) 2.98150E+02 -3950+.489*T; 6.00000E+03 N REF:257 ! PARAMETER G(LIQUID,FE,MN;1) 2.98150E+02 1145; 6.00000E+03 N REF:257 ! TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! PHASE BCC_A2 %& 2 1 3 ! CONSTITUENT BCC_A2 :CR%,FE%,MN : C,VA% : ! PARAMETER G(BCC_A2,CR:C;0) 2.98150E+02 +GHSERCR#+3*GHSERCC#+GPCRBCC# +3*GPCGRA#+416000; 6.00000E+03 N REF:97 ! PARAMETER TC(BCC_A2,CR:C;0) 2.98150E+02 -311.5; 6.00000E+03 N REF:97 ! PARAMETER BMAGN(BCC_A2,CR:C;0) 2.98150E+02 -.008; 6.00000E+03 N REF:97 ! PARAMETER G(BCC_A2,FE:C;0) 2.98150E+02 +GHSERFE#+GPFEBCC#+3*GHSERCC# +3*GPCGRA#+322050+75.667*T; 6.00000E+03 N REF:186 ! PARAMETER TC(BCC_A2,FE:C;0) 2.98150E+02 1043; 6.00000E+03 N REF:186 ! PARAMETER BMAGN(BCC_A2,FE:C;0) 2.98150E+02 2.22; 6.00000E+03 N REF:186 ! PARAMETER G(BCC_A2,MN:C;0) 2.98150E+02 +10000+30*T+GHSERMN#+3*GHSERCC#; 6.00000E+03 N REF:263 ! PARAMETER G(BCC_A2,CR:VA;0) 2.98150E+02 +GHSERCR#+GPCRBCC#; 6.00000E+03 N REF:279 ! PARAMETER TC(BCC_A2,CR:VA;0) 2.98150E+02 -311.5; 6.00000E+03 N REF:277 ! PARAMETER BMAGN(BCC_A2,CR:VA;0) 2.98150E+02 -.008; 6.00000E+03 N REF:277 ! PARAMETER G(BCC_A2,FE:VA;0) 2.98150E+02 +GHSERFE#+GPFEBCC#; 6.00000E+03 N REF:279 ! PARAMETER TC(BCC_A2,FE:VA;0) 2.98150E+02 1043; 6.00000E+03 N REF:277 ! PARAMETER BMAGN(BCC_A2,FE:VA;0) 2.98150E+02 2.22; 6.00000E+03 N REF:277 ! PARAMETER G(BCC_A2,MN:VA;0) 2.98150E+02 +GMNBCC#; 6.00000E+03 N REF:279 ! PARAMETER TC(BCC_A2,MN:VA;0) 2.98140E+02 -580; 2.00000E+03 N REF:277 ! PARAMETER BMAGN(BCC_A2,MN:VA;0) 2.98140E+02 -.27; 2.00000E+03 N REF:277 ! PARAMETER G(BCC_A2,CR,FE:C;0) 2.98150E+02 -1250000+667.7*T; 6.00000E+03 N REF:314 ! PARAMETER BMAGN(BCC_A2,CR,FE:C;0) 2.98150E+02 -.85; 6.00000E+03 N REF:98 ! PARAMETER TC(BCC_A2,CR,FE:C;0) 2.98150E+02 1650; 6.00000E+03 N REF:98 ! PARAMETER TC(BCC_A2,CR,FE:C;1) 2.98150E+02 550; 6.00000E+03 N REF:98 ! PARAMETER G(BCC_A2,CR,MN:C;0) 2.98150E+02 -20328+18.7339*T; 6.00000E+03 N REF:324 ! PARAMETER G(BCC_A2,CR,MN:C;1) 2.98150E+02 -9162+4.4183*T; 6.00000E+03 N REF:324 ! PARAMETER G(BCC_A2,CR:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N REF:97 ! PARAMETER G(BCC_A2,FE,MN:C;0) 2.98150E+02 +34052-23.467*T; 6.00000E+03 N REF:263 ! PARAMETER G(BCC_A2,FE:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N REF:186 ! PARAMETER G(BCC_A2,CR,FE:VA;0) 2.98150E+02 +20500-9.68*T; 6.00000E+03 N REF:103 ! PARAMETER BMAGN(BCC_A2,CR,FE:VA;0) 2.98150E+02 -.85; 6.00000E+03 N REF:103 ! PARAMETER TC(BCC_A2,CR,FE:VA;0) 2.98150E+02 1650; 6.00000E+03 N REF:103 ! PARAMETER TC(BCC_A2,CR,FE:VA;1) 2.98150E+02 550; 6.00000E+03 N REF:103 ! PARAMETER G(BCC_A2,CR,FE,MN:VA;0) 2.98150E+02 -5996; 6.00000E+03 N REF:323 ! PARAMETER G(BCC_A2,CR,MN:VA;0) 2.98150E+02 -20328+18.7339*T; 6.00000E+03 N REF:323 ! PARAMETER G(BCC_A2,CR,MN:VA;1) 2.98150E+02 -9162+4.4183*T; 6.00000E+03 N REF:323 ! PARAMETER BMAGN(BCC_A2,CR,MN:VA;0) 2.98150E+02 .48643; 6.00000E+03 N REF:323 ! PARAMETER BMAGN(BCC_A2,CR,MN:VA;2) 2.98150E+02 -.72035; 6.00000E+03 N REF:323 ! PARAMETER BMAGN(BCC_A2,CR,MN:VA;4) 2.98150E+02 -1.93265; 6.00000E+03 N REF:323 ! PARAMETER TC(BCC_A2,CR,MN:VA;0) 2.98150E+02 -1325; 6.00000E+03 N REF:323 ! PARAMETER TC(BCC_A2,CR,MN:VA;2) 2.98150E+02 -1133; 6.00000E+03 N REF:323 ! PARAMETER TC(BCC_A2,CR,MN:VA;4) 2.98150E+02 -10294; 6.00000E+03 N REF:323 ! PARAMETER TC(BCC_A2,CR,MN:VA;6) 2.98150E+02 26706; 6.00000E+03 N REF:323 ! PARAMETER G(BCC_A2,FE,MN:VA;0) 2.98150E+02 -2759+1.237*T; 6.00000E+03 N REF:257 ! PARAMETER TC(BCC_A2,FE,MN:VA;0) 2.98150E+02 123; 6.00000E+03 N REF:257 ! PHASE CEMENTITE % 2 3 1 ! CONSTITUENT CEMENTITE :CR,FE%,MN : C : ! PARAMETER G(CEMENTITE,CR:C;0) 2.98150E+02 +3*GHSERCR#+GHSERCC#-48000 -9.2888*T; 6.00000E+03 N REF:314 ! PARAMETER G(CEMENTITE,FE:C;0) 2.98150E+02 +GFECEM#; 6.00000E+03 N REF:186 ! PARAMETER G(CEMENTITE,MN:C;0) 2.98150E+02 -40379+3.524*T+3*GHSERMN# +GHSERCC#; 6.00000E+03 N REF:263 ! PARAMETER G(CEMENTITE,CR,FE:C;0) 2.98150E+02 +25278-17.5*T; 6.00000E+03 N REF:314 ! PARAMETER G(CEMENTITE,CR,MN:C;0) 2.98150E+02 9000; 6.00000E+03 N REF:324 ! PARAMETER G(CEMENTITE,FE,MN:C;0) 2.98150E+02 +10434-14.281*T; 6.00000E+03 N REF:263 ! PHASE CR3MN5 % 2 3 5 ! CONSTITUENT CR3MN5 :CR : MN : ! PARAMETER G(CR3MN5,CR:MN;0) 2.98150E+02 +3*GHSERCR#+5*GHSERMN#-72550 +21.1732*T; 6.00000E+03 N REF:323 ! TYPE_DEFINITION ( GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! PHASE FCC_A1 %( 2 1 1 ! CONSTITUENT FCC_A1 :CR,FE%,MN : C,VA% : ! PARAMETER G(FCC_A1,CR:C;0) 2.98150E+02 +GHSERCR#+GHSERCC#+1200-1.94*T; 6.00000E+03 N REF:314 ! PARAMETER G(FCC_A1,FE:C;0) 2.98150E+02 +77207-15.877*T+GFEFCC#+GHSERCC# +GPCFCC#; 6.00000E+03 N REF:186 ! PARAMETER TC(FCC_A1,FE:C;0) 2.98150E+02 -201; 6.00000E+03 N REF:186 ! PARAMETER BMAGN(FCC_A1,FE:C;0) 2.98150E+02 -2.1; 6.00000E+03 N REF:186 ! PARAMETER G(FCC_A1,MN:C;0) 2.98150E+02 +502+15.261*T+GHSERMN#+GHSERCC#; 6.00000E+03 N REF:263 ! PARAMETER G(FCC_A1,CR:VA;0) 2.98150E+02 +GCRFCC#+GPCRBCC#; 6.00000E+03 N REF:277 ! PARAMETER TC(FCC_A1,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N REF:277 ! PARAMETER BMAGN(FCC_A1,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N REF:277 ! PARAMETER G(FCC_A1,FE:VA;0) 2.98150E+02 +GFEFCC#+GPFEFCC#; 6.00000E+03 N REF:279 ! PARAMETER TC(FCC_A1,FE:VA;0) 2.98150E+02 -201; 6.00000E+03 N REF:277 ! PARAMETER BMAGN(FCC_A1,FE:VA;0) 2.98150E+02 -2.1; 6.00000E+03 N REF:277 ! PARAMETER G(FCC_A1,MN:VA;0) 2.98150E+02 +GMNFCC#; 6.00000E+03 N REF:279 ! PARAMETER TC(FCC_A1,MN:VA;0) 2.98140E+02 -1620; 2.00000E+03 N REF:277 ! PARAMETER BMAGN(FCC_A1,MN:VA;0) 2.98140E+02 -1.86; 2.00000E+03 N REF:277 ! PARAMETER G(FCC_A1,CR,FE:C;0) 2.98150E+02 -74319+3.2353*T; 6.00000E+03 N REF:314 ! PARAMETER G(FCC_A1,CR,MN:C;0) 2.98150E+02 -19088+17.5423*T; 6.00000E+03 N REF:324 ! PARAMETER G(FCC_A1,CR:C,VA;0) 2.98150E+02 -11977+6.8194*T; 6.00000E+03 N REF:314 ! PARAMETER G(FCC_A1,FE,MN:C;0) 2.98150E+02 +34052-23.467*T; 6.00000E+03 N REF:263 ! PARAMETER G(FCC_A1,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N REF:186 ! PARAMETER G(FCC_A1,MN:C,VA;0) 2.98150E+02 -43433; 6.00000E+03 N REF:263 ! PARAMETER G(FCC_A1,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; 6.00000E+03 N REF:103 ! PARAMETER G(FCC_A1,CR,FE:VA;1) 2.98150E+02 1410; 6.00000E+03 N REF:103 ! PARAMETER G(FCC_A1,CR,FE,MN:VA;0) 2.98150E+02 +6715-10.3933*T; 6.00000E+03 N REF:323 ! PARAMETER G(FCC_A1,CR,MN:VA;0) 2.98150E+02 -19088+17.5423*T; 6.00000E+03 N REF:323 ! PARAMETER G(FCC_A1,FE,MN:VA;0) 2.98150E+02 -7762+3.865*T; 6.00000E+03 N REF:257 ! PARAMETER G(FCC_A1,FE,MN:VA;1) 2.98150E+02 -259; 6.00000E+03 N REF:257 ! PARAMETER TC(FCC_A1,FE,MN:VA;0) 2.98150E+02 -2282; 6.00000E+03 N REF:257 ! PARAMETER TC(FCC_A1,FE,MN:VA;1) 2.98150E+02 -2068; 6.00000E+03 N REF:257 ! PHASE M23C6 % 3 20 3 6 ! CONSTITUENT M23C6 :CR%,FE%,MN : CR%,FE%,MN : C : ! PARAMETER G(M23C6,CR:CR:C;0) 2.98150E+02 +GCRM23C6#; 6.00000E+03 N REF:97 ! PARAMETER G(M23C6,FE:CR:C;0) 2.98150E+02 +.130435*GCRM23C6# +.869565*GFEM23C6#; 6.00000E+03 N REF:98 ! PARAMETER G(M23C6,MN:CR:C;0) 2.98150E+02 +.869565*GMNM23C6# +.130435*GCRM23C6#; 6.00000E+03 N REF:324 ! PARAMETER G(M23C6,CR:FE:C;0) 2.98150E+02 +.869565*GCRM23C6# +.130435*GFEM23C6#; 6.00000E+03 N REF:98 ! PARAMETER G(M23C6,FE:FE:C;0) 2.98150E+02 +GFEM23C6#; 6.00000E+03 N REF:98 ! PARAMETER G(M23C6,MN:FE:C;0) 2.98150E+02 +.869565*GMNM23C6# +.130435*GFEM23C6#; 6.00000E+03 N REF:263 ! PARAMETER G(M23C6,CR:MN:C;0) 2.98150E+02 +.869565*GCRM23C6# +.130435*GMNM23C6#; 6.00000E+03 N REF:324 ! PARAMETER G(M23C6,FE:MN:C;0) 2.98150E+02 +.869565*GFEM23C6# +.130435*GMNM23C6#; 6.00000E+03 N REF:263 ! PARAMETER G(M23C6,MN:MN:C;0) 2.98150E+02 +GMNM23C6#; 6.00000E+03 N REF:263 ! PARAMETER G(M23C6,CR,FE:CR:C;0) 2.98150E+02 -205342+141.6667*T; 6.00000E+03 N REF:314 ! PARAMETER G(M23C6,CR,MN:CR:C;0) 2.98150E+02 -173680+160*T; 6.00000E+03 N REF:324 ! PARAMETER G(M23C6,CR,MN:CR:C;1) 2.98150E+02 -286614; 6.00000E+03 N REF:324 ! PARAMETER G(M23C6,FE,MN:CR,FE:C;0) 2.98150E+02 -100000; 6.00000E+03 N REF:324 ! PARAMETER G(M23C6,FE,MN:CR,MN:C;0) 2.98150E+02 -100000; 6.00000E+03 N REF:324 ! PARAMETER G(M23C6,CR,FE:FE:C;0) 2.98150E+02 -205342+141.6667*T; 6.00000E+03 N REF:314 ! PARAMETER G(M23C6,CR,MN:FE:C;0) 2.98150E+02 -173680+160*T; 6.00000E+03 N REF:324 ! PARAMETER G(M23C6,CR,MN:FE:C;1) 2.98150E+02 -286614; 6.00000E+03 N REF:324 ! PARAMETER G(M23C6,FE,MN:FE,MN:C;0) 2.98150E+02 -100000; 6.00000E+03 N REF:263 ! PARAMETER G(M23C6,CR,FE:MN:C;0) 2.98150E+02 -205342+141.6667*T; 6.00000E+03 N REF:324 ! PARAMETER G(M23C6,CR,MN:MN:C;0) 2.98150E+02 -173680+160*T; 6.00000E+03 N REF:324 ! PARAMETER G(M23C6,CR,MN:MN:C;1) 2.98150E+02 -286614; 6.00000E+03 N REF:324 ! PHASE M3C2 % 2 3 2 ! CONSTITUENT M3C2 :CR : C : ! PARAMETER G(M3C2,CR:C;0) 2.98150E+02 +GCRM3C2#; 6.00000E+03 N REF:314 ! PHASE M5C2 % 2 5 2 ! CONSTITUENT M5C2 :FE,MN : C : ! PARAMETER G(M5C2,FE:C;0) 2.98150E+02 +5*GHSERFE#+2*GHSERCC#+54852 -33.7518*T; 6.00000E+03 N REF:314 ! PARAMETER G(M5C2,MN:C;0) 2.98150E+02 -76849+8.517*T+5*GHSERMN# +2*GHSERCC#; 6.00000E+03 N REF:263 ! PARAMETER G(M5C2,FE,MN:C;0) 2.98150E+02 -42056+3.5*T; 6.00000E+03 N REF:314 ! PHASE M7C3 % 2 7 3 ! CONSTITUENT M7C3 :CR%,FE,MN : C : ! PARAMETER G(M7C3,CR:C;0) 2.98150E+02 +GCRM7C3#; 6.00000E+03 N REF:314 ! PARAMETER G(M7C3,FE:C;0) 2.98150E+02 +7*GHSERFE#+3*GHSERCC#+75000 -48.2168*T; 6.00000E+03 N REF:314 ! PARAMETER G(M7C3,MN:C;0) 2.98150E+02 -111765+13.092*T+7*GHSERMN# +3*GHSERCC#; 6.00000E+03 N REF:263 ! PARAMETER G(M7C3,CR,FE:C;0) 2.98150E+02 -4520-10*T; 6.00000E+03 N REF:314 ! PARAMETER G(M7C3,CR,MN:C;0) 2.98150E+02 +72737-56.4964*T; 6.00000E+03 N REF:324 ! PARAMETER G(M7C3,FE,MN:C;0) 2.98150E+02 -43057+4.0625*T; 6.00000E+03 N REF:314 ! LIST_OF_REFERENCES NUMBER SOURCE 279 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 Rev. August 1990' 97 'J-O Andersson, Calphad Vol 11 (1987) p 271-276, TRITA 0314; C-CR' 322 'Byeong-Joo Lee, Calphad (1993), revison of Fe-Cr Fe-Ni liquid' 186 'P. Gustafson, Scan. J. Metall. vol 14, (1985) p 259-267 TRITA 0237 (1984); C-FE' 263 'W. Huang, Metall. Trans. Vol 21A(1990) p 2115-2123, TRITA-MAC 411 (Rev 1989); C-FE-MN' 323 'Byeong-Joo Lee, Metall. Trans. 24A (1993) 1919-1933; Cr-Mn Fe-Cr-Mn' 257 'W. Huang, Calphad Vol 13 (1989) pp 243-252, TRITA-MAC 388 (rev 1989); FE-MN' 277 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 September 1989' 314 'Byeong-Joo Lee, unpublished revision (1991); C-Cr-Fe-Ni' 98 'J-O Andersson, Met. Trans A, Vol 19A, (1988) p 627-636 TRITA 0207 (1986); C-CR-FE' 324 'Byeong-Joo Lee, Metall. Trans. 24A (1993) 1017-1025; Fe-Cr-Mn-C' 103 'J-O Andersson, B. Sundman, CALPHAD Vol 11, (1987), p 83-92 TRITA 0270 (1986); CR-FE' 338 'Caian Qiu, ISIJ International 32 (1992) 1117-1127; C-Cr-Fe-Mo' 203 'P. Gustafson, Metall. Trans. 19A(1988) p 2547-2554, TRITA-MAC 348, (1987); C-CR-FE-W' 122 'K. Frisk, Metall. Trans. Vol 21A (1990) p 2477-2488, TRITA 0409 (1989); CR-FE-N' 341 'Caian Qiu, Metall. Trans. A, 24A (1993) 2393-2409; Cr-Fe-Mn-N' 342 'K. Frisk, Calphad 17 (1993) 335-349; Cr-Mn-N' 325 'Byeong-Joo Lee, KRISS, unpublished research, during 1993-1995' ! ================================================ FILE: examples/TQ4lib/Cpp/Matthias/FENI.TDB ================================================ $ Database file written 2014- 1-15 $ From database: SSOL2 ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! ELEMENT NI FCC_A1 5.8690E+01 4.7870E+03 2.9796E+01! FUNCTION GFELIQ 298.15 +12040.17-6.55843*T-3.6751551E-21*T**7 +GHSERFE#; 1.81100E+03 Y -10839.7+291.302*T-46*T*LN(T); 6000 N ! FUNCTION GHSERFE 298.15 +1225.7+124.134*T-23.5143*T*LN(T) -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6000 N ! FUNCTION GNIBCC 298.15 +8715.084-3.556*T+GHSERNI#; 6000 N ! FUNCTION GFEFCC 298.15 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2 +GHSERFE#; 1.81100E+03 Y -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6000 N ! FUNCTION GHSERNI 298.15 -5179.159+117.854*T-22.096*T*LN(T) -.0048407*T**2; 1.72800E+03 Y -27840.655+279.135*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 3.00000E+03 N ! FUNCTION GPFELIQ 298.15 7E-6*P; 6000 N ! FUNCTION GPFEFCC 298.15 5E-6*P; 6000 N ! FUNCTION GPFEBCC 298.15 6E-6*P; 6000 N ! FUNCTION GPNILIQ 298.15 8E-6*P; 6000 N ! FUNCTION GPNIFCC 298.15 6E-6*P; 6000 N ! FUNCTION GPNIBCC 298.15 7E-6*P; 6000 N ! $ this is 1/RT FUNCTION IQRT 298.15 0.12027167*T**(-1); 6000 N ! TYPE_DEFINITION % SEQ *! DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! PHASE LIQUID:L % 1 1.0 ! CONSTITUENT LIQUID:L :FE,NI : ! PARAMETER G(LIQUID,FE;0) 298.15 +GFELIQ#+GPFELIQ#; 6000 N REF283 ! PARAMETER G(LIQUID,NI;0) 298.15 +11235.527+108.457*T -22.096*T*LN(T)-.0048407*T**2-3.82318E-21*T**7+GPNILIQ; 1.72800E+03 Y -9549.775+268.598*T-43.1*T*LN(T)+GPNILIQ; 3.00000E+03 N REF283 ! PARAMETER G(LIQUID,FE,NI;0) 298.15 -18378.86+6.03912*T; 6000 N REF158 ! PARAMETER G(LIQUID,FE,NI;1) 298.15 +9228.1-3.54642*T; 6000 N REF158 ! $ LN(mobilities) PARAMETER MQ&FE(LIQUID,FE;0) 298.15 -10000*IQRT-18; 6000 N BOS ! PARAMETER MQ&FE(LIQUID,NI;0) 298.15 -12000*IQRT-19; 6000 N BOS ! PARAMETER MQ&NI(LIQUID,NI;0) 298.15 -11000*IQRT-18; 6000 N BOS ! PARAMETER MQ&NI(LIQUID,FE;0) 298.15 -13000*IQRT-19; 6000 N BOS ! TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! $ PHASE BCC_A2 %& 2 1 3 ! $ CONSTITUENT BCC_A2 :FE%,NI : VA% : ! PARAMETER G(BCC_A2,FE:VA;0) 298.15 +GHSERFE#+GPFEBCC#; 6000 N REF283 ! PARAMETER TC(BCC_A2,FE:VA;0) 298.15 1043; 6000 N REF281 ! PARAMETER BMAGN(BCC_A2,FE:VA;0) 298.15 2.22; 6000 N REF281 ! PARAMETER G(BCC_A2,NI:VA;0) 298.15 +GNIBCC#+GPNIBCC; 3000 N REF283 ! PARAMETER TC(BCC_A2,NI:VA;0) 298.15 575; 6000 N REF281 ! PARAMETER BMAGN(BCC_A2,NI:VA;0) 298.15 .85; 6000 N REF281 ! PARAMETER G(BCC_A2,FE,NI:VA;0) 298.15 -956.63-1.28726*T; 6000 N REF158 ! PARAMETER G(BCC_A2,FE,NI:VA;1) 298.15 +1789.03-1.92912*T; 6000 N REF158 ! $ LN(mobilities) PARAMETER MQ&FE(BCC_A2,FE:VA;0) 298.15 -20000*IQRT-24; 6000 N BOS ! PARAMETER MQ&FE(BCC_A2,NI:VA;0) 298.15 -22000*IQRT-24; 6000 N BOS ! PARAMETER MQ&NI(BCC_A2,NI:VA;0) 298.15 -25000*IQRT-25; 6000 N BOS ! PARAMETER MQ&NI(BCC_A2,FE:VA;0) 298.15 -28000*IQRT-25; 6000 N BOS ! TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! PHASE FCC_A1 %' 2 1 1 ! CONSTITUENT FCC_A1 :FE%,NI% : VA% : ! PARAMETER G(FCC_A1,FE:VA;0) 298.15 +GFEFCC#+GPFEFCC#; 6000 N REF283 ! PARAMETER TC(FCC_A1,FE:VA;0) 298.15 -201; 6000 N REF281 ! PARAMETER BMAGN(FCC_A1,FE:VA;0) 298.15 -2.1; 6000 N REF281 ! PARAMETER G(FCC_A1,NI:VA;0) 298.15 +GHSERNI#+GPNIFCC; 3000 N REF283 ! PARAMETER TC(FCC_A1,NI:VA;0) 298.15 633; 6000 N REF281 ! PARAMETER BMAGN(FCC_A1,NI:VA;0) 298.15 .52; 6000 N REF281 ! PARAMETER G(FCC_A1,FE,NI:VA;0) 298.15 -12054.355+3.27413*T; 6000 N REF158 ! PARAMETER G(FCC_A1,FE,NI:VA;1) 298.15 +11082.1315-4.45077*T; 6000 N REF158 ! PARAMETER G(FCC_A1,FE,NI:VA;2) 298.15 -725.805174; 6000 N REF158 ! PARAMETER TC(FCC_A1,FE,NI:VA;0) 298.15 2133; 6000 N REF158 ! PARAMETER TC(FCC_A1,FE,NI:VA;1) 298.15 -682; 6000 N REF158 ! PARAMETER BMAGN(FCC_A1,FE,NI:VA;0) 298.15 9.55; 6000 N REF158 ! PARAMETER BMAGN(FCC_A1,FE,NI:VA;1) 298.15 7.23; 6000 N REF158 ! PARAMETER BMAGN(FCC_A1,FE,NI:VA;2) 298.15 5.93; 6000 N REF158 ! PARAMETER BMAGN(FCC_A1,FE,NI:VA;3) 298.15 6.18; 6000 N REF158 ! $ LN(mobilities) PARAMETER MQ&FE(FCC_A1,FE:VA;0) 298.15 -30000*IQRT-30; 6000 N BOS ! PARAMETER MQ&FE(FCC_A1,NI:VA;0) 298.15 -32000*IQRT-32; 6000 N BOS ! PARAMETER MQ&NI(FCC_A1,NI:VA;0) 298.15 -33000*IQRT-32; 6000 N BOS ! PARAMETER MQ&NI(FCC_A1,FE:VA;0) 298.15 -25000*IQRT-31; 6000 N BOS ! LIST_OF_REFERENCES NUMBER SOURCE REF283 'Alan Dinsdale, SGTE Data for Pure Elements, Calphad Vol 15(1991) p 317-425, also in NPL Report DMA(A)195 Rev. August 1990' REF158 'A. Dinsdale, T. Chart, MTDS NPL, unpublished work (1986); FE-NI' REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 September 1989' BOS 'Invented mobilities and molar volumes' ! ================================================ FILE: examples/TQ4lib/Cpp/Matthias/Makefile ================================================ EXE=cpptest LIBS=../../.. CFLAGS=-lstdc++ #UNCOMMENT THE NEXT LINE IF YOU WANT TO COMPILE OPENCALPHAD IN PARALLEL #CFLAGS+=-fopenmp #==============================================================================# #Available compilation flags: all, clean .PHONY : all clean #Compiles OpenCalphad's OCASI examples as standalone binary executable #software. all: make $(EXE) #Removes all binary files that were created in the compiling step. clean: rm -f *.o *.mod $(EXE) #==============================================================================# $(EXE): $(OBJS) g++ -o $(EXE) $(CFLAGS) $(EXE).cpp -L$(LIBS) ../../../liboctq-isoc.a -lgfortran -lm g++ -c -I../.. $(EXE).cpp ================================================ FILE: examples/TQ4lib/Cpp/Matthias/Makefile-parallel ================================================ OBJS=liboctq.o liboctqisoc.o EXE=tqintf LIBS=../.. .PHONY : all clean all: make $(EXE) clean: rm -f *.o *.mod $(EXE) liboctq.o: ../liboctq.F90 gfortran -c -g -fbounds-check -finit-local-zero -I$(LIBS) ../liboctq.F90 liboctqisoc.o: ../isoC/liboctqisoc.F90 gfortran -c -g -fbounds-check -finit-local-zero -I$(LIBS) ../isoC/liboctqisoc.F90 $(EXE): $(OBJS) gcc -o $(EXE) -fopenmp -lstdc++ $(EXE).cpp liboctqisoc.o liboctq.o ../../liboceq.a -lgfortran -lm gcc -c -I../.. $(EXE).cpp ================================================ FILE: examples/TQ4lib/Cpp/Matthias/OC-isoC.h ================================================ #if !defined __OCASI__ #define __OCASI__ /* Modification history 160829 Bo Sundman Update 2015-2016 Matthias Stratmann and Cristophe Sigli Modifications 2014 Teslos? First version This contains the structure of TYPE variables in OC needed for the OC/TQ OCASI interface NOTE there is also a c_gtp_equilibrium_data structure defined in liboctqisoc.F90 */ typedef struct { int forcenewcalc; double tpused[2]; double results[6]; } tpfun_parres; typedef struct { int splink, phlink, status; char refstate[16]; int *endmember; double tpref[2]; double chempot[2]; double mass, molat; } gtp_components; typedef struct { int lokph, compset, ixphase, lokvares, nextcs; } gtp_phasetuple; typedef struct { int statevarid, norm, unit, phref, argtyp; int phase, compset, component, constituent; double coeff; int oldstv; } gtp_state_variable; typedef struct { int latd, ndd, tnoofxfr, tnoofyfr, varreslink, totdis; char id; double *dsites; int *nooffr; int *splink; int *y2x; double *dxidyj; double fsites; } gtp_fraction_set; //struct gtp_fraction_set; typedef struct { int nextfree, phlink, status2, phstate,phtupx; double abnorm[3]; char prefix[4], suffix[4]; int *constat; double *yfr; double *mmyfr; double *sites; double *dpqdy; double *d2pqdvay; //struct gtp_fraction_set disfra; double amfu, netcharge, dgm; int nprop; int *listprop; double **gval; double ***dgval; double **d2gval; double curlat[3][3]; double **cinvy; double *cxmol; double **cdxmol; } gtp_phase_varres; typedef struct gtp_condition { int noofterms, statev, active, iunit, nid, iref, seqz, experimenttype; int symlink1, symlink2; int **indices; double *condcoeff; double *prescribed, current, uncertainity; // should this be a struct ?? gtp_state_variable *statvar; struct gtp_condition *next, *previous; } gtp_condition; typedef struct { int status, multiuse, eqno, next; char eqname[24], comment[72]; double tpval[2], rtn; double weight; double *svfunres; gtp_condition *lastcondition, *lastexperiment; gtp_components *complist; double **compstoi, **invcompstoi; gtp_phase_varres *phase_varres; tpfun_parres *eq_tpres; double *cmuval; double xconv; double gmindif; int maxiter; char eqextra[80]; int sysmatdim, nfixmu, nfixph; int *fixmu; int *fixph; double **savesysmat; } gtp_equilibrium_data; #endif ================================================ FILE: examples/TQ4lib/Cpp/Matthias/crfe/crfe.TDB ================================================ $ Database file written 2012- 9- 7 $ From database: SSOL2 ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01! ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T) +.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2.18000E+03 Y -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6.00000E+03 N ! FUNCTION GPCRLIQ 2.98150E+02 +YCRLIQ#*EXP(ZCRLIQ#); 6.00000E+03 N ! FUNCTION GFELIQ 2.98150E+02 +12040.17-6.55843*T-3.6751551E-21*T**7 +GHSERFE#; 1.81100E+03 Y -10839.7+291.302*T-46*T*LN(T); 6.00000E+03 N ! FUNCTION GPFELIQ 2.98150E+02 +YFELIQ#*EXP(ZFELIQ#); 6.00000E+03 N ! FUNCTION GPCRBCC 2.98150E+02 +YCRBCC#*EXP(ZCRBCC#); 6.00000E+03 N ! FUNCTION GHSERFE 2.98150E+02 +1225.7+124.134*T-23.5143*T*LN(T) -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6.00000E+03 N ! FUNCTION GPFEBCC 2.98150E+02 +YFEBCC#*EXP(ZFEBCC#); 6.00000E+03 N ! FUNCTION GCRFCC 2.98150E+02 +7284+.163*T+GHSERCR#; 6.00000E+03 N ! FUNCTION GFEFCC 2.98150E+02 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2 +GHSERFE#; 1.81100E+03 Y -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6.00000E+03 N ! FUNCTION GPFEFCC 2.98150E+02 +YFEFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! FUNCTION GPSIG1 2.98150E+02 +1.09E-04*P; 6.00000E+03 N ! FUNCTION GPSIG2 2.98150E+02 +1.117E-04*P; 6.00000E+03 N ! FUNCTION YCRLIQ 2.98150E+02 +VCRLIQ#*EXP(-ECRLIQ#); 6.00000E+03 N ! FUNCTION ZCRLIQ 2.98150E+02 +1*LN(XCRLIQ#); 6.00000E+03 N ! FUNCTION YFELIQ 2.98150E+02 +VFELIQ#*EXP(-EFELIQ#); 6.00000E+03 N ! FUNCTION ZFELIQ 2.98150E+02 +1*LN(XFELIQ#); 6.00000E+03 N ! FUNCTION YCRBCC 2.98150E+02 +VCRBCC#*EXP(-ECRBCC#); 6.00000E+03 N ! FUNCTION ZCRBCC 2.98150E+02 +1*LN(XCRBCC#); 6.00000E+03 N ! FUNCTION YFEBCC 2.98150E+02 +VFEBCC#*EXP(-EFEBCC#); 6.00000E+03 N ! FUNCTION ZFEBCC 2.98150E+02 +1*LN(XFEBCC#); 6.00000E+03 N ! FUNCTION YFEFCC 2.98150E+02 +VFEFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! FUNCTION ZFEFCC 2.98150E+02 +1*LN(XFEFCC#); 6.00000E+03 N ! FUNCTION VCRLIQ 2.98150E+02 +7.653E-06*EXP(ACRLIQ#); 6.00000E+03 N ! FUNCTION ECRLIQ 2.98150E+02 +1*LN(CCRLIQ#); 6.00000E+03 N ! FUNCTION XCRLIQ 2.98150E+02 +1*EXP(.8*DCRLIQ#)-1; 6.00000E+03 N ! FUNCTION VFELIQ 2.98150E+02 +6.46677E-06*EXP(AFELIQ#); 6.00000E+03 N ! FUNCTION EFELIQ 2.98150E+02 +1*LN(CFELIQ#); 6.00000E+03 N ! FUNCTION XFELIQ 2.98150E+02 +1*EXP(.8484467*DFELIQ#)-1; 6.00000E+03 N ! FUNCTION VCRBCC 2.98150E+02 +7.188E-06*EXP(ACRBCC#); 6.00000E+03 N ! FUNCTION ECRBCC 2.98150E+02 +1*LN(CCRBCC#); 6.00000E+03 N ! FUNCTION XCRBCC 2.98150E+02 +1*EXP(.8*DCRBCC#)-1; 6.00000E+03 N ! FUNCTION VFEBCC 2.98150E+02 +7.042095E-06*EXP(AFEBCC#); 6.00000E+03 N ! FUNCTION EFEBCC 2.98150E+02 +1*LN(CFEBCC#); 6.00000E+03 N ! FUNCTION XFEBCC 2.98150E+02 +1*EXP(.7874195*DFEBCC#)-1; 6.00000E+03 N ! FUNCTION VFEFCC 2.98150E+02 +6.688726E-06*EXP(AFEFCC#); 6.00000E+03 N ! FUNCTION EFEFCC 2.98150E+02 +1*LN(CFEFCC#); 6.00000E+03 N ! FUNCTION XFEFCC 2.98150E+02 +1*EXP(.8064454*DFEFCC#)-1; 6.00000E+03 N ! FUNCTION ACRLIQ 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N ! FUNCTION CCRLIQ 2.98150E+02 3.72E-11; 6.00000E+03 N ! FUNCTION DCRLIQ 2.98150E+02 +1*LN(BCRLIQ#); 6.00000E+03 N ! FUNCTION AFELIQ 2.98150E+02 +1.135E-04*T; 6.00000E+03 N ! FUNCTION CFELIQ 2.98150E+02 +4.22534787E-12+2.71569924E-14*T; 6.00000E+03 N ! FUNCTION DFELIQ 2.98150E+02 +1*LN(BFELIQ#); 6.00000E+03 N ! FUNCTION ACRBCC 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N ! FUNCTION CCRBCC 2.98150E+02 2.08E-11; 6.00000E+03 N ! FUNCTION DCRBCC 2.98150E+02 +1*LN(BCRBCC#); 6.00000E+03 N ! FUNCTION AFEBCC 2.98150E+02 +2.3987E-05*T+1.2845E-08*T**2; 6.00000E+03 N ! FUNCTION CFEBCC 2.98150E+02 +2.20949565E-11+2.41329523E-16*T; 6.00000E+03 N ! FUNCTION DFEBCC 2.98150E+02 +1*LN(BFEBCC#); 6.00000E+03 N ! FUNCTION AFEFCC 2.98150E+02 +7.3097E-05*T; 6.00000E+03 N ! FUNCTION CFEFCC 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; 6.00000E+03 N ! FUNCTION DFEFCC 2.98150E+02 +1*LN(BFEFCC#); 6.00000E+03 N ! FUNCTION BCRLIQ 2.98150E+02 +1+4.65E-11*P; 6.00000E+03 N ! FUNCTION BFELIQ 2.98150E+02 +1+4.98009787E-12*P+3.20078924E-14*T*P; 6.00000E+03 N ! FUNCTION BCRBCC 2.98150E+02 +1+2.6E-11*P; 6.00000E+03 N ! FUNCTION BFEBCC 2.98150E+02 +1+2.80599565E-11*P+3.06481523E-16*T*P; 6.00000E+03 N ! FUNCTION BFEFCC 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; 6.00000E+03 N ! FUNCTION UN_ASS 298.15 0; 300 N ! TYPE_DEFINITION % SEQ *! DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! PHASE LIQUID:L % 1 1.0 ! CONSTITUENT LIQUID:L :CR,FE : ! PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T +2.37615E-21*T**7+GHSERCR#+GPCRLIQ#; 2.18000E+03 Y +18409.36-8.563683*T+2.88526E+32*T**(-9)+GHSERCR#+GPCRLIQ#; 6.00000E+03 N REF283 ! PARAMETER G(LIQUID,FE;0) 2.98150E+02 +GFELIQ#+GPFELIQ#; 6.00000E+03 N REF283 ! PARAMETER G(LIQUID,CR,FE;0) 2.98150E+02 -14550+6.65*T; 6.00000E+03 N REF107 ! TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! PHASE BCC_A2 %& 2 1 3 ! CONSTITUENT BCC_A2 :CR%,FE% : VA% : ! PARAMETER G(BCC_A2,CR:VA;0) 2.98150E+02 +GHSERCR#+GPCRBCC#; 6.00000E+03 N REF283 ! PARAMETER TC(BCC_A2,CR:VA;0) 2.98150E+02 -311.5; 6.00000E+03 N REF281 ! PARAMETER BMAGN(BCC_A2,CR:VA;0) 2.98150E+02 -.01; 6.00000E+03 N REF281 ! PARAMETER G(BCC_A2,FE:VA;0) 2.98150E+02 +GHSERFE#+GPFEBCC#; 6.00000E+03 N REF283 ! PARAMETER TC(BCC_A2,FE:VA;0) 2.98150E+02 1043; 6.00000E+03 N REF281 ! PARAMETER BMAGN(BCC_A2,FE:VA;0) 2.98150E+02 2.22; 6.00000E+03 N REF281 ! PARAMETER G(BCC_A2,CR,FE:VA;0) 2.98150E+02 +20500-9.68*T; 6.00000E+03 N REF107 ! PARAMETER TC(BCC_A2,CR,FE:VA;0) 2.98150E+02 1650; 6.00000E+03 N REF107 ! PARAMETER TC(BCC_A2,CR,FE:VA;1) 2.98150E+02 550; 6.00000E+03 N REF107 ! PARAMETER BMAGN(BCC_A2,CR,FE:VA;0) 2.98150E+02 -.85; 6.00000E+03 N REF107 ! TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! PHASE FCC_A1 %' 2 1 1 ! CONSTITUENT FCC_A1 :CR,FE% : VA% : ! PARAMETER G(FCC_A1,CR:VA;0) 2.98150E+02 +GCRFCC#+GPCRBCC#; 6.00000E+03 N REF281 ! PARAMETER TC(FCC_A1,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N REF281 ! PARAMETER BMAGN(FCC_A1,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N REF281 ! PARAMETER G(FCC_A1,FE:VA;0) 2.98150E+02 +GFEFCC#+GPFEFCC#; 6.00000E+03 N REF283 ! PARAMETER TC(FCC_A1,FE:VA;0) 2.98150E+02 -201; 6.00000E+03 N REF281 ! PARAMETER BMAGN(FCC_A1,FE:VA;0) 2.98150E+02 -2.1; 6.00000E+03 N REF281 ! PARAMETER G(FCC_A1,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; 6.00000E+03 N REF107 ! PARAMETER G(FCC_A1,CR,FE:VA;1) 2.98150E+02 1410; 6.00000E+03 N REF107 ! PHASE SIGMA % 3 8 4 18 ! CONSTITUENT SIGMA :FE : CR : CR,FE : ! PARAMETER G(SIGMA,FE:CR:CR;0) 2.98150E+02 +8*GFEFCC#+22*GHSERCR#+92300 -95.96*T+GPSIG1#; 6.00000E+03 N REF107 ! PARAMETER G(SIGMA,FE:CR:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# +18*GHSERFE#+117300-95.96*T+GPSIG2#; 6.00000E+03 N REF107 ! LIST_OF_REFERENCES NUMBER SOURCE REF283 'Alan Dinsdale, SGTE Data for Pure Elements, Calphad Vol 15(1991) p 317-425, also in NPL Report DMA(A)195 Rev. August 1990' REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 September 1989' REF107 'J-O Andersson, B. Sundman, CALPHAD Vol 11, (1987), p 83-92 TRITA 0270 (1986); CR-FE' ! ================================================ FILE: examples/TQ4lib/Cpp/Matthias/crfe/tqex1.cpp ================================================ #include "../liboctqcpp.h" using namespace std; int main(int argc, char *argv[]) { /* Bugtracker: 1) OCASI.tqgetv("MUS", -1, 0, nel, &ceq)[i] returns error: Unknown state variable: MUS >: 0.0) { cout << "Stable phase: " << OCASI.tqgpn(i+1, &ceq) << ", amount: " << OCASI.PhaseFractions(&ceq)[i] << ", mole fractions:" << endl; for(int j = 0; j < nel; j++) { cout << OCASI.tqgcom(&ceq)[j] << ": " << OCASI.tqgetv("X", i+1, -1, 4, &ceq)[j]; if(j < nel-1) { cout << ", "; } } cout << endl; cout << endl; } cout << "Component, mole fraction, chemical potential (SER) BCC" << endl; for(unsigned int i = 0; i < nel; i++) { cout << OCASI.tqgcom(&ceq)[i] << " " << OCASI.tqgetv("X", -1, 0, nel, &ceq)[i] << " " << OCASI.tqgetv("MU", -1, 0, nel, &ceq)[i] << " " << OCASI.tqgetv("MU", -1, 0, nel, &ceq)[i] << endl; } cout << endl; cout << "Mole fractions of all components in stable phases:" << endl; cout << "X(*,*):"; for(unsigned int i = 0; i < 4; i++) { cout << " " << OCASI.tqgetv("X(*,*)", -1, -1, 4, &ceq)[i]; } cout << endl; cout << "Mole fraction of a component in all phases, also those unstable:" << endl; cout << "in phase tuple order!" << endl; cout << "X(*,CR):"; for(unsigned int i = 0; i < 4; i++) { cout << " " << OCASI.tqgetv("X(*,*)", -1, 1, 4, &ceq)[i]; } cout << endl; OCASI.tqlr(0, &ceq); cout << endl; cout << "Any more calculations? /N/:" << endl; cout << endl; cout << "Auf wiedersehen" << endl; return 0; } ================================================ FILE: examples/TQ4lib/Cpp/Matthias/feni/FENI.TDB ================================================ $ Database file written 2014- 1-15 $ From database: SSOL2 ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! ELEMENT NI FCC_A1 5.8690E+01 4.7870E+03 2.9796E+01! FUNCTION GFELIQ 298.15 +12040.17-6.55843*T-3.6751551E-21*T**7 +GHSERFE#; 1.81100E+03 Y -10839.7+291.302*T-46*T*LN(T); 6000 N ! FUNCTION GHSERFE 298.15 +1225.7+124.134*T-23.5143*T*LN(T) -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6000 N ! FUNCTION GNIBCC 298.15 +8715.084-3.556*T+GHSERNI#; 6000 N ! FUNCTION GFEFCC 298.15 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2 +GHSERFE#; 1.81100E+03 Y -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6000 N ! FUNCTION GHSERNI 298.15 -5179.159+117.854*T-22.096*T*LN(T) -.0048407*T**2; 1.72800E+03 Y -27840.655+279.135*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 3.00000E+03 N ! FUNCTION GPFELIQ 298.15 7E-6*P; 6000 N ! FUNCTION GPFEFCC 298.15 5E-6*P; 6000 N ! FUNCTION GPFEBCC 298.15 6E-6*P; 6000 N ! FUNCTION GPNILIQ 298.15 8E-6*P; 6000 N ! FUNCTION GPNIFCC 298.15 6E-6*P; 6000 N ! FUNCTION GPNIBCC 298.15 7E-6*P; 6000 N ! $ this is 1/RT FUNCTION IQRT 298.15 0.12027167*T**(-1); 6000 N ! TYPE_DEFINITION % SEQ *! DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! PHASE LIQUID:L % 1 1.0 ! CONSTITUENT LIQUID:L :FE,NI : ! PARAMETER G(LIQUID,FE;0) 298.15 +GFELIQ#+GPFELIQ#; 6000 N REF283 ! PARAMETER G(LIQUID,NI;0) 298.15 +11235.527+108.457*T -22.096*T*LN(T)-.0048407*T**2-3.82318E-21*T**7+GPNILIQ; 1.72800E+03 Y -9549.775+268.598*T-43.1*T*LN(T)+GPNILIQ; 3.00000E+03 N REF283 ! PARAMETER G(LIQUID,FE,NI;0) 298.15 -18378.86+6.03912*T; 6000 N REF158 ! PARAMETER G(LIQUID,FE,NI;1) 298.15 +9228.1-3.54642*T; 6000 N REF158 ! $ LN(mobilities) PARAMETER MQ&FE(LIQUID,FE;0) 298.15 -10000*IQRT-18; 6000 N BOS ! PARAMETER MQ&FE(LIQUID,NI;0) 298.15 -12000*IQRT-19; 6000 N BOS ! PARAMETER MQ&NI(LIQUID,NI;0) 298.15 -11000*IQRT-18; 6000 N BOS ! PARAMETER MQ&NI(LIQUID,FE;0) 298.15 -13000*IQRT-19; 6000 N BOS ! TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! $ PHASE BCC_A2 %& 2 1 3 ! $ CONSTITUENT BCC_A2 :FE%,NI : VA% : ! PARAMETER G(BCC_A2,FE:VA;0) 298.15 +GHSERFE#+GPFEBCC#; 6000 N REF283 ! PARAMETER TC(BCC_A2,FE:VA;0) 298.15 1043; 6000 N REF281 ! PARAMETER BMAGN(BCC_A2,FE:VA;0) 298.15 2.22; 6000 N REF281 ! PARAMETER G(BCC_A2,NI:VA;0) 298.15 +GNIBCC#+GPNIBCC; 3000 N REF283 ! PARAMETER TC(BCC_A2,NI:VA;0) 298.15 575; 6000 N REF281 ! PARAMETER BMAGN(BCC_A2,NI:VA;0) 298.15 .85; 6000 N REF281 ! PARAMETER G(BCC_A2,FE,NI:VA;0) 298.15 -956.63-1.28726*T; 6000 N REF158 ! PARAMETER G(BCC_A2,FE,NI:VA;1) 298.15 +1789.03-1.92912*T; 6000 N REF158 ! $ LN(mobilities) PARAMETER MQ&FE(BCC_A2,FE:VA;0) 298.15 -20000*IQRT-24; 6000 N BOS ! PARAMETER MQ&FE(BCC_A2,NI:VA;0) 298.15 -22000*IQRT-24; 6000 N BOS ! PARAMETER MQ&NI(BCC_A2,NI:VA;0) 298.15 -25000*IQRT-25; 6000 N BOS ! PARAMETER MQ&NI(BCC_A2,FE:VA;0) 298.15 -28000*IQRT-25; 6000 N BOS ! TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! PHASE FCC_A1 %' 2 1 1 ! CONSTITUENT FCC_A1 :FE%,NI% : VA% : ! PARAMETER G(FCC_A1,FE:VA;0) 298.15 +GFEFCC#+GPFEFCC#; 6000 N REF283 ! PARAMETER TC(FCC_A1,FE:VA;0) 298.15 -201; 6000 N REF281 ! PARAMETER BMAGN(FCC_A1,FE:VA;0) 298.15 -2.1; 6000 N REF281 ! PARAMETER G(FCC_A1,NI:VA;0) 298.15 +GHSERNI#+GPNIFCC; 3000 N REF283 ! PARAMETER TC(FCC_A1,NI:VA;0) 298.15 633; 6000 N REF281 ! PARAMETER BMAGN(FCC_A1,NI:VA;0) 298.15 .52; 6000 N REF281 ! PARAMETER G(FCC_A1,FE,NI:VA;0) 298.15 -12054.355+3.27413*T; 6000 N REF158 ! PARAMETER G(FCC_A1,FE,NI:VA;1) 298.15 +11082.1315-4.45077*T; 6000 N REF158 ! PARAMETER G(FCC_A1,FE,NI:VA;2) 298.15 -725.805174; 6000 N REF158 ! PARAMETER TC(FCC_A1,FE,NI:VA;0) 298.15 2133; 6000 N REF158 ! PARAMETER TC(FCC_A1,FE,NI:VA;1) 298.15 -682; 6000 N REF158 ! PARAMETER BMAGN(FCC_A1,FE,NI:VA;0) 298.15 9.55; 6000 N REF158 ! PARAMETER BMAGN(FCC_A1,FE,NI:VA;1) 298.15 7.23; 6000 N REF158 ! PARAMETER BMAGN(FCC_A1,FE,NI:VA;2) 298.15 5.93; 6000 N REF158 ! PARAMETER BMAGN(FCC_A1,FE,NI:VA;3) 298.15 6.18; 6000 N REF158 ! $ LN(mobilities) PARAMETER MQ&FE(FCC_A1,FE:VA;0) 298.15 -30000*IQRT-30; 6000 N BOS ! PARAMETER MQ&FE(FCC_A1,NI:VA;0) 298.15 -32000*IQRT-32; 6000 N BOS ! PARAMETER MQ&NI(FCC_A1,NI:VA;0) 298.15 -33000*IQRT-32; 6000 N BOS ! PARAMETER MQ&NI(FCC_A1,FE:VA;0) 298.15 -25000*IQRT-31; 6000 N BOS ! LIST_OF_REFERENCES NUMBER SOURCE REF283 'Alan Dinsdale, SGTE Data for Pure Elements, Calphad Vol 15(1991) p 317-425, also in NPL Report DMA(A)195 Rev. August 1990' REF158 'A. Dinsdale, T. Chart, MTDS NPL, unpublished work (1986); FE-NI' REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 September 1989' BOS 'Invented mobilities and molar volumes' ! ================================================ FILE: examples/TQ4lib/Cpp/Matthias/feni/tqex2.cpp ================================================ #include "../liboctqcpp.h" #include using namespace std; int main(int argc, char *argv[]) { /* Bugtracker: 1) No equilph1d(phtup,ceq%tpval,xknown,mu,.TRUE.,nend,mugrad,mobilities,ceq) function in liboctq.F90 */ liboctqcpp OCASI; void * ceq = 0; string filename = "TQ4lib/Cpp/Matthias/feni/FENI.TDB"; cout << endl; cout << "Calculation of equilibria and mobility data in Fe-Ni system" << endl; cout << endl; cout << "Fictitious ln(mobility data) in the TDB file:" << endl; cout << "PARAMETER MQ&FE(LIQUID,FE;0) 298.15 -10000*IQRT-18; 6000 N BOS !" << endl; cout << "PARAMETER MQ&FE(LIQUID,NI;0) 298.15 -12000*IQRT-19; 6000 N BOS !" << endl; cout << "PARAMETER MQ&NI(LIQUID,NI;0) 298.15 -11000*IQRT-18; 6000 N BOS !" << endl; cout << "PARAMETER MQ&NI(LIQUID,FE;0) 298.15 -13000*IQRT-19; 6000 N BOS !" << endl; cout << "PARAMETER MQ&FE(FCC_A1,FE:VA;0) 298.15 -30000*IQRT-30; 6000 N BOS !" << endl; cout << "PARAMETER MQ&FE(FCC_A1,NI:VA;0) 298.15 -32000*IQRT-32; 6000 N BOS !" << endl; cout << "PARAMETER MQ&NI(FCC_A1,NI:VA;0) 298.15 -33000*IQRT-32; 6000 N BOS !" << endl; cout << "PARAMETER MQ&NI(FCC_A1,FE:VA;0) 298.15 -25000*IQRT-31; 6000 N BOS !" << endl; cout << endl; OCASI.tqini(0,&ceq); vector Elements; Elements.push_back("FE"); Elements.push_back("NI"); vector elnames = OCASI.tqrpfil("TQ4lib/Cpp/Matthias/feni/FENI.TDB", Elements, &ceq); int nel = OCASI.tqgcom(&ceq).size(); cout << "System with " << nel << " elements: "; for(int i = 0; i < nel; i++) { cout << OCASI.tqgcom(&ceq)[i]; if(i < nel-1) { cout << ", "; } } cout << endl; int phasetuples = OCASI.tqgnp(&ceq); cout << "and " << phasetuples << " phases: "; for(int i = 0; i < phasetuples; i++) { cout << OCASI.tqgpn(i+1, &ceq); if(i < phasetuples-1) { cout << ", "; } } cout << endl; cout << endl; cout << "Give conditions:" << endl; cout << "Temperature: /1000/:" << endl; OCASI.tqsetc("T", 0, 0, 1000, &ceq); cout << "Pressure: /100000/:" << endl; OCASI.tqsetc("P", 0, 0, 100000, &ceq); cout << "Mole fractions for FE: /0.5/:" << endl; OCASI.tqsetc("X", 1, 0, 0.5, &ceq); OCASI.tqsetc("N", 0, 0, 1.0, &ceq); OCASI.tqce(&ceq); cout << endl; cout << "Successfull calculation" << endl; cout << endl; int equphasetuples = OCASI.tqgnp(&ceq); cout << "Amount of " << equphasetuples << " phases: "; for(int i = 0; i < equphasetuples; i++) { cout << OCASI.PhaseFractions(&ceq)[i]; if(i < equphasetuples-1) { cout << ", "; } } cout << endl; for(unsigned int i = 0; i < equphasetuples; i++) if(OCASI.PhaseFractions(&ceq)[i] > 0.0) { cout << "Stable phase: " << OCASI.tqgpn(i+1, &ceq) << ", amount: " << OCASI.PhaseFractions(&ceq)[i] << ", mole fractions:" << endl; for(int j = 0; j < nel; j++) { cout << OCASI.tqgcom(&ceq)[j] << ": " << OCASI.tqgetv("X", i+1, -1, 4, &ceq)[j]; if(j < nel-1) { cout << ", "; } } cout << endl; cout << endl; } cout << "System volume: " << OCASI.tqgetv("V", 0, 0, &ceq) << endl; cout << endl; cout << "Component, mole fraction, chemical potentials, lnac = mu/RT" << endl; for(int i = 0; i < elnames.size(); i++) { cout << OCASI.tqgcom(&ceq)[i] << " " << OCASI.tqgetv("X", i+1, 0, &ceq) << " " << OCASI.tqgetv("MU", i+1, 0, &ceq) << " " << OCASI.tqgetv("MU", i+1, 0, &ceq)/8.31451 /OCASI.tqgetv("T", 0, 0, &ceq) << endl; } cout << endl; cout << "LN(mobility of component in phase) and exp(..):" << endl; for(int i = 0; i < equphasetuples; i++) for(int j = 0; j < nel; j++) { string temp = "MQ&" + OCASI.tqgcom(&ceq)[j]; cout << temp << "(" << OCASI.tqgpn(i+1, &ceq) << ") = " << OCASI.tqgetv(temp, i+1, j+1, &ceq) << " " << exp(OCASI.tqgetv(temp, i+1, j+1, &ceq)) << endl; } cout << endl; cout << "Calculating Darken stability matrix, dG_A/dN_B for phase 2:" << endl; /*Calculating Darken stability matrix, dG_A/dN_B for phase 2: Calculation required 6 its Chemical potential derivative matrix, dG_I/dN_J for 2 endmembers 1 2 1 1.2100E+04 -1.2100E+04 2 -1.2100E+04 1.2100E+04 LN(mobility) values for 2 components 1 -3.4728E+01 -3.4988E+01*/ cout << endl; cout << "Any more calculations? /N/:" << endl; cout << endl; cout << "Auf wiedersehen" << endl; return 0; } ================================================ FILE: examples/TQ4lib/Cpp/Matthias/liboctqcpp.cpp ================================================ #include "liboctqcpp.h" using namespace std; #define MAXEL 24; #define MAXPH 20 void liboctqcpp::tqini(int n, void * ceq) { //============== c_tqini(n, ceq); //============== }; vector liboctqcpp::tqrfil(string fname, void * ceq) { char *filename = strcpy((char*)malloc(fname.length()+1),fname.c_str()); //====================== c_tqrfil(filename, ceq); //====================== ntup = c_ntup; nel = c_nel; cnam.resize(nel); for(int i = 0; i < nel; i++) cnam[i] = c_cnam[i]; free(filename); //================= return tqgcom(ceq); //================= }; vector liboctqcpp::tqrpfil(string fname, vector elnames, void * ceq) { char *filename = strcpy((char*)malloc(fname.length()+1), fname.c_str()); char *selel[elnames.size()]; char *tempchar; for(int i = 0; i < elnames.size(); i++) { tempchar = strcpy((char*)malloc(elnames[i].length()+1), elnames[i].c_str()); selel[i] = tempchar; } //============================================== c_tqrpfil(filename, elnames.size(), selel, ceq); //============================================== ntup = c_ntup; nel = c_nel; cnam.resize(nel); for(int i = 0; i < nel; i++) cnam[i] = c_cnam[i]; free(filename); free(tempchar); //free(selel); vector asdf = tqgcom(ceq); //================= return tqgcom(ceq); //================= }; int liboctqcpp::tqgcn(void * ceq) { int n = MAXEL; char elnames[24]; //========================= c_tqgcom(&n, elnames, ceq); //========================= return n; }; vector liboctqcpp::tqgcom(void * ceq) { int n = MAXEL; char elnames[24]; vector result; //========================= c_tqgcom(&n, elnames, ceq); //========================= result.resize(n); for(int i = 0; i < n; i++) { char temp[3]; for(int j = 0; j < 2; j++) { temp[j] = elnames[j+i*2]; if(temp[j] == ' ') temp[j] = 0; } temp[2] = 0; string temp2(temp); result[i] = temp2; } return result; }; int liboctqcpp::tqgnp(void * ceq) { int n; //=============== c_tqgnp(&n, ceq); //=============== return n; }; string liboctqcpp::tqgpn(int i, void * ceq) { char phname[24]; string result; //====================== c_tqgpn(i, phname, ceq); //====================== result = phname; return result; }; int liboctqcpp::tqgpi(string pname, void * ceq) { char *phasename = strcpy((char*)malloc(pname.length()+1), pname.c_str()); int i; //========================= c_tqgpi(&i, phasename, ceq); //========================= free(phasename); return i; }; string liboctqcpp::tqgpcn2(int phidx, int i, void * ceq) { //--------------------------- return tqgpcn(phidx, i, ceq); //--------------------------- }; string liboctqcpp::tqgpcn(int phidx, int i, void * ceq) { char constituentname[24]; string result; //======================================= c_tqgpcn(phidx, i, constituentname, ceq); //TODO: c_tqgpcn is not implemented in liboctq.F90!! //======================================= result = constituentname; return result; }; int liboctqcpp::tqgpci(int phidx, string cname, void * ceq) { int c; char *constituent = strcpy((char*)malloc(cname.length()+1), cname.c_str()); //==================================== c_tqgpci(phidx, &c, constituent, ceq); //TODO: c_tqgpci is not implemented in liboctq.F90!! //==================================== free(constituent); return c; }; vector liboctqcpp::tqgpcs(int phidx, int con, double& mass, void * ceq) { vector result; double * stoi; c_tqgpcs(phidx, con, stoi, &mass, ceq); free(stoi); return result; }; void liboctqcpp::tqgccf(int comp, void * ceq) { int nel; char * elnames; double stoi; double mass; //=============================================== c_tqgccf(comp, &nel, elnames, &stoi, &mass, ceq); //TODO: c_tqgccf is not implemented in liboctq.F90 //=============================================== free(elnames); }; int liboctqcpp::tqgnpc(int phidx, void * ceq) { int nc; //======================== c_tqgnpc(phidx, &nc, ceq); //TODO: c_tqgnpc is not implemented in liboctq.F90 //======================== return nc; }; void liboctqcpp::tqphtupsts(int phidx, int newstatus, double val, void * ceq) { // phidx < 0 means "all phases" // newstatus -4 hidden // newstatus -3 suspended // newstatus -2 dormant // newstatus -1 TODO: entered? // newstatus 0 TODO: entered? // newstatus 1 entered // newstatus 2 fix //===================================== c_tqphtupsts(phidx, newstatus, val, ceq); //===================================== }; void liboctqcpp::tqsetc(string par, int n1, int n2, double val, void * ceq) { int cnum; char *name = strcpy((char*)malloc(par.length()+1), par.c_str()); //====================================== c_tqsetc(name, n1, n2, val, &cnum, ceq); //====================================== free(name); }; void liboctqcpp::tqce(void * ceq) { char target[60] = " "; double val; //============================== c_tqce(target, 0, 0, &val, ceq); //============================== }; double liboctqcpp::tqgetv(string par, int n1, int n2, void * ceq) { char *name = strcpy((char*)malloc(par.length()+1), par.c_str()); double val; int cnum; //======================================= c_tqgetv(name, n1, n2, &cnum, &val, ceq); //======================================= free(name); return val; }; vector liboctqcpp::tqgetv(string par, int n1, int n2, int n3, void * ceq) { vector results(n3); char *name = strcpy((char*)malloc(par.length()+1), par.c_str()); double val[n3]; //==================================== c_tqgetv(name, n1, n2, &n3, val, ceq); //==================================== for(int i = 0; i < n3; i++) results[i] = val[i]; free(name); return results; }; vector liboctqcpp::tqgphc1(int phIdx, vector& ncons, vector& sites, double& moles, void * ceq) { int nlat; int nlatc[MAXPH];//TODO: MAXPH is misleading int conlista[MAXPH]; double yfr[MAXPH]; double site[MAXPH]; double extra[MAXPH]; //============================================================== c_tqgphc1(phIdx, &nlat, nlatc, conlista, yfr, site, extra, ceq); //============================================================== ncons.resize(nlat); sites.resize(nlat); int nc = 0; for(unsigned int i = 0; i < ncons.size(); i++) { ncons[i] = nlatc[i]; sites[i] = site[i]; nc += nlatc[i]; } vector y(nc, 0); for(unsigned int i = 0; i < nc; i++) y[i] = yfr[i]; moles = extra[0]; return y; }; void liboctqcpp::tqsphc1(int phidx, vector y, void * ceq) { double extra[MAXPH]; double yfr[y.size()]; for(int i = 0; i < y.size(); i++) yfr[i] = y[i]; //================================ c_tqsphc1(phidx, yfr, extra, ceq); //================================ }; double liboctqcpp::tqcph1(int phidx, vector& G_TP, vector& G_Y, vector& G_YT, vector& G_YP, vector& G_YY, void * ceq) { int n2 = 2; int n3; double gtp[6]; double dgdy[100]; double d2gdydt[100]; double d2gdydp[100]; double d2gdy2[100]; //================================================================= c_tqcph1(phidx, n2, &n3, gtp, dgdy, d2gdydt, d2gdydp, d2gdy2, ceq); //================================================================= double G = gtp[0]; G_TP.resize(5); G_Y.resize(n3); G_YT.resize(n3); G_YP.resize(n3); int yy = n3*(n3+1.)/2.; G_YY.resize(yy); for(int i = 0; i < 5; i++) G_TP[i] = gtp[i+1]; //GibbsEnergy_TP[0] G.T //GibbsEnergy_TP[1] G.P //GibbsEnergy_TP[2] G.T.T //GibbsEnergy_TP[3] G.T.P //GibbsEnergy_TP[4] G.P.P for(int i = 0; i < n3; i++) { G_Y[i] = dgdy[i]; //GibbsEnergy_Y[0] G.Y0 //GibbsEnergy_Y[1] G.Y1 G_YT[i] = d2gdydt[i]; //GibbsEnergy_YT[0] G.Y0.T //GibbsEnergy_YT[1] G.Y1.T G_YP[i] = d2gdydp[i]; //GibbsEnergy_YP[0] G.Y0.P //GibbsEnergy_YP[1] G.Y1.P } for(int i = 0; i < yy; i++) G_YY[i] = d2gdy2[i]; //GibbsEnergy_YY[0] G.Y0.Y0 //GibbsEnergy_YY[0] G.Y0.Y1 //GibbsEnergy_YY[0] G.Y1.Y1 //GibbsEnergy_YY[0] G.Y1.Y2 //GibbsEnergy_YY[0] G.Y2.Y2 //GibbsEnergy_YY[0] G.Y2.Y3 return G; }; int liboctqcpp::tqcph2(int phidx, int type, void * ceq) { int lokres; //ceq%phase_varres(lokres)% with all results int n3; //======================================= c_tqcph2(phidx, type, &n3, &lokres, ceq); //======================================= return lokres; }; void liboctqcpp::tqdceq(string name) { char *ceqname = strcpy((char*)malloc(name.length()+1), name.c_str()); //================ c_tqdceq(ceqname); //================ free(ceqname); }; int liboctqcpp::tqcceq(string name, void * newceq, void * ceq) { char *ceqname = strcpy((char*)malloc(name.length()+1), name.c_str()); int n1; //================================== c_tqcceq(ceqname, &n1, newceq, ceq); //================================== return n1; }; void liboctqcpp::tqselceq(string name, void * ceq) { char *ceqname = strcpy((char*)malloc(name.length()+1), name.c_str()); //======================= c_tqselceq(ceqname, ceq); //======================= free(ceqname); }; void liboctqcpp::reset_conditions(string condition, double newval, void * ceq) { char *cond = strcpy((char*)malloc(condition.length()+1), condition.c_str()); //============================ c_reset_conditions(cond, ceq); //TODO: send newval to liboctq.F90 //============================ free(cond); }; void liboctqcpp::Change_Status_Phase(string phname, int newstatus, double val, void * ceq) { //-------------------------------------------------- tqphtupsts(tqgpi(phname, ceq), newstatus, val, ceq); //-------------------------------------------------- }; void liboctqcpp::tqlr(int lut, void * ceq) { //=============== c_tqlr(lut, ceq); //=============== }; void liboctqcpp::tqlc(int lut, void * ceq) { //=============== c_tqlc(lut, ceq); //=============== }; vector liboctqcpp::PhaseFractions(void *ceq) { vector results = //---------------------------- tqgetv("NP", -1, 0, tqgnp(ceq), ceq); //---------------------------- return results; }; vector liboctqcpp::ConstituentFractions(int phase, void *ceq) { vector results = //------------------------------- tqgetv("X", phase, -1, tqgcn(ceq), ceq); //------------------------------- return results; }; ================================================ FILE: examples/TQ4lib/Cpp/Matthias/liboctqcpp.h ================================================ #include #include #include #include #include #include extern"C" int c_nel; extern"C" int c_maxc; extern"C" int c_maxp; extern"C" char * c_cnam[24]; extern"C" char * cnames[25]; extern"C" int c_ntup; extern"C" int c_noofcs(int); extern"C" int c_ierr(void); extern"C" { void c_tqini(int, void *); void c_tqrfil(char *, void *); void c_tqrpfil(char *, int, char **, void *); void c_tqgcom(int *, char *, void *); void c_tqgnp(int *, void *); void c_tqgpn(int, char *, void *); void c_tqgpi(int *, char *, void *); void c_tqgpcn2(int, int, char *, void *); void c_tqgpcn(int, int, char *, void *); void c_tqgpci(int, int *, char *, void *); void c_tqgpcs(int, int, double *, double *, void *); void c_tqgccf(int, int *, char *, double *, double *, void *); void c_tqgnpc(int, int *, void *); void c_tqphtupsts(int, int, double, void *); void c_tqsetc(char *, int, int, double, int *, void *); void c_tqce(char *, int, int, double *, void *); void c_tqgetv(char *, int, int, int *, double *, void *); void c_tqgphc1(int, int * , int *, int *, double *, double *, double *, void *); void c_tqsphc1(int, double *, double *, void *); void c_tqcph1(int, int, int *, double *, double *, double *, double *, double *, void *); void c_tqcph2(int, int, int *, int *, void *); void c_tqdceq(char *); void c_tqcceq(char *, int *, void *, void *); void c_tqselceq(char *, void *); void c_reset_conditions(char *, void *); void c_Change_Status_Phase(char *, int, double, void *); void c_tqlr(int, void *); void c_tqlc(int, void *); } class liboctqcpp { public: void * ceq2; int ntup; int nel; std::vector cnames; std::vector cnam; void tqini(int n, void * ceq); std::vector tqrfil(std::string fname, void * ceq); std::vector tqrpfil(std::string fname, std::vector elnames, void * ceq); int tqgcn(void * ceq); std::vector tqgcom(void * ceq); int tqgnp(void * ceq); std::string tqgpn(int i, void * ceq); int tqgpi(std::string pname, void * ceq); std::string tqgpcn(int phidx, int i, void * ceq); std::string tqgpcn2(int phidx, int i, void * ceq); int tqgpci(int phidx, std::string cname, void * ceq); void tqgpcs(int, int, double *, double *, void *); std::vector tqgpcs(int phidx, int con, double& mass, void * ceq); void tqgccf(int comp, void * ceq); int tqgnpc(int phidx, void * ceq); void tqphtupsts(int, int, double, void *); void tqsetc(std::string, int, int, double, void *); void tqce(void *); double tqgetv(std::string, int, int, void *); std::vector tqgetv(std::string, int, int, int, void *); std::vector tqgphc1(int phIdx, std::vector& ncons, std::vector& sites, double& moles, void * ceq); void tqsphc1(int phidx, std::vector y, void * ceq); double tqcph1(int phidx, std::vector& G_TP, std::vector& G_Y, std::vector& G_YT, std::vector& G_YP, std::vector& G_YY, void * ceq); int tqcph2(int phidx, int type, void * ceq); void tqdceq(std::string); int tqcceq(std::string name, void * newceq, void * ceq); void tqselceq(std::string, void *); void reset_conditions(std::string condition, double newval, void * ceq); void Change_Status_Phase(std::string phname, int newstatus, double val, void * ceq); void tqlr(int, void *); void tqlc(int, void *); std::vector PhaseFractions(void *); std::vector ConstituentFractions(int phase, void *ceq); }; ================================================ FILE: examples/TQ4lib/Cpp/Matthias/liboctqisoc.F90 ================================================ module cstr contains function c_to_f_string(s) result(str) use iso_c_binding implicit none character(kind=c_char,len=1), intent(in) :: s(*) character(len=:), allocatable :: str integer i, nchars i = 1 do if (s(i) == c_null_char) exit i = i + 1 end do nchars = i - 1 allocate(character(len=nchars) :: str) str = transfer(s(1:nchars), str) end function c_to_f_string subroutine f_to_c_string(fstring, cstr) use iso_c_binding implicit none character(len=24) :: fstring character(kind=c_char, len=1), intent(out) :: cstr(*) integer i do i = 1, len(fstring) cstr(i) = fstring(i:i) cstr(i+1) = c_null_char end do end subroutine f_to_c_string end module cstr module liboctqisoc use iso_c_binding use cstr use liboctq implicit none integer(c_int), bind(c) :: c_nel integer(c_int), bind(c) :: c_maxc=20 integer(c_int), bind(c) :: c_maxp=100 type(c_ptr), bind(c), dimension(maxc) :: c_cnam character(len=25), dimension(maxc), target :: cnames integer(c_int), bind(c) :: c_ntup TYPE, bind(c) :: c_gtp_equilibrium_data integer(c_int) :: status,multiuse,eqno,next character(c_char) :: eqname*24 character(c_char) :: comment*72 real(c_double) :: tpval(2) real(c_double) :: rtn real(c_double) :: weight real(c_double) :: svfunres TYPE(c_ptr) :: lastcondition TYPE(c_ptr) :: lastexperiment TYPE(c_ptr) :: complist real(c_double) :: compstoi real(c_double) :: invcompstoi TYPE(c_ptr) :: phase_varres TYPE(c_ptr) :: eq_tpres real(c_double) :: cmuval real(c_double) :: xconv real(c_double) :: gmindif=-5.0D-2 integer(c_int) :: maxiter character(c_char) :: eqextra*80 integer(c_int) :: sysmatdim=0 integer(c_int) :: nfixmu=0 integer(c_int) :: nfixph=0 integer(c_int) :: fixmu integer(c_int) :: fixph real(c_double) :: savesysmat END TYPE c_gtp_equilibrium_data contains integer function c_noofcs(iph) bind(c, name='c_noofcs') integer(c_int), value :: iph c_noofcs = noofcs(iph) return end function c_noofcs integer function c_ierr() bind(c, name='c_ierr') c_ierr=gx%bmperr return end function c_ierr subroutine c_tqini(n, c_ceq) bind(c, name='c_tqini') integer(c_int), intent(in) :: n type(c_ptr), intent(out) :: c_ceq type(gtp_equilibrium_data), pointer :: ceq !================= call tqini(n, ceq) !================= c_ceq = c_loc(ceq) end subroutine c_tqini subroutine c_tqrfil(filename,c_ceq) bind(c, name='c_tqrfil') character(kind=c_char,len=1), intent(in) :: filename(*) character(len=:), allocatable :: fstring type(gtp_equilibrium_data), pointer :: ceq type(c_ptr), intent(inout) :: c_ceq integer :: i integer :: j integer :: l character(kind=c_char, len=1),dimension(24), target :: f_pointers call c_f_pointer(c_ceq, ceq) fstring = c_to_f_string(filename) !======================== call tqrfil(fstring, ceq) !======================== c_ntup = ntup c_nel = nel do i = 1, nel cnames(i) = trim(cnam(i)) // c_null_char c_cnam(i) = c_loc(cnames(i)) end do c_ceq = c_loc(ceq) end subroutine c_tqrfil subroutine c_tqrpfil(filename,nel,c_selel,c_ceq) bind(c, name='c_tqrpfil') character(kind=c_char), intent(in) :: filename integer(c_int), intent(in), value :: nel type(c_ptr), intent(in), dimension(nel), target :: c_selel type(c_ptr), intent(inout) :: c_ceq type(gtp_equilibrium_data), pointer :: ceq character(len=:), allocatable :: fstring character, pointer :: selel(:) integer :: i character elem(nel)*2 fstring = c_to_f_string(filename) call c_f_pointer(c_ceq, ceq) do i = 1, nel call c_f_pointer(c_selel(i), selel, [3]) elem(i) = c_to_f_string(selel) end do !==================================== call tqrpfil(fstring, nel, elem, ceq) !==================================== c_ntup = ntup c_nel = nel do i = 1, nel cnames(i) = trim(cnam(i)) // c_null_char c_cnam(i) = c_loc(cnames(i)) end do c_ceq = c_loc(ceq) end subroutine c_tqrpfil subroutine c_tqgcom(n,components,c_ceq) bind(c, name='c_tqgcom') integer(c_int), intent(inout) :: n type(c_ptr), intent(inout) :: c_ceq character(kind=c_char, len=1), intent(out) :: components(maxel*3) integer, target :: nc character(len=24) :: fcomponents(maxel) type(gtp_equilibrium_data), pointer :: ceq integer :: i,j,l call c_f_pointer(c_ceq, ceq) !================================ call tqgcom(nc, fcomponents, ceq) !================================ l = 1 do i = 1, nc do j = 1, 2 components(l)(1:1) = fcomponents(i)(j:j) l=l+1 end do end do ! null termination components(i*2-1) = c_null_char c_ceq = c_loc(ceq) n = nc end subroutine c_tqgcom subroutine c_tqgnp(n, c_ceq) bind(c, name='c_tqgnp') integer(c_int), intent(inout) :: n type(c_ptr), intent(inout) :: c_ceq integer, target :: nc type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) !================= call tqgnp(n, ceq) !================= c_ceq = c_loc(ceq) end subroutine c_tqgnp subroutine c_tqgpn(n,phasename, c_ceq) bind(c, name='c_tqgpn') integer(c_int), intent(in), value :: n character(kind=c_char, len=1), intent(inout) :: phasename(36) type(c_ptr), intent(inout) :: c_ceq type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fstring integer :: i call c_f_pointer(c_ceq, ceq) !========================== call tqgpn(n, fstring, ceq) !========================== do i=1,len(trim(fstring)) phasename(i)(1:1) = fstring(i:i) phasename(i+1)(1:1) = c_null_char end do c_ceq = c_loc(ceq) end subroutine c_tqgpn subroutine c_tqgpi(n,phasename,c_ceq) bind(c, name='c_tqgpi') integer(c_int), intent(out) :: n character(c_char), intent(in) :: phasename(24) type(c_ptr), intent(inout) :: c_ceq type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fstring call c_f_pointer(c_ceq, ceq) fstring = c_to_f_string(phasename) !========================== call tqgpi(n, fstring, ceq) !========================== c_ceq = c_loc(ceq) end subroutine c_tqgpi subroutine c_tqgpcn2(n, c, constituentname, c_ceq) bind(c, name='c_tqgpcn2') integer(c_int), intent(in), value :: n integer(c_int), intent(in), value :: c character(c_char), intent(out) :: constituentname(24) type(c_ptr), intent(inout) :: c_ceq type(gtp_equilibrium_data), pointer :: ceq character fstring*(24) double precision mass call c_f_pointer(c_ceq, ceq) !================================================== call get_constituent_name(n,c,fstring,mass) !================================================== call f_to_c_string(fstring, constituentname) c_ceq = c_loc(ceq) end subroutine c_tqgpcn2 subroutine c_tqgpcn(n, c, constituentname, c_ceq) bind(c, name='c_tqgpcn') integer(c_int), intent(in), value :: n integer(c_int), intent(in), value :: c character(c_char), intent(out) :: constituentname(24) type(c_ptr), intent(inout) :: c_ceq type(gtp_equilibrium_data), pointer :: ceq character fstring*(24) double precision mass integer :: i call c_f_pointer(c_ceq, ceq) !========================================== call get_constituent_name(n,c,fstring,mass) !========================================== !call f_to_c_string(fstring, constituentname) do i=1,len(trim(fstring)) constituentname(i)(1:1) = fstring(i:i) constituentname(i+1)(1:1) = c_null_char end do c_ceq = c_loc(ceq) end subroutine c_tqgpcn subroutine c_tqgpci(n,c, constituentname, c_ceq) bind(c, name='c_tqgpci') integer(c_int), intent(in) :: n integer(c_int), intent(out) :: c character(c_char), intent(in) :: constituentname(24) type(c_ptr), intent(inout) :: c_ceq type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fstring fstring = c_to_f_string(constituentname) call c_f_pointer(c_ceq, ceq) !============================== call tqgpci(n, c, fstring, ceq) !============================== c_ceq = c_loc(ceq) end subroutine c_tqgpci subroutine c_tqgpcs(n, c, stoi, mass, c_ceq) bind(c, name='c_tqgpcs') integer(c_int), intent(in) :: n integer(c_int), intent(in) :: c real(c_double), intent(out) :: stoi(*) real(c_double), intent(out) :: mass type(c_ptr), intent(inout) :: c_ceq type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) !============================= call tqgpcs(n,c,stoi,mass,ceq) !============================= c_ceq=c_loc(ceq) end subroutine c_tqgpcs subroutine c_tqgccf(n1,n2,elnames,stoi,mass,c_ceq) bind(c, name='c_tqgccf') integer(c_int), intent(in) :: n1 integer(c_int), intent(out) :: n2 character(c_char), intent(out) :: elnames(2) real(c_double), intent(out) :: stoi(*) real(c_double), intent(out) :: mass type(c_ptr), intent(inout) :: c_ceq type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) !========================================= call tqgccf(n1,n2,elnames,stoi, mass, ceq) !========================================= c_ceq = c_loc(ceq) end subroutine c_tqgccf subroutine c_tqgnpc(n,c,c_ceq) bind(c, name='c_tqgnpc') integer(c_int), intent(in) :: n integer(c_int), intent(out) :: c type(c_ptr), intent(inout) :: c_ceq type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq,ceq) !=================== call tqgnpc(n,c,ceq) !=================== c_ceq = c_loc(ceq) end subroutine c_tqgnpc subroutine c_tqphtupsts(phtupx,newstat,val,c_ceq) & bind(c, name='c_tqphtupsts') integer(c_int), intent(in), value :: phtupx integer(c_int), intent(in), value :: newstat real(c_double), intent(in), value :: val type(c_ptr), intent(inout) :: c_ceq type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq,ceq) !====================================== call tqphtupsts(phtupx,newstat,val,ceq) !====================================== c_ceq = c_loc(ceq) end subroutine c_tqphtupsts subroutine c_tqsetc(statvar, n1, n2, mvalue, cnum, c_ceq) & bind(c, name='c_tqsetc') integer(c_int), intent(in),value :: n1 integer(c_int), intent(in),value :: n2 ! integer(c_int), intent(out) :: cnum character(c_char), intent(in) :: statvar real(c_double), intent(in), value :: mvalue type(gtp_equilibrium_data), pointer :: ceq type(c_ptr), intent(inout) :: c_ceq call c_f_pointer(c_ceq, ceq) !============================================== call tqsetc(statvar, n1, n2, mvalue, cnum, ceq) !============================================== c_ceq = c_loc(ceq) end subroutine c_tqsetc subroutine c_tqce(mtarget,n1,n2,mvalue,c_ceq) bind(c,name='c_tqce') integer(c_int), intent(in),value :: n1 integer(c_int), intent(in),value :: n2 type(c_ptr), intent(inout) :: c_ceq character(c_char), intent(inout) :: mtarget real(c_double), intent(inout) :: mvalue type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fstring call c_f_pointer(c_ceq,ceq) fstring = c_to_f_string(mtarget) !================================== call tqce(fstring,n1,n2,mvalue,ceq) !================================== c_ceq = c_loc(ceq) end subroutine c_tqce subroutine c_tqgetv(statvar,n1,n2,n3,values,c_ceq) bind(c,name='c_tqgetv') integer(c_int), intent(in), value :: n1 integer(c_int), intent(in), value :: n2 integer(c_int), intent(inout) :: n3 character(c_char), intent(in) :: statvar real(c_double), intent(inout) :: values(*) type(c_ptr), intent(inout) :: c_ceq type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fstring !integer :: n integer :: i call c_f_pointer(c_ceq, ceq) fstring = c_to_f_string(statvar) !======================================== call tqgetv(fstring, n1,n2,n3,values,ceq) !======================================== c_ceq = c_loc(ceq) end subroutine c_tqgetv subroutine c_tqgphc1(n1,nsub,cinsub,spix,yfrac,sites,extra,c_ceq) & bind(c,name='c_tqgphc1') integer(c_int), intent(in), value :: n1 integer(c_int), intent(out) :: nsub integer(c_int), intent(out) :: cinsub(*) integer(c_int), intent(in) :: spix(*) real(c_double), intent(in) :: sites(*) real(c_double), intent(in) :: yfrac(*) real(c_double), intent(in) :: extra(*) type(c_ptr), intent(inout) :: c_ceq type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) !====================================================== call tqgphc1(n1,nsub,cinsub,spix,yfrac,sites,extra,ceq) !====================================================== c_ceq = c_loc(ceq) end subroutine c_tqgphc1 subroutine c_tqsphc1(n1,yfra,extra,c_ceq) bind(c,name='c_tqsphc1') integer(c_int), intent(in), value :: n1 real(c_double), intent(in) ::yfra(*) real(c_double), intent(out) :: extra(*) type(c_ptr), intent(inout) :: c_ceq type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) !===================================================================== call set_constitution(phasetuple(n1)%ixphase,phasetuple(n1)%compset, & yfra,extra,ceq) !===================================================================== c_ceq = c_loc(ceq) end subroutine c_tqsphc1 subroutine c_tqcph1(n1,n2,n3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,c_ceq) & bind(c,name='c_tqcph1') integer(c_int), intent(in), value :: n1 integer(c_int), intent(in), value :: n2 integer(c_int), intent(out) :: n3 real(c_double), intent(out) :: gtp(6) real(c_double), intent(out) :: dgdy(*) real(c_double), intent(out) :: d2gdydt(*) real(c_double), intent(out) :: d2gdydp(*) real(c_double), intent(out) :: d2gdy2(*) type(c_ptr), intent(inout) :: c_ceq type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) !======================================================== call tqcph1(n1,n2,n3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,ceq) !======================================================== c_ceq = c_loc(ceq) end subroutine c_tqcph1 subroutine c_tqcph2(n1,n2,n3,n4,c_ceq) bind(c,name='c_tqcph2') integer(c_int), intent(in), value :: n1 integer(c_int), intent(in), value :: n2 integer(c_int), intent(out) :: n3 integer(c_int), intent(out) :: n4 type(c_ptr), intent(inout) :: c_ceq type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) !=========================== call tqcph2(n1,n2,n3,n4,ceq) !=========================== c_ceq = c_loc(ceq) end subroutine c_tqcph2 subroutine c_tqdceq(ceqname) bind(c,name='c_tqdceq') character(c_char), intent(in) :: ceqname(24) character(len=24) :: fstring fstring = c_to_f_string(ceqname) !================ call tqdceq(fstring) !================ end subroutine c_tqdceq subroutine c_tqcceq(ceqname,n1,c_newceq,c_ceq) bind(c,name='c_tqcceq') character(c_char), intent(in) :: ceqname(24) integer(c_int), intent(out) :: n1 type(c_ptr), intent(inout) :: c_newceq type(c_ptr), intent(inout) :: c_ceq type(gtp_equilibrium_data), pointer :: ceq type(gtp_equilibrium_data), pointer :: newceq character(len=24) :: fstring call c_f_pointer(c_newceq, newceq) call c_f_pointer(c_ceq, ceq) fstring = c_to_f_string(ceqname) !================================= call tqcceq(fstring,n1,newceq,ceq) !================================= c_newceq = c_loc(newceq) c_ceq = c_loc(ceq) end subroutine c_tqcceq subroutine c_tqselceq(ceqname,c_ceq) bind(c,name='c_tqselceq') character(c_char), intent(in) :: ceqname(24) type(c_ptr), intent(inout) :: c_ceq type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fstring call c_f_pointer(c_ceq, ceq) fstring = c_to_f_string(ceqname) !========================= call tqselceq(fstring,ceq) !========================= c_ceq = c_loc(ceq) end subroutine c_tqselceq subroutine c_reset_conditions(cline,c_ceq) bind(c,name='c_reset_conditions') character(c_char), intent(in) :: cline(24) type(c_ptr), intent(inout) :: c_ceq type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fstring call c_f_pointer(c_ceq, ceq) fstring = c_to_f_string(cline) !================================= call reset_conditions(fstring,ceq) !================================= c_ceq = c_loc(ceq) end subroutine c_reset_conditions subroutine c_Change_Status_Phase(myname,nystat,myval,c_ceq) & bind(c,name='c_Change_Status_Phase') character(c_char), intent(in) :: myname(24) integer(c_int), intent(in), value :: nystat real(c_double), intent(in), value :: myval type(c_ptr), intent(inout) :: c_ceq type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fstring call c_f_pointer(c_ceq, ceq) fstring = c_to_f_string(myname) !================================================= call Change_Status_Phase(fstring,nystat,myval,ceq) !================================================= c_ceq = c_loc(ceq) end subroutine c_Change_Status_Phase subroutine c_tqlr(lut,c_ceq) bind(c,name='c_tqlr') integer(c_int), intent(in), value :: lut type(c_ptr), intent(inout) :: c_ceq type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) !================= call tqlr(lut,ceq) !================= c_ceq = c_loc(ceq) end subroutine c_tqlr subroutine c_tqlc(lut,c_ceq) bind(c,name='c_tqlc') integer(c_int), intent(in), value :: lut type(c_ptr), intent(inout) :: c_ceq type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) !================= call tqlc(lut,ceq) !================= c_ceq = c_loc(ceq) end subroutine c_tqlc end module liboctqisoc ================================================ FILE: examples/TQ4lib/Cpp/Matthias/linkmake ================================================ REM 160926 Bo Sundman update REM 151210 Mathias original REM You must have compiled the OC software without parallelization REM to obtain liboceq.a and liboceqplus.mod REM These files are copied here together with REM the F90 source library liboctq.F90 REM liboctqisoc.F90 is the OC/TQ library that can be called from C++ REM The copy commands assume we are at REM TQ4lib/Cpp/isoC-matthias/ below OC copy ..\..\..\liboceq.a . copy ..\..\..\liboceqplus.mod . REM This is the Fortran part of TQ library for C++ copy ..\liboctq.F90 . gfortran -c liboctq.F90 REM This the C++ TQ library which calls the F90 library gfortran -c liboctqisoc.F90 REM This is linking all together g++ -o tqcpptest1 -lstdc++ tqcpptest1.cpp liboctqisoc.o liboctq.o liboceq.a -lgfortran -lm ================================================ FILE: examples/TQ4lib/Cpp/Matthias/steel1.TDB ================================================ $ Database file written 2012- 2-11 $ From database: SSOL2 ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT C GRAPHITE 1.2011E+01 1.0540E+03 5.7400E+00! ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01! ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! ELEMENT MO BCC_A2 9.5940E+01 4.5890E+03 2.8560E+01! ELEMENT SI DIAMOND_A4 2.8085E+01 3.2175E+03 1.8820E+01! ELEMENT V BCC_A2 5.0941E+01 4.5070E+03 3.0890E+01! SPECIES C1 C! SPECIES C2 C2! SPECIES C3 C3! SPECIES C4 C4! SPECIES C5 C5! SPECIES C6 C6! SPECIES C7 C7! SPECIES V1C1 V1C1! FUNCTION GHSERCC 2.98150E+02 -17368.441+170.73*T-24.3*T*LN(T) -4.723E-04*T**2+2562600*T**(-1)-2.643E+08*T**(-2)+1.2E+10*T**(-3); 6.00000E+03 N ! FUNCTION GPCLIQ 2.98150E+02 +YCLIQ#*EXP(ZCLIQ#); 6.00000E+03 N ! FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T) +.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2.18000E+03 Y -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6.00000E+03 N ! FUNCTION GPCRLIQ 2.98150E+02 +YCRLIQ#*EXP(ZCRLIQ#); 6.00000E+03 N ! FUNCTION GFELIQ 2.98150E+02 +12040.17-6.55843*T-3.6751551E-21*T**7 +GHSERFE#; 1.81100E+03 Y -10839.7+291.302*T-46*T*LN(T); 6.00000E+03 N ! FUNCTION GPFELIQ 2.98150E+02 +YFELIQ#*EXP(ZFELIQ#); 6.00000E+03 N ! FUNCTION GHSERMO 2.98150E+02 -7746.302+131.9197*T-23.56414*T*LN(T) -.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)-1.30927E-10*T**4; 2.89600E+03 Y -30556.41+283.559746*T-42.63829*T*LN(T)-4.849315E+33*T**(-9); 5.00000E+03 N ! FUNCTION GPMOLIQ 2.98150E+02 +YMOLIQ#*EXP(ZMOLIQ#); 6.00000E+03 N ! FUNCTION GHSERSI 2.98150E+02 -8162.609+137.227259*T-22.8317533*T*LN(T) -.001912904*T**2-3.552E-09*T**3+176667*T**(-1); 1.68700E+03 Y -9457.642+167.271767*T-27.196*T*LN(T)-4.20369E+30*T**(-9); 3.60000E+03 N ! FUNCTION GHSERVV 2.98150E+02 -7930.43+133.346053*T-24.134*T*LN(T) -.003098*T**2+1.2175E-07*T**3+69460*T**(-1); 7.90000E+02 Y -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; 2.18300E+03 Y -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); 4.00000E+03 N ! FUNCTION GPCRBCC 2.98150E+02 +YCRBCC#*EXP(ZCRBCC#); 6.00000E+03 N ! FUNCTION GPCGRA 2.98150E+02 +YCGRA#*EXP(ZCGRA#); 6.00000E+03 N ! FUNCTION GHSERFE 2.98150E+02 +1225.7+124.134*T-23.5143*T*LN(T) -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6.00000E+03 N ! FUNCTION GPFEBCC 2.98150E+02 +YFEBCC#*EXP(ZFEBCC#); 6.00000E+03 N ! FUNCTION GSIBCC 2.98150E+02 +47000-22.5*T+GHSERSI#; 6.00000E+03 N ! FUNCTION GPMOBCC 2.98150E+02 +YMOBCC#*EXP(ZMOBCC#); 6.00000E+03 N ! FUNCTION GFECEM 2.98150E+02 -10745+706.04*T-120.6*T*LN(T)+GPCEM1#; 6.00000E+03 N ! FUNCTION GCRFCC 2.98150E+02 +7284+.163*T+GHSERCR#; 6.00000E+03 N ! FUNCTION GFEFCC 2.98150E+02 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2 +GHSERFE#; 1.81100E+03 Y -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6.00000E+03 N ! FUNCTION GMOFCC 2.98150E+02 +15200+.63*T+GHSERMO#; 6.00000E+03 N ! FUNCTION GPCDIA 2.98150E+02 +YCDIA#*EXP(ZCDIA#); 6.00000E+03 N ! FUNCTION GPCFCC 2.98150E+02 +YCFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! FUNCTION GPFEFCC 2.98150E+02 +YFEFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! FUNCTION GHSERVZ 2.98150E+02 -7930.43+133.346053*T-24.134*T*LN(T) -.003098*T**2+1.2175E-07*T**3+69460*T**(-1); 7.90000E+02 Y -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; 4.00000E+03 Y -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); 6.00000E+03 N ! FUNCTION GPFEHCP 2.98150E+02 +YFEHCP#*EXP(ZFEHCP#); 6.00000E+03 N ! FUNCTION GCRM23C6 2.98150E+02 -521983+3622.24*T-620.965*T*LN(T) -.126431*T**2; 6.00000E+03 N ! FUNCTION GFEM23C6 2.98150E+02 +7.666667*GFECEM#-1.666667*GHSERCC#+66920 -40*T; 6.00000E+03 N ! FUNCTION GVM23C6 2.98150E+02 -990367+4330.63*T-728.829*T*LN(T) +5003425*T**(-1); 6.00000E+03 N ! FUNCTION GCRM3C2 2.98150E+02 -100823.8+530.66989*T-89.6694*T*LN(T) -.0301188*T**2; 6.00000E+03 N ! FUNCTION GCRM7C3 2.98150E+02 -201690+1103.128*T-190.177*T*LN(T) -.0578207*T**2; 6.00000E+03 N ! FUNCTION GPMU1 2.98150E+02 +8.72E-05*P; 6.00000E+03 N ! FUNCTION GPMU2 2.98150E+02 +1.04E-04*P; 6.00000E+03 N ! FUNCTION GPR1 2.98150E+02 +3.81E-04*P; 6.00000E+03 N ! FUNCTION GPR2 2.98150E+02 +4.33E-04*P; 6.00000E+03 N ! FUNCTION GPSIG1 2.98150E+02 +1.09E-04*P; 6.00000E+03 N ! FUNCTION GPSIG2 2.98150E+02 +1.117E-04*P; 6.00000E+03 N ! FUNCTION L0BCC 2.98150E+02 -27809+11.62*T; 6.00000E+03 N ! FUNCTION FESIW1 2.98150E+02 +1260*R#; 6.00000E+03 N ! FUNCTION L1BCC 2.98150E+02 -11544; 6.00000E+03 N ! FUNCTION L2BCC 2.98150E+02 3890; 6.00000E+03 N ! FUNCTION ETCFESI 2.98150E+02 63; 6.00000E+03 N ! FUNCTION YCLIQ 2.98150E+02 +VCLIQ#*EXP(-ECLIQ#); 6.00000E+03 N ! FUNCTION ZCLIQ 2.98150E+02 +1*LN(XCLIQ#); 6.00000E+03 N ! FUNCTION YCRLIQ 2.98150E+02 +VCRLIQ#*EXP(-ECRLIQ#); 6.00000E+03 N ! FUNCTION ZCRLIQ 2.98150E+02 +1*LN(XCRLIQ#); 6.00000E+03 N ! FUNCTION YFELIQ 2.98150E+02 +VFELIQ#*EXP(-EFELIQ#); 6.00000E+03 N ! FUNCTION ZFELIQ 2.98150E+02 +1*LN(XFELIQ#); 6.00000E+03 N ! FUNCTION YMOLIQ 2.98150E+02 +VMOLIQ#*EXP(-EMOLIQ#); 6.00000E+03 N ! FUNCTION ZMOLIQ 2.98150E+02 +1*LN(XMOLIQ#); 6.00000E+03 N ! FUNCTION YCRBCC 2.98150E+02 +VCRBCC#*EXP(-ECRBCC#); 6.00000E+03 N ! FUNCTION ZCRBCC 2.98150E+02 +1*LN(XCRBCC#); 6.00000E+03 N ! FUNCTION YCGRA 2.98150E+02 +VCGRA#*EXP(-ECGRA#); 6.00000E+03 N ! FUNCTION ZCGRA 2.98150E+02 +1*LN(XCGRA#); 6.00000E+03 N ! FUNCTION YFEBCC 2.98150E+02 +VFEBCC#*EXP(-EFEBCC#); 6.00000E+03 N ! FUNCTION ZFEBCC 2.98150E+02 +1*LN(XFEBCC#); 6.00000E+03 N ! FUNCTION YMOBCC 2.98150E+02 +VMOBCC#*EXP(-EMOBCC#); 6.00000E+03 N ! FUNCTION ZMOBCC 2.98150E+02 +1*LN(XMOBCC#); 6.00000E+03 N ! FUNCTION GPCEM1 2.98150E+02 +VCEM1#*P; 6.00000E+03 N ! FUNCTION YCDIA 2.98150E+02 +VCDIA#*EXP(-ECDIA#); 6.00000E+03 N ! FUNCTION ZCDIA 2.98150E+02 +1*LN(XCDIA#); 6.00000E+03 N ! FUNCTION YCFCC 2.98150E+02 +VCFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! FUNCTION ZFEFCC 2.98150E+02 +1*LN(XFEFCC#); 6.00000E+03 N ! FUNCTION YFEFCC 2.98150E+02 +VFEFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! FUNCTION YFEHCP 2.98150E+02 +VFEHCP#*EXP(-EFEHCP#); 6.00000E+03 N ! FUNCTION ZFEHCP 2.98150E+02 +1*LN(XFEHCP#); 6.00000E+03 N ! FUNCTION VCLIQ 2.98150E+02 +7.626E-06*EXP(ACLIQ#); 6.00000E+03 N ! FUNCTION ECLIQ 2.98150E+02 +1*LN(CCLIQ#); 6.00000E+03 N ! FUNCTION XCLIQ 2.98150E+02 +1*EXP(.5*DCLIQ#)-1; 6.00000E+03 N ! FUNCTION VCRLIQ 2.98150E+02 +7.653E-06*EXP(ACRLIQ#); 6.00000E+03 N ! FUNCTION ECRLIQ 2.98150E+02 +1*LN(CCRLIQ#); 6.00000E+03 N ! FUNCTION XCRLIQ 2.98150E+02 +1*EXP(.8*DCRLIQ#)-1; 6.00000E+03 N ! FUNCTION VFELIQ 2.98150E+02 +6.46677E-06*EXP(AFELIQ#); 6.00000E+03 N ! FUNCTION EFELIQ 2.98150E+02 +1*LN(CFELIQ#); 6.00000E+03 N ! FUNCTION XFELIQ 2.98150E+02 +1*EXP(.8484467*DFELIQ#)-1; 6.00000E+03 N ! FUNCTION VMOLIQ 2.98150E+02 +9.75079E-06*EXP(AMOLIQ#); 6.00000E+03 N ! FUNCTION EMOLIQ 2.98150E+02 +1*LN(CMOLIQ#); 6.00000E+03 N ! FUNCTION XMOLIQ 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 N ! FUNCTION VCRBCC 2.98150E+02 +7.188E-06*EXP(ACRBCC#); 6.00000E+03 N ! FUNCTION ECRBCC 2.98150E+02 +1*LN(CCRBCC#); 6.00000E+03 N ! FUNCTION XCRBCC 2.98150E+02 +1*EXP(.8*DCRBCC#)-1; 6.00000E+03 N ! FUNCTION VCGRA 2.98150E+02 +5.259E-06*EXP(ACGRA#); 6.00000E+03 N ! FUNCTION ECGRA 2.98150E+02 +1*LN(CCGRA#); 6.00000E+03 N ! FUNCTION XCGRA 2.98150E+02 +1*EXP(.9166667*DCGRA#)-1; 6.00000E+03 N ! FUNCTION VFEBCC 2.98150E+02 +7.042095E-06*EXP(AFEBCC#); 6.00000E+03 N ! FUNCTION EFEBCC 2.98150E+02 +1*LN(CFEBCC#); 6.00000E+03 N ! FUNCTION XFEBCC 2.98150E+02 +1*EXP(.7874195*DFEBCC#)-1; 6.00000E+03 N ! FUNCTION VMOBCC 2.98150E+02 +9.34372E-06*EXP(AMOBCC#); 6.00000E+03 N ! FUNCTION EMOBCC 2.98150E+02 +1*LN(CMOBCC#); 6.00000E+03 N ! FUNCTION XMOBCC 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 N ! FUNCTION VCEM1 2.98150E+02 +2.339E-05*EXP(ACEM1#); 6.00000E+03 N ! FUNCTION VCDIA 2.98150E+02 +3.412E-06*EXP(ACDIA#); 6.00000E+03 N ! FUNCTION ECDIA 2.98150E+02 +1*LN(CCDIA#); 6.00000E+03 N ! FUNCTION XCDIA 2.98150E+02 +1*EXP(.8*DCDIA#)-1; 6.00000E+03 N ! FUNCTION VCFCC 2.98150E+02 +1.031E-05*EXP(ACFCC#); 6.00000E+03 N ! FUNCTION EFEFCC 2.98150E+02 +1*LN(CFEFCC#); 6.00000E+03 N ! FUNCTION XFEFCC 2.98150E+02 +1*EXP(.8064454*DFEFCC#)-1; 6.00000E+03 N ! FUNCTION VFEFCC 2.98150E+02 +6.688726E-06*EXP(AFEFCC#); 6.00000E+03 N ! FUNCTION VFEHCP 2.98150E+02 +6.59121E-06*EXP(AFEHCP#); 6.00000E+03 N ! FUNCTION EFEHCP 2.98150E+02 +1*LN(CFEHCP#); 6.00000E+03 N ! FUNCTION XFEHCP 2.98150E+02 +1*EXP(.8064454*DFEHCP#)-1; 6.00000E+03 N ! FUNCTION ACLIQ 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 N ! FUNCTION CCLIQ 2.98150E+02 1.6E-10; 6.00000E+03 N ! FUNCTION DCLIQ 2.98150E+02 +1*LN(BCLIQ#); 6.00000E+03 N ! FUNCTION ACRLIQ 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N ! FUNCTION CCRLIQ 2.98150E+02 3.72E-11; 6.00000E+03 N ! FUNCTION DCRLIQ 2.98150E+02 +1*LN(BCRLIQ#); 6.00000E+03 N ! FUNCTION AFELIQ 2.98150E+02 +1.135E-04*T; 6.00000E+03 N ! FUNCTION CFELIQ 2.98150E+02 +4.22534787E-12+2.71569924E-14*T; 6.00000E+03 N ! FUNCTION DFELIQ 2.98150E+02 +1*LN(BFELIQ#); 6.00000E+03 N ! FUNCTION AMOLIQ 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2 +1.14687E-12*T**3; 6.00000E+03 N ! FUNCTION CMOLIQ 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; 6.00000E+03 N ! FUNCTION DMOBCC 2.98150E+02 +1*LN(BMOBCC#); 6.00000E+03 N ! FUNCTION ACRBCC 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N ! FUNCTION CCRBCC 2.98150E+02 2.08E-11; 6.00000E+03 N ! FUNCTION DCRBCC 2.98150E+02 +1*LN(BCRBCC#); 6.00000E+03 N ! FUNCTION ACGRA 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 N ! FUNCTION CCGRA 2.98150E+02 3.3E-10; 6.00000E+03 N ! FUNCTION DCGRA 2.98150E+02 +1*LN(BCGRA#); 6.00000E+03 N ! FUNCTION AFEBCC 2.98150E+02 +2.3987E-05*T+1.2845E-08*T**2; 6.00000E+03 N ! FUNCTION CFEBCC 2.98150E+02 +2.20949565E-11+2.41329523E-16*T; 6.00000E+03 N ! FUNCTION DFEBCC 2.98150E+02 +1*LN(BFEBCC#); 6.00000E+03 N ! FUNCTION AMOBCC 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2 +1.14687E-12*T**3; 6.00000E+03 N ! FUNCTION CMOBCC 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; 6.00000E+03 N ! FUNCTION ACEM1 2.98150E+02 -1.36E-05*T+4E-08*T**2; 6.00000E+03 N ! FUNCTION ACDIA 2.98150E+02 +2.43E-06*T+5E-09*T**2; 6.00000E+03 N ! FUNCTION CCDIA 2.98150E+02 6.8E-12; 6.00000E+03 N ! FUNCTION DCDIA 2.98150E+02 +1*LN(BCDIA#); 6.00000E+03 N ! FUNCTION ACFCC 2.98150E+02 +1.44E-04*T; 6.00000E+03 N ! FUNCTION CFEFCC 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; 6.00000E+03 N ! FUNCTION DFEFCC 2.98150E+02 +1*LN(BFEFCC#); 6.00000E+03 N ! FUNCTION AFEFCC 2.98150E+02 +7.3097E-05*T; 6.00000E+03 N ! FUNCTION AFEHCP 2.98150E+02 +7.3646E-05*T; 6.00000E+03 N ! FUNCTION CFEHCP 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; 6.00000E+03 N ! FUNCTION DFEHCP 2.98150E+02 +1*LN(BFEHCP#); 6.00000E+03 N ! FUNCTION BCLIQ 2.98150E+02 +1+3.2E-10*P; 6.00000E+03 N ! FUNCTION BCRLIQ 2.98150E+02 +1+4.65E-11*P; 6.00000E+03 N ! FUNCTION BFELIQ 2.98150E+02 +1+4.98009787E-12*P+3.20078924E-14*T*P; 6.00000E+03 N ! FUNCTION BMOBCC 2.98150E+02 +1+1.13837E-11*P+4.875E-16*T*P +1.2675E-19*T**2*P; 6.00000E+03 N ! FUNCTION BCRBCC 2.98150E+02 +1+2.6E-11*P; 6.00000E+03 N ! FUNCTION BCGRA 2.98150E+02 +1+3.6E-10*P; 6.00000E+03 N ! FUNCTION BFEBCC 2.98150E+02 +1+2.80599565E-11*P+3.06481523E-16*T*P; 6.00000E+03 N ! FUNCTION BCDIA 2.98150E+02 +1+8.5E-12*P; 6.00000E+03 N ! FUNCTION BFEFCC 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; 6.00000E+03 N ! FUNCTION BFEHCP 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; 6.00000E+03 N ! FUNCTION UN_ASS 298.15 0; 300 N ! TYPE_DEFINITION % SEQ *! DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! PHASE LIQUID:L % 1 1.0 ! CONSTITUENT LIQUID:L :C,CR,FE,MO,SI,V : ! PARAMETER G(LIQUID,C;0) 2.98150E+02 +117369-24.63*T+GHSERCC#+GPCLIQ#; 6.00000E+03 N REF283 ! PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T +2.37615E-21*T**7+GHSERCR#+GPCRLIQ#; 2.18000E+03 Y +18409.36-8.563683*T+2.88526E+32*T**(-9)+GHSERCR#+GPCRLIQ#; 6.00000E+03 N REF283 ! PARAMETER G(LIQUID,FE;0) 2.98150E+02 +GFELIQ#+GPFELIQ#; 6.00000E+03 N REF283 ! PARAMETER G(LIQUID,MO;0) 2.98150E+02 +41831.347-14.694912*T +4.24519E-22*T**7+GHSERMO#+GPMOLIQ#; 2.89600E+03 Y +34095.373-11.890046*T+4.849315E+33*T**(-9)+GHSERMO#+GPMOLIQ#; 5.00000E+03 N REF283 ! PARAMETER G(LIQUID,SI;0) 2.98150E+02 +50696.36-30.099439*T +2.09307E-21*T**7+GHSERSI#; 1.68700E+03 Y +49828.165-29.559069*T+4.20369E+30*T**(-9)+GHSERSI#; 3.60000E+03 N REF283 ! PARAMETER G(LIQUID,V;0) 2.98150E+02 +20764.117-9.455552*T -5.19136E-22*T**7+GHSERVV#; 7.90000E+02 Y +20764.117-9.455552*T-5.19136E-22*T**7+GHSERVV#; 2.18300E+03 Y +22072.354-10.0848*T-6.44389E+31*T**(-9)+GHSERVV#; 4.00000E+03 N REF283 ! PARAMETER G(LIQUID,C,CR;0) 2.98150E+02 -90526-25.9116*T; 6.00000E+03 N REF101 ! PARAMETER G(LIQUID,C,CR;1) 2.98150E+02 80000; 6.00000E+03 N REF101 ! PARAMETER G(LIQUID,C,CR;2) 2.98150E+02 80000; 6.00000E+03 N REF101 ! PARAMETER G(LIQUID,C,CR,FE;0) 2.98150E+02 -496063; 6.00000E+03 N REF322 ! PARAMETER G(LIQUID,C,CR,FE;1) 2.98150E+02 57990; 6.00000E+03 N REF322 ! PARAMETER G(LIQUID,C,CR,FE;2) 2.98150E+02 61404; 6.00000E+03 N REF322 ! PARAMETER G(LIQUID,C,CR,V;0) 2.98150E+02 -769497; 6.00000E+03 N REF324 ! PARAMETER G(LIQUID,C,CR,V;1) 2.98150E+02 263981; 6.00000E+03 N REF324 ! PARAMETER G(LIQUID,C,CR,V;2) 2.98150E+02 3599; 6.00000E+03 N REF324 ! PARAMETER G(LIQUID,C,FE;0) 2.98150E+02 -124320+28.5*T; 6.00000E+03 N REF190 ! PARAMETER G(LIQUID,C,FE;1) 2.98150E+02 19300; 6.00000E+03 N REF190 ! PARAMETER G(LIQUID,C,FE;2) 2.98150E+02 +49260-19*T; 6.00000E+03 N REF190 ! PARAMETER G(LIQUID,C,FE,SI;0) 2.98150E+02 445740; 6.00000E+03 N REF99 ! PARAMETER G(LIQUID,C,FE,SI;1) 2.98150E+02 -6065-35.33*T; 6.00000E+03 N REF99 ! PARAMETER G(LIQUID,C,FE,SI;2) 2.98150E+02 +2545792-1450.6*T; 6.00000E+03 N REF99 ! PARAMETER G(LIQUID,C,FE,V;0) 2.98150E+02 -60000; 6.00000E+03 N REF270 ! PARAMETER G(LIQUID,C,FE,V;1) 2.98150E+02 -60000; 6.00000E+03 N REF270 ! PARAMETER G(LIQUID,C,FE,V;2) 2.98150E+02 100000; 6.00000E+03 N REF270 ! PARAMETER G(LIQUID,C,FE,MO;0) 2.98150E+02 -37800; 6.00000E+03 N REF113 ! PARAMETER G(LIQUID,C,MO;0) 2.98150E+02 -217800+38.41*T; 6.00000E+03 N REF104 ! PARAMETER G(LIQUID,C,MO;1) 2.98150E+02 30000; 6.00000E+03 N REF104 ! PARAMETER G(LIQUID,C,MO;2) 2.98150E+02 47000; 6.00000E+03 N REF104 ! PARAMETER G(LIQUID,C,SI;0) 2.98150E+02 -133000+30.97*T; 6.00000E+03 N REF99 ! PARAMETER G(LIQUID,C,V;0) 2.98150E+02 -284196+38.952*T; 6.00000E+03 N REF256 ! PARAMETER G(LIQUID,C,V;1) 2.98150E+02 +96335-17.775*T; 6.00000E+03 N REF256 ! PARAMETER G(LIQUID,C,V;2) 2.98150E+02 102050; 6.00000E+03 N REF256 ! PARAMETER G(LIQUID,CR,FE;0) 2.98150E+02 -14550+6.65*T; 6.00000E+03 N REF107 ! PARAMETER G(LIQUID,CR,FE,V;0) 2.98150E+02 14881; 6.00000E+03 N REF323 ! PARAMETER G(LIQUID,CR,FE,V;1) 2.98150E+02 17968; 6.00000E+03 N REF323 ! PARAMETER G(LIQUID,CR,FE,V;2) 2.98150E+02 -7692; 6.00000E+03 N REF323 ! PARAMETER G(LIQUID,CR,MO;0) 2.98150E+02 +15810-6.714*T; 6.00000E+03 N REF123 ! PARAMETER G(LIQUID,CR,MO;1) 2.98150E+02 -6220; 6.00000E+03 N REF123 ! PARAMETER G(LIQUID,CR,SI;0) 2.98150E+02 -120157.52+16.63891*T; 6.00000E+03 N REF90 ! PARAMETER G(LIQUID,CR,SI;1) 2.98150E+02 -49502.35+13.76967*T; 6.00000E+03 N REF90 ! PARAMETER G(LIQUID,CR,V;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 N REF323 ! PARAMETER G(LIQUID,CR,V;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 N REF323 ! PARAMETER G(LIQUID,FE,MO;0) 2.98150E+02 -6973-.37*T; 6.00000E+03 N REF10 ! PARAMETER G(LIQUID,FE,MO;1) 2.98150E+02 -9424+4.502*T; 6.00000E+03 N REF10 ! PARAMETER G(LIQUID,FE,SI;0) 2.98150E+02 -164435+41.977*T; 6.00000E+03 N REF99 ! PARAMETER G(LIQUID,FE,SI;1) 2.98150E+02 -21.523*T; 6.00000E+03 N REF99 ! PARAMETER G(LIQUID,FE,SI;2) 2.98150E+02 -18821+22.07*T; 6.00000E+03 N REF99 ! PARAMETER G(LIQUID,FE,SI;3) 2.98150E+02 9696; 6.00000E+03 N REF99 ! PARAMETER G(LIQUID,FE,V;0) 2.98150E+02 -34679+1.895*T; 6.00000E+03 N REF269 ! PARAMETER G(LIQUID,FE,V;1) 2.98150E+02 10209; 6.00000E+03 N REF269 ! TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! PHASE BCC_A2 %& 2 1 3 ! CONSTITUENT BCC_A2 :CR%,FE%,MO%,SI,V% : C,VA% : ! PARAMETER G(BCC_A2,CR:C;0) 2.98150E+02 +GHSERCR#+3*GHSERCC#+GPCRBCC# +3*GPCGRA#+416000; 6.00000E+03 N REF101 ! PARAMETER TC(BCC_A2,CR:C;0) 2.98150E+02 -311.5; 6.00000E+03 N REF101 ! PARAMETER BMAGN(BCC_A2,CR:C;0) 2.98150E+02 -.008; 6.00000E+03 N REF101 ! PARAMETER G(BCC_A2,FE:C;0) 2.98150E+02 +322050+75.667*T+GHSERFE# +GPFEBCC#+3*GHSERCC#+3*GPCGRA#; 6.00000E+03 N REF190 ! PARAMETER TC(BCC_A2,FE:C;0) 2.98150E+02 1043; 6.00000E+03 N REF190 ! PARAMETER BMAGN(BCC_A2,FE:C;0) 2.98150E+02 2.22; 6.00000E+03 N REF190 ! PARAMETER G(BCC_A2,MO:C;0) 2.98150E+02 +331000-75*T+GHSERMO#+3*GHSERCC#; 6.00000E+03 N REF104 ! PARAMETER G(BCC_A2,SI:C;0) 2.98150E+02 +322050-75.667*T+GSIBCC# +3*GHSERCC#+3*GPCGRA#; 6.00000E+03 N REF98 ! PARAMETER G(BCC_A2,V:C;0) 2.98150E+02 +108449+GHSERVV#+3*GHSERCC#; 6.00000E+03 N REF256 ! PARAMETER G(BCC_A2,CR:VA;0) 2.98150E+02 +GHSERCR#+GPCRBCC#; 6.00000E+03 N REF283 ! PARAMETER TC(BCC_A2,CR:VA;0) 2.98150E+02 -311.5; 6.00000E+03 N REF281 ! PARAMETER BMAGN(BCC_A2,CR:VA;0) 2.98150E+02 -.01; 6.00000E+03 N REF281 ! PARAMETER G(BCC_A2,FE:VA;0) 2.98150E+02 +GHSERFE#+GPFEBCC#; 6.00000E+03 N REF283 ! PARAMETER TC(BCC_A2,FE:VA;0) 2.98150E+02 1043; 6.00000E+03 N REF281 ! PARAMETER BMAGN(BCC_A2,FE:VA;0) 2.98150E+02 2.22; 6.00000E+03 N REF281 ! PARAMETER G(BCC_A2,MO:VA;0) 2.98150E+02 +GHSERMO#+GPMOBCC#; 5.00000E+03 N REF283 ! PARAMETER G(BCC_A2,SI:VA;0) 2.98150E+02 +GSIBCC#; 3.60000E+03 N REF283 ! PARAMETER G(BCC_A2,V:VA;0) 2.98150E+02 +GHSERVV#; 4.00000E+03 N REF283 ! PARAMETER G(BCC_A2,CR,FE:C;0) 2.98150E+02 -1250000+667.7*T; 6.00000E+03 N REF322 ! PARAMETER TC(BCC_A2,CR,FE:C;0) 2.98150E+02 1650; 6.00000E+03 N REF102 ! PARAMETER TC(BCC_A2,CR,FE:C;1) 2.98150E+02 550; 6.00000E+03 N REF102 ! PARAMETER BMAGN(BCC_A2,CR,FE:C;0) 2.98150E+02 -.85; 6.00000E+03 N REF102 ! PARAMETER G(BCC_A2,CR:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N REF101 ! PARAMETER G(BCC_A2,FE,MO:C;0) 2.98150E+02 -1250000+667.7*T; 6.00000E+03 N REF325 ! PARAMETER TC(BCC_A2,FE,MO:C;0) 2.98150E+02 335; 6.00000E+03 N REF104 ! PARAMETER TC(BCC_A2,FE,MO:C;1) 2.98150E+02 526; 6.00000E+03 N REF104 ! PARAMETER G(BCC_A2,FE,SI:C;0) 2.98150E+02 78866; 6.00000E+03 N REF99 ! PARAMETER G(BCC_A2,FE,V:C;0) 2.98150E+02 -23674+.465*T; 6.00000E+03 N REF270 ! PARAMETER G(BCC_A2,FE,V:C;1) 2.98150E+02 8283; 6.00000E+03 N REF270 ! PARAMETER G(BCC_A2,FE:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N REF190 ! PARAMETER G(BCC_A2,V:C,VA;0) 2.98150E+02 -297868; 6.00000E+03 N REF256 ! PARAMETER G(BCC_A2,CR,FE:VA;0) 2.98150E+02 +20500-9.68*T; 6.00000E+03 N REF107 ! PARAMETER TC(BCC_A2,CR,FE:VA;0) 2.98150E+02 1650; 6.00000E+03 N REF107 ! PARAMETER TC(BCC_A2,CR,FE:VA;1) 2.98150E+02 550; 6.00000E+03 N REF107 ! PARAMETER BMAGN(BCC_A2,CR,FE:VA;0) 2.98150E+02 -.85; 6.00000E+03 N REF107 ! PARAMETER G(BCC_A2,CR,FE,V:VA;0) 2.98150E+02 14881; 6.00000E+03 N REF323 ! PARAMETER G(BCC_A2,CR,FE,V:VA;1) 2.98150E+02 17968; 6.00000E+03 N REF323 ! PARAMETER G(BCC_A2,CR,FE,V:VA;2) 2.98150E+02 -7692; 6.00000E+03 N REF323 ! PARAMETER G(BCC_A2,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; 6.00000E+03 N REF123 ! PARAMETER G(BCC_A2,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 N REF123 ! PARAMETER G(BCC_A2,CR,SI:VA;0) 2.98150E+02 -102850.19+9.85457*T; 6.00000E+03 N REF90 ! PARAMETER G(BCC_A2,CR,SI:VA;1) 2.98150E+02 -49502.35+13.76967*T; 6.00000E+03 N REF90 ! PARAMETER G(BCC_A2,CR,V:VA;0) 2.98150E+02 -9875-2.6964*T; 6.00000E+03 N REF323 ! PARAMETER G(BCC_A2,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 N REF323 ! PARAMETER G(BCC_A2,FE,MO:VA;0) 2.98150E+02 +36818-9.141*T; 6.00000E+03 N REF10 ! PARAMETER G(BCC_A2,FE,MO:VA;1) 2.98150E+02 -362-5.724*T; 6.00000E+03 N REF10 ! PARAMETER TC(BCC_A2,FE,MO:VA;0) 2.98150E+02 335; 6.00000E+03 N REF10 ! PARAMETER TC(BCC_A2,FE,MO:VA;1) 2.98150E+02 526; 6.00000E+03 N REF10 ! PARAMETER G(BCC_A2,FE,SI:VA;0) 2.98150E+02 +4*L0BCC#-4*FESIW1#; 6.00000E+03 N REF98 ! PARAMETER G(BCC_A2,FE,SI:VA;1) 2.98150E+02 +8*L1BCC#; 6.00000E+03 N REF98 ! PARAMETER G(BCC_A2,FE,SI:VA;2) 2.98150E+02 +16*L2BCC#; 6.00000E+03 N REF98 ! PARAMETER TC(BCC_A2,FE,SI:VA;1) 2.98150E+02 +8*ETCFESI#; 6.00000E+03 N REF98 ! PARAMETER G(BCC_A2,FE,V:VA;0) 2.98150E+02 -23674+.465*T; 6.00000E+03 N REF269 ! PARAMETER G(BCC_A2,FE,V:VA;1) 2.98150E+02 8283; 6.00000E+03 N REF269 ! PARAMETER TC(BCC_A2,FE,V:VA;0) 2.98150E+02 -110; 6.00000E+03 N REF111 ! PARAMETER TC(BCC_A2,FE,V:VA;1) 2.98150E+02 3075; 6.00000E+03 N REF111 ! PARAMETER TC(BCC_A2,FE,V:VA;2) 2.98150E+02 808; 6.00000E+03 N REF111 ! PARAMETER TC(BCC_A2,FE,V:VA;3) 2.98150E+02 -2169; 6.00000E+03 N REF111 ! PARAMETER BMAGN(BCC_A2,FE,V:VA;0) 2.98150E+02 -2.26; 6.00000E+03 N REF111 ! TYPE_DEFINITION ' GES A_P_D CBCC_A12 MAGNETIC -3.0 2.80000E-01 ! PHASE CBCC_A12 %' 2 1 1 ! CONSTITUENT CBCC_A12 :CR,FE,SI,V : C,VA% : ! PARAMETER G(CBCC_A12,CR:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(CBCC_A12,FE:C;0) 2.98150E+02 +80000+GHSERFE#+GHSERCC#; 6.00000E+03 N REF267 ! PARAMETER G(CBCC_A12,SI:C;0) 2.98150E+02 +1000000+566.0326*T -85.955678*T*LN(T)-.007814909*T**2+3.7239E-07*T**3+1688653*T**(-1); 3.00000E+03 N REF177 ! PARAMETER G(CBCC_A12,V:C;0) 2.98150E+02 +10000+GHSERVV#+GHSERCC#; 6.00000E+03 N REF275 ! PARAMETER G(CBCC_A12,CR:VA;0) 2.98150E+02 +11087+2.7196*T+GHSERCR#; 6.00000E+03 N REF283 ! PARAMETER G(CBCC_A12,FE:VA;0) 2.98150E+02 +4745+GHSERFE#; 6.00000E+03 N REF283 ! PARAMETER G(CBCC_A12,SI:VA;0) 2.98150E+02 +50208-20.377*T+GHSERSI#; 3.60000E+03 N REF283 ! PARAMETER G(CBCC_A12,V:VA;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(CBCC_A12,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N REF267 ! PARAMETER G(CBCC_A12,FE,SI:VA;0) 2.98150E+02 -153141+46.48*T; 6.00000E+03 N REF42 ! PARAMETER G(CBCC_A12,FE,SI:VA;1) 2.98150E+02 -92352; 6.00000E+03 N REF42 ! PARAMETER G(CBCC_A12,FE,SI:VA;2) 2.98150E+02 62240; 6.00000E+03 N REF42 ! PARAMETER G(CBCC_A12,FE,V:VA;0) 2.98150E+02 -10000; 6.00000E+03 N REF275 ! PHASE CEMENTITE % 2 3 1 ! CONSTITUENT CEMENTITE :CR,FE%,MO,V : C : ! PARAMETER G(CEMENTITE,CR:C;0) 2.98150E+02 +3*GHSERCR#+GHSERCC#-48000 -9.2888*T; 6.00000E+03 N REF322 ! PARAMETER G(CEMENTITE,FE:C;0) 2.98150E+02 +GFECEM#; 6.00000E+03 N REF190 ! PARAMETER G(CEMENTITE,MO:C;0) 2.98150E+02 +3*GHSERMO#+GHSERCC#+77000 -57.4*T; 6.00000E+03 N REF104 ! PARAMETER G(CEMENTITE,V:C;0) 2.98150E+02 -156971+601.922*T -100.438*T*LN(T)+765557*T**(-1); 6.00000E+03 N REF275 ! PARAMETER G(CEMENTITE,CR,FE:C;0) 2.98150E+02 +25278-17.5*T; 6.00000E+03 N REF322 ! PARAMETER G(CEMENTITE,CR,MO:C;0) 2.98150E+02 40000; 6.00000E+03 N REF316 ! PARAMETER G(CEMENTITE,CR,V:C;0) 2.98150E+02 -29622-8.0892*T; 6.00000E+03 N REF324 ! PARAMETER G(CEMENTITE,CR,V:C;1) 2.98150E+02 -5160-7.5711*T; 6.00000E+03 N REF324 ! PARAMETER G(CEMENTITE,FE,V:C;0) 2.98150E+02 -45873-12.414*T; 6.00000E+03 N REF270 ! PHASE CHI_A12 % 3 24 10 24 ! CONSTITUENT CHI_A12 :CR,FE : CR,MO : CR,FE,MO : ! PARAMETER G(CHI_A12,CR:CR:CR;0) 2.98150E+02 +48*GCRFCC#+10*GHSERCR# +109000+123*T; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,FE:CR:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR# +24*GCRFCC#+18300-100*T; 6.00000E+03 N REF115 ! PARAMETER G(CHI_A12,CR:MO:CR;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# +24*GCRFCC#-26000; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,FE:MO:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO# +24*GCRFCC#+32555-385*T; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,CR:CR:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR# +24*GFEFCC#+500000; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,FE:CR:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERCR# +57300-100*T; 6.00000E+03 N REF115 ! PARAMETER G(CHI_A12,CR:MO:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# +24*GFEFCC#+500000; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,FE:MO:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERMO# +305210-270*T; 6.00000E+03 N REF115 ! PARAMETER G(CHI_A12,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR# +24*GMOFCC#+500000; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,FE:CR:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR# +24*GMOFCC#+100000; 6.00000E+03 N REF115 ! PARAMETER G(CHI_A12,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# +24*GMOFCC#+500000; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO# +24*GMOFCC#+97300-100*T; 6.00000E+03 N REF115 ! PHASE CR2VC2 % 3 2 1 2 ! CONSTITUENT CR2VC2 :CR : V : C : ! PARAMETER G(CR2VC2,CR:V:C;0) 2.98150E+02 -105987-38.2069*T+2*GHSERCR# +GHSERVV#+2*GHSERCC#; 6.00000E+03 N REF324 ! PHASE CR3SI % 2 3 1 ! CONSTITUENT CR3SI :CR%,SI : CR,SI% : ! PARAMETER G(CR3SI,CR:CR;0) 2.98150E+02 +17008.82+4*T+4*GHSERCR#; 6.00000E+03 N REF90 ! PARAMETER G(CR3SI,SI:CR;0) 2.98150E+02 +167008.8+4*T+GHSERCR# +3*GHSERSI#; 6.00000E+03 N REF90 ! PARAMETER G(CR3SI,CR:SI;0) 2.98150E+02 -125456.6+4*T+3*GHSERCR# +GHSERSI#; 6.00000E+03 N REF90 ! PARAMETER G(CR3SI,SI:SI;0) 2.98150E+02 +24543.3+4*T+4*GHSERSI#; 6.00000E+03 N REF90 ! PHASE CR5SI3 % 2 5 3 ! CONSTITUENT CR5SI3 :CR : SI : ! PARAMETER G(CR5SI3,CR:SI;0) 2.98150E+02 -318953.76+1067.49776*T -182.57818*T*LN(T)-.02391968*T**2-2.31728E-06*T**3; 6.00000E+03 N REF90 ! PHASE CRSI % 2 1 1 ! CONSTITUENT CRSI :CR : SI : ! PARAMETER G(CRSI,CR:SI;0) 2.98150E+02 -79041.68+311.75228*T -51.62865*T*LN(T)-.00447355*T**2+391330*T**(-1); 6.00000E+03 N REF90 ! PHASE CRSI2 % 2 1 2 ! CONSTITUENT CRSI2 :CR%,SI : CR,SI% : ! PARAMETER G(CRSI2,CR:CR;0) 2.98150E+02 +10000+10*T+3*GHSERCR#; 6.00000E+03 N REF90 ! PARAMETER G(CRSI2,SI:CR;0) 2.98150E+02 +150000-T+2*GHSERCR#+GHSERSI#; 6.00000E+03 N REF90 ! PARAMETER G(CRSI2,CR:SI;0) 2.98150E+02 -96793.65+333.25242*T -57.85575*T*LN(T)-.01322769*T**2-4.3203E-07*T**3; 6.00000E+03 N REF90 ! PARAMETER G(CRSI2,SI:SI;0) 2.98150E+02 +77711.85-15.05638*T+3*GHSERSI#; 6.00000E+03 N REF90 ! PARAMETER G(CRSI2,CR:CR,SI;0) 2.98150E+02 -57532.96+11.37201*T; 6.00000E+03 N REF90 ! PARAMETER G(CRSI2,SI:CR,SI;0) 2.98150E+02 -57532.96+11.37201*T; 6.00000E+03 N REF90 ! PHASE CUB_A13 % 2 1 1 ! CONSTITUENT CUB_A13 :CR,FE,SI,V : C,VA% : ! PARAMETER G(CUB_A13,CR:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(CUB_A13,FE:C;0) 2.98150E+02 +90000+GHSERFE#+GHSERCC#; 6.00000E+03 N REF267 ! PARAMETER G(CUB_A13,SI:C;0) 2.98150E+02 +1000000+566.0326*T -85.955678*T*LN(T)-.007814909*T**2+3.7239E-07*T**3+1688653*T**(-1); 3.00000E+03 N REF177 ! PARAMETER G(CUB_A13,V:C;0) 2.98150E+02 +10000+GHSERVV#+GHSERCC#; 6.00000E+03 N REF275 ! PARAMETER G(CUB_A13,CR:VA;0) 2.98150E+02 +15899+.6276*T+GHSERCR#; 6.00000E+03 N REF283 ! PARAMETER G(CUB_A13,FE:VA;0) 2.98150E+02 +3745+GHSERFE#; 6.00000E+03 N REF283 ! PARAMETER G(CUB_A13,SI:VA;0) 2.98150E+02 +47279-20.377*T+GHSERSI#; 3.60000E+03 N REF283 ! PARAMETER G(CUB_A13,V:VA;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(CUB_A13,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N REF267 ! PARAMETER G(CUB_A13,FE,SI:VA;0) 2.98150E+02 -153141+46.48*T; 6.00000E+03 N REF42 ! PARAMETER G(CUB_A13,FE,SI:VA;1) 2.98150E+02 -92352; 6.00000E+03 N REF42 ! PARAMETER G(CUB_A13,FE,SI:VA;2) 2.98150E+02 62240; 6.00000E+03 N REF42 ! PARAMETER G(CUB_A13,FE,V:VA;0) 2.98150E+02 -10000; 6.00000E+03 N REF275 ! PHASE DIAMOND_A4 % 1 1.0 ! CONSTITUENT DIAMOND_A4 :C,SI% : ! PARAMETER G(DIAMOND_A4,C;0) 2.98150E+02 -16359.441+175.61*T -24.31*T*LN(T)-4.723E-04*T**2+2698000*T**(-1)-2.61E+08*T**(-2) +1.11E+10*T**(-3)+GPCDIA#; 6.00000E+03 N REF283 ! PARAMETER G(DIAMOND_A4,SI;0) 2.98150E+02 +GHSERSI#; 3.60000E+03 N REF283 ! TYPE_DEFINITION ( GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! PHASE FCC_A1 %( 2 1 1 ! CONSTITUENT FCC_A1 :CR,FE%,MO,SI,V : C,VA% : ! PARAMETER G(FCC_A1,CR:C;0) 2.98150E+02 +GHSERCR#+GHSERCC#+1200-1.94*T; 6.00000E+03 N REF322 ! PARAMETER G(FCC_A1,FE:C;0) 2.98150E+02 +77207-15.877*T+GFEFCC#+GHSERCC# +GPCFCC#; 6.00000E+03 N REF190 ! PARAMETER TC(FCC_A1,FE:C;0) 2.98150E+02 -201; 6.00000E+03 N REF190 ! PARAMETER BMAGN(FCC_A1,FE:C;0) 2.98150E+02 -2.1; 6.00000E+03 N REF190 ! PARAMETER G(FCC_A1,MO:C;0) 2.98150E+02 -7500-8.3*T-750000*T**(-1) +GHSERMO#+GHSERCC#; 6.00000E+03 N REF104 ! PARAMETER G(FCC_A1,SI:C;0) 2.98150E+02 +GHSERSI#+GHSERCC#-20510+38.7*T; 6.00000E+03 N REF98 ! PARAMETER G(FCC_A1,V:C;0) 2.98150E+02 -117302+262.57*T-41.756*T*LN(T) -.00557101*T**2+590546*T**(-1); 6.00000E+03 N REF256 ! PARAMETER G(FCC_A1,CR:VA;0) 2.98150E+02 +GCRFCC#+GPCRBCC#; 6.00000E+03 N REF281 ! PARAMETER TC(FCC_A1,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N REF281 ! PARAMETER BMAGN(FCC_A1,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N REF281 ! PARAMETER G(FCC_A1,FE:VA;0) 2.98150E+02 +GFEFCC#+GPFEFCC#; 6.00000E+03 N REF283 ! PARAMETER TC(FCC_A1,FE:VA;0) 2.98150E+02 -201; 6.00000E+03 N REF281 ! PARAMETER BMAGN(FCC_A1,FE:VA;0) 2.98150E+02 -2.1; 6.00000E+03 N REF281 ! PARAMETER G(FCC_A1,MO:VA;0) 2.98150E+02 +15200+.63*T+GHSERMO#+GPMOBCC#; 5.00000E+03 N REF283 ! PARAMETER G(FCC_A1,SI:VA;0) 2.98150E+02 +51000-21.8*T+GHSERSI#; 3.60000E+03 N REF283 ! PARAMETER G(FCC_A1,V:VA;0) 2.98150E+02 +7500+1.7*T+GHSERVZ#; 4.00000E+03 N REF283 ! PARAMETER G(FCC_A1,CR,FE:C;0) 2.98150E+02 -74319+3.2353*T; 6.00000E+03 N REF322 ! PARAMETER G(FCC_A1,CR,V:C;0) 2.98150E+02 +35698-50.0981*T; 6.00000E+03 N REF324 ! PARAMETER G(FCC_A1,CR:C,VA;0) 2.98150E+02 -11977+6.8194*T; 6.00000E+03 N REF322 ! PARAMETER G(FCC_A1,FE,MO:C;0) 2.98150E+02 6000; 6.00000E+03 N REF113 ! PARAMETER G(FCC_A1,FE,SI:C;0) 2.98150E+02 +143220+39.31*T; 6.00000E+03 N REF99 ! PARAMETER G(FCC_A1,FE,SI:C;1) 2.98150E+02 -216321; 6.00000E+03 N REF99 ! PARAMETER G(FCC_A1,FE,V:C;0) 2.98150E+02 -7645.5-2.069*T; 6.00000E+03 N REF270 ! PARAMETER G(FCC_A1,FE,V:C;1) 2.98150E+02 -7645.5-2.069*T; 6.00000E+03 N REF270 ! PARAMETER G(FCC_A1,FE,V:C,VA;0) 2.98150E+02 -40000; 6.00000E+03 N REF270 ! PARAMETER G(FCC_A1,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N REF190 ! PARAMETER G(FCC_A1,MO,V:C;0) 2.98150E+02 -18000; 6.00000E+03 N REF220 ! PARAMETER G(FCC_A1,MO:C,VA;0) 2.98150E+02 -41300; 6.00000E+03 N REF104 ! PARAMETER G(FCC_A1,V:C,VA;0) 2.98150E+02 -74811+10.201*T; 6.00000E+03 N REF256 ! PARAMETER G(FCC_A1,V:C,VA;1) 2.98150E+02 -30394; 6.00000E+03 N REF256 ! PARAMETER G(FCC_A1,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; 6.00000E+03 N REF107 ! PARAMETER G(FCC_A1,CR,FE:VA;1) 2.98150E+02 1410; 6.00000E+03 N REF107 ! PARAMETER G(FCC_A1,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; 6.00000E+03 N REF58 ! PARAMETER G(FCC_A1,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 N REF58 ! PARAMETER G(FCC_A1,CR,SI:VA;0) 2.98150E+02 -122850+9.85457*T; 6.00000E+03 N REF58 ! PARAMETER G(FCC_A1,CR,SI:VA;1) 2.98150E+02 -49502+13.76967*T; 6.00000E+03 N REF58 ! PARAMETER G(FCC_A1,CR,V:VA;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 N REF323 ! PARAMETER G(FCC_A1,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 N REF323 ! PARAMETER G(FCC_A1,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; 6.00000E+03 N REF10 ! PARAMETER G(FCC_A1,FE,SI:VA;0) 2.98150E+02 -125248+41.116*T; 6.00000E+03 N REF98 ! PARAMETER G(FCC_A1,FE,SI:VA;1) 2.98150E+02 -142708; 6.00000E+03 N REF98 ! PARAMETER G(FCC_A1,FE,SI:VA;2) 2.98150E+02 89907; 6.00000E+03 N REF98 ! PARAMETER G(FCC_A1,FE,V:VA;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 N REF269 ! PHASE FE1SI1 % 2 .5 .5 ! CONSTITUENT FE1SI1 :FE : SI : ! PARAMETER G(FE1SI1,FE:SI;0) 2.98150E+02 +.5*GHSERFE#+.5*GHSERSI#-36381 +2.22*T; 6.00000E+03 N REF98 ! PHASE FE2SI % 2 .666667 .333333 ! CONSTITUENT FE2SI :FE : SI : ! PARAMETER G(FE2SI,FE:SI;0) 2.98150E+02 +.6666667*GHSERFE# +.3333333*GHSERSI#-23752-3.54*T; 6.00000E+03 N REF98 ! PHASE FE4N % 2 4 1 ! CONSTITUENT FE4N :FE : C,VA : ! PARAMETER G(FE4N,FE:C;0) 2.98150E+02 +15965+4*GHSERFE#+GHSERCC#; 6.00000E+03 N REF319 ! PARAMETER G(FE4N,FE:VA;0) 2.98150E+02 +4*GFEFCC#+10; 6.00000E+03 N REF319 ! PHASE FE5SI3 % 2 .625 .375 ! CONSTITUENT FE5SI3 :FE : SI : ! PARAMETER G(FE5SI3,FE:SI;0) 2.98150E+02 +.625*GHSERFE#+.375*GHSERSI# -30143+.27*T; 6.00000E+03 N REF98 ! PHASE FE8SI2C % 3 8 2 1 ! CONSTITUENT FE8SI2C :FE : SI : C : ! PARAMETER G(FE8SI2C,FE:SI:C;0) 2.98150E+02 +8*GHSERFE#+2*GHSERSI# +GHSERCC#-231047+5.566*T; 6.00000E+03 N REF99 ! PHASE FECN_CHI % 2 5 2 ! CONSTITUENT FECN_CHI :FE : C : ! PARAMETER G(FECN_CHI,FE:C;0) 2.98150E+02 -11287.4+1013.78*T -176.412*T*LN(T)+810869*T**(-1); 6.00000E+03 N REF319 ! PHASE FESI2_H % 2 .3 .7 ! CONSTITUENT FESI2_H :FE : SI : ! PARAMETER G(FESI2_H,FE:SI;0) 2.98150E+02 +.3*GHSERFE#+.7*GHSERSI#-19649 -.92*T; 6.00000E+03 N REF98 ! PHASE FESI2_L % 2 .333333 .666667 ! CONSTITUENT FESI2_L :FE : SI : ! PARAMETER G(FESI2_L,FE:SI;0) 2.98150E+02 +.333333*GHSERFE# +.666667*GHSERSI#-27383+3.48*T; 6.00000E+03 N REF98 ! PHASE GRAPHITE % 1 1.0 ! CONSTITUENT GRAPHITE :C : ! PARAMETER G(GRAPHITE,C;0) 2.98150E+02 +GHSERCC#+GPCGRA#; 6.00000E+03 N REF283 ! TYPE_DEFINITION ) GES A_P_D HCP_A3 MAGNETIC -3.0 2.80000E-01 ! PHASE HCP_A3 %) 2 1 .5 ! CONSTITUENT HCP_A3 :CR,FE,MO,SI,V : C,VA% : ! PARAMETER G(HCP_A3,CR:C;0) 2.98150E+02 +GHSERCR#+.5*GHSERCC#-18504 +9.4173*T-2.4997*T*LN(T)+.001386*T**2; 6.00000E+03 N REF322 ! PARAMETER G(HCP_A3,FE:C;0) 2.98150E+02 +52905-11.9075*T+GFEFCC# +.5*GHSERCC#+GPCFCC#; 6.00000E+03 N REF190 ! PARAMETER G(HCP_A3,MO:C;0) 2.98150E+02 -24150-3.625*T-163000*T**(-1) +GHSERMO#+.5*GHSERCC#; 6.00000E+03 N REF104 ! PARAMETER G(HCP_A3,SI:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,V:C;0) 2.98150E+02 -85473+182.441*T-30.551*T*LN(T) -.00538998*T**2+229029*T**(-1); 6.00000E+03 N REF256 ! PARAMETER G(HCP_A3,CR:VA;0) 2.98150E+02 +4438+GHSERCR#+GPCRBCC#; 6.00000E+03 N REF283 ! PARAMETER TC(HCP_A3,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N REF281 ! PARAMETER BMAGN(HCP_A3,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N REF281 ! PARAMETER G(HCP_A3,FE:VA;0) 2.98150E+02 -3705.78+12.591*T-1.15*T*LN(T) +6.4E-04*T**2+GHSERFE#+GPFEHCP#; 1.81100E+03 Y -3957.199+5.24951*T+4.9251E+30*T**(-9)+GHSERFE#+GPFEHCP#; 6.00000E+03 N REF283 ! PARAMETER G(HCP_A3,MO:VA;0) 2.98150E+02 +11550+GHSERMO#+GPMOBCC#; 5.00000E+03 N REF283 ! PARAMETER G(HCP_A3,SI:VA;0) 2.98150E+02 +49200-20.8*T+GHSERSI#; 3.60000E+03 N REF283 ! PARAMETER G(HCP_A3,V:VA;0) 2.98150E+02 +4000+2.4*T+GHSERVZ#; 4.00000E+03 N REF283 ! PARAMETER G(HCP_A3,CR,FE,MO:C;0) 2.98150E+02 -57062; 6.00000E+03 N REF316 ! PARAMETER G(HCP_A3,CR,MO:C;0) 2.98150E+02 -3905+18.5304*T; 6.00000E+03 N REF316 ! PARAMETER G(HCP_A3,CR,V:C;0) 2.98150E+02 +17165-9.9072*T; 6.00000E+03 N REF323 ! PARAMETER G(HCP_A3,CR:C,VA;0) 2.98150E+02 4165; 6.00000E+03 N REF207 ! PARAMETER G(HCP_A3,FE,MO:C;0) 2.98150E+02 +13030-33.8*T; 6.00000E+03 N REF113 ! PARAMETER G(HCP_A3,FE,V:C;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 N REF270 ! PARAMETER G(HCP_A3,FE:C,VA;0) 2.98150E+02 -22126; 6.00000E+03 N REF319 ! PARAMETER G(HCP_A3,MO:C,VA;0) 2.98150E+02 4150; 6.00000E+03 N REF104 ! PARAMETER G(HCP_A3,V:C,VA;0) 2.98150E+02 +12430-3.986*T; 6.00000E+03 N REF256 ! PARAMETER G(HCP_A3,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; 6.00000E+03 N REF126 ! PARAMETER G(HCP_A3,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; 6.00000E+03 N REF117 ! PARAMETER G(HCP_A3,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 N REF117 ! PARAMETER G(HCP_A3,CR,V:VA;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 N REF323 ! PARAMETER G(HCP_A3,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 N REF323 ! PARAMETER G(HCP_A3,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; 6.00000E+03 N REF10 ! PARAMETER G(HCP_A3,FE,SI:VA;0) 2.98150E+02 -123468+41.116*T; 6.00000E+03 N REF42 ! PARAMETER G(HCP_A3,FE,SI:VA;1) 2.98150E+02 -142708; 6.00000E+03 N REF42 ! PARAMETER G(HCP_A3,FE,SI:VA;2) 2.98150E+02 89907; 6.00000E+03 N REF42 ! PARAMETER G(HCP_A3,FE,V:VA;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 N REF270 ! PHASE KSI_CARBIDE % 2 3 1 ! CONSTITUENT KSI_CARBIDE :CR,FE,MO% : C : ! PARAMETER G(KSI_CARBIDE,CR:C;0) 2.98150E+02 +3*GHSERCR#+GHSERCC#+114060 -47.2519*T; 6.00000E+03 N REF316 ! PARAMETER G(KSI_CARBIDE,FE:C;0) 2.98150E+02 +14540+20*T+3*GHSERFE# +GHSERCC#; 6.00000E+03 N REF113 ! PARAMETER G(KSI_CARBIDE,MO:C;0) 2.98150E+02 +167009-33*T+3*GHSERMO# +GHSERCC#; 6.00000E+03 N REF113 ! PARAMETER G(KSI_CARBIDE,CR,FE:C;0) 2.98150E+02 -139900; 6.00000E+03 N REF316 ! PARAMETER G(KSI_CARBIDE,CR,MO:C;0) 2.98150E+02 -348033; 6.00000E+03 N REF316 ! PARAMETER G(KSI_CARBIDE,FE,MO:C;0) 2.98150E+02 -380000; 6.00000E+03 N REF113 ! PHASE LAVES_PHASE % 2 2 1 ! CONSTITUENT LAVES_PHASE :CR,FE : MO : ! PARAMETER G(LAVES_PHASE,CR:MO;0) 2.98150E+02 +2*GCRFCC#+GHSERMO#-8000 -6*T; 6.00000E+03 N REF214 ! PARAMETER G(LAVES_PHASE,FE:MO;0) 2.98150E+02 -10798-.132*T+2*GFEFCC# +GHSERMO#; 6.00000E+03 N REF10 ! PHASE M23C6 % 3 20 3 6 ! CONSTITUENT M23C6 :CR%,FE%,V : CR%,FE%,MO%,V : C : ! PARAMETER G(M23C6,CR:CR:C;0) 2.98150E+02 +GCRM23C6#; 6.00000E+03 N REF102 ! PARAMETER G(M23C6,FE:CR:C;0) 2.98150E+02 +.1304348*GCRM23C6# +.8695652*GFEM23C6#; 6.00000E+03 N REF102 ! PARAMETER G(M23C6,V:CR:C;0) 2.98150E+02 +.869565*GVM23C6# +.130435*GCRM23C6#; 6.00000E+03 N REF323 ! PARAMETER G(M23C6,CR:FE:C;0) 2.98150E+02 +.8695652*GCRM23C6# +.1304348*GFEM23C6#; 6.00000E+03 N REF102 ! PARAMETER G(M23C6,FE:FE:C;0) 2.98150E+02 +GFEM23C6#; 6.00000E+03 N REF102 ! PARAMETER G(M23C6,V:FE:C;0) 2.98150E+02 +.869565*GVM23C6# +.130435*GFEM23C6#; 6.00000E+03 N REF323 ! PARAMETER G(M23C6,CR:MO:C;0) 2.98150E+02 +20*GHSERCR#+3*GHSERMO# +6*GHSERCC#-439117-50.0535*T; 6.00000E+03 N REF316 ! PARAMETER G(M23C6,FE:MO:C;0) 2.98150E+02 +20*GHSERFE#+3*GHSERMO# +6*GHSERCC#-76351-5.095*T; 6.00000E+03 N REF316 ! PARAMETER G(M23C6,V:MO:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(M23C6,CR:V:C;0) 2.98150E+02 +.869565*GCRM23C6# +.130435*GVM23C6#; 6.00000E+03 N REF323 ! PARAMETER G(M23C6,FE:V:C;0) 2.98150E+02 +.869565*GFEM23C6# +.130435*GVM23C6#; 6.00000E+03 N REF323 ! PARAMETER G(M23C6,V:V:C;0) 2.98150E+02 +GVM23C6#; 6.00000E+03 N REF323 ! PARAMETER G(M23C6,CR,FE:CR:C;0) 2.98150E+02 -205342+141.6667*T; 6.00000E+03 N REF322 ! PARAMETER G(M23C6,CR,FE,V:CR:C;0) 2.98150E+02 -1499585; 6.00000E+03 N REF324 ! PARAMETER G(M23C6,CR,V:CR:C;0) 2.98150E+02 -385502; 6.00000E+03 N REF324 ! PARAMETER G(M23C6,CR,FE:FE:C;0) 2.98150E+02 -205342+141.6667*T; 6.00000E+03 N REF322 ! PARAMETER G(M23C6,CR,FE,V:FE:C;0) 2.98150E+02 -1499585; 6.00000E+03 N REF324 ! PARAMETER G(M23C6,CR,V:FE:C;0) 2.98150E+02 -385502; 6.00000E+03 N REF324 ! PARAMETER G(M23C6,CR,FE:MO:C;0) 2.98150E+02 -177850+153.905*T; 6.00000E+03 N REF316 ! PARAMETER G(M23C6,CR,FE:V:C;0) 2.98150E+02 -205342+141.6667*T; 6.00000E+03 N REF324 ! PARAMETER G(M23C6,CR,FE,V:V:C;0) 2.98150E+02 -1499585; 6.00000E+03 N REF324 ! PARAMETER G(M23C6,CR,V:V:C;0) 2.98150E+02 -385502; 6.00000E+03 N REF324 ! PHASE M3C2 % 2 3 2 ! CONSTITUENT M3C2 :CR,MO,V : C : ! PARAMETER G(M3C2,CR:C;0) 2.98150E+02 +GCRM3C2#; 6.00000E+03 N REF322 ! PARAMETER G(M3C2,MO:C;0) 2.98150E+02 +3*GHSERMO#+2*GHSERCC#+27183; 6.00000E+03 N REF316 ! PARAMETER G(M3C2,V:C;0) 2.98150E+02 -222500+16.6545*T+3*GHSERVV# +2*GHSERCC#; 6.00000E+03 N REF324 ! PARAMETER G(M3C2,CR,MO:C;0) 2.98150E+02 40000; 6.00000E+03 N REF316 ! PARAMETER G(M3C2,CR,V:C;0) 2.98150E+02 21072; 6.00000E+03 N REF324 ! PHASE M3SI % 2 3 1 ! CONSTITUENT M3SI :FE : SI : ! PARAMETER G(M3SI,FE:SI;0) 2.98150E+02 +3*GHSERFE#+GHSERSI#-94274-3.56*T; 6.00000E+03 N REF42 ! PHASE M5C2 % 2 5 2 ! CONSTITUENT M5C2 :FE,V : C : ! PARAMETER G(M5C2,FE:C;0) 2.98150E+02 +5*GHSERFE#+2*GHSERCC#+54852 -33.7518*T; 6.00000E+03 N REF322 ! PARAMETER G(M5C2,V:C;0) 2.98150E+02 -307123.3+1059.7*T-175.66*T*LN(T) +1453274*T**(-1); 6.00000E+03 N REF275 ! PHASE M6C % 4 2 2 2 1 ! CONSTITUENT M6C :FE : MO : CR,FE,MO,V : C : ! PARAMETER G(M6C,FE:MO:CR:C;0) 2.98150E+02 +2*GHSERFE#+2*GHSERCR# +2*GHSERMO#+GHSERCC#-25298-54.8698*T; 6.00000E+03 N REF316 ! PARAMETER G(M6C,FE:MO:FE:C;0) 2.98150E+02 +4*GHSERFE#+2*GHSERMO# +GHSERCC#+77705-101.5*T; 6.00000E+03 N REF113 ! PARAMETER G(M6C,FE:MO:MO:C;0) 2.98150E+02 +2*GHSERFE#+4*GHSERMO# +GHSERCC#-122410+30.25*T; 6.00000E+03 N REF113 ! PARAMETER G(M6C,FE:MO:V:C;0) 2.98150E+02 +2*GHSERFE#+2*GHSERMO# +2*GHSERVV#+GHSERCC#-173000; 6.00000E+03 N REF220 ! PARAMETER G(M6C,FE:MO:FE,MO:C;0) 2.98150E+02 -37700; 6.00000E+03 N REF113 ! PHASE M7C3 % 2 7 3 ! CONSTITUENT M7C3 :CR%,FE,MO,V : C : ! PARAMETER G(M7C3,CR:C;0) 2.98150E+02 +GCRM7C3#; 6.00000E+03 N REF322 ! PARAMETER G(M7C3,FE:C;0) 2.98150E+02 +7*GHSERFE#+3*GHSERCC#+75000 -48.2168*T; 6.00000E+03 N REF322 ! PARAMETER G(M7C3,MO:C;0) 2.98150E+02 +7*GHSERMO#+3*GHSERCC#-140415 +24.24*T; 6.00000E+03 N REF316 ! PARAMETER G(M7C3,V:C;0) 2.98150E+02 -454245+1518.48*T-250.981*T*LN(T) +2148691*T**(-1); 6.00000E+03 N REF324 ! PARAMETER G(M7C3,CR,FE:C;0) 2.98150E+02 -4520-10*T; 6.00000E+03 N REF322 ! PARAMETER G(M7C3,CR,FE,V:C;0) 2.98150E+02 -250158; 6.00000E+03 N REF324 ! PARAMETER G(M7C3,CR,MO:C;0) 2.98150E+02 165280; 6.00000E+03 N REF316 ! PARAMETER G(M7C3,CR,V:C;0) 2.98150E+02 -110271; 6.00000E+03 N REF324 ! PHASE MC_ETA % 2 1 1 ! CONSTITUENT MC_ETA :MO% : C%,VA : ! PARAMETER G(MC_ETA,MO:C;0) 2.98150E+02 -9100-5.35*T-750000*T**(-1) +GHSERMO#+GHSERCC#; 6.00000E+03 N REF113 ! PARAMETER G(MC_ETA,MO:VA;0) 2.98150E+02 +GHSERMO#+15200+.63*T; 6.00000E+03 N REF113 ! PARAMETER G(MC_ETA,MO:C,VA;0) 2.98150E+02 -59500; 6.00000E+03 N REF104 ! PHASE MC_SHP % 2 1 1 ! CONSTITUENT MC_SHP :MO : C : ! PARAMETER G(MC_SHP,MO:C;0) 2.98150E+02 -32983+2.5*T+GHSERMO#+GHSERCC#; 6.00000E+03 N REF104 ! PHASE MONI_DELTA % 3 24 20 12 ! CONSTITUENT MONI_DELTA :CR,FE : CR,FE,MO : MO : ! PARAMETER G(MONI_DELTA,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR# +12*GHSERMO#+50000; 6.00000E+03 N REF133 ! PARAMETER G(MONI_DELTA,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(MONI_DELTA,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(MONI_DELTA,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE# +12*GHSERMO#+100000; 6.00000E+03 N REF132 ! PARAMETER G(MONI_DELTA,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO# +100000; 6.00000E+03 N REF133 ! PARAMETER G(MONI_DELTA,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO# +100000; 6.00000E+03 N REF132 ! PHASE MU_PHASE % 3 7 2 4 ! CONSTITUENT MU_PHASE :CR,FE : MO : CR,FE,MO : ! PARAMETER G(MU_PHASE,CR:MO:CR;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO# +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 ! PARAMETER G(MU_PHASE,FE:MO:CR;0) 2.98150E+02 +7*GFEFCC#+2*GHSERMO# +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 ! PARAMETER G(MU_PHASE,CR:MO:FE;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO# +4*GHSERFE#+130000-100*T; 6.00000E+03 N REF115 ! PARAMETER G(MU_PHASE,FE:MO:FE;0) 2.98150E+02 +39475-6.032*T+7*GFEFCC# +2*GHSERMO#+4*GHSERFE#+GPMU1#; 6.00000E+03 N REF10 ! PARAMETER G(MU_PHASE,CR:MO:MO;0) 2.98150E+02 +7*GCRFCC#+6*GHSERMO# +130000-100*T; 6.00000E+03 N REF115 ! PARAMETER G(MU_PHASE,FE:MO:MO;0) 2.98150E+02 -46663-5.891*T+7*GFEFCC# +6*GHSERMO#+GPMU2#; 6.00000E+03 N REF10 ! PARAMETER G(MU_PHASE,CR,FE:MO:MO;0) 2.98150E+02 -45000; 6.00000E+03 N REF115 ! PHASE P_PHASE % 3 24 20 12 ! CONSTITUENT P_PHASE :CR,FE : CR,FE,MO : MO : ! PARAMETER G(P_PHASE,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR# +12*GHSERMO#+252300-100*T; 6.00000E+03 N REF133 ! PARAMETER G(P_PHASE,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(P_PHASE,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(P_PHASE,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE# +12*GHSERMO#+111361; 6.00000E+03 N REF132 ! PARAMETER G(P_PHASE,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO# +95573-200*T; 6.00000E+03 N REF133 ! PARAMETER G(P_PHASE,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO# +362525-332.7*T; 6.00000E+03 N REF132 ! PHASE R_PHASE % 3 27 14 12 ! CONSTITUENT R_PHASE :CR,FE : MO : CR,FE,MO : ! PARAMETER G(R_PHASE,CR:MO:CR;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO# +12*GHSERCR#-20000; 6.00000E+03 N REF115 ! PARAMETER G(R_PHASE,FE:MO:CR;0) 2.98150E+02 +27*GFEFCC#+14*GHSERMO# +12*GHSERCR#+600260-620*T; 6.00000E+03 N REF115 ! PARAMETER G(R_PHASE,CR:MO:FE;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO# +12*GHSERFE#+645260-620*T; 6.00000E+03 N REF115 ! PARAMETER G(R_PHASE,FE:MO:FE;0) 2.98150E+02 -77487-50.486*T+27*GFEFCC# +14*GHSERMO#+12*GHSERFE#+GPR1#; 6.00000E+03 N REF10 ! PARAMETER G(R_PHASE,CR:MO:MO;0) 2.98150E+02 +27*GCRFCC#+26*GHSERMO# -20000; 6.00000E+03 N REF115 ! PARAMETER G(R_PHASE,FE:MO:MO;0) 2.98150E+02 +313474-289.472*T +27*GFEFCC#+26*GHSERMO#+GPR2#; 6.00000E+03 N REF10 ! PHASE SIC % 2 1 1 ! CONSTITUENT SIC :SI : C : ! PARAMETER G(SIC,SI:C;0) 2.98150E+02 -85572.2636+173.200518*T -25.856*T*LN(T)-.02106825*T**2+3.2153E-06*T**3+438415*T**(-1); 7.00000E+02 Y -95145.9018+300.345769*T-45.093*T*LN(T)-.00366815*T**2 +2.19983333E-07*T**3+1341065*T**(-1); 2.10000E+03 Y -105007.971+360.308813*T-53.073*T*LN(T)-7.4525E-04*T**2 +1.73166667E-08*T**3+3693345*T**(-1); 4.00000E+03 N REF286 ! PHASE SIGMA % 3 8 4 18 ! CONSTITUENT SIGMA :FE : CR,MO,V : CR,FE,MO,V : ! PARAMETER G(SIGMA,FE:CR:CR;0) 2.98150E+02 +8*GFEFCC#+22*GHSERCR#+92300 -95.96*T+GPSIG1#; 6.00000E+03 N REF107 ! PARAMETER G(SIGMA,FE:MO:CR;0) 2.98150E+02 +8*GFEFCC#+4*GHSERMO# +18*GHSERCR#+488480-360*T; 6.00000E+03 N REF115 ! PARAMETER G(SIGMA,FE:V:CR;0) 2.98150E+02 +155735-89.5976*T+8*GFEFCC# +4*GHSERVV#+18*GHSERCR#; 6.00000E+03 N REF323 ! PARAMETER G(SIGMA,FE:CR:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# +18*GHSERFE#+117300-95.96*T+GPSIG2#; 6.00000E+03 N REF107 ! PARAMETER G(SIGMA,FE:MO:FE;0) 2.98150E+02 -1813-27.272*T+8*GFEFCC# +18*GHSERFE#+4*GHSERMO#; 6.00000E+03 N REF10 ! PARAMETER G(SIGMA,FE:V:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERVV# +18*GHSERFE#-157961+60.729*T; 6.00000E+03 N REF269 ! PARAMETER G(SIGMA,FE:CR:MO;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# +18*GHSERMO#+312580-260*T; 6.00000E+03 N REF115 ! PARAMETER G(SIGMA,FE:MO:MO;0) 2.98150E+02 +83326-69.618*T+8*GFEFCC# +22*GHSERMO#; 6.00000E+03 N REF10 ! PARAMETER G(SIGMA,FE:V:MO;0) 2.98150E+02 +8*GFEFCC#+4*GHSERVV# +18*GHSERMO#; 6.00000E+03 N REF136 ! PARAMETER G(SIGMA,FE:CR:V;0) 2.98150E+02 -245761-67.3294*T+8*GFEFCC# +4*GHSERCR#+18*GHSERVV#; 6.00000E+03 N REF323 ! PARAMETER G(SIGMA,FE:MO:V;0) 2.98150E+02 +8*GFEFCC#+4*GHSERMO# +18*GHSERVV#; 6.00000E+03 N REF136 ! PARAMETER G(SIGMA,FE:V:V;0) 2.98150E+02 +8*GFEFCC#+22*GHSERVV#-205321 -60.967*T; 6.00000E+03 N REF269 ! PARAMETER G(SIGMA,FE:CR:CR,MO;0) 2.98150E+02 -148000; 6.00000E+03 N REF115 ! PARAMETER G(SIGMA,FE:MO:CR,MO;0) 2.98150E+02 121000; 6.00000E+03 N REF115 ! PARAMETER G(SIGMA,FE:CR:FE,MO;0) 2.98150E+02 570000; 6.00000E+03 N REF115 ! PARAMETER G(SIGMA,FE:CR:FE,V;0) 2.98150E+02 -235158; 6.00000E+03 N REF323 ! PARAMETER G(SIGMA,FE:MO:FE,MO;0) 2.98150E+02 222909; 6.00000E+03 N REF10 ! PARAMETER G(SIGMA,FE:V:FE,V;0) 2.98150E+02 -305784; 6.00000E+03 N REF269 ! PHASE V3C2 % 2 3 2 ! CONSTITUENT V3C2 :FE,V : C : ! PARAMETER G(V3C2,FE:C;0) 2.98150E+02 +7250+741.566*T-125.833*T*LN(T) +779485*T**(-1); 6.00000E+03 N REF275 ! PARAMETER G(V3C2,V:C;0) 2.98150E+02 -260341+16.897*T+3*GHSERVV# +2*GHSERCC#; 6.00000E+03 N REF256 ! LIST_OF_REFERENCES NUMBER SOURCE REF283 'Alan Dinsdale, SGTE Data for Pure Elements, Calphad Vol 15(1991) p 317-425, also in NPL Report DMA(A)195 Rev. August 1990' REF101 'J-O Andersson, Calphad Vol 11 (1987) p 271-276, TRITA 0314; C-CR' REF190 'P. Gustafson, Scan. J. Metall. vol 14, (1985) p 259-267 TRITA 0237 (1984); C-FE' REF104 'J-O Andersson, Calphad Vol 12 (1988) p 1-8 TRITA 0317 (1986); C -MO' REF98 'J. Lacaze and B. Sundman, provisional; Fe-Si' REF256 'W. Huang, TRITA-MAC 431 (1990); C-V' REF267 'W. Huang, Metall. Trans. Vol 21A(1990) p 2115-2123, TRITA-MAC 411 (Rev 1989); C-FE-MN' REF177 'NPL, unpublished work (1989); C-Mn-Si' REF275 'W. Huang, TRITA-MAC 441 (1990), Fe-Mn-V-C *' REF322 'Byeong-Joo Lee, unpublished revision (1991); C-Cr-Fe-Ni' REF213 'P. Gustafson, TRITA-MAC 342, (1987); CR-FE-W' REF115 'J-O Andersson, Met Trans A, Vol 19A, (1988) p 1385-1394 TRITA 0322 (1986); CR-FE-MO' REF324 'Byeong-Joo Lee, TRITA-MAC 475 (1991), C-Cr-Fe-V' REF90 'I Ansara, unpublished work (1991); Cr-Si' REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 September 1989' REF319 'H. Du and M. Hillert, revision; C-Fe-N' REF99 'J. Lacaze and B. Sundman, Met. Trans A, Vol 22A (1991) pp 2211-2223; C-Fe-Si' REF316 'Caian Qui, Trita-MAC 482 (1992) Revision ; C-Cr-Fe-Mo' REF113 'J-O Andersson, Calphad Vol 12 (1988), p 9-23 TRITA 0321 (1986); C-FE-MO' REF214 'P. Gustafson, TRITA-MAC 354 (1987); C-Cr-Fe-Mo-W' REF10 'A. Fernandez Guillermet, CALPHAD Vol 6 (1982), p 127-140 (sigma phase revised 1986), TRITA-MAC 200 (1982); FE-MO' REF102 'J-O Andersson, Met. Trans A, Vol 19A, (1988) p 627-636 TRITA 0207 (1986); C-CR-FE' REF323 'Byeong-Joo Lee, TRITA-MAC 474 (1991), Cr-Fe-V' REF42 'Annika Forsberg and John ]gren, TRITA-MAC 483 (1992); Fe-Mn-Si' REF220 'P Gustafson, Inst. Met. Res. (Sweden) (1990); Estimations of C-CR-FE-V, C-CR-FE-MO-V-W, FE-N-W, FE-MN-N, FE-N-SI, CR-N-V, C-CR -N, FE-MO-N, CR-N-W, CR-TI-N' REF133 'K. Frisk, TRITA-MAC 429 (1990); CR-MO-NI' REF132 'K. Frisk, TRITA-MAC 428 (1990); FE-MO-NI' REF286 'SGTE Substance database, AUG 1989.' REF107 'J-O Andersson, B. Sundman, CALPHAD Vol 11, (1987), p 83-92 TRITA 0270 (1986); CR-FE' REF269 'W. Huang, TRITA-MAC 432 (Rev 1989,1990); FE-V' REF136 'Unassessed parameter, linear combination of unary data. (MU, SIGMA)' REF123 'K. Frisk, Report D 60, KTH, (1984); CR-MO' REF325 'Byeong-Joo Lee, unpublished revision (1991), C-Cr-Fe-Mo-Ni' REF270 'W. Huang, TRITA-MAC 432 (1990); C-Fe-V' REF58 'B. Sundman, TEST' REF207 'P. Gustafson, Metall. Trans. 19A(1988) p 2547-2554, TRITA-MAC 348, (1987); C-CR-FE-W' REF126 'K. Frisk, Metall. Trans. Vol 21A (1990) p 2477-2488, TRITA 0409 (1989); CR-FE-N' REF117 'J-O Andersson, TRITA-MAC 323 (1986); C-CR-FE-MO' REF111 'J-O Andersson, CALPHAD Vol 7, (1983), p 305-315 (parameters revised 1986 due to new decription of V) TRITA 0201 (1982); FE-V' ! ================================================ FILE: examples/TQ4lib/Cpp/Matthias/tqcpptest1.cpp ================================================ #include "tqintf.h" void example_1(string fname, double t, double p, double n, vector x); void example_2(string fname, int phidx, double t, double p, double n, vector x, vector y); void example_3(string fname, int phidx, double t, double p, double n, vector y); int main(int argc, char **argv) { /******************* EXAMPLE 1 ******************* Similar to /C/cexample1: calls the TQ-Interface for any given thermodynamic database file {FILENAME}, sets conditions specified in this function {T}, {P}, {N} and {X[*]} and prints the output of the thermodynamic equilibrium calculation. string FILENAME = "FENI.TDB"; // Name of the thermodynamic database file (*.TDB, *.tdb) int I = 1; // Number of Phase double T = 778.0; // Temperature in K double P = 1.0e5; // Pressure in Pa double N = 1.0; // Number of moles vector X; // Concentration array for phase I X.push_back(0.6); // manual override of X[0] X.push_back(0.4); // manual override of X[1] //X.push_back(0.3); // .. and so on .. X[2] example_1(FILENAME, T, P, N, X); // Call to Example 1 /**************************************************/ /******************* EXAMPLE 2 ******************* Similar to /F90/test4:: calls the TQ-Interface for any given thermodynamic database file {FILENAME}, suspends all phases except phase {I}, sets conditions for this single phase as specified in this function {T}, {P}, {N} and {X[*]} and prints the output of the thermodynamic values like the Gibbs energy, the partial derivative of the Gibbs energy with respect to every single site fraction without doing a thermodyamic equilibrium calculation.*/ string FILENAME = "steel1.TDB"; // Name of the thermodynamic database file (*.TDB, *.tdb) int I = 2; // Number of Phase double T = 8.0e2; // Temperature in K double P = 1.0e5; // Pressure in Pa double N = 1.0; // Number of moles vector X; // Concentration array for the system X.push_back(0.3); // manual override of X[0] vector Y; // Constituents array for phase I Y.push_back(0.197577); // manual override of Y[0] Y.push_back(0.802423); // manual override of Y[1] Y.push_back(1); // manual override of Y[2] example_2(FILENAME, I, T, P, N, X, Y); // Call to Example 2 /**************************************************/ /******************* EXAMPLE 3 ******************* experimental - work in progress ************************************************* string FILENAME = "steel1.TDB"; // Name of the thermodynamic database file (*.TDB, *.tdb) int I = 2; // Number of Phase double T = 8.0e2; // Temperature in K double P = 1.0e5; // Pressure in Pa double N = 1.0; // Number of moles vector X; // Concentration array for the system X.push_back(0.3); // manual override of X[0] example_3(FILENAME, I, T, P, N, X); // Call to Example 3 /**************************************************/ return 0; } /********************************** EXAMPLE 1 *********************************/ void example_1(string fname, double t, double p, double n, vector x) { void *ceq = 0; // Pointer to the OpenCalphad storage vector > elfract; // Array including all equilibrium compositions vector phnames; // Array including all phase names vector phfract; // Array including all phase fractions //-----------------------Initialize and read TDB data----------------------- Initialize(&ceq); // Initialize OpenCalphad and allocate memory ReadDatabase(fname, &ceq); // Define TDB-file and read elements ReadPhases(phnames, &ceq); // Read Phases data SetTemperature(t, &ceq); // Set Temperature SetPressure(p, &ceq); // Set Pressure SetMoles(n, &ceq); // Set Number of moles SetComposition(x, &ceq); // Set Composition of the system //---------------------------Calculate Equilibrium-------------------------- CalculateEquilibrium(&ceq); // Calculate a phase equilibrium //-------------------------------List Results------------------------------- ListPhaseFractions(phnames, phfract, &ceq); // Write output of the amount of stable phases ListConstituentFractions(phnames, phfract, elfract, &ceq); // Write output of the composition of each stable phase } /********************************** EXAMPLE 2 *********************************/ void example_2(string fname, int phidx, double t, double p, double n, vector x, vector y) { void *ceq = 0; // Pointer to the OpenCalphad storage vector elnames; // Array including selected elements elnames.push_back("CR"); elnames.push_back("FE"); vector phnames; // Array including all phase names vector phfract; // Array including all phase fractions vector > elfract; // Array including all equilibrium compositions //-----------------------Initialize and read TDB data----------------------- Initialize(&ceq); // Initialize OpenCalphad and allocate memory ReadDatabaseLimited(fname, elnames, &ceq); // Define TDB-file and read only selected elements ReadPhases(phnames, &ceq); // Read Phases data SetTemperature(t, &ceq); // Set Temperature SetPressure(p, &ceq); // Set Pressure SetMoles(n, &ceq); // Set Number of moles SetComposition(x, &ceq); // Set Composition of the system //---------------------------Calculate Equilibrium-------------------------- CalculateEquilibrium(&ceq); //-------------------------------List Results------------------------------- ListPhaseFractions(phnames, phfract, &ceq); // Write output of the amount of stable phases ListConstituentFractions(phnames, phfract, elfract, &ceq); // Write output of the composition of each stable phase ListExtConstituentFractions(phidx, phnames, &ceq); // Write output of the constituents of a given phase //----------------------------Change Parameters----------------------------- SetConstituents(phidx, y, &ceq); // Set Constituents of the phase //-------------------------------List Results------------------------------- GetGibbsData(phidx, &ceq); // Write output of the thermodynamic values of the given parameters }; /********************************** EXAMPLE 3 *********************************/ void example_3(string fname, int phidx, double t, double p, double n, vector x) { void *ceq = 0; // Pointer to the OpenCalphad storage vector elnames; // Array including selected elements elnames.push_back("CR"); elnames.push_back("FE"); vector phnames; // Array including all phase names vector phfract; // Array including all phase fractions vector > elfract; // Array including all equilibrium compositions //-----------------------Initialize and read TDB data----------------------- Initialize(&ceq); // Initialize OpenCalphad and allocate memory ReadDatabaseLimited(fname, elnames, &ceq); // Define TDB-file and read only selected elements ReadPhases(phnames, &ceq); // Read Phases data SetTemperature(t, &ceq); // Set Temperature SetPressure(p, &ceq); // Set Pressure SetMoles(n, &ceq); // Set Number of moles SetComposition(x, &ceq); // Set Composition of the system //---------------------------Calculate Equilibrium-------------------------- CalculateEquilibrium(&ceq); //-------------------------------List Results------------------------------- ListPhaseFractions(phnames, phfract, &ceq); // Write output of the amount of stable phases ListConstituentFractions(phnames, phfract, elfract, &ceq); // Write output of the composition of each stable phase ListExtConstituentFractions(phidx, phnames, &ceq); // Write output of the constituents of a given phase for(int i = 0; i < 10; i++) { cout << "========== " << i << " / 10 ==========" << endl; double constit = i/10.0; vector y; // Constituents array for phase I y.push_back(constit); // manual override of Y[0] y.push_back(1-constit); // manual override of Y[1] y.push_back(1); // manual override of Y[2] //--------------------------Change Parameters--------------------------- SetConstituents(phidx, y, &ceq); // Set Constituents of the phase //-----------------------------List Results----------------------------- GetGibbsData(phidx, &ceq); // Write output of the thermodynamic values of the given parameters } }; ================================================ FILE: examples/TQ4lib/Cpp/Matthias/tqex3.cpp ================================================ #include "liboctqcpp.h" using namespace std; /******************************************************************************* * The following routine is for testing the interface functionality and produces * debug output. However it also demonstrates a usecase and can be used as a * starting point for a new implementation of OpenCalphad C++ interface. *******************************************************************************/ int main(int argc, char *argv[]) { /* Bugtracker: 1) OCASI.tqgetv("N", 0, 0, &ceq) returns 0 even though it was set to 1.0 2) OCASI.tqgetv("X", 1, 0, &ceq) returns 0 even though it was set to 0.3 3) OCASI.tqgpci(4, "CR", &ceq) breaks, when phase 4 is BCC_A2_AUTO#2 4) OCASI.tqgccf only returns "tqgccf not implemented yet" 5) OCASI.tqgnpc only returns "tqgnpc not implemented yet" 6) OCASI.tqgpci only returns "tqgpci not implemented yet" 7) OCASI.tqgpcs only returns "tqgpcs not implemented yet" 8) OCASI.reset_conditions only resets a single condition, even though its name implies different. Additionally it uses the console!!! to ask for a new value for the condition. 9) OCASI.tqcph2 breaks with an error 10) OCASI.tqcceq("test", &newceq, &ceq) seems to copy ceq, but not all information! OCASI.tqgpn(1, &newceq) seems to have no information, and OCASI.tqlc(0,&newceq) crashes. 11) tqdceq, tqcceq and tqselceq require a CEQ-name! Where is it set? */ liboctqcpp OCASI; void * ceq = 0; //================= OCASI.tqini(0,&ceq); //================= cout << "-> Adress of ceq-Storage: [" << &ceq << "]" << endl; /* uncomment this for reading full database with all elemens //===================================================== vector elnames = OCASI.tqrfil("TQ4lib/Cpp/Matthias/FECRMNC.TDB", ceq); //===================================================== cout << "-> Element Data: ["; for(int i = 0; i < elnames.size(); i++) { cout << elnames[i]; if(i < elnames.size()-1) { cout << ", "; } } cout << "]" << " [" << &ceq << "]" << endl;*/ vector Elements; Elements.push_back("CR"); Elements.push_back("FE"); vector elnames2 = //=============================================================== OCASI.tqrpfil("TQ4lib/Cpp/Matthias/FECRMNC.TDB", Elements, &ceq); //=============================================================== cout << "-> Element Data: ["; for(int i = 0; i < elnames2.size(); i++) { cout << elnames2[i]; if(i < elnames2.size()-1) { cout << ", "; } } cout << "]" << " [" << &ceq << "]" << endl; vector elnames3 = //================= OCASI.tqgcom(&ceq); //================= cout << "-> Element Data: ["; for(int i = 0; i < elnames3.size(); i++) { cout << elnames3[i]; if(i < elnames3.size()-1) { cout << ", "; } } cout << "]" << " [" << &ceq << "]" << endl; int phasetuples = //================ OCASI.tqgnp(&ceq); //================ cout << "-> Number of phasetuples: [" << phasetuples << "]" << endl; vector PhNames(phasetuples); cout << "-> Phase Data: ["; for(int i = 0; i < phasetuples; i++) { PhNames[i] = //===================== OCASI.tqgpn(i+1, &ceq); //===================== cout << PhNames[i] << "[" << //================== OCASI.tqgpi(PhNames[i], &ceq) //================== << "]"; if(i < phasetuples-1) { cout << ", "; } } cout << "]" << " [" << &ceq << "]" << endl; double T = 800; double P = 100000; double N = 1.0; double XCR = 0.3; //=================================== OCASI.tqsetc("T", 0, 0, T, &ceq); OCASI.tqsetc("P", 0, 0, P, &ceq); OCASI.tqsetc("N", 0, 0, N, &ceq); OCASI.tqsetc("X", 1, 0, XCR, &ceq); //=================================== cout << "-> Set Temperature to: [" << T << "]" << " [" << &ceq << "]" << endl; cout << "-> Set Ambient Pressure to: [" << P << "]" << " [" << &ceq << "]" << endl; cout << "-> Set Moles to: [" << N << "]" << " [" << &ceq << "]" << endl; cout << "-> Set X(1) to: [" << XCR << "]" << " [" << &ceq << "]" << endl; //========================================= T = OCASI.tqgetv("T", 0, 0, &ceq); P = OCASI.tqgetv("P", 0, 0, &ceq); N = OCASI.tqgetv("N", 0, 0, &ceq); XCR = OCASI.tqgetv("X", 1, 0, &ceq); //========================================= cout << "-> Temperature set to: [" << T << "]" << " [" << &ceq << "]" << endl; cout << "-> Ambient Pressure set to: [" << P << "]" << " [" << &ceq << "]" << endl; cout << "-> Moles set to: [" << N << "]" << " [" << &ceq << "]" << endl; cout << "-> X(1) set to: [" << XCR << "]" << " [" << &ceq << "]" << endl; //=============== OCASI.tqce(&ceq); //=============== cout << "-> Calculated Equilibrium [" << ceq << "]" << endl; vector EquPhFr = //=========================== OCASI.PhaseFractions(&ceq); //=========================== phasetuples = //================ OCASI.tqgnp(&ceq); //================ cout << "-> Number of phasetuples: [" << phasetuples << "]" << endl; PhNames.resize(phasetuples); cout << "-> Phase Data: ["; for(int i = 0; i < phasetuples; i++) { PhNames[i] = //===================== OCASI.tqgpn(i+1, &ceq); //===================== cout << PhNames[i] << "[" << //=========================== OCASI.tqgpi(PhNames[i], &ceq) //=========================== << "]"; if(i < phasetuples-1) { cout << ", "; } } cout << "]" << " [" << &ceq << "]" << endl; cout << "-> Phase Fractions: ["; for (unsigned int i = 0; i < EquPhFr.size(); i++) { cout << PhNames[i] << ": " << EquPhFr[i]; if(i < EquPhFr.size()-1) { cout << ", "; } } cout << "]" << " [" << &ceq << "]" << endl; for(unsigned int phase = 0; phase < EquPhFr.size(); phase++) if(EquPhFr[phase] > 0.0) { cout << "-> Constituent Fractions for " << PhNames[phase] << " ["; vector ConFr = //========================================== OCASI.ConstituentFractions(phase+1, &ceq); //========================================== for(unsigned int i = 0; i < ConFr.size(); i++) { cout << elnames3[i] << ": " << ConFr[i]; if(i < elnames3.size()-1) { cout << ", "; } } cout << "]" << " [" << &ceq << "]" << endl; } vector ncons; vector sites; double moles; for(int k = 0; k < phasetuples; k++) { if(k == phasetuples-1) { cout << "TQGPCN CANNOT BE CALLED FOR PHASE BCC_A2_AUTO#2, BECAUSE IT WILL BREAK!" << endl; break; } vector y = OCASI.tqgphc1(k+1, ncons, sites, moles, &ceq); cout << "-> Extended Constituent Fractions for " << PhNames[k] << " [" << moles << " moles of atoms/formula unit]"; int consti = 0; for(unsigned int i = 0; i < ncons.size(); i++) { cout << " ["; for(int j = 0; j < ncons[i]; j++) { string cname = //============================== OCASI.tqgpcn(k+1, consti+1, &ceq); //============================== cout << cname << "[" << //============================ //OCASI.tqgpci(k+1, cname, &ceq) // TODO: not yet implemented j+1 //============================ << "]: " << y[consti]; if(j < ncons[i]-1) { cout << ", "; } consti += 1; } cout << "]_(" << sites[i] << ")"; } cout << endl; } cout << "-> For Phase " << PhNames[1] << ":" << endl; vector Y2; Y2.push_back(0.197577); Y2.push_back(0.802423); Y2.push_back(1); //========================= OCASI.tqsphc1(2, Y2, &ceq); //========================= cout << "-> Set Constituents to: ["; for(int i = 0; i < Y2.size(); i++) { cout << i << ": " << Y2[i]; if(i < Y2.size()-1) { cout << ", "; } } cout << "]" << endl; vector G_TP; vector G_Y; vector G_YT; vector G_YP; vector G_YY; double G = //================================================= OCASI.tqcph1(2, G_TP, G_Y, G_YT, G_YP, G_YY, &ceq); //================================================= cout << "-> Read Gibbs Energy G: [" << G << "]" << endl; cout << "-> Read Gibbs Data G: ["; for(int i = 0; i < 5; i++) { cout << G_TP[i]; if(i < 4) { cout << ", "; } } cout << "]" << endl; cout << "-> Read Gibbs Data dGdY: ["; for(unsigned int i = 0; i < G_Y.size(); i++) { cout << G_Y[i]; if(i < G_Y.size()-1) { cout << ", "; } } cout << "]" << endl; cout << "-> Read Gibbs Data d2GdYdT: ["; for(unsigned int i = 0; i < G_YT.size(); i++) { cout << G_YT[i]; if(i < G_YT.size()-1) { cout << ", "; } } cout << "]" << endl; cout << "-> Read Gibbs Data d2GdYdP: ["; for(unsigned int i = 0; i < G_YP.size(); i++) { cout << G_YP[i]; if(i < G_YP.size()-1) { cout << ", "; } } cout << "]" << endl; int kk=G_Y.size()*(G_Y.size()+1)/2; cout << "-> Read Gibbs Data d2GdY2: ["; for(int i = 0; i < kk; i++) { cout << G_YY[i]; if(i < kk-1) { cout << ", "; } } cout << "]" << endl; OCASI.tqgccf(1, &ceq); OCASI.tqgnpc(1, &ceq); OCASI.tqgpci(1, "CR", &ceq); OCASI.tqphtupsts(1, -2, 0.0, &ceq); double mass; OCASI.tqgpcs(1, 1, mass, & ceq); //OCASI.tqcph2(1, 0, &ceq); OCASI.tqlr(0, &ceq); OCASI.tqlc(0, &ceq); OCASI.reset_conditions("T", 1000.0, &ceq); OCASI.tqlc(0, &ceq); int * newceq = 0; //================================== OCASI.tqcceq("test", &newceq, &ceq); //================================== cout << "-> Copy CEQ@" << &ceq << " to NEWCEQ@" << &newceq << endl; vector elnames4 = //================= OCASI.tqgcom(&newceq); //================= cout << "-> Element Data: ["; for(int i = 0; i < elnames4.size(); i++) { cout << elnames4[i]; if(i < elnames4.size()-1) { cout << ", "; } } cout << "]" << " [" << &newceq << "]" << endl; phasetuples = //================ OCASI.tqgnp(&newceq); //================ cout << "-> Number of phasetuples: [" << phasetuples << "]" << endl; PhNames.resize(phasetuples); cout << "-> Phase Data: ["; for(int i = 0; i < phasetuples; i++) { PhNames[i] = //===================== OCASI.tqgpn(i+1, &newceq); //===================== cout << PhNames[i] << "[" << //=========================== OCASI.tqgpi(PhNames[i], &newceq) //=========================== << "]"; if(i < phasetuples-1) { cout << ", "; } } cout << "]" << " [" << &newceq << "]" << endl; return 0; } ================================================ FILE: examples/TQ4lib/Cpp/Matthias/tqintf.h ================================================ #define MAXEL 10 #define MAXPH 20 //#include "octqc.h" #include "OC-isoC.h" #include #include #include #include #include #include /* 160829 Bo Sundman revision This is the C++ connection to the Fortran libocisoc.F90 library The declarations here have corresponing F08 source code in liboctqisoc.F90 */ extern"C" { void c_tqini(int, void *); // initiates the OC package void c_tqrfil(char *, void *); // read all elements from a TDB file //void c_tqgcom(int *, char[MAXEL][24], void **); // get system component names. At present the elements void c_tqrpfil(char *, int, char **, void *); // read TDB file with selection of elements //void c_tqgnp(int *, void **); // get total number of phases and composition sets void c_tqgpn(int, char *, void *); // get name of phase+compset tuple with index phcsx void c_tqgetv(char *, int, int, int *, double *, void *); // get equilibrium results using state variables void c_tqsetc(char *, int, int, double, int *, void *); // set condition void c_tqce(char *, int, int, double *, void *); // calculate quilibrium with possible target //void c_tqgnp(int, gtp_equilibrium_data **); // get total number of phases and composition sets void examine_gtp_equilibrium_data(void *); // //void c_getG(int, void *); //void c_calcg(int, int, int, int, void *); void c_tqgphc1(int, int * , int *, int *, double *, double *, double *, void *); void c_tqsphc1(int, double *, double *, void *); void c_tqcph1(int, int, int *, double *, double *, double *, double *, double *, void *); } extern"C" int c_ntup; // extern"C" int c_nel; // number of elements extern"C" int c_maxc; // extern"C" char *c_cnam[24]; // character array with all element names extern"C" double c_gval[24]; extern"C" int c_noofcs(int); using namespace std; void Initialize(void *ceq) { int n = 0; //=============== c_tqini(n, ceq); //=============== cout << "-> Adress of ceq-Storage: [" << &ceq << "]" << endl; }; void ReadDatabase(string fname, void *ceq) { char *filename = strcpy((char*)malloc(fname.length()+1), fname.c_str()); //====================== c_tqrfil(filename, ceq); //====================== cout << "-> Element Data: ["; for(int i = 0; i < c_nel; i++) { cout << c_cnam[i]; if(i < c_nel-1) { cout << ", "; } } cout << "]" << " [" << &ceq << "]" << endl; }; void ReadDatabaseLimited(string fname, vector elnames, void *ceq) { char *filename = strcpy((char*)malloc(fname.length()+1), fname.c_str()); char *selel[elnames.size()]; for(int i = 0; i < elnames.size(); i++) { char *tempchar = strcpy((char*)malloc(elnames[i].length()+1), elnames[i].c_str()); selel[i] = tempchar; } //============================================== c_tqrpfil(filename, elnames.size(), selel, ceq); //============================================== cout << "-> Element Data: ["; for(int i = 0; i < c_nel; i++) { cout << c_cnam[i]; if(i < c_nel-1) { cout << ", "; } } cout << "]" << " [" << &ceq << "]" << endl; }; void ReadPhases(vector &phnames, void *ceq) { phnames.clear(); for(int i = 1; i < c_ntup+1; i++) { char phn[24]; //========================== c_tqgpn(i, phn, ceq); //========================== phnames.push_back(phn); } cout << "-> Phase Data: ["; for(int i = 0; i < phnames.size(); i++) { cout << phnames[i]; if(i < phnames.size()-1) { cout << ", "; } } cout << "]" << " [" << &ceq << "]" << endl; }; void SetTemperature(double T, void *ceq) { int cnum; int n1 = 0; int n2 = 0; char par[60] = "T"; if (T < 1.0) T = 1.0; //========================================= c_tqsetc(par, n1, n2, T, &cnum, ceq); //========================================= cout << "-> Set Temperature to: [" << T << "]" << " [" << &ceq << "]" << endl; }; void SetPressure(double P, void *ceq) { int cnum; int n1 = 0; int n2 = 0; char par[60] = "P"; if (P < 1.0) P = 1.0; //========================================= c_tqsetc(par, n1, n2, P, &cnum, ceq); //========================================= cout << "-> Set Pressure to: [" << P << "]" << " [" << &ceq << "]" << endl; }; void SetMoles(double N, void *ceq) { int cnum; int n1 = 0; int n2 = 0; char par[60] = "N"; //========================================= c_tqsetc(par, n1, n2, N, &cnum, ceq); //========================================= cout << "-> Set Moles to: [" << N << "]" << " [" << &ceq << "]" << endl; }; void SetComposition(vector X, void *ceq) { int cnum; int n1 = 0; int n2 = 0; char par[60] = "X"; for (int i = 0; i < c_nel; i++) { if (X[i] < 1.0e-6) X[i] = 1.0e-6; // Check and fix, if composition is below treshold if(i < c_nel - 1) { // Set and print composition, if element 'i' is not the reference/(last) element //================================================== c_tqsetc(par, i+1, n2, X[i], &cnum, ceq); //================================================== cout << "-> Set Composition of " << c_cnam[i] << " to: [" << X[i] << "]" << " [" << &ceq << "]" << endl; } else { // Print composition, if element 'i' is the reference/(last) element double X_ref = 1; for(int j = 0; j < i; j++) { X_ref -= X[j]; } cout << "-> Set Composition of " << c_cnam[i] << " to: [" << X_ref << "]" << " [" << &ceq << "]" << endl; } } }; void SetConstituents(int phidx, vector y, void *ceq) { int stable1 = phidx; double extra[MAXPH]; double yfr[y.size()]; for(int i = 0; i < y.size(); i++) { yfr[i] = y[i]; } //=============================== c_tqsphc1(stable1,yfr,extra,ceq); //=============================== cout << "-> Set Constituents to: ["; for(int i = 0; i < y.size(); i++) { cout << i << ": " << yfr[i]; if(i < y.size()-1) { cout << ", "; } } cout << "]" << endl; }; void SelectSinglePhase(int PhIdx, void *ceq) { // }; void CalculateEquilibrium(void *ceq) { char target[60] = " "; int null1 = 0; int null2 = 0; double val; //====================================== c_tqce(target, null1, null2, &val, ceq); //====================================== cout << "-> Calculated Equilibrium [" << ceq << "]" << endl; }; void GetGibbsData(int phidx, void *ceq) { int n2 = 2; int n3; double gtp[6]; double dgdy[100]; double d2gdydt[100]; double d2gdydp[100]; double d2gdy2[100]; //================================================================= c_tqcph1(phidx, n2, &n3, gtp, dgdy, d2gdydt, d2gdydp, d2gdy2, ceq); //================================================================= cout << "-> Read Gibbs Data G: ["; for(int i = 0; i < 6; i++) { cout << gtp[i]; if(i < 5) { cout << ", "; } } cout << "]" << endl; cout << "-> Read Gibbs Data dGdY: ["; for(int i = 0; i < n3; i++) { cout << dgdy[i]; if(i < n3-1) { cout << ", "; } } cout << "]" << endl; cout << "-> Read Gibbs Data d2GdYdT: ["; for(int i = 0; i < n3; i++) { cout << d2gdydt[i]; if(i < n3-1) { cout << ", "; } } cout << "]" << endl; cout << "-> Read Gibbs Data d2GdYdP: ["; for(int i = 0; i < n3; i++) { cout << d2gdydp[i]; if(i < n3-1) { cout << ", "; } } cout << "]" << endl; int kk=n2*(n2+1)/2; cout << "-> Read Gibbs Data d2GdY2: ["; for(int i = 0; i < kk; i++) { cout << d2gdy2[i]; if(i < kk-1) { cout << ", "; } } cout << "]" << endl; }; void ListPhaseFractions(vector phnames, vector& phfract, void *ceq) { double npf[MAXPH]; char statevar[60] = "NP"; int n1 = -1; int n2 = 0; int n3 = MAXPH;//sizeof(npf) / sizeof(npf[0]); //======================================== c_tqgetv(statevar, n1, n2, &n3, npf, ceq); //======================================== for(int i = 0; i < n3; i++) phfract.push_back(npf[i]); cout << "-> Phase Fractions: ["; for (int i = 0; i < n3; i++) { cout << phnames[i] << ": " << phfract[i]; if(i < n3-1) { cout << ", "; } } cout << "]" << " [" << &ceq << "]" << endl; }; void ListConstituentFractions(vector phnames, vector phfract, vector > elfract, void *ceq) { elfract.clear(); elfract.resize(phnames.size()); double pxf[10*MAXPH]; for (int i = 1; i < c_ntup+1; i++) { if (phfract[i-1] > 0.0) { char* statevar = "X"; int n1 = 0; int n2 = -1; //composition of stable phase n2 = -1 means all fractions int n4 = sizeof(pxf)/sizeof(pxf[0]); //======================================= c_tqgetv(statevar, i, n2, &n4, pxf, ceq); //======================================= for (int k = 0; k < n4; k++) { elfract[i-1].push_back(pxf[k]); } cout << "-> Constituent Fractions for " << phnames[i-1] << " ["; for (int k = 0; k < n4; k++) { cout << c_cnam[k] << ": " << elfract[i-1][k]; if(k < n4-1) { cout << ", "; } } cout << "]" << " [" << &ceq << "]" << endl; } } }; void ListExtConstituentFractions(int phidx, vector phnames, void *ceq) { int stable1 = phidx; int nlat; int nlatc[MAXPH]; int conlista[MAXPH]; double yfr[MAXPH]; double sites[MAXPH]; double extra[MAXPH]; //====================================================================== c_tqgphc1(stable1, &nlat, nlatc, conlista, yfr, sites, extra, ceq); //====================================================================== cout << "-> Extended Constituent Fractions for " << phnames[stable1-1] << " [" << extra[0] << " moles of atoms/formula unit]"; int consti = 0; for(int i = 0; i < nlat; i++) { cout << " ["; for(int j = 0; j < nlatc[i]; j++) { cout << "Const. " << consti << ": " << yfr[consti]; if(j < nlatc[i]-1) { cout << ", "; } consti += 1; } cout << "]_(" << sites[i] << ")"; } cout << endl; }; ================================================ FILE: examples/TQ4lib/Cpp/Scheil/Compile_OCASI_win32.bash ================================================ #!/bin/bash # # You must adjust this command file to your local environment # COMPILER=i686-w64-mingw32 GFORTRAN=${COMPILER}-gfortran GCPP=${COMPILER}-g++ set -x rm *.o # Copy the libraries from OC (compiled with parallel) cp ../F90/{liboceq.a,liboceq.mod,/liboceqplus.mod} . ${GFORTRAN} -c -fopenmp liboctq.F90 ${GFORTRAN} -c -fopenmp liboctqisoc.F90 ${GCPP} -o scheil.exe -static -fopenmp -lstdc++ example_OCASI.cpp liboctqisoc.o liboctq.o liboceq.a -lgfortran -lm -lquadmath ================================================ FILE: examples/TQ4lib/Cpp/Scheil/Example_OCASI.cpp ================================================ #define CTEC 0// should be 0 for non CTEC users # if CTEC<1 #include "ocasiintf.h" #define OCVERSION "Open CalPhad Software Interface July 2016" #endif #if CTEC>0 #include "CTEC.h" #define OCVERSION "OC_Prophase July 2016" #endif #include /* CTEC = 0 Compilation Open Source CTEC = 1 Compilation Constellium Unix Server CTEC = 2 Compilation Constellium Windows 7 PC */ using namespace std; int main(int argc, char **argv) { int ncpu=1; vector Store_Equilibria; Store_Equilibria.resize(0); vector Store_Equilibria_compo_unit; vector Suspended_phase_list; Suspended_phase_list.resize(0); Store_Equilibria_compo_unit.resize(0); vector eldatabase; string el_ref; bool compo_in_percent=false; string compo_unit="W"; string temp_unit="C"; vector Compo_all_el; vector Compo_all_el_old; int i_ref=0; vector W; vector MU; vector el_reduced_names; el_reduced_names.resize(0); // Array including selected elements W.resize(0); size_t i_compo=0; string strcompo="Compo"; string strcomponb=""; size_t i_eq=0; string strEqui="Equilibrium"; string strEquinb=""; string myequi=""; string element_file="elements.txt"; int i_error=0; void *ceq =0; // Pointer to the OpenCalphad storage double TK=2000; double TC=2000; double TK_Liquidus=10; vector phnames; // Array including all phase names vector phfract; // Array including all phase fractions vector< vector > elfract; // Array including all equilibrium compositions struct timeval start1, end1; ofstream file; long seconds, useconds; double elapsed_time; char command[255]; omp_set_num_threads(ncpu); //cout <<" name of the input file :"< month; month.resize(13,""); month[1]="January"; month[2]="February"; month[3]="March"; month[4]="April"; month[5]="May"; month[6]="June"; month[7]="July"; month[8]="August"; month[9]="September"; month[10]="October"; month[11]="November"; month[12]="December"; string strLIQUID="LIQUID"; string strSOLSOL="FCC_A1"; #if CTEC==2 { right_to_use=InitInstance(); } #endif while (!inputfile.eof() ){ string strmyline; std::getline(inputfile, strmyline); cout<strmyline.size())) { sout<<" error in command line < not found in line:"<"); if ((i<0) or (i>strmyline.size())) { sout<<" error in command line > not found in line:"<"); if ((i<0) or (i>strmyline.size())) { sout<<" error in command line > not found in line:"<0 { CTECGetAllElementsFromDatabase(TDBFILE); } #endif //end *************************** applicable for CTEC only sout<<" the following elements are in the database:"<"); if ((i<0) or (i>strmyline.size())) { sout<<" error in command line > not found in line:"<"); if ((i<0) or (i>strmyline.size())) { sout<<" error in command line > not found in line:"<"); if ((i<0) or (i>strmyline.size())) { sout<<" error in command line > not found in line:"<"); if ((i<0) or (i>strmyline.size())) { sout<<" error in command line > not found in line:"<"); if ((i<0) or (i>strmyline.size())) { sout<<" error in command line > not found in line:"<"); if ((i<0) or (i>strmyline.size())) { sout<<" error in command line > not found in line:"<"); if ((i<0) or (i>strmyline.size())) { sout<<" error in command line > not found in line:"<tm_mday<<" "<tm_mon]<<" "<<1900 + ltm->tm_year<<" , "<< ltm->tm_hour << "h:"<< ltm->tm_min << "mn:"<< ltm->tm_sec<<"s"<< endl; file<tm_mday<<" "<tm_mon]<<" "<<1900 + ltm->tm_year<<" , "<< ltm->tm_hour << "h:"<< ltm->tm_min << "mn:"<< ltm->tm_sec<<"s"<< endl; sout<"); if ((i<0) or (i>strmyline.size())) { sout<<" error in command line > not found in line:"< New element detected :"< element detected with zero composition :"<0){ re_read_compo=true; sout<<" all possible phases will be allowed again with new composition" <1e-10){ el_reduced_names.push_back(eldatabase[i]); W.push_back(Compo_all_el[i]); file<0 { CTECReadDatabaseLimited(TDBFILE, el_reduced_names, &ceq); // Define TDB-file and read only selected elements (non zero composition) } #endif //end *************************** applicable for CTEC only data_base_already_read=true; sout<<"reading phases"<100){ length=0; sout<(el_reduced_names.size(),0.)); SetPressure(1e5, &ceq); // Set Pressure SetMoles(1.0, &ceq); // Set Number of moles MU.resize(W.size(),0.); } else{ file<<"=================================================================="<"); if ((i<0) or (i>strmyline.size())) { sout<<" error in command line, first > not found in line:"< liquidus is: "<"); if ((i<0) or (i>strmyline.size())) { sout<<" error in command line, first > not found in line:"< solidus is: "<strmyline.size())) { sout<<" error in command line, first / not found in line:"<strmyline.size())) { sout<<" error in command line, second / not found in line:"<strmyline.size())) { sout<<" error in command line, third / not found in line:"<"); if ((i<0) or (i>strmyline.size())) { sout<<" error in command line, > not found in line:"<strmyline.size())) { sout<<" error in command line, / not found in line:"<"); if ((i<0) or (i>strmyline.size())) { sout<<" error in command line, > not found in line:"<strmyline.size())))) { string strphasename=strmyline.substr(0,i); All_Capital_Letters(strphasename); bool phase_found=false; for (int j=0;j"); if ((i<0) or (i>strmyline.size())) { sout<<" error in command line, > not found in line:"<"); if ((i<0) or (i>strmyline.size())) { sout<<" error in command line, > not found in line:"<"); file<<"["<strmyline.size())))) { string strphasename=strmyline.substr(0,i); All_Capital_Letters(strphasename); bool phase_found=false; for (int j=0;j"); if ((i<0) or (i>strmyline.size())) { sout<<" error in command line, > not found in line:"<strmyline.size())) { sout<<" error in command line, > not found in line:"<strmyline.size())) { sout<<" error in command line, very first / not found in line:"<strmyline.size())) { sout<<" error in command line, second / not found in line:"<strmyline.size())) { sout<<" error in command line, third / not found in line:"<"); if ((i<0) or (i>strmyline.size())) { sout<<" error in command line, fourth / not found in line:"<0)){ //parameter target_delta_f_liq //paramter delta_T_min //paramter delta_T_max sout<strmyline.size())) { sout<<" error in command line, very first / not found in line:"<strmyline.size())) { sout<<" error in command line, third / not found in line:"<strmyline.size())) { sout<<" error in command line, fourth / not found in line:"<strmyline.size())) { sout<<" error in command line, fifth / not found in line:"<strmyline.size())) { sout<<" error in command line, sixth / not found in line:"<strmyline.size())) { sout<<" error in command line, seventh / not found in line:"<strmyline.size())) { sout<<" error in command line, heigth / not found in line:"<strmyline.size())) { sout<<" error in command line, > not found in line:"<strmyline.size())) { sout<<" error in command line, > not found in line:"<"); if ((i<0) or (i>strmyline.size())) { sout<<" error in command line, > not found in line:"<0)){ //parameter target_delta_f_liq //paramter delta_T_min //paramter delta_T_max vector < double > TC1; vector < double > TC2; vector < double > segments_time_h; sout<strmyline.size())) { sout<<" error in command line, very first / not found in line:"<strmyline.size())) { sout<<" error in command line, third / not found in line:"<strmyline.size())) { sout<<" error in command line, fourth / not found in line:"<strmyline.size())) { sout<<" error in command line, fifth / not found in line:"<strmyline.size())) { sout<<" error in command line, sixth / not found in line:"<strmyline.size())) { sout<<" error in command line, seventh / not found in line:"<strmyline.size())) { i = strmyline.find(">"); if ((i<0) or (i>strmyline.size())) { sout<<" error in command line, > not found in line:"<0 homo(strGradientFileIn,strGradientFileOut,printresultevery_s,printgradientevery_h,strLIQUID,strSOLSOL,file,el_reduced_names,phnames,delta_T_max,i_ref,Store_Equilibria,Store_Equilibria_compo_unit,TC1, TC2,segments_time_h,Suspended_phase_list,strcomponb,element_file); #endif gettimeofday(&end1, NULL); seconds = end1.tv_sec - start1.tv_sec; useconds = end1.tv_usec - start1.tv_usec; elapsed_time = ((double)(((seconds) * 1000 + useconds/1000.0) + 0.5))/1000.; sout<<" elapsed time for the back-diffusion solidification routine (s)= "<0)){ //parameter target_delta_f_liq //paramter delta_T_min //paramter delta_T_max vector < double > TC1; vector < double > TC2; vector < double > segments_time_h; sout<"); if ((i<0) or (i>strmyline.size())) { sout<<" error in command line, > not found in line:"<0 compute_properties(strFile,strSOLSOL,el_reduced_names, W, compo_unit,i_ref, &ceq, phnames,file,strcomponb,element_file); #endif } else if((strcommand=="FIX_A_PHASE")){ sout<strmyline.size())) { sout<<" error in command line, / not found in line:"<"); if ((i<0) or (i>strmyline.size())) { sout<<" error in command line, / not found in line:"<strmyline.size())) { sout<<" error in command line, / not found in line:"<"); if ((i<0) or (i>strmyline.size())) { sout<<" error in command line, > not found in line:"<>>> to be modified to use phase tuplets integer(c_int), intent(in),value :: n1 !in: 0 or extended phase index: ! 10*phase_number+comp.set ! or component set integer(c_int), intent(in),value :: n2 ! integer(c_int), intent(out) :: cnum !exit: ! sequential number of this condition character(c_char), intent(in) :: statvar !in: character ! with state variable symbol real(c_double), intent(in),value :: mvalue !in: value of condition type(c_ptr), intent(in) :: c_ceq ! in: current equilibrium !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) call tqsetc(statvar, n1, n2, mvalue, cnum, ceq) nullify(ceq) end subroutine c_tqsetc !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqce(mtarget,n1,n2,mvalue,c_ceq) bind(c,name='c_tqce') ! calculate equilibrium with possible target ! Target can be empty or a state variable with indicies n1 and n2 ! value is the calculated value of target integer(c_int), intent(in),value :: n1 integer(c_int), intent(in),value :: n2 type(c_ptr), intent(inout) :: c_ceq character(c_char), intent(inout) :: mtarget real(c_double), intent(inout) :: mvalue !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq character(len=:), allocatable :: fstring call c_f_pointer(c_ceq,ceq) fstring = c_to_f_string(mtarget) call tqce(fstring,n1,n2,mvalue,ceq) c_ceq = c_loc(ceq) deallocate(fstring) nullify(ceq) end subroutine c_tqce !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgetv(statvar,n1,n2,n3,values,c_ceq) bind(c,name='c_tqgetv') ! get equilibrium results using state variables ! stavar is the state variable IN CAPITAL LETTERS with indices n1 and n2 ! n3 at the call is the dimension of values, changed to number of values ! value is the calculated value, it can be an array with n3 values. implicit none integer(c_int), intent(in),value :: n1,n2 integer(c_int), intent(inout) :: n3 character(c_char), intent(in) :: statvar real(c_double), intent(inout) :: values(*) type(c_ptr), intent(inout) :: c_ceq !IN: current equilibrium !======================================================== ! >>>> implement use of phase tuples ! stavar must be a symbol listed below ! IMPORTANT: some terms explained after the table ! Symbol index1,index2 Meaning (unit) !.... potentials ! T 0,0 Temperature (K) ! P 0,0 Pressure (Pa) ! MU component,0 or phase-tuple*1,constituent*2 Chemical potential (J) ! AC component,0 or phase-tuple,constituent Activity = EXP(MU/RT) ! LNAC component,0 or phase-tuple,constituent LN(activity) = MU/RT !...... extensive variables ! U 0,0 or phase-tuple,0 Internal energy (J) whole system or phase ! UM 0,0 or phase-tuple,0 same per mole components ! UW 0,0 or phase-tuple,0 same per kg ! UV 0,0 or phase-tuple,0 same per m3 ! UF phase-tuple,0 same per formula unit of phase ! S*3 0,0 or phase-tuple,0 Entropy (J/K) ! V 0,0 or phase-tuple,0 Volume (m3) ! H 0,0 or phase-tuple,0 Enthalpy (J) ! A 0,0 or phase-tuple,0 Helmholtz energy (J) ! G 0,0 or phase-tuple,0 Gibbs energy (J) ! ..... some extra state variables ! NP phase-tuple,0 Moles of phase ! BP phase-tuple,0 Mass of moles (kg) ! Q phase-tuple,0 Internal stability/RT (dimensionless) ! DG phase-tuple,0 Driving force/RT (dimensionless) !....... amounts of components ! N 0,0 or component,0 or phase-tuple,component Moles of component ! X component,0 or phase-tuple,component Mole fraction of component ! B 0,0 or component,0 or phase-tuple,component Mass of component ! W component,0 or phase-tuple,component Mass fraction of component ! Y phase-tuple,constituent*1 Constituent fraction !........ some parameter identifiers ! TC phase-tuple,0 Magnetic ordering temperature ! BMAG phase-tuple,0 Aver. Bohr magneton number ! MQ& phase-tuple,constituent Mobility ! THET phase-tuple,0 Debye temperature ! LNX phase-tuple,0 Lattice parameter ! EC11 phase-tuple,0 Elastic constant C11 ! EC12 phase-tuple,0 Elastic constant C12 ! EC44 phase-tuple,0 Elastic constant C44 !........ NOTES: ! *1 The phase-tuple is is structure with 2 integers: phase and comp.set ! *2 The constituent index is 10*species_number + sublattice_number ! *3 S, V, H, A, G, NP, BP, N, B and DG can have suffixes M, W, V, F also !-------------------------------------------------------------------- ! special addition for TQ interface: d2G/dyidyj ! D2G + extended phase index !------------------------------------ type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fstring integer :: n integer :: i call c_f_pointer(c_ceq, ceq) ! call list_conditions(6,ceq) ! call list_phase_results(1,1,0,6,ceq) ! write(*,*)'Phase and error code: ',1,gx%bmperr ! call list_phase_results(2,1,0,6,ceq) ! write(*,*)'Phase and error code: ',2,gx%bmperr ! write(*,*) call c_to_f_str(statvar,fstring) call tqgetv(fstring, n1, n2, n3, values, ceq) ! debug ... ! write(*,55)fstring(1:len_trim(fstring)),n1,n2,n3,(values(i),i=1,n3) !55 format(/'From c_tqgetv: ',a,': ',3i3,6(1pe12.4)) ! write(*,*) ! end debug c_ceq = c_loc(ceq) end subroutine c_tqgetv !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgphc1(n1,nsub,cinsub,spix,yfrac,sites,extra,c_ceq)& bind(c,name='c_tqgphc1') ! tq_get_phase_constitution ! This subroutine returns the sublattices and constitution of a phase ! n1 is phase tuple index ! nsub is the number of sublattices (1 if no sublattices) ! cinsub is an array with the number of const\EDtuents in each sublattice ! spix is an array with the species index of the constituents in all sublattices ! sites is an array of the site ratios for all sublattices. ! yfrac is the constituent fractions in same order as in spix ! extra is an array with some extra values: ! extra(1) is the number of moles of components per formula unit ! extra(2) is the net charge of the phase implicit none !integer n1,nsub,cinsub(*),spix(*) integer(c_int), intent(in), value :: n1 integer(c_int), intent(out) :: nsub integer(c_int), intent(out) :: cinsub(*) integer(c_int), intent(in) :: spix(*) !double precision sites(*),yfrac(*),extra(*) real(c_double), intent(in) :: sites(*) real(c_double), intent(in) :: yfrac(*) real(c_double), intent(in) :: extra(*) !type(gtp_equilibrium_data), pointer :: ceq type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) !call tqgphc1(n1,nsub2,cinsub2,spix2,yfrac2,sites2,extra2,ceq) call tqgphc1(n1,nsub,cinsub,spix,yfrac,sites,extra,ceq) c_ceq = c_loc(ceq) end subroutine c_tqgphc1 !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqsphc1(n1,yfra,extra,c_ceq) bind(c,name='c_tqsphc1') ! tq_set_phase_constitution ! To set the constitution of a phase ! n1 is phase tuple index ! yfra is an array with the constituent fractions in all sublattices ! in the same order as obtained by tqgphc1 ! extra is an array with returned values with the same meaning as in tqgphc1 ! NOTE The constituents fractions are normallized to sum to unity for each ! sublattice and extra is calculated by tqsphc1 ! T and P must be set as conditions. implicit none integer(c_int), intent(in), value :: n1 real(c_double), intent(in) ::yfra(*) real(c_double), intent(out) :: extra(*) type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) call set_constitution(phasetuple(n1)%ixphase,phasetuple(n1)%compset,& yfra,extra,ceq) c_ceq = c_loc(ceq) end subroutine c_tqsphc1 !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqcph1(n1,n2,n3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,c_ceq) & bind(c,name='c_tqcph1') ! tq_calculate_phase_properties !vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! WARNIG: this is not a subroutine to calculate chemical potentials ! those can only be made by an equilibrium calculation. ! The values returned are partial derivatives of G for the phase at the ! current T, P and phase constitution. The phase constitution has been ! obtained by a previous equilibrium calculation or ! set by the subroutine tqsphc ! It corresponds to the "calculate phase" command. ! ! NOTE that values are per formula unit divided by RT, ! divide also by extra(1) in subroutine tqsphc1 to get them per mole component ! !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! calculate G and some or all derivatives for a phase at current composition ! n1 is the phase tuple index ! n2 is 0 if only G and derivatves wrt T and P, 1 also first drivatives wrt ! compositions, 2 if also 2nd derivatives ! n3 is returned as number of constituents (dimension of returned arrays) ! gtp is an array with G, G.T, G:P, G.T.T, G.T.P and G.P.P ! dgdy is an array with G.Yi ! d2gdydt is an array with G.T.Yi ! d2gdydp is an array with G.P.Yi ! d2gdy2 is an array with the upper triangle of the symmetrix matrix G.Yi.Yj ! reurned in the order: 1,1; 1,2; 1,3; ... ! 2,2; 2,3; ... ! 3,3; ... ! for indexing one can use the integer function ixsym(i1,i2) implicit none integer(c_int), intent(in), value :: n1 integer(c_int), intent(in), value :: n2 integer(c_int), intent(out) :: n3 real(c_double), intent(out) :: gtp(6) real(c_double), intent(out) :: dgdy(*) real(c_double), intent(out) :: d2gdydt(*) real(c_double), intent(out) :: d2gdydp(*) real(c_double), intent(out) :: d2gdy2(*) type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) call tqcph1(n1,n2,n3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,ceq) c_ceq = c_loc(ceq) end subroutine c_tqcph1 !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_reset_conditions(cline,c_ceq) bind(c, name='c_reset_conditions') implicit none character(c_char), intent(in) :: cline(24) type(c_ptr), intent(inout) :: c_ceq ! in: current equilibrium !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fstring fstring = c_to_f_string(cline) call c_f_pointer(c_ceq, ceq) call reset_conditions(fstring,ceq) c_ceq = c_loc(ceq) end subroutine c_reset_conditions !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_Change_Status_Phase(phasename,nystat,myval,c_ceq)& bind(c, name='c_Change_Status_Phase') !change the status Fixed or Entered of a phase !PHFIXED=2 !PHENTERED=0 implicit none character(c_char), intent(in) :: phasename(24) integer(c_int), intent(in), value :: nystat real(c_double), intent(in),value :: myval type(c_ptr), intent(inout) :: c_ceq ! in: current equilibrium !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fstring call c_f_pointer(c_ceq, ceq) call c_to_f_str(phasename,fstring) call Change_Status_Phase(fstring,nystat,myval,ceq) c_ceq = c_loc(ceq) 1000 continue return end subroutine c_Change_Status_Phase !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_List_Conditions(c_ceq)& bind(c, name='c_List_Conditions') !change the status Fixed or Entered of a phase !PHFIXED=2 !PHENTERED=0 implicit none type(c_ptr), intent(inout) :: c_ceq ! in: current equilibrium !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) call list_conditions(6,ceq) c_ceq = c_loc(ceq) 1000 continue return end subroutine c_List_Conditions !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_checktdb(tdbfile)& bind(c, name='c_checktdb') character(kind=c_char), intent(in) :: tdbfile !\end{verbatim} integer:: nel,i character selel(maxel)*2 character(len=:), allocatable :: fstring character(len=:), allocatable :: ext ext='.tdb' fstring = c_to_f_string(tdbfile) call checkdb(fstring,ext,nel,selel) c_nel = nel do i = 1, nel cnames(i) = trim(selel(i)) // c_null_char c_cnam(i) = c_loc(cnames(i)) end do deallocate(fstring) return end subroutine c_checktdb !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_newEquilibrium(ceqname,ieq) bind(c, name='c_newEquilibrium') character(kind=c_char), intent(in) :: ceqname integer(c_int), intent(out):: ieq !\end{verbatim} character(len=:), allocatable :: fstring fstring = c_to_f_string(ceqname) call enter_equilibrium(fstring,ieq) deallocate(fstring) end subroutine c_newEquilibrium !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_selecteq(ieq,c_ceq) bind(c, name='c_selecteq') integer(c_int), intent(in),value :: ieq type(c_ptr), intent(out) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq !call c_f_pointer(c_ceq, ceq) !call selecteq(ieq,ceq) ceq=>eqlista(ieq) c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_selecteq !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_copy_equilibrium(c_neweq,ceqname,c_ceq) & bind(c, name='c_copy_equilibrium') type(c_ptr), intent(inout) :: c_neweq character(kind=c_char), intent(in) :: ceqname type(c_ptr), intent(in) :: c_ceq !\end{verbatim} character(len=:), allocatable :: fstring type(gtp_equilibrium_data), pointer :: ceq type(gtp_equilibrium_data), pointer :: neweq call c_f_pointer(c_ceq, ceq) fstring = c_to_f_string(ceqname) call copy_equilibrium(neweq,fstring,ceq) c_neweq=c_loc(neweq) deallocate(fstring) nullify(ceq) return end subroutine c_copy_equilibrium !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_set_status_globaldata() bind(c, name='c_set_status_globaldata') !\end{verbatim} !globaldata%status=ibclr(globaldata%status,GSADV) !globaldata%status=ibclr(globaldata%status,GSNOPAR) !globaldata%status=ibclr(globaldata%status,GSXGRID) globaldata%status=ibclr(globaldata%status,GSNOACS) return end subroutine c_set_status_globaldata !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} integer function c_errors_number() bind(c, name='c_errors_number') !\end{verbatim} c_errors_number=0 if(gx%bmperr.ne.0) then c_errors_number=gx%bmperr endif return end function c_errors_number !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_new_gtp() bind(c, name='c_new_gtp') !\end{verbatim} call new_gtp end subroutine c_new_gtp end module liboctqisoc ================================================ FILE: examples/TQ4lib/Cpp/Scheil/linkscheil ================================================ REM You must first install OC to generate the libraries REM liboceq.a, liboceqplus.mod REM You must compile the parallel version, linkpara or Makefile-parallel REM These are copied there (assumed to be three levels above) copy ..\..\..\libocasi.a . copy ..\..\..\liboceqplus.mod . REM Then the libraries for TQ are copied here from one level above copy ..\liboctq.F90 . copy ..\liboctqisoc.F90 . REM Compile this library together with the isoc library and the program gfortran -c liboctq.F90 gfortran -c liboctqisoc.F90 g++ -o scheil -fopenmp -lstdc++ Example_OCASI.cpp liboctqisoc.o liboctq.o libocasi.a -lgfortran -lm ================================================ FILE: examples/TQ4lib/Cpp/Scheil/ocasiintf.h ================================================ //define PARALLEL 0 no loop with parallelization //define PARALLEL 1 declared loops with parallelization #define PARALLEL 1 #define MAXEL 41 #define MAXPH 501 #define PHFIXED 2 #define PHENTERED 0 #define PHSUS -3 #define GRID 0 #define NOGRID -1 #define TCtoTK 273.15 #define TAB "\t" #include "octqc.h" #include #include #include #include #include #include #include #include #include #include #include #include #include #include extern"C" { void c_Change_Status_Phase(char *, int ,double ,void *); void c_tqgetv(char *, int , int , int *, double *, void *); // get equilibrium results using state variables void c_tqsetc(char *, int, int , double, int *, void *); // set condition void c_tqce(char *, int , int , double *, void *); // calculate quilibrium with possible target void c_tqini(int, void *); // initiates the OC package void c_tqrfil(char *, void *); // read all elements from a TDB file //void c_tqgcom(int *, char[MAXEL][24], void **); // get system component names. At present the elements void c_tqrpfil(char *, int, char **, void *); // read TDB file with selection of elements //void c_tqgnp(int *, void **); // get total number of phases and composition sets void c_tqgpi(int *, char *, void *); // get index of phase phasename void c_tqgpn(int, char *, void *); // get name of phase+compset tuple with index phcsx //void c_tqgnp(int, gtp_equilibrium_data **); // get total number of phases and composition sets void examine_gtp_equilibrium_data(void *); // //void c_getG(int, void *); //void c_calcg(int, int, int, int, void *); void c_tqgphc1(int, int * , int *, int *, double *, double *, double *, void *); void c_tqsphc1(int, double *, double *, void *); void c_tqcph1(int, int, int *, double *, double *, double *, double *, double *, void *); void c_List_Conditions(void *); void c_checktdb(char *); void c_newEquilibrium(char *,int *); void c_selecteq(int ,void *); void c_copy_equilibrium(void *,char *,void *); void c_set_status_globaldata(); int c_errors_number(); void c_new_gtp(); void c_reset_conditions(char *,void *); } extern"C" int c_ntup; // extern"C" int c_nel; // number of elements extern"C" int c_maxc; // extern"C" char *c_cnam[MAXEL]; // character array with all element names extern"C" double c_gval[24]; extern"C" int c_noofcs(int); extern"C" double c_mass[24]; using namespace std; const double R=8.31451; template < typename CHAR_TYPE, typename TRAITS_TYPE = std::char_traits > struct basic_teebuf : public std::basic_streambuf< CHAR_TYPE, TRAITS_TYPE > { typedef std::basic_streambuf< CHAR_TYPE, TRAITS_TYPE > streambuf_type ; typedef typename TRAITS_TYPE::int_type int_type ; basic_teebuf( streambuf_type* buff_a, streambuf_type* buff_b ) : first(buff_a), second(buff_b) {} protected: virtual int_type overflow( int_type c ) { const int_type eof = TRAITS_TYPE::eof() ; if( TRAITS_TYPE::eq_int_type( c, eof ) ) return TRAITS_TYPE::not_eof(c) ; else { const CHAR_TYPE ch = TRAITS_TYPE::to_char_type(c) ; if( TRAITS_TYPE::eq_int_type( first->sputc(ch), eof ) || TRAITS_TYPE::eq_int_type( second->sputc(ch), eof ) ) return eof ; else return c ; } } virtual int sync() { return !first->pubsync() && !second->pubsync() ? 0 : -1 ; } private: streambuf_type* first ; streambuf_type* second ; }; template < typename CHAR_TYPE, typename TRAITS_TYPE = std::char_traits > struct basic_teestream : public std::basic_ostream< CHAR_TYPE, TRAITS_TYPE > { typedef std::basic_ostream< CHAR_TYPE, TRAITS_TYPE > stream_type ; typedef basic_teebuf< CHAR_TYPE, TRAITS_TYPE > streambuff_type ; basic_teestream( stream_type& first, stream_type& second ) : stream_type( &stmbuf), stmbuf( first.rdbuf(), second.rdbuf() ) {} ~basic_teestream() { stmbuf.pubsync() ; } private: streambuff_type stmbuf ; }; typedef basic_teebuf teebuf ; typedef basic_teestream teestream ; std::ofstream logfile( "oc_log.txt" ) ; teestream sout( logfile, std::cout ) ; void Get_Ceq(const int &iceq,void *ceq){ c_selecteq(iceq,ceq); //sout << "-> Adress of ceq-Storage: [" << ceq << "]" < Adress of ceq-Storage: [" << ceq << "]" < Element Data: ["; for(int i = 0; i < c_nel; i++) { sout << c_cnam[i]; if(i < c_nel-1) { sout << ", "; } } sout << "]" << " [" << &ceq << "]" < &elnames, void *ceq) { char *buffer=(char*)malloc(tdbfilename.length()+1); char *filename = strcpy(buffer, tdbfilename.c_str()); char *selel[elnames.size()]; for(size_t i = 0; i < elnames.size(); i++) { char *buffer=(char*)malloc(elnames[i].length()+1); char *tempchar = strcpy(buffer, elnames[i].c_str()); selel[i] = tempchar; } //============================================== c_tqrpfil(filename, elnames.size(), selel, ceq); //============================================== /* sout << "-> Element Data: ["; for(int i = 0; i < c_nel; i++) { sout << c_cnam[i]; if(i < c_nel-1) { sout << ", "; } } sout << "]" << " [" << &ceq << "]" << endl; */ free (buffer); }; void ReadPhases(vector &phnames, void *ceq) { phnames.clear(); phnames.resize(c_ntup); for(int i = 1; i < c_ntup+1; i++) { char phn[24]; //========================== c_tqgpn(i, phn, ceq); //========================== int index; c_tqgpi(&index,phn,ceq); string myname(phn); transform(myname.begin(), myname.end(), myname.begin(), ::toupper);// to have it in CAPITAL LETTERS phnames[index-1]=myname; } /* sout << "-> Phase Data: ["; for(size_t i = 0; i < phnames.size(); i++) { sout << i<< " "< &el_reduced_names,const int &i_ref, const string &compo_unit){ { string mystring("T=none"); char *buffer=(char*)malloc(mystring.length()+1); char *conditions = strcpy(buffer, mystring.c_str()); c_reset_conditions(conditions,ceq); free (buffer); } string mystring=""; for (int i=0;i Set Temperature to: [" << T << "]" << " [" << &ceq << "]" << // endl; }; void SetPressure(const double &P, void *ceq) { int cnum; int n1 = 0; int n2 = 0; char par[60] = "P"; // if (P < 1.0) P = 1.0; //========================================= c_tqsetc(par, n1, n2, P, &cnum, ceq); //========================================= // sout << "-> Set Pressure to: [" << P << "]" << " [" << &ceq << "]" << // endl; }; void SetMoles(const double &N, void *ceq) { int cnum; int n1 = 0; int n2 = 0; char par[60] = "N"; //========================================= c_tqsetc(par, n1, n2, N, &cnum, ceq); //========================================= // sout << "-> Set Moles to: [" << N << "]" << " [" << &ceq << "]" << // endl; }; void SetComposition(vector& X, void *ceq, const int &i_ref,string &compo_unit) { int cnum; int n2 = 0; char par[60]; strcpy(par,compo_unit.c_str()); for (int i = 0; i < c_nel; i++) { if (X[i] < 1.0e-8) X[i] = 1.0e-8; // Check and fix, if composition is below treshold if(not (i == i_ref)) { int j=i+1; double value= X[i];// Set and print composition, if element 'i' is not the reference/(last) element //================================================== c_tqsetc(par, j, n2,value, &cnum, ceq); //================================================== // sout << "-> Set Composition of " << c_cnam[i] << " to: [" << // X[i] << "]" << " [" << &ceq << "]" << // endl; } else { // Print composition, if element 'i' is the reference/(last) element double X_ref = 1; for(size_t j = 0; j < i; j++) { X_ref -= X[j]; } // sout << "-> Set Composition of " << c_cnam[i] << " to: [" << // X_ref << "]" << " [" << &ceq << "]" << // endl; } } }; void SetConstituents(int phidx, vector y, void *ceq) { int stable1 = phidx; double extra[MAXPH]; double yfr[y.size()]; for(size_t i = 0; i < y.size(); i++) { yfr[i] = y[i]; } //=============================== c_tqsphc1(stable1,yfr,extra,ceq); //=============================== sout << "-> Set Constituents to: ["; for(int i = 0; i < y.size(); i++) { sout << i << ": " << yfr[i]; if(i < y.size()-1) { sout << ", "; } } sout << "]" << endl; }; void ReadPhaseFractions(const vector &phnames, vector& phfract, void *ceq) { double npf[MAXPH]; char statevar[60] = "NP"; int n1 = -1;//-1 int n2 = 0; int n3 = MAXPH;//sizeof(npf) / sizeof(npf[0]); //======================================== c_tqgetv(statevar, n1, n2, &n3, npf, ceq); //======================================== for(int i = 0; i < phnames.size(); i++){ /* char phn[24]; c_tqgpn(i+1, phn, ceq); size_t index=0; for (size_t j=0;j Read Gibbs Data G: ["; for(int i = 0; i < 6; i++) { sout << gtp[i]; if(i < 5) { sout << ", "; } } sout << "]" << endl; sout << "-> Read Gibbs Data dGdY: ["; for(int i = 0; i < n3; i++) { sout << dgdy[i]; if(i < n3-1) { sout << ", "; } } sout << "]" << endl; sout << "-> Read Gibbs Data d2GdYdT: ["; for(int i = 0; i < n3; i++) { sout << d2gdydt[i]; if(i < n3-1) { sout << ", "; } } sout << "]" << endl; sout << "-> Read Gibbs Data d2GdYdP: ["; for(int i = 0; i < n3; i++) { sout << d2gdydp[i]; if(i < n3-1) { sout << ", "; } } sout << "]" << endl; int kk=n2*(n2+1)/2; sout << "-> Read Gibbs Data d2GdY2: ["; for(int i = 0; i < kk; i++) { sout << d2gdy2[i]; if(i < kk-1) { sout << ", "; } } sout << "]" << endl; }; void SelectSinglePhase(int PhIdx, void *ceq) { // }; void List_Conditions(void *ceq){ c_List_Conditions(ceq); } void CalculateEquilibrium(void *ceq, const int &n1, int &i_error, const vector < string > &Suspended_phase_list) { for (int i=0;i0){ for (int i=0;i0){ sout<<"!!!!!!!! convergence issue !!!!!!!!!!!!!!!!!!!!!"< &MU) { double npf[1]; char statevar[60] = "MU"; for (int i = 1; i < c_nel+1; i++) { int n1 = i; int n2 = 0; int n3 = 1; //======================================== c_tqgetv(statevar, n1, n2, &n3, npf, ceq); //======================================== MU[i-1]=npf[0]; } }; double ReadTemperature(void *ceq) { double npf[1]; char statevar[60] = "T"; int n1 = 0; int n2 = 0; int n3 = 1; double TK; //======================================== c_tqgetv(statevar, n1, n2, &n3, npf, ceq); //======================================== TK=npf[0]; return(TK); }; double ReadTotalEnthalpy(void *ceq) { double npf[1]; char statevar[60] = "H"; int n1 = 0; int n2 = 0; int n3 = 1; double H; //======================================== c_tqgetv(statevar, n1, n2, &n3, npf, ceq); //======================================== H=npf[0]; return(H); }; void ReadConstituentFractions(const vector &phnames, const vector &phfract, vector< vector > &elfract, void *ceq, const string &compo_unit) { double pxf[10*MAXPH]; for (int i = 1; i < c_ntup+1; i++) { char phn[24]; c_tqgpn(i, phn, ceq); size_t index=0; bool index_found=false; for (size_t j=0;j phnames, void *ceq) { int stable1 = phidx; int nlat; int nlatc[MAXPH]; int conlista[MAXPH]; double yfr[MAXPH]; double sites[MAXPH]; double extra[MAXPH]; //====================================================================== c_tqgphc1(stable1, &nlat, nlatc, conlista, yfr, sites, extra, ceq); //====================================================================== sout << "-> Extended Constituent Fractions for " << phnames[stable1-1] << " [" << extra[0] << " moles of atoms/formula unit]"; int consti = 0; for(int i = 0; i < nlat; i++) { sout << " ["; for(int j = 0; j < nlatc[i]; j++) { sout << "Const. " << consti << ": " << yfr[consti]; if(j < nlatc[i]-1) { sout << ", "; } consti += 1; } sout << "]_(" << sites[i] << ")"; } sout << endl; }; std::string IntToString ( int number ) { std::string mystr; std::stringstream out; out << number; mystr = out.str(); return mystr; } // Write the results of a given equilibrium // el_reduced_names: vector of names elements with non zero composition // phnames: vector of names phases that can appear for these elements // phfract: atomic fraction of these phases after equilibrium // elfract[i][j]: atomic composition of element i in phase j // ceqh: pointer for the given equilibrium calculation // mode: 1 write only atomic fractions of phases after equilibrium // mode: 1 write atomic fractions + compositions of phases after equilibrium void Write_Results_Equilibrium(ofstream& file, const vector &el_reduced_names, const vector &phnames, vector &phfract, vector< vector > &elfract, void *ceqh,const int &mode,const string &compo_unit, vector &MU,const string &temp_unit,const string &myequi){ //-------------------------------List Results------------------------------- ReadPhaseFractions(phnames, phfract, &ceqh); // Read the amount of stable phases if (mode >1) ReadConstituentFractions(phnames, phfract, elfract, &ceqh, compo_unit); // Read the composition of each stable phase double TC=ReadTemperature(&ceqh); if (temp_unit=="C") TC-=TCtoTK; sout<0){ sout<<" "<2) { file<1e-10){ sout<<" --------------------------------------- "<1e-10) sout<<" "<1e-10) file< &W, const vector &phnames,vector &Transitions,const vector &el_reduced_names,const bool first_iteration, const bool last_iteration, vector &Store_Equilibria,vector< string > &Phase_transitions_mixture, void *ceq,const double required_accuracy_on_TK, const vector< string > &Suspended_phase_list, bool status_ok){ int iceq=0; vector phfract; phfract.resize(phnames.size(),0.); vector< vector > elfract; // Array including all equilibrium compositions elfract.resize(phnames.size(),vector(el_reduced_names.size(),0.)); vector TKCE; vector< vector > CeqFract; TKCE.resize(0); CeqFract.resize(0); double TK_end=TK_start+(nstep-1)*step_TK; double TK=TK_start; int nstep_total=nstep; if (not first_iteration) nstep_total+=1; for (int i=0; i(phnames.size(),0.)); size_t max_number_of_phase=0; // the three lines below trigger parallelism for the nex for {....} loop if PARALLEL is not 0 // sout<<"number of threads detected:"<0 #pragma omp parallel for #endif for (int i=0; i0)) { c_selecteq(Store_Equilibria[i], &ceqi);// retrieve the pointer with index stored in Store_Equilibria }else{ //ceqi=ceq;// if no parallelization use STANDART EQUILIBRIUM c_selecteq(1, &ceqi); } //for (int k=0;k0) CeqFract[i][j]=phfract[j]; } } } /* for (int i=0; i"<"<0) sout<<" "<1e-8)&&(CeqFract[i+1][j]>1e-8))) { // a transition has been detected // sout<<"********transition at: "<0) { Phase_transitions_mixture.back()+=phnames[k]; Phase_transitions_mixture.back()+=" + "; } } } Transitions.push_back(TKCE[i+1]); Phase_transitions_mixture.push_back(""); bool first_phase=true; for (size_t k=0; k0) { if (not first_phase) Phase_transitions_mixture.back()+=" + ";; Phase_transitions_mixture.back()+=phnames[k]; first_phase=false; } } } j=phnames.size()+1;// exit the loop } } } } // *************************************************************************************************************** // find all the transitions temperatures for a given alloy composition // step_TK: first interval of temperature used // n_step : number of steps set to NSTEP // between TK_start and TK_end=TK_start+(n_step-1)*step_TK; // required_accuracy_on_TK: self explanatory // W : weight composition of elements // phnames: vector of names phases that can appear for these elements // el_reduced_names: vector of names elements with non zero composition // ceq: pointer for the given equilibrium calculation used to pass the standart equilibrium in non parallel computation // parallelization option is in Find_Transitions // see Find_Transitions for comments on parallelization void Global_Find_Transitions(const string &strLIQUID,const string &strSOLSOL, ofstream& file,double &TK_start,const int &n_step,double &TK_end,const double required_accuracy_on_TK, vector &W, const vector &phnames,const vector &el_reduced_names, void *ceq, const int &i_ref, const string &compo_unit, const int &ncpu, vector &Store_Equilibria, vector< string > &Store_Equilibria_compo_unit, const vector< string > &Suspended_phase_list, const string &strcomponb){ string mycompo_unit=compo_unit; double TK_end_ini, TK_start_ini; TK_start_ini=TK_start; TK_end_ini=TK_end; // sout<<"sntep="< phfract; vector Transitions1; vector Transitions0; phfract.resize(phnames.size(),0.); string root; Transitions1.push_back(TK_start); //c_no_ph_creation(); root= "CEQ_"; string Ceq_Name=root; if (PARALLEL>0) { for (int i=Store_Equilibria.size(); i Phase_transitions_mixture; bool status_ok=true; for (size_t k=0; (k &el_reduced_names, const vector &phnames, void *ceq,vector &W,const double &target_delta_f_liq, const double &delta_T_min,const double &delta_T_max, double &TK_liquidus,const int &i_ref,const string &compo_unit,const vector &Suspended_phase_list, const string &strcomponb) { vector< vector > elfract; vector phfract_old; vector phfract; vector phfract_cum; elfract.resize(phnames.size(),vector(el_reduced_names.size(),0.)); phfract_old.resize(phnames.size(),0.); phfract.resize(phnames.size(),0.); phfract_cum.resize(phnames.size(),0.); vector TransitionsT; vector TransitionsFl; vector Phase_transitions_mixture; string my_compo_unit("X"); char tab = '\t'; vector XLiq; XLiq.resize(el_reduced_names.size(),0.); vector XLiq_ini; XLiq_ini.resize(el_reduced_names.size(),0.); vector XssCastAt; XssCastAt.resize(el_reduced_names.size(),0.); double fsol_cum=0; double fLiq=1.0; double d_T=delta_T_min; int iLiq=0; int iSol=0; int i_error=0; bool phase_found=false; for (int i=0;i5e-4)and(j_error<10)){ for (int i=0;i0){ for (int i=0;i0){ for (int i=0;i0){ sout<<"TK= "<0) XssCastAt[i]+=fsolid*elfract[iSol][i]; if (not i==i_ref) { double value=(XLiq[i]-phfract[iLiq]*elfract[iLiq][i])/(1.0-phfract[iLiq]); if (value<1e-8) value=1e-8; gradientOut<1e-6){ gradientOut<0)){ phfract_cum[j]+=phfract[j]*fLiq; } } fLiq*=phfract[iLiq]; } bool transition_detected=false; for (size_t j=0; j1e-8)&&(phfract[j]>1e-8))){ // a transition has been detected // sout<<"********transition at: "<0) { if (not first_phase) Phase_transitions_mixture.back()+=" + ";; Phase_transitions_mixture.back()+=phnames[k]; first_phase=false; } } } } if (phfract[iLiq]>target_delta_f_liq) { d_T*=1.05; if (d_T>delta_T_max) d_T=delta_T_max; } if (phfract[iLiq]0){ sout<<" concentrations left in "<0)){ sout<<"fat("<0)){ file<1e-10) file< &phnames,const vector &Suspended_phase_list){ bool phase_found=false; int i_LIQ=0; vector< double > phfract; phfract.resize(phnames.size(),0.); TK=0; for (int i=0;itemperature_accuracy)and (iter<=iter_max)){ valueT+=step_T; SetTemperature(valueT, &ceq); Safer_CalculateEquilibrium (ceq,NOGRID,i_error,Suspended_phase_list,strLIQUID,strSOLIDSOLUTION,phnames); /*CalculateEquilibrium(&ceq,NOGRID,i_error,Suspended_phase_list); if (i_error>0){ for (int i=0;i0){ for (int i=0;itargeted_fraction) and (step_T>0)) step_T=-fabs(step_T)/2.; if ((Fliter_max) i_error=1000; if (i_error==0){ TK=valueT; } else{ sout<<"not converged"<scheil.exe input.txt DEFINE_OUTPUT_FILE_NAME name of the log file ******************************************************************************** ***************************** Open CalPhad Software Interface July 2016 Computation performed on: 4 November 2016 , 22h:14mn:50s ******************************************************************************** ***************************** TDB_FILE_NAME name of the thermodynamic data file TDB_FILE_NAME cost507r.tdb the following elements are in the database: AL / B / C / CE / CR / CU / FE / LI / MG / MN / N / ND / NI / SI / SN / TI / V / Y / ZN / ZR / DEFINE_REF_ELEMENT DEFINE_REF_ELEMENT AL DEFINE_LIQUID_NAME DEFINE_LIQUID_NAME LIQUID DEFINE_SOLSOL_NAME DEFINE_SOLSOL_NAME FCC_A1 DEFINE_UNIT_COMPO_INPUT DEFINE_UNIT_COMPO_INPUT W% DEFINE_UNIT_TEMP_INPUT C or K DEFINE_UNIT_TEMP_INPUT C DEFINE_NCPU<8> DEFINE_NCPU 8 DEFINE_COMPOSITION DEFINE_COMPOSITION tqini created: DEFAULT_EQUIL IBRIUM MG=5/SI=1 MG=5/SI=1 reading phases list of possible phases in the system : LIQUID AL12MG17 AL5FE4 ALCU_THETA ALLI ALMG_BETA ALMG_DZETA ALMG_UPSILON ALTI A LTI3 BCC_A2 BCC_B2 BCT_A5 CBCC_A12 CR3SI_A15 CRSI2 CUB_A13 DIAMOND_A4 FCC_A1 HCP_A3 LAVES_C15 MG24Y5 MG2S I MGY_GAMMA SIV3 LIQUIDUS<> LIQUIDUS * ----> liquidus is: 629.716 C SOLIDUS<> SOLIDUS * ----> solidus is: 587.599 C COMPUTE_TRANSITION_TEMPERATURES<1100.0/400.0/0.0010000/20 > COMPUTE_TRANSITION_TEMPERATURES 1100.0 / 400.0 / 0.0010000 / 20 first convergence issue ====================================================================== TQ Parallel: Yes / number of threads: 8 Here are the transition temperatures that have been found in the temperature range [400,1100] C for the following composition: 0 629.72 LIQUID + 1 629.715 LIQUID + FCC_A1 2 592.104 LIQUID + FCC_A1 + MG2SI 3 587.591 FCC_A1 + MG2SI Store_Equilibria.size()=21 elapsed time for the transition temperature routine (s)= 0.3205 COMPUTE_EQUILIBRIUM<500/3> COMPUTE_EQUILIBRIUM 500 / 3 Equilibrium at: 500 C fat% FCC_A1=97.1874 MG2SI=2.81263 MU(AL)= -28943.8 MU(MG)= -47677.9 MU(SI)= -44984.1 --------------------------------------- FCC_A1 --------------------------------------- AL = 96.5871 (W%) MG = 3.3932 (W%) SI = 0.0196668 (W%) --------------------------------------- MG2SI --------------------------------------- MG = 63.3809 (W%) SI = 36.6191 (W%) LIQUIDUS<> LIQUIDUS * ----> liquidus is: 629.716 C SCHEIL_SOLIDIFICATION SCHEIL_SOLIDIFICATION castcompoS0001.txt / 0.99500 / 1.0 / 0.1 first convergence issue !!!!!!!! convergence issue !!!!!!!!!!!!!!!!!!!!! Error setting condition: T= 0.20000000E+04 2 Error code 4204 reset before calling grid minimizer 3Y Gridmin: 263 points 0.00E+00 s and 0 clockcycles, T= 722.87 Phases: 6 1 0.91 19 1 0.09 23 1 0.00 ------------------------------------------ starting composition in at : AL = 0.935217 at MG = 0.0552247 at SI = 0.00955838 at ------------------------------------------ concentrations left in FCC_A1 after Scheil solidification: AL = 0.966794 at MG = 0.0320182 at SI = 0.00118751 at ------------------------------------------ Phases formed after Scheil solidification: fat(ALMG_BETA)=0.0203004 fat(FCC_A1)=0.954425 fat(MG2SI)=0.025275 ------------------------------------------ ====================================================================== Here are the transition temperatures that have been found during a Scheil solidification simulation 0 627.716 C FL= 0.915013 LIQUID + FCC_A1 1 590.716 C FL= 0.300997 LIQUID + FCC_A1 + MG2SI 2 449.716 C FL= 0 ALMG_BETA + FCC_A1 + MG2SI end of solidification: 449.716 elapsed time for the scheil solidification routine (s)= 0.640501 C:\Users\...\TQ4lib\Cpp\Scheil> \end{verbatim}} \end{document} ================================================ FILE: examples/TQ4lib/Cpp/Scheil/tqintf.h ================================================ //define PARALLEL 0 no loop with parallelization //define PARALLEL 1 declared loops with parallelization #define PARALLEL 1 #define OCVERSION "Open Calphad TQ v3.0 beta" #define MAXEL 41 #define MAXPH 501 #define PHFIXED 2 #define PHENTERED 0 #define PHSUS -3 #define GRID 0 #define NOGRID -1 #define TCtoTK 273.15 #define TAB "\t" #define R 8.31451 #include "octqc.h" #include #include #include #include #include #include #include #include #include #include #include #include #include #include extern"C" { void c_Change_Status_Phase(char *, int ,double ,void *); void c_tqgetv(char *, int , int , int *, double *, void *); // get equilibrium results using state variables void c_tqsetc(char *, int, int , double, int *, void *); // set condition void c_tqce(char *, int , int , double *, void *); // calculate quilibrium with possible target void c_tqini(int, void *); // initiates the OC package void c_tqrfil(char *, void *); // read all elements from a TDB file //void c_tqgcom(int *, char[MAXEL][24], void **); // get system component names. At present the elements void c_tqrpfil(char *, int, char **, void *); // read TDB file with selection of elements //void c_tqgnp(int *, void **); // get total number of phases and composition sets void c_tqgpi(int *, char *, void *); // get index of phase phasename void c_tqgpn(int, char *, void *); // get name of phase+compset tuple with index phcsx //void c_tqgnp(int, gtp_equilibrium_data **); // get total number of phases and composition sets void examine_gtp_equilibrium_data(void *); // //void c_getG(int, void *); //void c_calcg(int, int, int, int, void *); void c_tqgphc1(int, int * , int *, int *, double *, double *, double *, void *); void c_tqsphc1(int, double *, double *, void *); void c_tqcph1(int, int, int *, double *, double *, double *, double *, double *, void *); void c_List_Conditions(void *); void c_checktdb(char *); void c_newEquilibrium(char *,int *); void c_selecteq(int ,void *); void c_copy_equilibrium(void *,char *,void *); void c_set_status_globaldata(); int c_errors_number(); void c_new_gtp(); void c_reset_conditions(char *,void *); } extern"C" int c_ntup; // extern"C" int c_nel; // number of elements extern"C" int c_maxc; // extern"C" char *c_cnam[MAXEL]; // character array with all element names extern"C" double c_gval[24]; extern"C" int c_noofcs(int); extern"C" double c_mass[24]; using namespace std; void Get_Ceq(const int &iceq,void *ceq){ c_selecteq(iceq,ceq); //cout << "-> Adress of ceq-Storage: [" << ceq << "]" < Adress of ceq-Storage: [" << ceq << "]" < Element Data: ["; for(int i = 0; i < c_nel; i++) { cout << c_cnam[i]; if(i < c_nel-1) { cout << ", "; } } cout << "]" << " [" << &ceq << "]" < &elnames, void *ceq) { char *buffer=(char*)malloc(tdbfilename.length()+1); char *filename = strcpy(buffer, tdbfilename.c_str()); char *selel[elnames.size()]; for(size_t i = 0; i < elnames.size(); i++) { char *buffer=(char*)malloc(elnames[i].length()+1); char *tempchar = strcpy(buffer, elnames[i].c_str()); selel[i] = tempchar; } //============================================== c_tqrpfil(filename, elnames.size(), selel, ceq); //============================================== /* cout << "-> Element Data: ["; for(int i = 0; i < c_nel; i++) { cout << c_cnam[i]; if(i < c_nel-1) { cout << ", "; } } cout << "]" << " [" << &ceq << "]" << endl; */ free (buffer); }; void ReadPhases(vector &phnames, void *ceq) { phnames.clear(); phnames.resize(c_ntup); for(int i = 1; i < c_ntup+1; i++) { char phn[24]; //========================== c_tqgpn(i, phn, ceq); //========================== int index; c_tqgpi(&index,phn,ceq); string myname(phn); transform(myname.begin(), myname.end(), myname.begin(), ::toupper);// to have it in CAPITAL LETTERS phnames[index-1]=myname; } /* cout << "-> Phase Data: ["; for(size_t i = 0; i < phnames.size(); i++) { cout << i<< " "< &el_reduced_names,const int &i_ref, const string &compo_unit){ { string mystring("T=none"); char *buffer=(char*)malloc(mystring.length()+1); char *conditions = strcpy(buffer, mystring.c_str()); c_reset_conditions(conditions,ceq); free (buffer); } string mystring=""; for (int i=1;i Set Temperature to: [" << T << "]" << " [" << &ceq << "]" << // endl; }; void SetPressure(const double &P, void *ceq) { int cnum; int n1 = 0; int n2 = 0; char par[60] = "P"; // if (P < 1.0) P = 1.0; //========================================= c_tqsetc(par, n1, n2, P, &cnum, ceq); //========================================= // cout << "-> Set Pressure to: [" << P << "]" << " [" << &ceq << "]" << // endl; }; void SetMoles(const double &N, void *ceq) { int cnum; int n1 = 0; int n2 = 0; char par[60] = "N"; //========================================= c_tqsetc(par, n1, n2, N, &cnum, ceq); //========================================= // cout << "-> Set Moles to: [" << N << "]" << " [" << &ceq << "]" << // endl; }; void SetComposition(vector& X, void *ceq, const int &i_ref,string &compo_unit) { int cnum; int n2 = 0; char par[60]; strcpy(par,compo_unit.c_str()); for (int i = 0; i < c_nel; i++) { if (X[i] < 1.0e-8) X[i] = 1.0e-8; // Check and fix, if composition is below treshold if(not (i == i_ref)) { int j=i+1; double value= X[i];// Set and print composition, if element 'i' is not the reference/(last) element //================================================== c_tqsetc(par, j, n2,value, &cnum, ceq); //================================================== // cout << "-> Set Composition of " << c_cnam[i] << " to: [" << // X[i] << "]" << " [" << &ceq << "]" << // endl; } else { // Print composition, if element 'i' is the reference/(last) element double X_ref = 1; for(size_t j = 0; j < i; j++) { X_ref -= X[j]; } // cout << "-> Set Composition of " << c_cnam[i] << " to: [" << // X_ref << "]" << " [" << &ceq << "]" << // endl; } } }; void SetConstituents(int phidx, vector y, void *ceq) { int stable1 = phidx; double extra[MAXPH]; double yfr[y.size()]; for(size_t i = 0; i < y.size(); i++) { yfr[i] = y[i]; } //=============================== c_tqsphc1(stable1,yfr,extra,ceq); //=============================== cout << "-> Set Constituents to: ["; for(int i = 0; i < y.size(); i++) { cout << i << ": " << yfr[i]; if(i < y.size()-1) { cout << ", "; } } cout << "]" << endl; }; void SelectSinglePhase(int PhIdx, void *ceq) { // }; void List_Conditions(void *ceq){ c_List_Conditions(ceq); } void CalculateEquilibrium(void *ceq, const int &n1, int &i_error, const vector < string > &Suspended_phase_list) { for (int i=0;i Read Gibbs Data G: ["; for(int i = 0; i < 6; i++) { cout << gtp[i]; if(i < 5) { cout << ", "; } } cout << "]" << endl; cout << "-> Read Gibbs Data dGdY: ["; for(int i = 0; i < n3; i++) { cout << dgdy[i]; if(i < n3-1) { cout << ", "; } } cout << "]" << endl; cout << "-> Read Gibbs Data d2GdYdT: ["; for(int i = 0; i < n3; i++) { cout << d2gdydt[i]; if(i < n3-1) { cout << ", "; } } cout << "]" << endl; cout << "-> Read Gibbs Data d2GdYdP: ["; for(int i = 0; i < n3; i++) { cout << d2gdydp[i]; if(i < n3-1) { cout << ", "; } } cout << "]" << endl; int kk=n2*(n2+1)/2; cout << "-> Read Gibbs Data d2GdY2: ["; for(int i = 0; i < kk; i++) { cout << d2gdy2[i]; if(i < kk-1) { cout << ", "; } } cout << "]" << endl; }; void ReadPhaseFractions(const vector &phnames, vector& phfract, void *ceq) { double npf[MAXPH]; char statevar[60] = "NP"; int n1 = -1;//-1 int n2 = 0; int n3 = MAXPH;//sizeof(npf) / sizeof(npf[0]); //======================================== c_tqgetv(statevar, n1, n2, &n3, npf, ceq); //======================================== for(int i = 0; i < phnames.size(); i++){ /* char phn[24]; c_tqgpn(i+1, phn, ceq); size_t index=0; for (size_t j=0;j &MU) { double npf[1]; char statevar[60] = "MU"; for (int i = 1; i < c_nel+1; i++) { int n1 = i; int n2 = 0; int n3 = 1; //======================================== c_tqgetv(statevar, n1, n2, &n3, npf, ceq); //======================================== MU[i-1]=npf[0]; } }; double ReadTemperature(void *ceq) { double npf[1]; char statevar[60] = "T"; int n1 = 0; int n2 = 0; int n3 = 1; double TK; //======================================== c_tqgetv(statevar, n1, n2, &n3, npf, ceq); //======================================== TK=npf[0]; return(TK); }; double ReadTotalEnthalpy(void *ceq) { double npf[1]; char statevar[60] = "H"; int n1 = 0; int n2 = 0; int n3 = 1; double H; //======================================== c_tqgetv(statevar, n1, n2, &n3, npf, ceq); //======================================== H=npf[0]; return(H); }; void ReadConstituentFractions(const vector &phnames, const vector &phfract, vector< vector > &elfract, void *ceq, const string &compo_unit) { double pxf[10*MAXPH]; for (int i = 1; i < c_ntup+1; i++) { char phn[24]; c_tqgpn(i, phn, ceq); size_t index=0; for (size_t j=0;j 1e-10) { char statevar[60] = "X"; strcpy(statevar,compo_unit.c_str()); int n2 = -1; //composition of stable phase n2 = -1 means all fractions int n4 = sizeof(pxf)/sizeof(pxf[0]); //======================================= c_tqgetv(statevar, i, n2, &n4, pxf, ceq); //======================================= for (int k = 0; k < n4; k++) { elfract[index][k]=pxf[k]; } // cout << "-> Constituent Fractions for " << phnames[i-1] <<" ["; //cout << "-> Constituent Fractions for " << phnames[index]<<" ["; for (int k = 0; k < n4; k++) { //cout << c_cnam[k] << ": " << elfract[index][k]; if(k < n4-1) { // cout << ", "; } } //cout << "]" << " [" << &ceq << "]" < phnames, void *ceq) { int stable1 = phidx; int nlat; int nlatc[MAXPH]; int conlista[MAXPH]; double yfr[MAXPH]; double sites[MAXPH]; double extra[MAXPH]; //====================================================================== c_tqgphc1(stable1, &nlat, nlatc, conlista, yfr, sites, extra, ceq); //====================================================================== cout << "-> Extended Constituent Fractions for " << phnames[stable1-1] << " [" << extra[0] << " moles of atoms/formula unit]"; int consti = 0; for(int i = 0; i < nlat; i++) { cout << " ["; for(int j = 0; j < nlatc[i]; j++) { cout << "Const. " << consti << ": " << yfr[consti]; if(j < nlatc[i]-1) { cout << ", "; } consti += 1; } cout << "]_(" << sites[i] << ")"; } cout << endl; }; std::string IntToString ( int number ) { std::string mystr; std::stringstream out; out << number; mystr = out.str(); return mystr; } // Write the results of a given equilibrium // el_reduced_names: vector of names elements with non zero composition // phnames: vector of names phases that can appear for these elements // phfract: atomic fraction of these phases after equilibrium // elfract[i][j]: atomic composition of element i in phase j // ceqh: pointer for the given equilibrium calculation // mode: 1 write only atomic fractions of phases after equilibrium // mode: 1 write atomic fractions + compositions of phases after equilibrium void Write_Results_Equilibrium(ofstream& file, const vector &el_reduced_names, const vector &phnames, vector &phfract, vector< vector > &elfract, void *ceqh,const int &mode,const string &compo_unit, vector &MU){ //-------------------------------List Results------------------------------- ReadPhaseFractions(phnames, phfract, &ceqh); // Read the amount of stable phases if (mode >1) ReadConstituentFractions(phnames, phfract, elfract, &ceqh, compo_unit); // Read the composition of each stable phase double TC=ReadTemperature(&ceqh)-TCtoTK; cout<0){ cout<<" "<1e-10) cout<<" "<1e-10) file< &W, const vector &phnames,vector &Transitions,const vector &el_reduced_names,const bool first_iteration, const bool last_iteration, vector &Store_Equilibria,vector< string > &Phase_transitions_mixture, void *ceq,const double required_accuracy_on_TK, const vector< string > &Suspended_phase_list){ int iceq=0; vector phfract; phfract.resize(phnames.size(),0.); vector< vector > elfract; // Array including all equilibrium compositions elfract.resize(phnames.size(),vector(el_reduced_names.size(),0.)); vector TKCE; vector< vector > CeqFract; TKCE.resize(0); CeqFract.resize(0); double TK_end=TK_start+(nstep-1)*step_TK; double TK=TK_start; int nstep_total=nstep; if (not first_iteration) nstep_total+=1; for (int i=0; i(phnames.size(),0.)); size_t max_number_of_phase=0; // the three lines below trigger parallelism for the nex for {....} loop if PARALLEL is not 0 // cout<<"number of threads detected:"<0 #pragma omp parallel for default(none), schedule(dynamic), shared(TKCE,W,Store_Equilibria, el_reduced_names,phnames,phfract,CeqFract,Suspended_phase_list) #endif for (int i=0; i0)) { c_selecteq(Store_Equilibria[i], &ceqi);// retrieve the pointer with index stored in Store_Equilibria }else{ // ceqi=ceq;// if no parallelization use STANDART EQUILIBRIUM c_selecteq(1, &ceqi); } for (int k=0;k0) CeqFract[i][j]=phfract[j]; } } /* for (int i=0; i"<"<0) cout<<" "<1e-8)&&(CeqFract[i+1][j]>1e-8))) { // a transition has been detected // cout<<"********transition at: "<0) { Phase_transitions_mixture.back()+=phnames[k]; Phase_transitions_mixture.back()+=" + "; } } } Transitions.push_back(TKCE[i+1]); Phase_transitions_mixture.push_back(""); bool first_phase=true; for (size_t k=0; k0) { if (not first_phase) Phase_transitions_mixture.back()+=" + ";; Phase_transitions_mixture.back()+=phnames[k]; first_phase=false; } } } j=phnames.size()+1;// exit the loop } } } } // *************************************************************************************************************** // find all the transitions temperatures for a given alloy composition // step_TK: first interval of temperature used // n_step : number of steps set to NSTEP // between TK_start and TK_end=TK_start+(n_step-1)*step_TK; // required_accuracy_on_TK: self explanatory // W : weight composition of elements // phnames: vector of names phases that can appear for these elements // el_reduced_names: vector of names elements with non zero composition // ceq: pointer for the given equilibrium calculation used to pass the standart equilibrium in non parallel computation // parallelization option is in Find_Transitions // see Find_Transitions for comments on parallelization void Global_Find_Transitions(ofstream& file,double &TK_start,const int &n_step,double &TK_end,const double required_accuracy_on_TK, vector &W, const vector &phnames,const vector &el_reduced_names, void *ceq, const int &i_ref, const string &compo_unit, const int &ncpu, vector &Store_Equilibria, vector< string > &Store_Equilibria_compo_unit, const vector< string > &Suspended_phase_list){ string mycompo_unit=compo_unit; double TK_end_ini, TK_start_ini; TK_start_ini=TK_start; TK_end_ini=TK_end; // cout<<"sntep="< phfract; vector Transitions1; vector Transitions0; phfract.resize(phnames.size(),0.); string root; Transitions1.push_back(TK_start); //c_no_ph_creation(); root= "CEQ_"; string Ceq_Name=root; if (PARALLEL>0) { for (int i=Store_Equilibria.size(); i Phase_transitions_mixture; for (size_t k=0; k0) file<<" using a parallel calculation with "< &W_ini, const vector &phnames,const vector &el_reduced_names, void *ceq, const int i_ref, const string &compo_unit, const int &total_number_of_loops, const int &ncpu,vector &Store_Equilibria , vector< string > &Store_Equilibria_compo_unit, const vector< string > &Suspended_phase_list){ string mycompo_unit=compo_unit; vector< vector< double> > LISTCOMPO; vector< double> LISTTK; vector Wrand; Wrand.resize(W_ini.size(),0.); int total_number_of_errors=0; string root= "CEQ_"; string Ceq_Name=root; int number_of_loops=64; int jter_print=0; // if (PARALLEL==0) number_of_loops=1; LISTCOMPO.resize(number_of_loops,vector(W_ini.size(),0.)); LISTTK.resize(number_of_loops,0.); cout<<"number of threads detected:"<0) { int iceq; for (int i=Store_Equilibria.size(); i0 #pragma omp parallel for #endif for (int k=0; k0)) { c_selecteq(Store_Equilibria[k], &ceqi);// retrieve the pointer with index stored in Store_Equilibria }else{ // ceqi=ceq;// if no parallelization use STANDART EQUILIBRIUM c_selecteq(1, &ceqi); } SetComposition(LISTCOMPO[k], &ceqi, i_ref,mycompo_unit);// Set the composition when ceqi is created } /* #if PARALLEL>0 #pragma omp parallel for #endif for (int k=0; k0)) { c_selecteq(Store_Equilibria[k], &ceqi);// retrieve the pointer with index stored in Store_Equilibria }else{ // ceqi=ceq;// if no parallelization use STANDART EQUILIBRIUM c_selecteq(1, &ceqi); } int i_error=0; CalculateEquilibrium(&ceqi,NOGRID,i_error,Suspended_phase_list); if (not(i_error==0)){ cout<<" equilibrium calculation not converged in transition subroutine for the following conditions"<0)) { c_selecteq(Store_Equilibria[k], &ceqi);// retrieve the pointer with index stored in Store_Equilibria }else{ // ceqi=ceq;// if no parallelization use STANDART EQUILIBRIUM c_selecteq(1, &ceqi); } SetTemperature(LISTTK[k], &ceqi); // set temperature for specific equilibrium // for (int i=0;i0 #pragma omp parallel for default(none),schedule(dynamic), private (k,i_error), shared(LISTTK,LISTCOMPO,Store_Equilibria, total_number_of_errors, jter_print,number_of_loops,el_reduced_names) #endif for (int k=0; k0)) { c_selecteq(Store_Equilibria[k], &ceqi);// retrieve the pointer with index stored in Store_Equilibria }else{ // ceqi=ceq;// if no parallelization use STANDART EQUILIBRIUM c_selecteq(1, &ceqi); } int i_error=0; CalculateEquilibrium(&ceqi,NOGRID,i_error,Suspended_phase_list); // perform an equilibrium calculation if (not(i_error==0)){ double TK=LISTTK[k]-1; SetTemperature(TK, &ceqi); // set temperature for specific equilibrium CalculateEquilibrium(&ceqi,GRID,i_error,Suspended_phase_list); // perform an equilibrium calculation if (i_error==0) { //cout<<" case fixed"<199) { cout<total number of random tests:"<total number of random tests:"< &el_reduced_names, const vector &phnames, void *ceq,vector &W,const double &target_delta_f_liq, const double &delta_T_min,const double &delta_T_max, double &TK_liquidus,const int &i_ref,const string &compo_unit,const vector &Suspended_phase_list) { vector< vector > elfract; vector phfract_old; vector phfract; elfract.resize(phnames.size(),vector(el_reduced_names.size(),0.)); phfract_old.resize(phnames.size(),0.); phfract.resize(phnames.size(),0.); vector TransitionsT; vector TransitionsFl; vector Phase_transitions_mixture; string my_compo_unit("X"); char tab = '\t'; vector XLiq; XLiq.resize(el_reduced_names.size(),0.); double fLiq=1.0; double d_T=delta_T_min; int iLiq=0; int iSol=0; int i_error=0; bool phase_found=false; for (int i=0;i5e-4)and(j_error<10)){ for (int i=0;i0){ d_T=delta_T_min; j_error+=1; //cout<<"TK="<1e-8)&&(phfract[j]>1e-8))){ // a transition has been detected // cout<<"********transition at: "<0) { if (not first_phase) Phase_transitions_mixture.back()+=" + ";; Phase_transitions_mixture.back()+=phnames[k]; first_phase=false; } } } } if (phfract[iLiq]>target_delta_f_liq) { d_T*=1.15; if (d_T>delta_T_max) d_T=delta_T_max; } if (phfract[iLiq] &phnames,const vector &Suspended_phase_list){ bool phase_found=false; int i_LIQ=0; vector< double > phfract; phfract.resize(phnames.size(),0.); TK=0; for (int i=0;itemperature_accuracy)and (iter<=iter_max)){ valueT+=step_T; SetTemperature(valueT, &ceq); CalculateEquilibrium(&ceq,NOGRID,i_error,Suspended_phase_list); if (i_error==0){ ReadPhaseFractions(phnames, phfract, &ceq); Fl=phfract[i_LIQ]; } else{ iter=iter_max+1; } if ((Fl>targeted_fraction) and (step_T>0)) step_T=-fabs(step_T)/2.; if ((Fliter_max) i_error=1000; if (i_error==0){ TK=valueT; } else{ cout<<"not converged"<firsteq write(*,*)'tqini created: ',ceq%eqname 1000 continue return end subroutine tqini !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqrfil(filename,ceq) ! read all elements from a TDB file implicit none character*(*) filename ! IN: database filename character ellista(10)*2 ! dummy type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} %+ integer iz character elname*2,name*24,refs*24 double precision a1,a2,a3 ! second argument 0 means ellista is ignored, all element read call readtdb(filename,0,ellista) ! ceq=>firsteq nel=noel() do iz=1,nel ! store the element name in the cname array call get_element_data(iz,elname,name,refs,a1,a2,a3) cnam(iz)=elname cmass(iz)=a1 enddo ! store phase tuples ntup=nooftup() 1000 continue return end subroutine tqrfil !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} %- subroutine tqrpfil(filename,nsel,selel,ceq) ! read TDB file with selection of elements implicit none character*(*) filename ! IN: database filename integer nsel character selel(*)*2 ! IN: elements to be read from the database type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} integer iz character elname*2,name*24,refs*24 double precision a1,a2,a3 ! call readtdb(filename,nsel,selel) if(gx%bmperr.ne.0) goto 1000 ! is this really necessary?? ! ceq=>firsteq nel=noel() do iz=1,nel ! store element name in module array components call get_element_data(iz,elname,name,refs,a1,a2,a3) cnam(iz)=elname enddo ! store phase tuples and indices ntup=nooftup() 1000 continue return end subroutine tqrpfil !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgcom(n,compnames,ceq) ! get system component names. At present the elements implicit none integer n ! EXIT: number of components character*24, dimension(*) :: compnames ! EXIT: names of components type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} integer iz character elname*24,refs*24 double precision a1,a2,a3 do iz=1,nel compnames(iz)=' ' call get_element_data(iz,compnames(iz),elname,refs,a1,a2,a3) ! store name in module array components also (already done when reading TDB) cnam(iz)=compnames(iz) enddo n=nel 1000 continue return end subroutine tqgcom !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgnp(n,ceq) ! get total number of phase tuples (phases and composition sets) ! A second composition set of a phase is normally placed after all other ! phases with one composition set implicit none integer n !EXIT: n is number of phases type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} ! NOTE the number composition sets may change at a calculation or if new ! composition sets are added or deleted explicitly ! This changes the number of phase tuples! ntup=nooftup() n=ntup 1000 continue return end subroutine tqgnp !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgpn(phtupx,phasename,ceq) ! get name of phase tuple with index phtupx (ceq redundant) implicit none integer phtupx ! IN: index in phase tuple array character phasename*(*) !EXIT: phase name, max 24+8 for pre/suffix type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} call get_phasetup_name(phtupx,phasename) 1000 continue return end subroutine tqgpn !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgpi(phtupx,phasename,ceq) ! get index of phase phasename (including comp.set (ceq redundant) implicit none integer phtupx !EXIT: phase tuple index character phasename*(*) !IN: phase name type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} call find_phasetuple_by_name(phasename,phtupx) 1000 continue return end subroutine tqgpi !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgpcn2(n,c,constituentname,ceq) ! get name of consitutent with index c in phasetuple n ! NOTE An identical routine with different constituent index is tqgpcn implicit none integer n !IN: phase number (not phase tuple) integer c !IN: constituent index sequentially over all sublattices character constituentname*(24) !EXIT: costituent name type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} double precision mass call get_constituent_name(n,c,constituentname,mass) ! write(*,*)'tqgpcn not implemented yet' ! gx%bmperr=8888 1000 continue return end subroutine tqgpcn2 !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgpci(n,c,constituentname,ceq) ! get index of constituent with name in phase n implicit none integer n !IN: phase index integer c !IN: sequantial constituent index over all sublattices character constituentname*(*) type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} write(*,*)'tqgpci not implemented yet' gx%bmperr=8888 1000 continue return end subroutine tqgpci !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgpcs(n,c,stoi,mass,ceq) ! get stoichiometry of constituent c in phase n !? missing argument number of elements???? implicit none integer n !IN: phase number integer c !IN: sequantial constituent index over all sublattices double precision stoi(*) !EXIT: stoichiometry of elements double precision mass !EXIT: total mass type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} write(*,*)'tqgpcs not implemented yet' gx%bmperr=8888 1000 continue return end subroutine tqgpcs !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgccf(n1,n2,elnames,stoi,mass,ceq) ! get stoichiometry of component n1 ! n2 is number of elements (dimension of elnames and stoi) implicit none integer n1 !IN: component number integer n2 !EXIT: number of elements in component character elnames(*)*(2) ! EXIT: element symbols double precision stoi(*) ! EXIT: element stoichiometry double precision mass ! EXIT: component mass (sum of element mass) type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} write(*,*)'tqgccf not implemented yet' gx%bmperr=8888 1000 continue return end subroutine tqgccf !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgnpc(n,c,ceq) ! get number of constituents of phase n implicit none integer n !IN: Phase number integer c !EXIT: number of constituents type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} write(*,*)'tqgnpc not implemented yet' gx%bmperr=8888 1000 continue return end subroutine tqgnpc !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgpsm(n,phases,status,amdgm,ceq) ! get all phase names and their status and amounts or DGM integer n character phases(*)*24 integer status(*) double precision amdgm(*) type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} integer i character dummy*64,statevar*64 n=nooftup() ! phasetuple: lokph,compset,ixphase,lokvares,nextcs do i=1,n call get_phasetup_name(i,phases(i)) ! the status is in phase_varres record, THIS IS NOT PRIVATE ! phastate values: 2 fix, 1,0,-1 entered, -2 dormant, -3 suspended status(i)=ceq%phase_varres(phasetuple(i)%lokvares)%phstate ! if status 0 or less the phase is not stable, extract DGM if(status(i).le.0) then statevar='DGM('//trim(phases(i))//')' call get_state_var_value(statevar,amdgm(i),dummy,ceq) else ! this phase is stable, extract amount statevar='NPM('//trim(phases(i))//')' call get_state_var_value(statevar,amdgm(i),dummy,ceq) endif enddo 1000 continue return end subroutine tqgpsm !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqcref(cix,phase,tpref,ceq) ! set component reference state integer cix character phase*(*) double precision tpref(*) type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium !\end{verbatim} integer phtupx call find_phasetuple_by_name(phase,phtupx) if(gx%bmperr.ne.0) goto 1000 call set_reference_state(cix,phtupx,tpref,ceq) 1000 continue return end subroutine tqcref !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqphsts(phtupx,newstat,val,ceq) ! set status of phase tuple: SUSPEND, DORMANT, ENTERED, FIX integer phtupx,newstat double precision val type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium !\end{verbatim} integer n if(phtupx.le.0) then ! if tup<0 change status of all phases do n=1,ntup call change_phtup_status(n,newstat,val,ceq) if(gx%bmperr.ne.0) goto 1000 enddo elseif(phtupx.le.ntup) then call change_phtup_status(phtupx,newstat,val,ceq) else write(*,*)'Illegal phase tuple index',phtupx gx%bmperr=8888 endif 1000 continue return end subroutine tqphsts !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqsetc(stavar,n1,n2,value,cnum,ceq) ! set condition ! stavar is state variable as text ! n1 and n2 are auxilliary indices ! value is the value of the condition ! cnum is returned as an index of the condition. ! to remove a condition the value sould be equial to RNONE ???? ! phase index is phase tuple index (include composition set) ! see TQGETV for doucumentation of stavar etc. implicit none integer n1 ! IN: 0 or phase tuple index or component number integer n2 ! IN: 0 or component number integer cnum ! EXIT: sequential number of this condition character stavar*(*) ! IN: character with state variable symbol double precision value ! IN: value of condition type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium !\end{verbatim} integer ip,ip2 character cline*60,selvar*4,cval*24 ! ! write(*,11)'In tqsetc ',stavar(1:len_trim(stavar)),n1,n2,value 11 format(a,a,2i5,1pe14.6) cline=' ' ! extract a value after an = ip=index(stavar,'=') if(ip.gt.0) then selvar=stavar(1:ip-1) cval=stavar(ip:) !@CC ip2=index(stavar,'(') if(ip2.gt.0) then ip = ip2 selvar=stavar(1:ip-1) cval=stavar(ip:) endif !@CC ! write(*,*)'Value after = :',cval else selvar=stavar cval=' ' endif call capson(selvar) select case(selvar) case default write(*,*)'Condition wrong, not implemented or illegal: ',stavar gx%bmperr=8888; goto 1000 ! Potentials T and P case('T ','P ') if(ip.gt.0) then cline=' '//stavar else write(cline,110)selvar(1:1),value 110 format(' ',a,'=',E15.8) endif ! Total amount or amount of a component in moles case('N ') if(ip.gt.0) then cline=' '//stavar else if(n1.gt.0) then ! call get_component_name(n1,name,ceq) ! if(gx%bmperr.ne.0) goto 1000 write(cline,112)selvar(1:1),cnam(n1)(1:len_trim(cnam(n1))),value 112 format(' ',a,'(',a,')=',E15.8) ! write(*,*)'Setting condition: ',cline(1:len_trim(cline)) else write(cline,110)selvar(1:1),value endif endif ! Overall fraction of a component case('X ','W ') ! ?? fraction of phase component not implemented, n1 must be component number ! call get_component_name(n1,cnam,ceq) ! if(gx%bmperr.ne.0) goto 1000 if(ip.gt.0) then cline=' '//stavar else write(cline,120)selvar(1:1),cnam(n1)(1:len_trim(cnam(n1))),value 120 format(1x,a,'(',a,')=',1pE15.8) endif case('H ','V ') ! enthalpy or volume of system if(cval(1:1).eq.'=') then cline=' '//stavar else write(cline,130)selvar(1:1),value 130 format(1x,a,'=',1pE15.8) endif ! case .... ! ?? MORE CONDITIONS WILL BE ADDED ... end select ! write(*,*)'tqsetc condition: ',trim(cline) ip=1 call set_condition(cline,ip,ceq) if(gx%bmperr.ne.0) then write(*,*)'Error setting condition: ',cline(1:len_trim(cline)),ip endif 1000 continue return end subroutine tqsetc !@CC !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine toggle_dense_grid() if(btest(globaldata%status,GSXGRID)) then globaldata%status=ibclr(globaldata%status,GSXGRID) write(*,3110)'reset' 3110 format('Dense grid ',a) else globaldata%status=ibset(globaldata%status,GSXGRID) write(*,3110)'dense grid set' endif return end subroutine toggle_dense_grid !@CC !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqce(target,n1,n2,value,ceq) ! calculate quilibrium with possible target ! Target can be empty or a state variable with indices n1 and n2 ! value is the calculated value of target implicit none integer n1,n2,mode character target*(*) double precision value logical confirm type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} integer nyfas,j1,j2 ! mode=1 means start values using global gridminimization if(n1.lt.0) then ! this means calculate without grid minimuzer mode=0 confirm=.FALSE. ! calcqeq3 is silent, no listing of phase changes etc. call calceq3(mode,confirm,ceq) else mode=1 call calceq2(mode,ceq) if(gx%bmperr.eq.4204) then ! if the error code is "too many iterations" try without grid minimizer ! it converges in many cases ! write(*,2048)gx%bmperr 2048 format('Error ',i5,', cleaning up and trying harder') gx%bmperr=0 call calceq2(0,ceq) endif endif if(gx%bmperr.ne.0) goto 1000 ! there may be new composition sets, update ntup ! write(*,*)'Number of phase tuples: ',ntup nyfas=nooftup() ! write(*,*)'Number of phase tuples: ',ntup,nyfas if(nyfas.ne.ntup) then ! write(*,*)'Number of phase tuples changed: ',nyfas,ntup ntup=nyfas ! if(allocated(ysave)) deallocate(ysave) ! allocate(ysave(nyfas,maxconst)) endif ! copy the constitution to a local save array ! if(.not.allocated(ysave)) then ! allocate(ysave(nyfas,maxconst)) ! endif if(allocated(ysave)) deallocate(ysave) allocate(ysave(nyfas,maxconst)) ! the intention of saving constitution is to make it possible to interpolate ! the calculation of G if the constitution is changed very little do j1=1,nyfas do j2=1,size(ceq%phase_varres(phasetuple(j1)%lokvares)%yfr) ysave(j1,j2)=ceq%phase_varres(phasetuple(j1)%lokvares)%yfr(j2) enddo enddo 1000 continue return end subroutine tqce !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgetv(stavar,n1,n2,n3,values,ceq) ! get equilibrium results using state variables ! stavar is the state variable IN CAPITAL LETTERS with indices n1 and n2 ! n1 can be a phase tuple index, n2 a component index ! n3 at the call is the dimension of the array values, ! changed to number of values on exit ! value is an array with the calculated value(s), n3 set to number of values. implicit none integer n1,n2,n3 character stavar*(*) double precision values(*) type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !======================================================== ! stavar must be a symbol listed below ! IMPORTANT: some terms explained after the table ! Symbol index1,index2 Meaning (unit) !.... potentials ! T 0,0 Temperature (K) ! P 0,0 Pressure (Pa) ! MU component,0 or ext.phase.index*1,constituent*2 Chemical potential (J) ! AC component,0 or ext.phase.index,constituent Activity = EXP(MU/RT) ! LNAC component,0 or ext.phase.index,constituent LN(activity) = MU/RT !...... extensive variables ! U 0,0 or ext.phase.index,0 Internal energy (J) whole system or phase ! UM 0,0 or ext.phase.index,0 same per mole components ! UW 0,0 or ext.phase.index,0 same per kg ! UV 0,0 or ext.phase.index,0 same per m3 ! UF ext.phase.index,0 same per formula unit of phase ! S*3 0,0 or ext.phase.index,0 Entropy (J/K) ! V 0,0 or ext.phase.index,0 Volume (m3) ! H 0,0 or ext.phase.index,0 Enthalpy (J) ! A 0,0 or ext.phase.index,0 Helmholtz energy (J) ! G 0,0 or ext.phase.index,0 Gibbs energy (J) ! ..... some extra state variables ! NP ext.phase.index,0 Moles of phase ! BP ext.phase.index,0 Mass of moles (kg) ! Q ext.phase.index,0 Internal stability/RT (dimensionless) ! DG ext.phase.index,0 Driving force/RT (dimensionless) !....... amounts of components ! N 0,0 or component,0 or ext.phase.index,component Moles of component ! X component,0 or ext.phase.index,component Mole fraction of component ! B 0,0 or component,0 or ext.phase.index,component Mass of component ! W component,0 or ext.phase.index,component Mass fraction of component ! Y ext.phase.index,constituent*1 Constituent fraction !........ some parameter identifiers ! TC ext.phase.index,0 Magnetic ordering temperature ! BMAG ext.phase.index,0 Aver. Bohr magneton number ! MQ& ext.phase.index,constituent Mobility ! THET ext.phase.index,0 Debye temperature ! LNX ext.phase.index,0 Lattice parameter ! EC11 ext.phase.index,0 Elastic constant C11 ! EC12 ext.phase.index,0 Elastic constant C12 ! EC44 ext.phase.index,0 Elastic constant C44 !........ NOTES: ! *1 The phase index is the phase tuple index (extra composition sets at end) ! *2 The constituent index is 10*species_number + sublattice_number ! *3 S, V, H, A, G, NP, BP, N, B and DG can have suffixes M, W, V, F also !-------------------------------------------------------------------- ! special addition for TQ interface: d2G/dyidyj ! D2G + phase tuple !-------------------------------------------------------------------- !\end{verbatim} integer ics,mjj,nph,ki,kj,lp,lokph,lokcs character statevar*60,encoded*2048,name*24,selvar*4,norm*4 ! mjj should be the dimension of the array values ... mjj=n3 selvar=stavar call capson(selvar) ! for state variables like MQ&FE remove the part from & before the select ! write(*,11)'In tqgetv: ',selvar,n1,n2,n3 11 format(a,a,3i5) norm=' ' lp=index(selvar,'&') if(lp.gt.0) then selvar(lp:)=' ' else ! check if variable is normallized, only M (per mole) allowed ki=len_trim(selvar) if(ki.ge.2) then if(selvar(ki:ki).eq.'M') then norm='M' selvar(ki:)=' ' ki=ki-1 endif endif endif !======================================================================= kj=index(selvar,'(') if(kj.gt.0) then selvar=selvar(1:kj-1) endif ! write(*,*)'tqgetv 0: ',kj,selvar,'>',stavar,'<' select case(selvar) case default write(*,*)'Unknown state variable: ',stavar(1:20),'>:<',selvar gx%bmperr=8888; goto 1000 !-------------------------------------------------------------------- ! T or P case('T ','P ') call get_state_var_value(selvar,values(1),encoded,ceq) !-------------------------------------------------------------------- ! chemical potential for a component case('MU ','MUS ') if(n1.lt.-1 .or. n1.eq.0) then write(*,*)'tqgetv 17: component number must be positive' gx%bmperr=8888; goto 1000 elseif(n1 .eq.-1) then ! this means all components statevar=trim(selvar)//'(*)' call get_many_svar(statevar,values,mjj,n3,encoded,ceq) elseif(n1.le.noel()) then statevar=trim(selvar)//'('//trim(cnam(n1))//') ' ! write(*,*)'tqgetv 4: ',statevar(1:len_trim(statevar)) ! we must use index value(1) as the subroutine expect a single variable call get_state_var_value(statevar,values(1),encoded,ceq) else write(*,*)'No such component' endif !-------------------------------------------------------------------- !@CC ! Amount of moles /mass of components in a phase case('NP ', 'BP ') if(n1.lt.0) then ! all phases statevar=stavar(1:2)//'(*)' !@CC ! this returns all composition sets for all phases call get_many_svar(statevar,values,mjj,n3,encoded,ceq) ! this output gives the amounts for all compsets of a phase sequentially ! but here we want them in phase tuple order ! the second argument is the number of values for each phase, here is 1 but ! it can be for example compositions, then it should be number of components call sortinphtup(n3,1,values) else ! NP for just one phase call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar='NP('//trim(name)//') ' call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 endif !-------------------------------------------------------------------- ! Mole or mass fractions !@CC case('N ','B ','X ','W ') !@CC ! write(*,*)'in tqgetv n,x,w: ',n1,n2,n3 if(n2.eq.0) then if(n1.lt.0) then ! moles, mole or mass fraction of all components for all phases statevar=stavar(1:1)//'(*) ' ! write(*,*)'tqgetv 3: ',mjj,statevar(1:len_trim(statevar)) call get_many_svar(statevar,values,mjj,n3,encoded,ceq) elseif(n1.eq.0) then ! mole fraction for the state variable written as X(FE) ! n1 and n2 not used, just check for wildcard ! write(*,*)'tqgetv 20: ',stavar(1:len_trim(stavar)) if(index(stavar,'*').gt.0) then call get_many_svar(stavar,values,mjj,n3,encoded,ceq) else call get_state_var_value(stavar,values(1),encoded,ceq) endif else ! mole fraction of a single component, no phase specification n3=1 ics=1 ! call get_component_name(n1,name,ceq) ! if(gx%bmperr.ne.0) goto 1000 statevar=stavar(1:1)//'('//trim(cnam(n1))//')' ! write(*,*)'tqgetv 4: ',statevar(1:len_trim(statevar)) call get_state_var_value(statevar,values(1),encoded,ceq) endif elseif(n1.lt.0) then !........................................................ ! for all phases one or several components if(n2.lt.0) then ! this means all components all phases, for example x(*,*) statevar=stavar(1:1)//'(*,*) ' ! write(*,*)'tqgetv 5: ',mjj,statevar(1:len_trim(statevar)) call get_many_svar(statevar,values,mjj,n3,encoded,ceq) ! this output gives the composition for all compsets of a phase sequentially ! but we want them in phase tuple order ! The second argument is the number of values for each phase, noel() ! in this case ics=noel() call sortinphtup(n3,ics,values) else ! a single component in all phases. n2 must not be zero ! call get_component_name(n2,name,ceq) ! if(gx%bmperr.ne.0) goto 1000 if(n2.le.0 .or. n2.ge.noel()) then write(*,*)'No such component' goto 1000 endif ! state variable like w(*,cr), the Cr content in all (stable) phases statevar=stavar(1:1)//'(*,'//cnam(n2)(1:len_trim(cnam(n2)))//')' ! write(*,*)'tqgetv 6: ',mjj,statevar(1:len_trim(statevar)) call get_many_svar(statevar,values,mjj,n3,encoded,ceq) ! this output gives the composition for all compsets of a phase sequentially ! but we want them in phase tuple order ! The second argument is the number of values for each phase, in this case 1 ! ics=noel() ! THIS MUST BE CHECKED !!! call sortinphtup(n3,1,values) endif elseif(n2.lt.0) then ! this means all components in one phase call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=stavar(1:1)//'('//trim(name)//',*) ' call get_many_svar(statevar,values,mjj,n3,encoded,ceq) else ! one component (n2) of one phase (n1) call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=stavar(1:1)//'('//trim(name)//',' call get_component_name(n2,name,ceq) if(gx%bmperr.ne.0) goto 1000 statevar(len_trim(statevar)+1:)=trim(name)//') ' ! write(*,*)'tqgetv 8: ',statevar call get_state_var_value(statevar,values(1),encoded,ceq) endif !-------------------------------------------------------------------- ! volume case('V ') if(norm(1:1).ne.' ') then statevar='V'//norm ki=2 else statevar='V ' ki=1 endif if(n1.gt.0) then ! Volume for a specific phase call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=statevar(1:ki)//'('//trim(name)//') ' call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 else ! Total volume call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 endif !-------------------------------------------------------------------- ! Enthalpy case('H ') ! phase specifier not allowed if(norm(1:1).ne.' ') then statevar='H'//norm ki=2 else statevar='H ' ki=1 endif ! write(*,*)'tqgetv 1: ',n1,ki if(n1.gt.0) then ! Gibbs energy for a specific phase call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=statevar(1:ki)//'('//trim(name)//') ' call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 else ! Total enthalpy call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 endif !-------------------------------------------------------------------- ! Gibbs energy case('G ') ! phase specifier not allowed if(norm(1:1).ne.' ') then statevar='G'//norm ki=2 else statevar='G ' ki=1 endif ! write(*,*)'tqgetv 1: ',n1,ki if(n1.gt.0) then ! Gibbs energy for a specific phase call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=statevar(1:ki)//'('//trim(name)//') ' ! write(*,*)'tqgetv 3: ',statevar call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 else ! Total Gibbs energy call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 endif !-------------------------------------------------------------------- ! Driving force relative stable equilibrium case('DG ') ! Always normalized per mole if(norm(3:3).ne.' ') then statevar='DG'//norm ki=3 else statevar='DG ' ki=2 endif ! write(*,*)'tqgetv DGM: ',n1,ki if(n1.gt.0) then ! The driving force for a specific phase call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=statevar(1:ki)//'M('//trim(name)//') ' ! write(*,*)'tqgetv 3: ',statevar call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 else ! For all phases n3=0 if(nooftup().gt.mjj) then write(*,*)'TQGETV error, array too small for DGM',mjj,nooftup() gx%bmperr=8888 goto 1000 endif statevar='DGM(#) ' write(*,*)'tqgetv 3: ',statevar call get_many_svar(statevar,values,mjj,n3,encoded,ceq) write(*,'(a,10(1pe12.4))')'TQGETV: ',(values(ki),ki=1,n3) write(*,*)'gx%bmperr: ',gx%bmperr endif !-------------------------------------------------------------------- ! Mobilities case('MQ ') call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=stavar(1:len_trim(stavar))//'('//trim(name)//')' ! write(*,*)'statevar: ',statevar call get_state_var_value(statevar,values(1),encoded,ceq) !-------------------------------------------------------------------- ! Second derivatives of the Gibbs energy of a phase case('D2G ') lokcs=phasetuple(n1)%lokvares ! this gives wrong value!! ?? n3=size(ceq%phase_varres(lokcs)%yfr) ! write(*,*)'D2G 3: ',n3 kj=(n3*(n3+1))/2 if(kj.gt.mjj) then write(*,*)'TQGETV error, array too small for D2G',mjj,kj gx%bmperr=8888 goto 1000 endif ! write(*,*)'D2G 3: ',kj do ki=1,kj values(ki)=ceq%phase_varres(lokcs)%d2gval(ki,1) enddo end select !=========================================================================== 1000 continue return end subroutine tqgetv !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ subroutine tqgetg(lokres,n1,n2,values,ceq) ! the partial derivative of the Gibbs energy ....?? implicit none integer n1,n2,lokres double precision values(*) type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium ! double precision napfu, rgast integer count integer jl,size TYPE(gtp_phase_varres), pointer :: parres ! count = 1 ! napfu=ceq%phase_varres(lokres)%abnorm(1) rgast=globaldata%rgas*ceq%tpval(1) parres=>ceq%phase_varres(lokres) ! ! write(*,100)(rgast*parres%gval(jl,1),jl=1,4) ! write(*,200)parres%gval(1,1)/parres%abnorm(1),parres%abnorm(1) 100 format('G/N, dG/dT:',4(1PE16.8)) 200 format('G/N/RT, N:',2(1PE16.8)) ! G_m^\alpha = G_M^\alpha/N^\alpha, \frac{\partial G_m^\alpha}{\partial T}, ! \frac{\partial G_m^\alpha}{\partial P}, ! \frac{\partial^2 G_m^\alpha}{\partial T^2} values(count:count+3) = rgast*parres%gval(1:4,1)/napfu count = count + 4 if (n1>0) then ! 1/N^\alpha * \frac{\partial G_M^\alpha}{\partial y_i} values(count:count+n1-1) = rgast*parres%dgval(1,1:n1,1)/napfu count = count + n1 if (n2>0) then ! 1/N^\alpha * \frac{\partial^2 G_M^\alpha}{\partial y_i\partial y_j} values(count:count+n2-1) = rgast*parres%d2gval(1:n2,1)/napfu endif endif end subroutine tqgetg !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ subroutine tqgdmat(phtupx,tpval,xknown,cpot,tyst,nend,mugrad,mobval,& consnames,n1,ceq) ! equilibrates the constituent fractions of a phase for mole fractions xknown ! and calculates the Darken matrix and unreduced diffusivities ! phtup is phase tuple ! tpval is T and P ! ceq is a datastructure with all relevant thermodynamic data ! cpot are the (calculated) chemical potentials ! tyst is TRUE means no outut ! nend is the number of values returned in mugrad ! mugrad are the derivatives of the chemical potentials wrt mole fractions?? ! mobval are the mobilities implicit none integer phtupx ! IN: index in phase tuple array integer nend logical tyst double precision tpval(*),xknown(*),cpot(*),mugrad(*),mobval(*) character*24, dimension(*) :: consnames integer n1 TYPE(gtp_phasetuple), pointer :: phtup TYPE(gtp_equilibrium_data), pointer :: ceq integer iph, ics, ll double precision mass character*24 spname phtup=>phasetuple(phtupx) call equilph1d(phtup,tpval,xknown,cpot,tyst,nend,mugrad,mobval,ceq) iph=phasetuple(phtupx)%ixphase ics=1 n1 = noconst(iph,ics,firsteq) do ll=1,n1 call get_constituent_name(iph,ll,consnames(ll),mass) enddo end subroutine tqgdmat !@CC !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgphc1(n1,nsub,cinsub,spix,yfrac,sites,extra,ceq) ! tq_get_phase_constitution ! This subroutine returns the sublattices and constitution of a phase ! n1 is phase tuple index ! nsub is the number of sublattices (1 if no sublattices) ! cinsub is an array with the number of consttuents in each sublattice ! spix is an array with the species index of the constituents in all sublattices ! sites is an array of the site ratios for all sublattices. ! yfrac is the constituent fractions in same order as in spix ! extra is an array with some extra values: ! extra(1) is the number of moles of components per formula unit ! extra(2) is the net charge of the phase implicit none integer n1,nsub,cinsub(*),spix(*) double precision sites(*),yfrac(*),extra(*) type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} call get_phase_data(phasetuple(n1)%ixphase,phasetuple(n1)%compset,& nsub,cinsub,spix,yfrac,sites,extra,ceq) 1000 continue return end subroutine tqgphc1 !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqsphc1(n1,yfra,extra,ceq) ! tq_set_phase_constitution ! To set the constitution of a phase ! n1 is phase tuple index ! yfra is an array with the constituent fractions in all sublattices ! in the same order as obtained by tqgphc1 ! extra is an array with returned values with the same meaning as in tqgphc1 ! NOTE The constituents fractions are normallized to sum to unity for each ! sublattice and extra is calculated by tqsphc1 ! T and P must be set as conditions. implicit none integer n1 double precision yfra(*),extra(*) type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} call set_constitution(phasetuple(n1)%ixphase,phasetuple(n1)%compset,& yfra,extra,ceq) 1000 continue return end subroutine tqsphc1 !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqcph1(n1,n2,n3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,ceq) ! tq_calculate_phase_properties !vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! WARNING: this is not a subroutine to calculate chemical potentials ! those can only be made by an equilibrium calculation. ! The values returned are partial derivatives of G for the phase at the ! current T, P and phase constitution. The phase constitution has been ! obtained by a previous equilibrium calculation or ! set by the subroutine tqsphc ! It corresponds to the "calculate phase" command. ! ! NOTE that values are per formula unit divided by RT, ! divide also by extra(1) in subroutine tqsphc1 to get them per mole component ! !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! calculate G and some or all derivatives for a phase at current composition ! n1 is the phase tuple index ! n2 is 0 if only G and derivatves wrt T and P, 1 also first drivatives wrt ! compositions, 2 if also 2nd derivatives ! n3 is returned as number of constituents (dimension of returned arrays) ! gtp is an array with G, G.T, G:P, G.T.T, G.T.P and G.P.P ! dgdy is an array with G.Yi ! d2gdydt is an array with G.T.Yi ! d2gdydp is an array with G.P.Yi ! d2gdy2 is an array with the upper triangle of the symmetrix matrix G.Yi.Yj ! reurned in the order: 1,1; 1,2; 1,3; ... ! 2,2; 2,3; ... ! 3,3; ... ! for indexing one can use the integer function ixsym(i1,i2) implicit none integer n1,n2,n3 double precision gtp(6),dgdy(*),d2gdydt(*),d2gdydp(*),d2gdy2(*) type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer ij,lokres,nofc ! write(*,*)'tqcph1 1: ',ceq%eqname ! write(*,*)'tqcph1 2',phasetuple(n1)%ixphase,phasetuple(n1)%compset !---------------------------------------------------------------------- ! THIS IS NO EQUILIBRIUM, JUST G AND DERIVATIVES FOR CURRENT T, P AND Y call calcg(phasetuple(n1)%ixphase,phasetuple(n1)%compset,n2,lokres,ceq) !---------------------------------------------------------------------- ! write(*,*)'tqcph1 3A',lokres,gx%bmperr ! The inital size here can be 1000 ! n3=size(ceq%phase_varres(lokres)%yfr) ! the actual number of constituents is better to take from this call n3=noconst(phasetuple(n1)%ixphase,1,ceq) ! write(*,*)'tqcph1 3C',n3 ! gval last index is the property, other properties can also be extracted ! t.ex. mobilites ! The application program can also access these data directly ... if(gx%bmperr.eq.0) then do ij=1,6 gtp(ij)=ceq%phase_varres(lokres)%gval(ij,1) enddo do ij=1,n3 dgdy(ij)=ceq%phase_varres(lokres)%dgval(1,ij,1) d2gdydt(ij)=ceq%phase_varres(lokres)%dgval(2,ij,1) d2gdydp(ij)=ceq%phase_varres(lokres)%dgval(3,ij,1) enddo ! size of upper triangle of symetrix matrix nofc=n3*(n3+1)/2 do ij=1,nofc d2gdy2(ij)=ceq%phase_varres(lokres)%d2gval(ij,1) enddo else gtp=zero do ij=1,nofc dgdy(ij)=zero d2gdydt(ij)=zero d2gdydp(ij)=zero enddo nofc=nofc*(nofc+1)/2 do ij=1,nofc d2gdy2(ij)=zero enddo endif 1000 continue return end subroutine tqcph1 !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} %- subroutine tqcph2(n1,n2,n3,n4,ceq) ! tq_calculate_phase_properties !vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! WARNIG: this is not a subroutine to calculate chemical potentials ! those can only be made by an equilibrium calculation. ! The values returned are partial derivatives of G for the phase at the ! current T, P and phase constitution. The phase constitution has been ! obtained by a previous equilibrium calculation or ! set by the subroutine tqsphc ! It corresponds to the "calculate phase" command. ! ! NOTE that values are per formula unit divided by RT, ! divide also by extra(1) in subroutine tqsphc1 to get them per mole component ! !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! calculate G and some or all derivatives for a phase at current composition ! n1 is the phase tuple index ! n2 is type of calculation (0, 1 or 2) ! n3 is returned as number of constituents ! n4 is index to ceq%phase_varres(lokres)% with all results ! for indexing one can use the integer function ixsym(i1,i2) implicit none integer n1,n2,n3,n4 type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer ij,lokres,nofc ! write(*,*)'tqcph1 1: ',ceq%eqname ! write(*,*)'tqcph1 2',phasetuple(n1)%ixphase,phasetuple(n1)%compset !---------------------------------------------------------------------- ! THIS IS NO EQUILIBRIUM, JUST G AND DERIVATIVES FOR CURRENT T, P AND Y call calcg(phasetuple(n1)%ixphase,phasetuple(n1)%compset,n2,lokres,ceq) !---------------------------------------------------------------------- ! write(*,*)'tqcph1 3A',lokres,gx%bmperr ! this should work but gave segmentation fault, find this a more cumbersum way n3=size(ceq%phase_varres(lokres)%yfr) n4=lokres ! Uer can access results like ! ceq%phase_varres(n4)%gval(1..6,1..prop) ! prop=1 is G, other can be t.ex. Curie T, mobilites etc ! ceq%phase_varres(lokres)%dgval(1,ij,1) are dG/dy(ij) ! ceq%phase_varres(lokres)%dgval(2,ij,1) are d2G/dy(ij)dT ! ceq%phase_varres(lokres)%dgval(3,ij,1) are d2G/dy(ij)dP ! ceq%phase_varres(lokres)%d2gval(ij,1) are d2G/dy(i)dy(j) ! arranged as a single dimenion array indexed by ixsym(i,j) ! ! NEVER CHANGE THE CONSTITUTION DIRECTLY, using n4, ALWAYS CALL tqsph1(...) ! 1000 continue return end subroutine tqcph2 !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqdceq(name) ! delete equilibrium with name implicit none character name*24 ! integer n1 type(gtp_equilibrium_data), pointer :: newceq,ceq !\end{verbatim} integer n1 call findeq(name,n1) if(gx%bmperr.ne.0) goto 1000 ! do not allow delete equilibrium 1 if(n1.eq.1) then write(*,*)'No allowed to delete default equilibrium' gx%bmperr=4333 goto 1000 endif ! ceq=>eqlista(n1) call delete_equilibria(name,ceq) 1000 continue return end subroutine tqdceq !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqcceq(name,n1,newceq,ceq) ! copy_current_equilibrium to newceq ! creates a new equilibrium record with name with values same as ceq ! n1 is returned as index implicit none character name*24 integer n1 type(gtp_equilibrium_data), pointer :: newceq,ceq !\end{verbatim} !call enter_equilibrium(name,n1) !if(gx%bmperr.ne.0) goto 1000 !newceq=>eqlista(n1) call copy_equilibrium(newceq,name,ceq) 1000 continue return end subroutine tqcceq !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqcneq(name,n1,newceq) ! creates a new equilibrium record, same but simpler call than tqcceq ! n1 is returned as index in eqlista implicit none character*(*), intent(in) :: name integer, intent(out) :: n1 type(gtp_equilibrium_data), pointer, intent(out) :: newceq !\end{verbatim} call enter_equilibrium(name,n1) if(gx%bmperr.ne.0) goto 1000 newceq=>eqlista(n1) 1000 continue return end subroutine tqcneq !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqselceq(name,ceq) ! select current equilibrium to be that with name. ! Note that equilibria can be deleted and change number but not name implicit none character name type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer n1 call findeq(name,n1) if(gx%bmperr.ne.0) goto 1000 call selecteq(n1,ceq) 1000 continue return end subroutine tqselceq !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqlr(lut,ceq) ! list the equilibrium results like in OC implicit none integer lut type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer phtupx,iph,ics,lokvares,mode logical once write(lut,10) 10 format(/20('*')/'Start debug output from TQLR: ') call list_conditions(lut,ceq) call list_global_results(lut,ceq) call list_components_result(lut,1,ceq) once=.TRUE. mode=0 do phtupx=1,nooftup() lokvares=phasetuple(phtupx)%lokvares if(ceq%phase_varres(lokvares)%phstate.ge.phentstab) then iph=phasetuple(phtupx)%ixphase ics=phasetuple(phtupx)%compset call list_phase_results(iph,ics,mode,lut,once,ceq) endif enddo write(lut,20) 20 format('End debug output from TQLR'/20('*')/) 1000 continue return end subroutine tqlr !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqlc(lut,ceq) ! list conditions like in OC implicit none integer lut type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} write(lut,10) 10 format(/'Debug output from TQLC: ') call list_conditions(lut,ceq) 1000 continue return end subroutine tqlc !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqltdb ! list TDB file elements, phases and parameters on screen implicit none !\end{verbatim} integer n,kou ! n is position in text, kou is output unit n=1; kou=6 call list_many_formats(' ,,,, ',n,1,kou) write(*,10) 10 format(/' no more ',/) return end subroutine tqltdb !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqquiet(yes) ! if argument TRUE spurious output should be suppressed implicit none logical yes !\end{verbatim} if(yes) then globaldata%status=ibclr(globaldata%status,GSVERBOSE) globaldata%status=ibset(globaldata%status,GSSILENT) else globaldata%status=ibset(globaldata%status,GSVERBOSE) endif return end subroutine tqquiet !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqchange_globalbit(bit,onoff) ! set a global bit implicit none integer bit,onoff !\end{verbatim} ! list here taken from models/gtp3.F90, only some allowed!! ! BEWHEARE, the meaning of bits may have changed !!! check with gtp3.F90 ! 4 NOMERGE: no merge of gridmin result, ! 5 NODATA: not any data, ! 6 NOPHASE: no phase in system, ! 7 NOACS: no automatic creation of composition set for any phase ! 8 NOREMCS: do not remove any redundant unstable composition sets ! 9 NOSAVE: data changed after last save command ! 10 VERBOSE: maximum of listing ! 11 SETVERB: permanent setting of verbose ! 12 SILENT: as little output as possible ! 13 NOAFTEREQ: no manipulations of results after equilibrium calculation ! 14 XGRID: extra dense grid for all phases ! 15 NOPAR: do not run in parallel ! 16 NOSMGLOB do not test global equilibrium at node points ! 17 NOTELCOMP the elements are not the components ! 18 TGRID use grid minimizer to test if global after calculating equilibrium ! 19 OGRID use old grid generator ! 20 NORECALC do not recalculate equilibria even if global test after fails ! 21 OLDMAP use old map algorithm ! 22 NOAUTOSP do not generate automatic start points for mapping ! 23 GSYGRID extra dense grid ! 24 GSVIRTUAL (CCI) enables calculations with a virtual element if((bit.ge.7 .and. bit.le.16) .or. (bit.ge.18 .and. bit.le.23)) then if(onoff.gt.0) then ! set bit globaldata%status=ibset(globaldata%status,bit) else globaldata%status=ibclr(globaldata%status,bit) endif else gx%bmperr=4326 endif return end subroutine tqchange_globalbit !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqchange_phasebit(phtupx,bit,onoff) ! set a bit of phase implicit none integer phtupx,bit,onoff !\end{verbatim} ! taken from models/gtp3.F90 !-Bits in PHASE record STATUS1 there are also bits in each phase_varres record! ! BEWHEARE, the meaning of bits may have changed !!! check with gtp3.F90 ! 0 HID phase is hidden (not implemented) ! 1 IMHID phase is implictly hidden (not implemented) ! 2 ID phase is ideal, substitutional and no interaction ! 3 NOCV phase has no concentration variation (fix composition) ! 4 HASP phase has at least one parameter entered ! 5 FORD phase has 4 sublattice FCC ordering with parameter permutations ! 6 BORD phase has 4 sublattice BCC ordering with parameter permutations ! 7 SORD phase has TCP type ordering (like for sigma) ! 8 MFS phase has a disordered fraction set ! 9 GAS this is the gas phase (first in phase list) ! 10 LIQ phase is liquid (can be several but listed directly after gas) ! 11 IONLIQ phase has ionic liquid model (I2SL) ! 12 AQ1 phase has aqueous model (not implemented) ! 13 STATE elemental liquid twostate (2-state) model parameter UNUSED? ! 14 QCE phase has quasichemical SRO configurational entropy (not implemented) ! 15 CVMCE phase has some CVM ordering entropy (not implemented) ! 16 EXCB phase need explicit charge balance (has ions) ! 17 XGRID use extra dense grid for this phase ! 18 FACTCE phase has FACT quasichemical SRO model (not implemented) ! 19 NOCS not allowed to create composition sets for this phase ! 20 HELM parameters are for a Helmholz energy model (not implemented), ! 21 PHNODGDY2 phase has model with no analytical 2nd derivatives ! 22 not implemented ELMA phase has elastic model A (not implemented) ! 23 EECLIQ the condensed phase (liquid) that should have highest entropy ! 24 PHSUBO special use testing models DO NOT USE ! 25 PALM interaction records numbered by PALMTREE NEEDED FOR PERMUTATIONS !!! ! 26 MULTI may be used with care ! 27 BMAV Xion magnetic model with average Bohr magneton number ! 28 UNIQUAC The UNIQUAC fluid model ! 29 DILCE phase has dilute configigurational entropy (not implemented) ! only bittar 3 left! integer lokph if(phtupx.le.0 .or. phtupx.gt.nooftup()) then gx%bmperr=4325 elseif(bit.eq.17 .or. bit.eq.19) then lokph=phasetuple(phtupx)%lokph if(onoff.gt.0) then call set_phase_status_bit(lokph,bit) else call clear_phase_status_bit(lokph,bit) endif else gx%bmperr=4326 endif return end subroutine tqchange_phasebit !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqset_gaddition(phtupx,gadd,ceq) ! set fix addition to Gibbs energy of a phase#compset implicit none integer phtupx double precision gadd type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} ! Provided by Christophe Sigli 2018? integer lokcs lokcs=phasetuple(phtupx)%lokvares if(.not.allocated(ceq%phase_varres(lokcs)%addg)) then allocate(ceq%phase_varres(lokcs)%addg(1)) endif ceq%phase_varres(lokcs)%addg(1)=gadd ! set bit that this should be calculated ceq%phase_varres(lokcs)%status2=& ibset(ceq%phase_varres(lokcs)%status2,CSADDG) return end subroutine tqset_gaddition !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tq_add_const_energy(energy,phtupx,ceq) ! add a constant energy in J/mole double precision,intent(in) :: energy type(gtp_equilibrium_data), pointer :: ceq integer,intent(in) :: phtupx !\end{verbatim} ! Provided by Jan Herrnring 2020.12.15 integer :: lokcs lokcs=phasetuple(phtupx)%lokvares if(.not.allocated(ceq%phase_varres(lokcs)%addg)) then allocate(ceq%phase_varres(lokcs)%addg(1)) endif ! add a constant term to G, value in J/FU ! Abnorm is the number of moles of the phase ceq%phase_varres(lokcs)%addg(1)=energy*ceq%phase_varres(lokcs)%abnorm(1) ! set bit that this should be calculated ceq%phase_varres(lokcs)%status2=& ibset(ceq%phase_varres(lokcs)%status2,CSADDG) end subroutine tq_add_const_energy !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ end MODULE LIBOCTQ !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ ! dummy modules !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ module ftinyopen ! ! This module replaces a C module for a popup window to open files ! used in the interactive OC. If you want to use the original ! version for opening files please check the linkmake or Makefile ! contains subroutine getfilename(typ,sval) implicit none integer typ character sval*(*) sval=' ' return end subroutine getfilename end module ftinyopen !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ ! dummy module (only Linux) !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ module M_getkey ! ! This module replaces a C module fore single character input on Linux ! contains character function getkex() getkex=' ' return end function getkex end module M_getkey !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ ================================================ FILE: examples/TQ4lib/Cpp/liboctqisoc.F90 ================================================ ! ! Part of iso-C bining for OC TQlib from Teslos ! modified by Matthias Stratmann, Christophe Sigli and Bo Sundman ! MODULE cstr ! ! convert characters from Fortran to C and vice versa contains function c_to_f_string(s) result(str) use iso_c_binding implicit none character(kind=c_char,len=1), intent(in) :: s(*) character(len=:), allocatable :: str integer i, nchars i = 1 do if (s(i) == c_null_char) exit i = i + 1 end do nchars = i - 1 ! Exclude null character from Fortran string allocate(character(len=nchars) :: str) str = transfer(s(1:nchars), str) end function c_to_f_string !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! subroutine c_to_f_str(s,sty) use iso_c_binding implicit none character(kind=c_char,len=1), intent(in) :: s(*) character(len=24), intent(out) :: sty character(len=:), allocatable :: str integer i, nchars i = 1 do if (s(i) == c_null_char) exit i = i + 1 end do nchars = i - 1 ! Exclude null character from Fortran string allocate(character(len=nchars) :: str) sty = transfer(s(1:nchars), str) deallocate (str) end subroutine c_to_f_str !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! subroutine f_to_c_string(fstring, cstr) use iso_c_binding implicit none character(len=24) :: fstring character(kind=c_char, len=1), intent(out) :: cstr(*) integer i do i = 1, len(fstring) cstr(i) = fstring(i:i) cstr(i+1) = c_null_char end do end subroutine f_to_c_string END MODULE cstr !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! ! ! module liboctqisoc ! !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! MODULE liboctqisoc ! ! OCTQlib with iso-C binding ! use iso_c_binding use cstr use liboctq ! use general_thermodynamic_package implicit none integer(c_int), bind(c) :: c_nel integer(c_int), bind(c) ::c_maxc=40, c_maxp=500 type(c_ptr), bind(c), dimension(maxc) :: c_cnam character(len=25), dimension(maxc), target :: cnames real(c_double), bind(c), dimension(maxc) :: c_mass integer(c_int), bind(c) :: c_ntup TYPE, bind(c) :: c_gtp_equilibrium_data ! this contains all data specific to an equilibrium like conditions, ! status, constitution and calculated values of all phases etc ! Several equilibria may be calculated simultaneously in parallell threads ! so each equilibrium must be independent ! NOTE: the error code must be local to each equilibria!!!! ! During step and map these records with results are saved ! values of T and P, conditions etc. ! Values here are normally set by external conditions or calculated from model ! local list of components, phase_varres with amounts and constitution ! lists of element, species, phases and thermodynamic parameters are global ! tpval(1) is T, tpval(2) is P, rgas is R, rtn is R*T ! status: not used yet? ! multiuse: used for various things like direction in start equilibria ! eqno: sequential number assigned when created ! next: index of next equilibrium in a sequence during step/map calculation. ! eqname: name of equilibrium ! tpval: value of T and P ! rtn: value of R*T integer(c_int) :: status,multiuse,eqno,next ! character(c_char) :: eqname ! NOT USED real(c_double) :: tpval(2),rtn ! svfunres: the values of state variable functions valid for this equilibrium type(c_ptr) :: svfunres ! the experiments are used in assessments and stored like conditions ! lastcondition: link to condition list ! lastexperiment: link to experiment list TYPE(c_ptr) :: lastcondition,lastexperiment ! components and conversion matrix from components to elements ! complist: array with components ! compstoi: stoichiometric matrix of compoents relative to elements ! invcompstoi: inverted stoichiometric matrix TYPE(c_ptr) :: complist real(c_double) :: compstoi real(c_double) :: invcompstoi ! one record for each phase+composition set that can be calculated ! phase_varres: here all calculated data for the phase is stored TYPE(c_ptr) :: phase_varres ! index to the tpfun_parres array is the same as in the global array tpres ! eq_tpres: here local calculated values of TP functions are stored TYPE(c_ptr) :: eq_tpres ! current values of chemical potentials stored in component record but ! duplicated here for easy acces by application software real(c_double) :: cmuval ! xconc: convergence criteria for constituent fractions and other things real(c_double) :: xconv ! delta-G value for merging gridpoints in grid minimizer ! smaller value creates problem for test step3.BMM, MC and austenite merged real(c_double) :: gmindif=-5.0D-2 ! maxiter: maximum number of iterations allowed integer(c_int) :: maxiter ! this is to save a copy of the last calculated system matrix, needed ! to calculate dot derivatives, initiate to zero integer(c_int) :: sysmatdim=0,nfixmu=0,nfixph=0 integer(c_int) :: fixmu integer(c_int) :: fixph real(c_double) :: savesysmat END TYPE c_gtp_equilibrium_data contains ! functions integer function c_noofcs(iph) bind(c, name='c_noofcs') integer(c_int), value :: iph c_noofcs = noofcs(iph) return end function c_noofcs !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! subroutine examine_gtp_equilibrium_data(c_ceq) & bind(c, name='examine_gtp_equilibrium_data') type(c_ptr), intent(in), value :: c_ceq type(gtp_equilibrium_data), pointer :: ceq integer :: i,j call c_f_pointer(c_ceq, ceq) write(*,10) ceq%status, ceq%multiuse, ceq%eqno 10 format(/'gtp_equilibrium_data: status, multiuse, eqno, next'/, 3i4) write(*,20) ceq%eqname 20 format(/'Name of equilibrium'/,a) write(*,30) ceq%tpval, ceq%rtn 30 format(/'Value of T and P'/, 2f8.3, /'R*T'/, f8.4) do i = 1, size(ceq%compstoi,1) write(*,*) (ceq%compstoi(i,j), j=1,size(ceq%compstoi,2)) end do write(*,*) ceq%cmuval write(*,*) ceq%xconv write(*,*) ceq%gmindif write(*,*) ceq%maxiter write(*,*) ceq%sysmatdim, ceq%nfixmu, ceq%nfixph write(*,*) ceq%fixmu, ceq%fixph, ceq%savesysmat end subroutine examine_gtp_equilibrium_data !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqini(n, c_ceq) bind(c, name='c_tqini') integer(c_int), intent(in) :: n type(c_ptr), intent(out) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq integer :: i1,i2 call tqini(n, ceq) c_ceq = c_loc(ceq) end subroutine c_tqini !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqrfil(filename,c_ceq) bind(c, name='c_tqrfil') character(kind=c_char,len=1), intent(in) :: filename(*) type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq character(len=:), allocatable :: fstring integer :: i,j,l character(kind=c_char, len=1),dimension(24), target :: f_pointers ! convert type(c_ptr) to fptr call c_f_pointer(c_ceq, ceq) fstring = c_to_f_string(filename) call tqrfil(fstring, ceq) ! after tqrfil ntup variable is defined c_ntup = ntup c_nel = nel do i = 1, nel cnames(i) = trim(cnam(i)) // c_null_char c_cnam(i) = c_loc(cnames(i)) ! c_mass(i)=cmass(i) ! write(*,*) cmass(i) end do c_ceq = c_loc(ceq) deallocate(fstring) nullify(ceq) end subroutine c_tqrfil !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqrpfil(filename,nel,c_selel,c_ceq) bind(c, name='c_tqrpfil') !change character(kind=c_char), intent(in) :: filename integer(c_int), intent(in), value :: nel type(c_ptr), intent(in), dimension(nel), target :: c_selel type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq character(len=:), allocatable :: fstring character, pointer :: selel(:) integer :: i character elem(nel)*2 fstring = c_to_f_string(filename) call c_f_pointer(c_ceq, ceq) ! convert the c type selel strings to f-selel strings ! note: additional character is for C terminated '\0' do i = 1, nel call c_f_pointer(c_selel(i), selel, [3]) elem(i) = c_to_f_string(selel) end do call tqrpfil(fstring, nel, elem, ceq) ! after tqrpfil ntup variable is defined c_ntup = ntup c_nel = nel do i = 1, nel cnames(i) = trim(cnam(i)) // c_null_char c_cnam(i) = c_loc(cnames(i)) c_mass(i)=cmass(i) end do c_ceq = c_loc(ceq) deallocate (fstring) nullify(ceq) end subroutine c_tqrpfil !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgcom(n,components,c_ceq) bind(c, name='c_tqgcom') ! get system components integer(c_int), intent(inout) :: n !character(kind=c_char, len=24), dimension(24), intent(out) :: c_components type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} integer, target :: nc character(len=24) :: fcomponents(maxel) character(kind=c_char, len=1), dimension(maxel*24) :: components type(gtp_equilibrium_data), pointer :: ceq integer :: i,j,l call c_f_pointer(c_ceq, ceq) call tqgcom(nc, fcomponents, ceq) ! convert the F components strings to C l = len(fcomponents(1)) do i = 1, nc do j = 1, l components((i-1)*l+j)(1:1) = fcomponents(i)(j:j) end do ! null termination components(i*l) = c_null_char end do c_ceq = c_loc(ceq) n = nc end subroutine c_tqgcom !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgnp(n, c_ceq) bind(c, name='c_tqgnp') integer(c_int), intent(inout) :: n type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) call tqgnp(n, ceq) c_ceq = c_loc(ceq) end subroutine c_tqgnp !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgpn(n,phasename, c_ceq) bind(c, name='c_tqgpn') ! get name of phase n, ! NOTE: n is phase number, not extended phase index integer(c_int), intent(in), value :: n character(kind=c_char, len=1), intent(inout) :: phasename(24) type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fstring integer :: i call c_f_pointer(c_ceq, ceq) ! fstring = c_to_f_string(phasename) call tqgpn(n, fstring, ceq) ! copy the f-string to c-string and end with '\0' do i=1,len(trim(fstring)) phasename(i)(1:1) = fstring(i:i) phasename(i+1)(1:1) = c_null_char end do c_ceq = c_loc(ceq) end subroutine c_tqgpn !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgpi(n,phasename,c_ceq) bind(c, name='c_tqgpi') ! get index of phase phasename integer(c_int), intent(out) :: n character(c_char), intent(in) :: phasename(24) type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fstring call c_f_pointer(c_ceq, ceq) fstring = c_to_f_string(phasename) call tqgpi(n, fstring, ceq) c_ceq = c_loc(ceq) end subroutine c_tqgpi !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgpcn(n, c, constituentname, c_ceq) bind(c, name='c_tqgpcn') ! get name of constitutent c in phase n integer(c_int), intent(in) :: n ! phase number integer(c_int), intent(in) :: c ! extended constituent index: ! 10*species_number + sublattice character(c_char), intent(out) :: constituentname(24) type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} write(*,*) 'tqgpcn not implemented yet' end subroutine c_tqgpcn !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgpci(n,c, constituentname, c_ceq) bind(c, name='c_tqgpci') ! get index of constituent with name in phase n integer(c_int), intent(in) :: n integer(c_int), intent(out) :: c ! exit: extended constituent index: ! 10*species_number+sublattice character(c_char), intent(in) :: constituentname(24) type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fstring fstring = c_to_f_string(constituentname) call c_f_pointer(c_ceq, ceq) call tqgpci(n, c, fstring, ceq) c_ceq = c_loc(ceq) end subroutine c_tqgpci !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgpcs(n, c, stoi, mass, c_ceq) bind(c, name='c_tqgpcs') !get stoichiometry of constituent c in phase n !? missing argument number of elements???? integer(c_int), intent(in) :: n integer(c_int), intent(in) :: c ! in: extended constituent index: ! 10*species_number + sublattice real(c_double), intent(out) :: stoi(*) ! exit: stoichiometry of elements real(c_double), intent(out) :: mass ! exit: total mass type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) call tqgpcs(n,c,stoi,mass,ceq) c_ceq=c_loc(ceq) end subroutine c_tqgpcs !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgccf(n1,n2,elnames,stoi,mass,c_ceq) ! get stoichiometry of component n1 ! n2 is number of elements ( dimension of elements and stoi ) integer(c_int), intent(in) :: n1 ! in: component number integer(c_int), intent(out) :: n2 ! exit: number of elements in component character(c_char), intent(out) :: elnames(2) ! exit: element symbols real(c_double), intent(out) :: stoi(*) ! exit: element stoichiometry real(c_double), intent(out) :: mass ! exit: component mass ! (sum of element mass) type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) call tqgccf(n1,n2,elnames,stoi, mass, ceq) c_ceq = c_loc(ceq) end subroutine c_tqgccf !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgnpc(n,c,c_ceq) bind(c, name='c_tqgnpc') ! get number of constituents of phase n integer(c_int), intent(in) :: n ! in: phase number integer(c_int), intent(out) :: c ! exit: number of constituents type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq,ceq) call tqgnpc(n,c,ceq) c_ceq = c_loc(ceq) end subroutine c_tqgnpc !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqsetc(statvar, n1, n2, mvalue, cnum, c_ceq) & bind(c, name='c_tqsetc') ! set condition ! stavar is state variable as text ! n1 and n2 are auxilliary indices ! value is the value of the condition ! cnum is returned as an index of the condition. ! to remove a condition the value sould be equial to RNONE ???? ! when a phase indesx is needed it should be 10*nph + ics ! SEE TQGETV for doucumentation of stavar etc. !>>>> to be modified to use phase tuplets integer(c_int), intent(in),value :: n1 !in: 0 or extended phase index: ! 10*phase_number+comp.set ! or component set integer(c_int), intent(in),value :: n2 ! integer(c_int), intent(out) :: cnum !exit: ! sequential number of this condition character(c_char), intent(in) :: statvar !in: character ! with state variable symbol real(c_double), intent(in),value :: mvalue !in: value of condition type(c_ptr), intent(in) :: c_ceq ! in: current equilibrium !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) call tqsetc(statvar, n1, n2, mvalue, cnum, ceq) nullify(ceq) end subroutine c_tqsetc !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqce(mtarget,n1,n2,mvalue,c_ceq) bind(c,name='c_tqce') ! calculate equilibrium with possible target ! Target can be empty or a state variable with indicies n1 and n2 ! value is the calculated value of target integer(c_int), intent(in),value :: n1 integer(c_int), intent(in),value :: n2 type(c_ptr), intent(inout) :: c_ceq character(c_char), intent(inout) :: mtarget real(c_double), intent(inout) :: mvalue !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq character(len=:), allocatable :: fstring call c_f_pointer(c_ceq,ceq) fstring = c_to_f_string(mtarget) call tqce(fstring,n1,n2,mvalue,ceq) c_ceq = c_loc(ceq) deallocate(fstring) nullify(ceq) end subroutine c_tqce !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgetv(statvar,n1,n2,n3,values,c_ceq) bind(c,name='c_tqgetv') ! get equilibrium results using state variables ! stavar is the state variable IN CAPITAL LETTERS with indices n1 and n2 ! n3 at the call is the dimension of values, changed to number of values ! value is the calculated value, it can be an array with n3 values. implicit none integer(c_int), intent(in),value :: n1,n2 integer(c_int), intent(inout) :: n3 character(c_char), intent(in) :: statvar real(c_double), intent(inout) :: values(*) type(c_ptr), intent(inout) :: c_ceq !IN: current equilibrium !======================================================== ! >>>> implement use of phase tuples ! stavar must be a symbol listed below ! IMPORTANT: some terms explained after the table ! Symbol index1,index2 Meaning (unit) !.... potentials ! T 0,0 Temperature (K) ! P 0,0 Pressure (Pa) ! MU component,0 or phase-tuple*1,constituent*2 Chemical potential (J) ! AC component,0 or phase-tuple,constituent Activity = EXP(MU/RT) ! LNAC component,0 or phase-tuple,constituent LN(activity) = MU/RT !...... extensive variables ! U 0,0 or phase-tuple,0 Internal energy (J) whole system or phase ! UM 0,0 or phase-tuple,0 same per mole components ! UW 0,0 or phase-tuple,0 same per kg ! UV 0,0 or phase-tuple,0 same per m3 ! UF phase-tuple,0 same per formula unit of phase ! S*3 0,0 or phase-tuple,0 Entropy (J/K) ! V 0,0 or phase-tuple,0 Volume (m3) ! H 0,0 or phase-tuple,0 Enthalpy (J) ! A 0,0 or phase-tuple,0 Helmholtz energy (J) ! G 0,0 or phase-tuple,0 Gibbs energy (J) ! ..... some extra state variables ! NP phase-tuple,0 Moles of phase ! BP phase-tuple,0 Mass of moles (kg) ! Q phase-tuple,0 Internal stability/RT (dimensionless) ! DG phase-tuple,0 Driving force/RT (dimensionless) !....... amounts of components ! N 0,0 or component,0 or phase-tuple,component Moles of component ! X component,0 or phase-tuple,component Mole fraction of component ! B 0,0 or component,0 or phase-tuple,component Mass of component ! W component,0 or phase-tuple,component Mass fraction of component ! Y phase-tuple,constituent*1 Constituent fraction !........ some parameter identifiers ! TC phase-tuple,0 Magnetic ordering temperature ! BMAG phase-tuple,0 Aver. Bohr magneton number ! MQ& phase-tuple,constituent Mobility ! THET phase-tuple,0 Debye temperature ! LNX phase-tuple,0 Lattice parameter ! EC11 phase-tuple,0 Elastic constant C11 ! EC12 phase-tuple,0 Elastic constant C12 ! EC44 phase-tuple,0 Elastic constant C44 !........ NOTES: ! *1 The phase-tuple is is structure with 2 integers: phase and comp.set ! *2 The constituent index is 10*species_number + sublattice_number ! *3 S, V, H, A, G, NP, BP, N, B and DG can have suffixes M, W, V, F also !-------------------------------------------------------------------- ! special addition for TQ interface: d2G/dyidyj ! D2G + extended phase index !------------------------------------ type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fstring integer :: n integer :: i call c_f_pointer(c_ceq, ceq) ! call list_conditions(6,ceq) ! call list_phase_results(1,1,0,6,ceq) ! write(*,*)'Phase and error code: ',1,gx%bmperr ! call list_phase_results(2,1,0,6,ceq) ! write(*,*)'Phase and error code: ',2,gx%bmperr ! write(*,*) call c_to_f_str(statvar,fstring) call tqgetv(fstring, n1, n2, n3, values, ceq) ! debug ... ! write(*,55)fstring(1:len_trim(fstring)),n1,n2,n3,(values(i),i=1,n3) !55 format(/'From c_tqgetv: ',a,': ',3i3,6(1pe12.4)) ! write(*,*) ! end debug c_ceq = c_loc(ceq) end subroutine c_tqgetv !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqgphc1(n1,nsub,cinsub,spix,yfrac,sites,extra,c_ceq)& bind(c,name='c_tqgphc1') ! tq_get_phase_constitution ! This subroutine returns the sublattices and constitution of a phase ! n1 is phase tuple index ! nsub is the number of sublattices (1 if no sublattices) ! cinsub is an array with the number of const\EDtuents in each sublattice ! spix is an array with the species index of the constituents in all sublattices ! sites is an array of the site ratios for all sublattices. ! yfrac is the constituent fractions in same order as in spix ! extra is an array with some extra values: ! extra(1) is the number of moles of components per formula unit ! extra(2) is the net charge of the phase implicit none !integer n1,nsub,cinsub(*),spix(*) integer(c_int), intent(in), value :: n1 integer(c_int), intent(out) :: nsub integer(c_int), intent(out) :: cinsub(*) integer(c_int), intent(in) :: spix(*) !double precision sites(*),yfrac(*),extra(*) real(c_double), intent(in) :: sites(*) real(c_double), intent(in) :: yfrac(*) real(c_double), intent(in) :: extra(*) !type(gtp_equilibrium_data), pointer :: ceq type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) !call tqgphc1(n1,nsub2,cinsub2,spix2,yfrac2,sites2,extra2,ceq) call tqgphc1(n1,nsub,cinsub,spix,yfrac,sites,extra,ceq) c_ceq = c_loc(ceq) end subroutine c_tqgphc1 !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqsphc1(n1,yfra,extra,c_ceq) bind(c,name='c_tqsphc1') ! tq_set_phase_constitution ! To set the constitution of a phase ! n1 is phase tuple index ! yfra is an array with the constituent fractions in all sublattices ! in the same order as obtained by tqgphc1 ! extra is an array with returned values with the same meaning as in tqgphc1 ! NOTE The constituents fractions are normallized to sum to unity for each ! sublattice and extra is calculated by tqsphc1 ! T and P must be set as conditions. implicit none integer(c_int), intent(in), value :: n1 real(c_double), intent(in) ::yfra(*) real(c_double), intent(out) :: extra(*) type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) call set_constitution(phasetuple(n1)%ixphase,phasetuple(n1)%compset,& yfra,extra,ceq) c_ceq = c_loc(ceq) end subroutine c_tqsphc1 !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqcph1(n1,n2,n3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,c_ceq) & bind(c,name='c_tqcph1') ! tq_calculate_phase_properties !vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! WARNIG: this is not a subroutine to calculate chemical potentials ! those can only be made by an equilibrium calculation. ! The values returned are partial derivatives of G for the phase at the ! current T, P and phase constitution. The phase constitution has been ! obtained by a previous equilibrium calculation or ! set by the subroutine tqsphc ! It corresponds to the "calculate phase" command. ! ! NOTE that values are per formula unit divided by RT, ! divide also by extra(1) in subroutine tqsphc1 to get them per mole component ! !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! calculate G and some or all derivatives for a phase at current composition ! n1 is the phase tuple index ! n2 is 0 if only G and derivatves wrt T and P, 1 also first drivatives wrt ! compositions, 2 if also 2nd derivatives ! n3 is returned as number of constituents (dimension of returned arrays) ! gtp is an array with G, G.T, G:P, G.T.T, G.T.P and G.P.P ! dgdy is an array with G.Yi ! d2gdydt is an array with G.T.Yi ! d2gdydp is an array with G.P.Yi ! d2gdy2 is an array with the upper triangle of the symmetrix matrix G.Yi.Yj ! reurned in the order: 1,1; 1,2; 1,3; ... ! 2,2; 2,3; ... ! 3,3; ... ! for indexing one can use the integer function ixsym(i1,i2) implicit none integer(c_int), intent(in), value :: n1 integer(c_int), intent(in), value :: n2 integer(c_int), intent(out) :: n3 real(c_double), intent(out) :: gtp(6) real(c_double), intent(out) :: dgdy(*) real(c_double), intent(out) :: d2gdydt(*) real(c_double), intent(out) :: d2gdydp(*) real(c_double), intent(out) :: d2gdy2(*) type(c_ptr), intent(inout) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) call tqcph1(n1,n2,n3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,ceq) c_ceq = c_loc(ceq) end subroutine c_tqcph1 !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_reset_conditions(cline,c_ceq) bind(c, name='c_reset_conditions') implicit none character(c_char), intent(in) :: cline(24) type(c_ptr), intent(inout) :: c_ceq ! in: current equilibrium !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fstring fstring = c_to_f_string(cline) call c_f_pointer(c_ceq, ceq) call reset_conditions(fstring,ceq) c_ceq = c_loc(ceq) end subroutine c_reset_conditions !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_Change_Status_Phase(phasename,nystat,myval,c_ceq)& bind(c, name='c_Change_Status_Phase') !change the status Fixed or Entered of a phase !PHFIXED=2 !PHENTERED=0 implicit none character(c_char), intent(in) :: phasename(24) integer(c_int), intent(in), value :: nystat real(c_double), intent(in),value :: myval type(c_ptr), intent(inout) :: c_ceq ! in: current equilibrium !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq character(len=24) :: fstring call c_f_pointer(c_ceq, ceq) call c_to_f_str(phasename,fstring) call Change_Status_Phase(fstring,nystat,myval,ceq) c_ceq = c_loc(ceq) 1000 continue return end subroutine c_Change_Status_Phase !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_List_Conditions(c_ceq)& bind(c, name='c_List_Conditions') !change the status Fixed or Entered of a phase !PHFIXED=2 !PHENTERED=0 implicit none type(c_ptr), intent(inout) :: c_ceq ! in: current equilibrium !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq call c_f_pointer(c_ceq, ceq) call list_conditions(6,ceq) c_ceq = c_loc(ceq) 1000 continue return end subroutine c_List_Conditions !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_checktdb(tdbfile)& bind(c, name='c_checktdb') character(kind=c_char), intent(in) :: tdbfile !\end{verbatim} integer:: nel,i character selel(maxel)*2 character(len=:), allocatable :: fstring character(len=:), allocatable :: ext ext='.tdb' fstring = c_to_f_string(tdbfile) call checkdb(fstring,ext,nel,selel) c_nel = nel do i = 1, nel cnames(i) = trim(selel(i)) // c_null_char c_cnam(i) = c_loc(cnames(i)) end do deallocate(fstring) return end subroutine c_checktdb !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_newEquilibrium(ceqname,ieq) bind(c, name='c_newEquilibrium') character(kind=c_char), intent(in) :: ceqname integer(c_int), intent(out):: ieq !\end{verbatim} character(len=:), allocatable :: fstring fstring = c_to_f_string(ceqname) call enter_equilibrium(fstring,ieq) deallocate(fstring) end subroutine c_newEquilibrium !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_selecteq(ieq,c_ceq) bind(c, name='c_selecteq') integer(c_int), intent(in),value :: ieq type(c_ptr), intent(out) :: c_ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq !call c_f_pointer(c_ceq, ceq) !call selecteq(ieq,ceq) ceq=>eqlista(ieq) c_ceq = c_loc(ceq) nullify(ceq) return end subroutine c_selecteq !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_copy_equilibrium(c_neweq,ceqname,c_ceq) & bind(c, name='c_copy_equilibrium') type(c_ptr), intent(inout) :: c_neweq character(kind=c_char), intent(in) :: ceqname type(c_ptr), intent(in) :: c_ceq !\end{verbatim} character(len=:), allocatable :: fstring type(gtp_equilibrium_data), pointer :: ceq type(gtp_equilibrium_data), pointer :: neweq call c_f_pointer(c_ceq, ceq) fstring = c_to_f_string(ceqname) call copy_equilibrium(neweq,fstring,ceq) c_neweq=c_loc(neweq) deallocate(fstring) nullify(ceq) return end subroutine c_copy_equilibrium !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_set_status_globaldata() bind(c, name='c_set_status_globaldata') !\end{verbatim} ! level of user: beginner, occational, advanced; NOGLOB: no global gridmin calc ! NOMERGE: no merge of gridmin result, ! NODATA: not any data, ! NOPHASE: no phase in system, ! NOACS: no automatic creation of composition set ! NOREMCS: do not remove any redundant unstable composition sets ! NOSAVE: data changed after last save command ! VERBOSE: maximum of listing ! SETVERB: explicit setting of verbose ! SILENT: as little output as possible ! NOAFTEREQ: no manipulations of results after equilibrum calculation ! XGRID: extra dense grid for all phases ! NOPAR: do not run in parallel ! NOSMGLOB do not test global equilibrium at node points ! NOTELCOMP the elements are not the components ! TGRID always check calculated equilibrium with grid minimizer !globaldata%status=ibclr(globaldata%status,GSADV) !globaldata%status=ibclr(globaldata%status,GSNOPAR) !globaldata%status=ibclr(globaldata%status,GSXGRID) globaldata%status=ibclr(globaldata%status,GSNOACS) return end subroutine c_set_status_globaldata !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} integer function c_errors_number() bind(c, name='c_errors_number') !\end{verbatim} c_errors_number=0 if(gx%bmperr.ne.0) then c_errors_number=gx%bmperr endif return end function c_errors_number !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_new_gtp() bind(c, name='c_new_gtp') !\end{verbatim} call new_gtp return end subroutine c_new_gtp !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_tqfree_newyes() bind(c, name='c_tqfree_newyes') integer intv(10) double precision dblv(10) if(allocated(firstash%eqlista)) then write(*,*)' *** Warning, assessment data not removed' endif if(allocated(firstash%eqlista)) deallocate(firstash%eqlista) deallocate(firstash) call new_gtp call init_gtp(intv,dblv) call deallocate_gtp(intv,dblv) end subroutine c_tqfree_newyes !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\begin{verbatim} subroutine c_enter_composition_set(iph,ics) & bind(c, name='c_enter_compostion_set') implicit none integer(c_int), intent(in),value :: iph integer(c_int), intent(out) :: ics !\end{verbatim} character*4 prefix,suffix prefix=' '; suffix=' ' call enter_composition_set(iph,prefix,suffix,ics) return end subroutine c_enter_composition_set !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! end module liboctqisoc ================================================ FILE: examples/TQ4lib/F90/crfe/TQ1-crfe.F90 ================================================ ! ! The first test program of programming interface LIBOCTQ using Cr-Fe binary ! ! Before compiling this you must first compile to OC program without omp ! Then copy the library file ..\..\..\lib\liboctq.a ! and ..\..\..\liboceqplus.mod ! and ..\liboctq.F90 ! then compile gfortran -c liboctq.F90 ! the compile this file and link with tqoctq.o and liboceq.a ! ! check the file link-tqtest1 ! program octq1 ! use liboctq ! implicit none ! maxel and maxph defined in gtp3 package ! phasetuples is a TYPE(gtp_phasetuples) array with phase numbers integer n,n1,n2,n3,n4,ip,cnum(maxel+3),mm,m2 character filename*60 character condition*60,line*80,statevar*60,quest*60,ch1*1 character target*60,phcsname*24 double precision value,temp,tp(2),mel(maxel) double precision xf(maxel),pxf(10*maxph),npf(maxph),mu(maxel),mus(maxel) double precision tpref(2),dgm(maxph) type(gtp_equilibrium_data), pointer :: ceq ! DUMMY target for on-line help reference character :: dummy*10=' ' ! ! initiate call tqini(n,ceq) if(gx%bmperr.ne.0) goto 1000 ! ! read database file filename='crfe ' write(*,*)'Reading all elements from the database file: ',trim(filename) call tqrfil(filename,ceq) if(gx%bmperr.ne.0) goto 1000 ! tqrfil enters the number of elements in NEL ! and the element names in CNAM ! and the number of phases in NTUP ! ! list elements and phases write(*,10)nel,(cnam(n)(1:2),n=1,nel) 10 format(/'System with ',i2,' elements: ',10(a,', ')) write(*,12,advance='no')ntup 12 format('and ',i3,' phases: ') ! list the phase names using the tuple index do n=1,ntup call tqgpn(n,phcsname,ceq) if(gx%bmperr.ne.0) goto 1000 write(*,20,advance='no')trim(phcsname) 20 format(a,', ') enddo write(*,*) ! ! set default values of temperature and pressure tp(1)=8.0D2 tp(2)=1.0D5 do n=1,nel xf(n)=0.5D0/dble(nel) enddo ! ! ask for conditions using the command line user interface (CUI) 100 continue write(*,105) 105 format(/'Give conditions:') ip=len(line) temp=tp(1) ! old version of question routine ! call gparrd('Temperature (K): ',line,ip,tp(1),temp,nohelp) call gparrdx('Temperature (K): ',line,ip,tp(1),temp,dummy) if(buperr.ne.0) goto 1000 if(tp(1).lt.1.0d0) then write(*,*)'Temperature must be larger than 1 K' tp(1)=1.0D0 endif temp=tp(2) call gparrdx('Pressure (Pa): ',line,ip,tp(2),temp,dummy) if(buperr.ne.0) goto 1000 if(tp(2).lt.1.0d0) then write(*,*)'Pressure must be larger than 1 Pa' tp(2)=1.0D0 endif do n=1,nel-1 quest='Mole fraction of '//trim(cnam(n))//':' temp=xf(n) call gparrdx(quest,line,ip,xf(n),temp,dummy) if(buperr.ne.0) goto 1000 if(xf(n).lt.1.0d-6) then write(*,*)'Fraction set to 1.0D-6' xf(n)=1.0D-6 elseif(xf(n).ge.1.0d0) then write(*,*)'Fraction set to 0.999999D0' xf(n)=0.999999D0 endif enddo ! ------------------------------------- ! set conditions in OC for the calculation n1=0 n2=0 condition='T' call tqsetc(condition,n1,n2,tp(1),cnum(1),ceq) if(gx%bmperr.ne.0) goto 1000 condition='P' call tqsetc(condition,n1,n2,tp(2),cnum(2),ceq) if(gx%bmperr.ne.0) goto 1000 condition='N' call tqsetc(condition,n1,n2,one,cnum(3),ceq) if(gx%bmperr.ne.0) goto 1000 do n=1,nel-1 condition='X' call tqsetc(condition,n,n2,xf(n),cnum(3+n),ceq) if(gx%bmperr.ne.0) goto 1000 enddo ! ! set reference state for the elements (components) to BCC at current T do n=1,nel phcsname='BCC_A2' tpref(1)=-one tpref(2)=1.0D5 call tqcref(n,phcsname,tpref,ceq) if(gx%bmperr.ne.0) goto 600 enddo ! ! calculate the equilibria ! n1=0 means call grid minimizer target=' ' n1=0 n2=0 call tqce(target,n1,n2,value,ceq) if(gx%bmperr.ne.0) then write(*,310)gx%bmperr,bmperrmess(gx%bmperr) 310 format('Calculation failed, error code: ',i5/a) gx%bmperr=0; goto 600 else write(*,320) 320 format(/'Successful calculation') endif ! !------------------------------------------------ ! list some results using TQ routines ! amount and DGM of all phases statevar='NP' n1=-1 n2=0 ! n3 is set to the dimension of npf ! it is changed inside tqgetv to the number of values set ! for this case n3 is set to the number of phase tuples ! note that this can change if new composition set has been created n3=size(npf) call tqgetv(statevar,n1,n2,n3,npf,ceq) if(gx%bmperr.ne.0) goto 1000 ! list DGM for all phases statevar='DGM ' call tqgetv(statevar,n1,n2,n3,dgm,ceq) if(gx%bmperr.ne.0) then write(*,*)'Error extrating DGM',gx%bmperr goto 1000 endif ! here n3 is the number of phase tuples! write(*,502) 502 format('Tuple index Phase name Amount DGM') do n=1,n3 call tqgpn(n,phcsname,ceq) if(gx%bmperr.ne.0) goto 600 write(*,505)n,phcsname,npf(n),dgm(n) 505 format(i3,10x,a,2x,2(1pe12.4)) enddo !------------------------------------------------ ! composition of stable phases ! NOTE that the number of phases may have changed if new composition sets ! created. n3 from previous call is current number of phase tuples ntup=n3 phloop: do n=1,ntup if(npf(n).gt.zero) then ! the phase is stable if it has a positive amount ... it can be stable with 0 call tqgpn(n,phcsname,ceq) if(gx%bmperr.ne.0) goto 600 write(*,510)trim(phcsname),npf(n) 510 format(/'Stable phase: ',a,', amount: ',1PE12.4,', mole fractions:') ! mole fractions of components in stable phase, n2=-1 means all fractions statevar='X' n2=-1 n4=size(pxf) ! Use phase tuple index: n call tqgetv(statevar,n,n2,n4,pxf,ceq) if(gx%bmperr.ne.0) goto 1000 ! write 3 fractions on each line write(*,520)(cnam(m2)(1:8),pxf(m2),m2=1,n4) 520 format(3(a,': ',F9.6,', ')) endif enddo phloop ! chemical potentials write(*,525) 525 format(/'Component, mole fraction, chemical potential (SER) BCC') statevar='X' n=-1 n2=0 n4=size(pxf) call tqgetv(statevar,n,n2,n4,pxf,ceq) if(gx%bmperr.ne.0) goto 1000 ! mus is the chemical potential relative to SER statevar='MUS' n4=size(mus) call tqgetv(statevar,n,n2,n4,mus,ceq) if(gx%bmperr.ne.0) goto 1000 ! mu is the chemival potential relative to user defined reference state statevar='MU' n4=size(mu) call tqgetv(statevar,n,n2,n4,mu,ceq) if(gx%bmperr.ne.0) goto 1000 do n=1,nel write(*,530)cnam(n)(1:2),pxf(n),mus(n),mu(n) 530 format(a,10x,F10.6,10x,2(1PE16.6)) enddo ! Some examples of using tqgetv write(*,*) write(*,*)'Mole fractions of all components in all stable phases:' n4=size(pxf) statevar='X(*,*) ' call tqgetv(statevar,-1,-1,n4,pxf,ceq) write(*,540)' X(*,*): ',(pxf(ip),ip=1,n4) 540 format(a,10F7.4) write(*,*)'Mole fraction of a component in all stable phases (unstable 0):' write(*,*)'in phase tuple order!' n4=size(pxf) statevar='X(*,CR) ' call tqgetv(statevar,-1,1,n4,pxf,ceq) write(*,540)' X(*,CR): ',(pxf(ip),ip=1,n4) ! for debugging also list results as OC call tqlr(kou,ceq) ! ! ask if more calculations of same system 600 continue write(*,*) ip=len(line) call gparcdx('Any more calculations?',line,ip,1,ch1,'N',dummy) if(ch1.ne.'N') then ! set silent! write(*,*)'Turning on silent mode, less output from OC' call tqquiet(.TRUE.) goto 100 endif ! ! end of program 1000 continue if(gx%bmperr.ne.0) then if(gx%bmperr.ge.4000 .and. gx%bmperr.le.4399) then write(*,1010)gx%bmperr,bmperrmess(gx%bmperr) 1010 format(' *** Error ',i5/a) else write(*,1020)gx%bmperr 1020 format(' *** Error ',i5/'Unknown reason') endif endif write(*,*) write(*,*)'A bientot!' end program octq1 ================================================ FILE: examples/TQ4lib/F90/crfe/crfe.TDB ================================================ $ Database file written 2012- 9- 7 $ From database: SSOL2 ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01! ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T) +.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2.18000E+03 Y -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6.00000E+03 N ! FUNCTION GPCRLIQ 2.98150E+02 +YCRLIQ#*EXP(ZCRLIQ#); 6.00000E+03 N ! FUNCTION GFELIQ 2.98150E+02 +12040.17-6.55843*T-3.6751551E-21*T**7 +GHSERFE#; 1.81100E+03 Y -10839.7+291.302*T-46*T*LN(T); 6.00000E+03 N ! FUNCTION GPFELIQ 2.98150E+02 +YFELIQ#*EXP(ZFELIQ#); 6.00000E+03 N ! FUNCTION GPCRBCC 2.98150E+02 +YCRBCC#*EXP(ZCRBCC#); 6.00000E+03 N ! FUNCTION GHSERFE 2.98150E+02 +1225.7+124.134*T-23.5143*T*LN(T) -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6.00000E+03 N ! FUNCTION GPFEBCC 2.98150E+02 +YFEBCC#*EXP(ZFEBCC#); 6.00000E+03 N ! FUNCTION GCRFCC 2.98150E+02 +7284+.163*T+GHSERCR#; 6.00000E+03 N ! FUNCTION GFEFCC 2.98150E+02 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2 +GHSERFE#; 1.81100E+03 Y -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6.00000E+03 N ! FUNCTION GPFEFCC 2.98150E+02 +YFEFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! FUNCTION GPSIG1 2.98150E+02 +1.09E-04*P; 6.00000E+03 N ! FUNCTION GPSIG2 2.98150E+02 +1.117E-04*P; 6.00000E+03 N ! FUNCTION YCRLIQ 2.98150E+02 +VCRLIQ#*EXP(-ECRLIQ#); 6.00000E+03 N ! FUNCTION ZCRLIQ 2.98150E+02 +1*LN(XCRLIQ#); 6.00000E+03 N ! FUNCTION YFELIQ 2.98150E+02 +VFELIQ#*EXP(-EFELIQ#); 6.00000E+03 N ! FUNCTION ZFELIQ 2.98150E+02 +1*LN(XFELIQ#); 6.00000E+03 N ! FUNCTION YCRBCC 2.98150E+02 +VCRBCC#*EXP(-ECRBCC#); 6.00000E+03 N ! FUNCTION ZCRBCC 2.98150E+02 +1*LN(XCRBCC#); 6.00000E+03 N ! FUNCTION YFEBCC 2.98150E+02 +VFEBCC#*EXP(-EFEBCC#); 6.00000E+03 N ! FUNCTION ZFEBCC 2.98150E+02 +1*LN(XFEBCC#); 6.00000E+03 N ! FUNCTION YFEFCC 2.98150E+02 +VFEFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! FUNCTION ZFEFCC 2.98150E+02 +1*LN(XFEFCC#); 6.00000E+03 N ! FUNCTION VCRLIQ 2.98150E+02 +7.653E-06*EXP(ACRLIQ#); 6.00000E+03 N ! FUNCTION ECRLIQ 2.98150E+02 +1*LN(CCRLIQ#); 6.00000E+03 N ! FUNCTION XCRLIQ 2.98150E+02 +1*EXP(.8*DCRLIQ#)-1; 6.00000E+03 N ! FUNCTION VFELIQ 2.98150E+02 +6.46677E-06*EXP(AFELIQ#); 6.00000E+03 N ! FUNCTION EFELIQ 2.98150E+02 +1*LN(CFELIQ#); 6.00000E+03 N ! FUNCTION XFELIQ 2.98150E+02 +1*EXP(.8484467*DFELIQ#)-1; 6.00000E+03 N ! FUNCTION VCRBCC 2.98150E+02 +7.188E-06*EXP(ACRBCC#); 6.00000E+03 N ! FUNCTION ECRBCC 2.98150E+02 +1*LN(CCRBCC#); 6.00000E+03 N ! FUNCTION XCRBCC 2.98150E+02 +1*EXP(.8*DCRBCC#)-1; 6.00000E+03 N ! FUNCTION VFEBCC 2.98150E+02 +7.042095E-06*EXP(AFEBCC#); 6.00000E+03 N ! FUNCTION EFEBCC 2.98150E+02 +1*LN(CFEBCC#); 6.00000E+03 N ! FUNCTION XFEBCC 2.98150E+02 +1*EXP(.7874195*DFEBCC#)-1; 6.00000E+03 N ! FUNCTION VFEFCC 2.98150E+02 +6.688726E-06*EXP(AFEFCC#); 6.00000E+03 N ! FUNCTION EFEFCC 2.98150E+02 +1*LN(CFEFCC#); 6.00000E+03 N ! FUNCTION XFEFCC 2.98150E+02 +1*EXP(.8064454*DFEFCC#)-1; 6.00000E+03 N ! FUNCTION ACRLIQ 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N ! FUNCTION CCRLIQ 2.98150E+02 3.72E-11; 6.00000E+03 N ! FUNCTION DCRLIQ 2.98150E+02 +1*LN(BCRLIQ#); 6.00000E+03 N ! FUNCTION AFELIQ 2.98150E+02 +1.135E-04*T; 6.00000E+03 N ! FUNCTION CFELIQ 2.98150E+02 +4.22534787E-12+2.71569924E-14*T; 6.00000E+03 N ! FUNCTION DFELIQ 2.98150E+02 +1*LN(BFELIQ#); 6.00000E+03 N ! FUNCTION ACRBCC 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N ! FUNCTION CCRBCC 2.98150E+02 2.08E-11; 6.00000E+03 N ! FUNCTION DCRBCC 2.98150E+02 +1*LN(BCRBCC#); 6.00000E+03 N ! FUNCTION AFEBCC 2.98150E+02 +2.3987E-05*T+1.2845E-08*T**2; 6.00000E+03 N ! FUNCTION CFEBCC 2.98150E+02 +2.20949565E-11+2.41329523E-16*T; 6.00000E+03 N ! FUNCTION DFEBCC 2.98150E+02 +1*LN(BFEBCC#); 6.00000E+03 N ! FUNCTION AFEFCC 2.98150E+02 +7.3097E-05*T; 6.00000E+03 N ! FUNCTION CFEFCC 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; 6.00000E+03 N ! FUNCTION DFEFCC 2.98150E+02 +1*LN(BFEFCC#); 6.00000E+03 N ! FUNCTION BCRLIQ 2.98150E+02 +1+4.65E-11*P; 6.00000E+03 N ! FUNCTION BFELIQ 2.98150E+02 +1+4.98009787E-12*P+3.20078924E-14*T*P; 6.00000E+03 N ! FUNCTION BCRBCC 2.98150E+02 +1+2.6E-11*P; 6.00000E+03 N ! FUNCTION BFEBCC 2.98150E+02 +1+2.80599565E-11*P+3.06481523E-16*T*P; 6.00000E+03 N ! FUNCTION BFEFCC 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; 6.00000E+03 N ! FUNCTION UN_ASS 298.15 0; 300 N ! TYPE_DEFINITION % SEQ *! DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! PHASE LIQUID:L % 1 1.0 ! CONSTITUENT LIQUID:L :CR,FE : ! PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T +2.37615E-21*T**7+GHSERCR#+GPCRLIQ#; 2.18000E+03 Y +18409.36-8.563683*T+2.88526E+32*T**(-9)+GHSERCR#+GPCRLIQ#; 6.00000E+03 N REF283 ! PARAMETER G(LIQUID,FE;0) 2.98150E+02 +GFELIQ#+GPFELIQ#; 6.00000E+03 N REF283 ! PARAMETER G(LIQUID,CR,FE;0) 2.98150E+02 -14550+6.65*T; 6.00000E+03 N REF107 ! TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! PHASE BCC_A2 %& 2 1 3 ! CONSTITUENT BCC_A2 :CR%,FE% : VA% : ! PARAMETER G(BCC_A2,CR:VA;0) 2.98150E+02 +GHSERCR#+GPCRBCC#; 6.00000E+03 N REF283 ! PARAMETER TC(BCC_A2,CR:VA;0) 2.98150E+02 -311.5; 6.00000E+03 N REF281 ! PARAMETER BMAGN(BCC_A2,CR:VA;0) 2.98150E+02 -.01; 6.00000E+03 N REF281 ! PARAMETER G(BCC_A2,FE:VA;0) 2.98150E+02 +GHSERFE#+GPFEBCC#; 6.00000E+03 N REF283 ! PARAMETER TC(BCC_A2,FE:VA;0) 2.98150E+02 1043; 6.00000E+03 N REF281 ! PARAMETER BMAGN(BCC_A2,FE:VA;0) 2.98150E+02 2.22; 6.00000E+03 N REF281 ! PARAMETER G(BCC_A2,CR,FE:VA;0) 2.98150E+02 +20500-9.68*T; 6.00000E+03 N REF107 ! PARAMETER TC(BCC_A2,CR,FE:VA;0) 2.98150E+02 1650; 6.00000E+03 N REF107 ! PARAMETER TC(BCC_A2,CR,FE:VA;1) 2.98150E+02 550; 6.00000E+03 N REF107 ! PARAMETER BMAGN(BCC_A2,CR,FE:VA;0) 2.98150E+02 -.85; 6.00000E+03 N REF107 ! TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! PHASE FCC_A1 %' 2 1 1 ! CONSTITUENT FCC_A1 :CR,FE% : VA% : ! PARAMETER G(FCC_A1,CR:VA;0) 2.98150E+02 +GCRFCC#+GPCRBCC#; 6.00000E+03 N REF281 ! PARAMETER TC(FCC_A1,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N REF281 ! PARAMETER BMAGN(FCC_A1,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N REF281 ! PARAMETER G(FCC_A1,FE:VA;0) 2.98150E+02 +GFEFCC#+GPFEFCC#; 6.00000E+03 N REF283 ! PARAMETER TC(FCC_A1,FE:VA;0) 2.98150E+02 -201; 6.00000E+03 N REF281 ! PARAMETER BMAGN(FCC_A1,FE:VA;0) 2.98150E+02 -2.1; 6.00000E+03 N REF281 ! PARAMETER G(FCC_A1,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; 6.00000E+03 N REF107 ! PARAMETER G(FCC_A1,CR,FE:VA;1) 2.98150E+02 1410; 6.00000E+03 N REF107 ! PHASE SIGMA % 3 8 4 18 ! CONSTITUENT SIGMA :FE : CR : CR,FE : ! PARAMETER G(SIGMA,FE:CR:CR;0) 2.98150E+02 +8*GFEFCC#+22*GHSERCR#+92300 -95.96*T+GPSIG1#; 6.00000E+03 N REF107 ! PARAMETER G(SIGMA,FE:CR:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# +18*GHSERFE#+117300-95.96*T+GPSIG2#; 6.00000E+03 N REF107 ! LIST_OF_REFERENCES NUMBER SOURCE REF283 'Alan Dinsdale, SGTE Data for Pure Elements, Calphad Vol 15(1991) p 317-425, also in NPL Report DMA(A)195 Rev. August 1990' REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 September 1989' REF107 'J-O Andersson, B. Sundman, CALPHAD Vol 11, (1987), p 83-92 TRITA 0270 (1986); CR-FE' ! ================================================ FILE: examples/TQ4lib/F90/crfe/link-tqtest1 ================================================ REM command file to cretate test program 1 for OCASI/TQ REM Either execute the commands below interactivly or rename REM this file with extention .cmd and execute it REM YOU MUST HAVE COMPILED AND LINKED THE MAIN OC PROGRAM REM The copy commands assume you are on the directory REM TQ4lib/F90/test1 REM and have the main program three directories up REM as when you downloaded the zip file with the program copy ..\..\..\..\libs\liboceq.a . copy ..\..\..\..\liboceqplus.mod . copy ..\liboctq.F90 . gfortran -c liboctq.F90 gfortran -o tqex1 TQ1-crfe.F90 liboctq.o liboceq.a ================================================ FILE: examples/TQ4lib/F90/crfe/readme-tq1.tex ================================================ \documentclass[12pt]{article} \textwidth 165mm \textheight 210mm \oddsidemargin 1mm \evensidemargin 1mm \topmargin 1mm \usepackage[latin1]{inputenc} \begin{document} \begin{center} {\Large \bf Example 1 using OC-TQ: Calculations in the binary Cr-Fe system with a miscibility gap in the bcc phase } \bigskip Bo Sundman \today \end{center} This is an example for the Fortran OCTQ interface. The example is based on the TQ standard for interfacing thermodynamic software with application software. A more extensive interface called OpenCalphad Application Software Interface (OCASI) is under development. If you are not familiar with compiling and linking software and do not understand the intructions here please ask some guru close to you for help. The instructions here are very brief but I do not have time to answer questions about how to compile and link software. If you find errors you are welcome to report them. To link this example you must first install the OC main program. This installation generates two files you need: {\bf liboceq.a} and {\bf liboceqplus.mod}. Both of these files are needed for these applications. You also need the {\bf liboctq.F90} source code which is on the directory above. \bigskip {\bf Files on this directory:} \begin{itemize} \item crfe.TDB is a small database in the TDB format. \item link-tqtest1 is a text file without extention which you can use as command file a on Windows system if you add the extention .cmd and execute it a batch file in a terminal window (or if you double click on it). If you use LINUX you have to edit it to create a Makefile or give the corresponing commands interactively. In the link-tqtest1 file there are some additional comments and instructions. If you do not understand these instruction please ask a local guru for help. \item readme-tq1.pdf is this file. \item readme-tql.tex is a LaTeX file to generate this pdf file. \item TQ1-crfe.F90 is the test1 program written in Fortran95/08. \end{itemize} \newpage {\bf Compiling and linking the test program} \bigskip When you have executed the link-tqtest1 file in a terminal window (or the corresponding Makefile) you should have a program called tqtest1.exe. The linking below assumes that the OC main program and the corresponing libraries will be two directories above this one. The output during compiling and linking will be something like: {\small \begin{verbatim} C:\Users...\TQ4lib\F90\crfe>link-tqtest1 C:\Users...\TQ4lib\F90\crfe>REM command file to cretate test program 1 for OCASI/TQ C:\Users...\TQ4lib\F90\crfe>REM Either execute the commands below interactivly or rename C:\Users...\TQ4lib\F90\crfe>REM this file with extention .cmd and execute it C:\Users...\TQ4lib\F90\crfe>REM YOU MUST HAVE COMPILED AND LINKED THE MAIN OC PROGRAM C:\Users...\TQ4lib\F90\crfe>REM The copy commands assume you are on the directory C:\Users\...\TQ4lib\F90\crfe>REM TQ4lib/F90/test1 C:\Users\...\TQ4lib\F90\crfe>REM and have the main program three directories up C:\Users\...\TQ4lib\F90\crfe>REM as when you downloaded the zip file with the program C:\Users\...\TQ4lib\F90\crfe>copy ..\..\..\liboceq.a . 1 file(s) copied. C:\Users\...\TQ4lib\F90\crfe>copy ..\..\..\liboceqplus.mod . 1 file(s) copied. C:\Users\...\TQ4lib\F90\crfe>REM copy ..\ftinyopen-dummy.F90 . C:\Users\...\TQ4lib\F90\crfe>copy ..\liboctq.F90 . 1 file(s) copied. C:\Users\...\TQ4lib\F90\crfe>REM gfortran -c ftinyopen-dummy.F90 C:\Users\...\TQ4lib\F90\crfe>gfortran -c liboctq.F90 C:\Users\...\TQ4lib\F90\crfe>gfortran -o tqex1 TQ1-crfe.F90 liboctq.o liboceq.a C:\Users\...\TQ4lib\F90\crfe> \end{verbatim} } \newpage \bigskip {\bf Running the test program} \bigskip When you execute this program in a terminal window you have to answer some questions. If you just press RETURN at the questions the default value (given within slashes //) will be take. This example calls a routine TQLR in the TQ interface which generates a listing of the claculated equilibrium and is mainly intended for debugging. Depending on your input you should obtain an output similar to the text below. Comment are inserted in {\em italics}. {\small \begin{verbatim} C:\Users\..\TQ4lib\F90\crfe>tqex1 tqini created: DEFAULT_EQUILIBRIUM Reading all elements from the database file: crfe System with 2 elements: CR, FE, and 4 phases: LIQUID, BCC_A2, FCC_A1, SIGMA, \end{verbatim} } {\em The output above is generated by the tq\_init subroutine and the test program. Below you can accept the default values of T, P and the mole fractions of Cr by just pressing return. The output after giving the mole fraction is generated by the OC minimizer just for information.} {\small \begin{verbatim} Give conditions: Temperature (K): /800/: Pressure (Pa): /100000/: Mole fraction of CR: /0.25/: 3Y total gridpoints: 128 3Y Constitution of metastable phases set Gridmin: 128 points 0.00E+00 s and 0 clockcycles, T= 800.00 Equilibrium result:: 9 its, 0.0000E+00 s, 0 cc, G= -2.9963780E+04 J/mol Successful calculation Tuple index Phase name Amount 1 LIQUID 0.0000 2 BCC_A2 0.8302 3 FCC_A1 0.0000 4 SIGMA 0.1698 Stable phase: BCC_A2, amount: 8.3018E-01, mole fractions: CR : 0.197577, FE : 0.802423, Stable phase: SIGMA, amount: 1.6982E-01, mole fractions: CR : 0.506278, FE : 0.493722, Component, mole fraction, chemical potential (SER) BCC CR 0.250000 -2.716211E+04 -1.024353E+03 FE 0.750000 -3.089767E+04 -9.918059E+02 \end{verbatim} } {\em The test program first writes a list of all phases and their amount, then again for each stable phase the amount and molefractions in each phase. Finally the the components are listed with their amount and their chemical potential referred to SER (the stable state at 298.15~K and 1 bar) and referred to BCC at the current T and 1 bar. The following output is provided by the subroutine TQLR which writes the same things (and a little more) using the standard way in OC. This can be used as a easy way to check your own output.} {\small \begin{verbatim} ******************** Start debug output from TQLR: 1:T=800, 2:P=100000, 3:N=1, 4:X(CR)=0.25 Degrees of freedom are 0 T= 800.00 K ( 526.85 C), P= 1.0000E+05 Pa, V= 6.6465E-06 m3 N= 1.0000E+00 moles, B= 5.4884E+01 g, RT= 6.6516E+03 J/mol G= -2.9964E+04 J, G/N= -2.9964E+04 J/mol, H= 1.9289E+04 J, S= 6.1566E+01 J/K Component name Moles Mole-fr Chem.pot/RT Activities Ref.state CR 2.5000E-01 0.25000 -1.5400E-01 8.5727E-01 BCC_A2 FE 7.5000E-01 0.75000 -1.4911E-01 8.6148E-01 BCC_A2 Name Status Moles Volume Form.Units Cmp/FU dGm/RT Comp: BCC_A2.................. E 8.302E-01 6.02E-06 8.30E-01 1.00 0.00E+00 X: FE 8.02423E-01 CR 1.97577E-01 SIGMA................... E 1.698E-01 6.23E-07 5.66E-03 30.00 0.00E+00 X: CR 5.06278E-01 FE 4.93722E-01 End debug output from TQLR ******************** \end{verbatim} } {\em The program is then finished but you can calculate again using another T, P and composition. In the case below the calculation is made at 600~K when the system has a miscibility gap in the BCC phase. We also turn on the SILENT mode which means less output from OC.} {\small \begin{verbatim} Any more calculations? /N/: y Turning on silent mode, less output from OC Give conditions: Temperature (K): /800/: 600 Pressure (Pa): /100000/: Mole fraction of CR: /0.25/: Successful calculation Tuple index Phase name Amount 1 LIQUID 0.0000 2 BCC_A2 0.2157 3 FCC_A1 0.0000 4 SIGMA 0.0000 5 BCC_A2_AUTO#2 0.7843 \end{verbatim} } {\em IMPORTANT: Note that there are now 5 phases because a second BCC composition set has been created. The new phase tuple is placed after the inital set of phases. The new BCC phase has the suffix AUTO as it is created automatically by the grid minimizer. It also has the composition set number 2 after the hash character, \#2. The first 5 phases all have a composition set number 1. Using OC interactivly you normally give the composition set number after a hash character but for the first composition set it is not needed. The two composition sets for BCC have exactly the same thermodynamic parameters but the BCC phase can at this temperature be stable with two different compositions. You must be aware of that new composition sets can be created automatically when you use the grid minimizer. Thus the number of phase tuples may change. Although a phase tuple that has been stable at one calculation will never be removed automatically, only explicitly. You can create composition sets manually and add your own pre- and suffix and also a default constitution. Note also the you had no output from the calculation as the silent mode was turned on.} {\small \begin{verbatim} Stable phase: BCC_A2, amount: 2.1567E-01, mole fractions: CR : 0.970535, FE : 0.029465, Stable phase: BCC_A2_AUTO#2, amount: 7.8433E-01, mole fractions: CR : 0.970535, FE : 0.029465, Component, mole fraction, chemical potential (SER) BCC CR 0.250000 -1.718694E+04 -1.364302E+02 FE 0.750000 -1.975398E+04 -2.252379E+02 ******************** Start debug output from TQLR: 1:T=600, 2:P=100000, 3:N=1, 4:X(CR)=0.25 Degrees of freedom are 0 T= 600.00 K ( 326.85 C), P= 1.0000E+05 Pa, V= 7.2044E-06 m3 N= 1.0000E+00 moles, B= 5.4884E+01 g, RT= 4.9887E+03 J/mol G= -1.9112E+04 J, G/N= -1.9112E+04 J/mol, H= 9.3417E+03 J, S= 4.7423E+01 J/K Component name Moles Mole-fr Chem.pot/RT Activities Ref.state CR 2.5000E-01 0.25000 -2.7348E-02 9.7302E-01 BCC_A2 FE 7.5000E-01 0.75000 -4.5150E-02 9.5585E-01 BCC_A2 Name Status Moles Volume Form.Units Cmp/FU dGm/RT Comp: BCC_A2.................. E 2.157E-01 1.57E-06 2.16E-01 1.00 0.00E+00 X: CR 9.70535E-01 FE 2.94648E-02 BCC_A2_AUTO#2........... E 7.843E-01 5.63E-06 7.84E-01 1.00 0.00E+00 X: FE 9.48133E-01 CR 5.18667E-02 End debug output from TQLR ******************** Any more calculations? /N/: Auf wiedersehen C:\Users\...\TQ4lib\F90\crfe> \end{verbatim} } \end{document} {\small \begin{verbatim} \end{verbatim} } \end{verbatim} } {\small \begin{verbatim} ================================================ FILE: examples/TQ4lib/F90/feni/FENI.TDB ================================================ $ Database file written 2014- 1-15 $ From database: SSOL2 ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! ELEMENT NI FCC_A1 5.8690E+01 4.7870E+03 2.9796E+01! FUNCTION GFELIQ 298.15 +12040.17-6.55843*T-3.6751551E-21*T**7 +GHSERFE#; 1.81100E+03 Y -10839.7+291.302*T-46*T*LN(T); 6000 N ! FUNCTION GHSERFE 298.15 +1225.7+124.134*T-23.5143*T*LN(T) -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6000 N ! FUNCTION GNIBCC 298.15 +8715.084-3.556*T+GHSERNI#; 6000 N ! FUNCTION GFEFCC 298.15 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2 +GHSERFE#; 1.81100E+03 Y -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6000 N ! FUNCTION GHSERNI 298.15 -5179.159+117.854*T-22.096*T*LN(T) -.0048407*T**2; 1.72800E+03 Y -27840.655+279.135*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 3.00000E+03 N ! FUNCTION GPFELIQ 298.15 7E-6*P; 6000 N ! FUNCTION GPFEFCC 298.15 5E-6*P; 6000 N ! FUNCTION GPFEBCC 298.15 6E-6*P; 6000 N ! FUNCTION GPNILIQ 298.15 8E-6*P; 6000 N ! FUNCTION GPNIFCC 298.15 6E-6*P; 6000 N ! FUNCTION GPNIBCC 298.15 7E-6*P; 6000 N ! $ this is 1/RT FUNCTION IQRT 298.15 0.12027167*T**(-1); 6000 N ! TYPE_DEFINITION % SEQ *! DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! PHASE LIQUID:L % 1 1.0 ! CONSTITUENT LIQUID:L :FE,NI : ! PARAMETER G(LIQUID,FE;0) 298.15 +GFELIQ#+GPFELIQ#; 6000 N REF283 ! PARAMETER G(LIQUID,NI;0) 298.15 +11235.527+108.457*T -22.096*T*LN(T)-.0048407*T**2-3.82318E-21*T**7+GPNILIQ; 1.72800E+03 Y -9549.775+268.598*T-43.1*T*LN(T)+GPNILIQ; 3.00000E+03 N REF283 ! PARAMETER G(LIQUID,FE,NI;0) 298.15 -18378.86+6.03912*T; 6000 N REF158 ! PARAMETER G(LIQUID,FE,NI;1) 298.15 +9228.1-3.54642*T; 6000 N REF158 ! $ LN(mobilities) PARAMETER MQ&FE(LIQUID,FE;0) 298.15 -10000*IQRT-18; 6000 N BOS ! PARAMETER MQ&FE(LIQUID,NI;0) 298.15 -12000*IQRT-19; 6000 N BOS ! PARAMETER MQ&NI(LIQUID,NI;0) 298.15 -11000*IQRT-18; 6000 N BOS ! PARAMETER MQ&NI(LIQUID,FE;0) 298.15 -13000*IQRT-19; 6000 N BOS ! TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! $ PHASE BCC_A2 %& 2 1 3 ! $ CONSTITUENT BCC_A2 :FE%,NI : VA% : ! PARAMETER G(BCC_A2,FE:VA;0) 298.15 +GHSERFE#+GPFEBCC#; 6000 N REF283 ! PARAMETER TC(BCC_A2,FE:VA;0) 298.15 1043; 6000 N REF281 ! PARAMETER BMAGN(BCC_A2,FE:VA;0) 298.15 2.22; 6000 N REF281 ! PARAMETER G(BCC_A2,NI:VA;0) 298.15 +GNIBCC#+GPNIBCC; 3000 N REF283 ! PARAMETER TC(BCC_A2,NI:VA;0) 298.15 575; 6000 N REF281 ! PARAMETER BMAGN(BCC_A2,NI:VA;0) 298.15 .85; 6000 N REF281 ! PARAMETER G(BCC_A2,FE,NI:VA;0) 298.15 -956.63-1.28726*T; 6000 N REF158 ! PARAMETER G(BCC_A2,FE,NI:VA;1) 298.15 +1789.03-1.92912*T; 6000 N REF158 ! $ LN(mobilities) PARAMETER MQ&FE(BCC_A2,FE:VA;0) 298.15 -20000*IQRT-24; 6000 N BOS ! PARAMETER MQ&FE(BCC_A2,NI:VA;0) 298.15 -22000*IQRT-24; 6000 N BOS ! PARAMETER MQ&NI(BCC_A2,NI:VA;0) 298.15 -25000*IQRT-25; 6000 N BOS ! PARAMETER MQ&NI(BCC_A2,FE:VA;0) 298.15 -28000*IQRT-25; 6000 N BOS ! TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! PHASE FCC_A1 %' 2 1 1 ! CONSTITUENT FCC_A1 :FE%,NI% : VA% : ! PARAMETER G(FCC_A1,FE:VA;0) 298.15 +GFEFCC#+GPFEFCC#; 6000 N REF283 ! PARAMETER TC(FCC_A1,FE:VA;0) 298.15 -201; 6000 N REF281 ! PARAMETER BMAGN(FCC_A1,FE:VA;0) 298.15 -2.1; 6000 N REF281 ! PARAMETER G(FCC_A1,NI:VA;0) 298.15 +GHSERNI#+GPNIFCC; 3000 N REF283 ! PARAMETER TC(FCC_A1,NI:VA;0) 298.15 633; 6000 N REF281 ! PARAMETER BMAGN(FCC_A1,NI:VA;0) 298.15 .52; 6000 N REF281 ! PARAMETER G(FCC_A1,FE,NI:VA;0) 298.15 -12054.355+3.27413*T; 6000 N REF158 ! PARAMETER G(FCC_A1,FE,NI:VA;1) 298.15 +11082.1315-4.45077*T; 6000 N REF158 ! PARAMETER G(FCC_A1,FE,NI:VA;2) 298.15 -725.805174; 6000 N REF158 ! PARAMETER TC(FCC_A1,FE,NI:VA;0) 298.15 2133; 6000 N REF158 ! PARAMETER TC(FCC_A1,FE,NI:VA;1) 298.15 -682; 6000 N REF158 ! PARAMETER BMAGN(FCC_A1,FE,NI:VA;0) 298.15 9.55; 6000 N REF158 ! PARAMETER BMAGN(FCC_A1,FE,NI:VA;1) 298.15 7.23; 6000 N REF158 ! PARAMETER BMAGN(FCC_A1,FE,NI:VA;2) 298.15 5.93; 6000 N REF158 ! PARAMETER BMAGN(FCC_A1,FE,NI:VA;3) 298.15 6.18; 6000 N REF158 ! $ LN(mobilities) PARAMETER MQ&FE(FCC_A1,FE:VA;0) 298.15 -30000*IQRT-30; 6000 N BOS ! PARAMETER MQ&FE(FCC_A1,NI:VA;0) 298.15 -32000*IQRT-32; 6000 N BOS ! PARAMETER MQ&NI(FCC_A1,NI:VA;0) 298.15 -33000*IQRT-32; 6000 N BOS ! PARAMETER MQ&NI(FCC_A1,FE:VA;0) 298.15 -25000*IQRT-31; 6000 N BOS ! LIST_OF_REFERENCES NUMBER SOURCE REF283 'Alan Dinsdale, SGTE Data for Pure Elements, Calphad Vol 15(1991) p 317-425, also in NPL Report DMA(A)195 Rev. August 1990' REF158 'A. Dinsdale, T. Chart, MTDS NPL, unpublished work (1986); FE-NI' REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 September 1989' BOS 'Invented mobilities and molar volumes' ! ================================================ FILE: examples/TQ4lib/F90/feni/TQ2-feni.F90 ================================================ ! second test program of OC-TQ program octq2 ! use liboctq ! implicit none ! maxel and maxph defined in pmod package ! integer, parameter :: maxel=10,maxph=20 integer n,n1,n2,n3,n4,nsel,ip,cnum(maxel+3),mm,m2,phstable,jp,nend,nv,i,zz character filename*60,phnames(maxph)*24 character condition*60,line*80,statevar*60,quest*60,ch1*1 character target*60,selel(2)*2,phcsname*36 double precision value,temp,tp(2),mel(maxel),mf(maxel),volume double precision xf(maxel),pxf(10*maxph),npf(maxph),mu(maxel) type(gtp_phasetuple), pointer :: phtup type(gtp_equilibrium_data), pointer :: ceq double precision mugrad(300),mobilities(20),xknown(20),yarr(20),irt ! for tqgp character xphase(100)*24 integer xstat(100) double precision xdgm(100) ! present the calculation write(*,5) 5 format(/'Calculation of equilibria and mobility data in Fe-Ni system'/& /'Fictitious ln(mobility data) in the TDB file:'/& 'PARAMETER MQ&FE(LIQUID,FE;0) 298.15 -10000*IQRT-18; 6000 N BOS !'/& 'PARAMETER MQ&FE(LIQUID,NI;0) 298.15 -12000*IQRT-19; 6000 N BOS !'/& 'PARAMETER MQ&NI(LIQUID,NI;0) 298.15 -11000*IQRT-18; 6000 N BOS !'/& 'PARAMETER MQ&NI(LIQUID,FE;0) 298.15 -13000*IQRT-19; 6000 N BOS !'/& 'PARAMETER MQ&FE(FCC_A1,FE:VA;0) 298.15 -30000*IQRT-30; 6000 N BOS !'/& 'PARAMETER MQ&FE(FCC_A1,NI:VA;0) 298.15 -32000*IQRT-32; 6000 N BOS !'/& 'PARAMETER MQ&NI(FCC_A1,NI:VA;0) 298.15 -33000*IQRT-32; 6000 N BOS !'/& 'PARAMETER MQ&NI(FCC_A1,FE:VA;0) 298.15 -25000*IQRT-31; 6000 N BOS !'/) ! set some defaults n=0 filename='FENI ' ! initiate call tqini(n,ceq) if(gx%bmperr.ne.0) goto 1000 ! read database file nsel=2 selel(1)='FE' selel(2)='NI' call tqrpfil(filename,nsel,selel,ceq) if(gx%bmperr.ne.0) goto 1000 ! This call store the number of elements and names in the module variables ! nel and cnam. The current number of phase tuples is stored in ntup ! and the phase and compositon set indices in phcs ! NOTE the number of phase tuples can change if new compsets are created ! for example by the grid minimiser. call tqgnp(ntup,ceq) if(gx%bmperr.ne.0) goto 1000 do n=1,ntup call tqgpn(n,phnames(n),ceq) if(gx%bmperr.ne.0) goto 1000 enddo ! ------------------------------------- write(*,10)nel,(cnam(n)(1:2),n=1,nel) 10 format(/'System with ',i2,' elements: ',10(a,', ')) write(*,20)ntup,(phnames(n)(1:len_trim(phnames(n))),n=1,ntup) 20 format('and ',i3,' phases: ',10(a,', ')) ! -------------------------------------- ! list parameters, the output unit, screen is zz=6 call tqltdb ! n=1 ! zz=6 ! call list_many_formats(' ,,,, ',n,1,zz) ! write(*,22) !22 format(/' no more ',/) ! -------------------------------------- ! test tqgpsm ! call tqgpsm(zz,xphase,xstat,xdgm,ceq) ! if(gx%bmperr.ne.0) stop 'error in tqgp' ! do n=1,zz ! write(*,30)n,xphase(n),xstat(n),xdgm(n) ! ! enddo ! set default values tp(1)=1.0D3 tp(2)=1.0D5 do n=1,nel xf(n)=1.0/dble(nel) enddo ! ask for conditions 100 continue write(*,105) 105 format(/'Give conditions:') ip=len(line) temp=tp(1) call gparrdx('Temperature: ',line,ip,tp(1),temp,'dummy') if(buperr.ne.0) goto 1000 if(tp(1).lt.1.0d0) then write(*,*)'Temperature must be larger than 1 K' tp(1)=1.0D0 endif temp=tp(2) call gparrdx('Pressure: ',line,ip,tp(2),temp,'dummy') if(buperr.ne.0) goto 1000 if(tp(2).lt.1.0d0) then write(*,*)'Pressure must be larger than 1 Pa' tp(2)=1.0D0 endif do n=1,nel-1 quest='Mole fraction of '//cnam(n)(1:len_trim(cnam(n)))//':' temp=xf(n) call gparrdx(quest,line,ip,xf(n),temp,'dummy') if(buperr.ne.0) goto 1000 if(xf(n).lt.1.0d-6) then write(*,*)'Fraction must be larger than 1.0D-6' xf(n)=1.0D-6 endif enddo ! ------------------------------------- ! set conditions n1=0 n2=0 condition='T' call tqsetc(condition,n1,n2,tp(1),cnum(1),ceq) if(gx%bmperr.ne.0) goto 1000 condition='P' call tqsetc(condition,n1,n2,tp(2),cnum(2),ceq) if(gx%bmperr.ne.0) goto 1000 condition='N' call tqsetc(condition,n1,n2,one,cnum(3),ceq) if(gx%bmperr.ne.0) goto 1000 do n=1,nel-1 condition='X' call tqsetc(condition,n,n2,xf(n),cnum(3+n),ceq) if(gx%bmperr.ne.0) goto 1000 enddo !-------------------------------------- ! calculate the equilibria target=' ' n1=0 n2=0 call tqce(target,n1,n2,value,ceq) if(gx%bmperr.ne.0) then write(*,310)gx%bmperr,bmperrmess(gx%bmperr) 310 format('Calculation failed, error code: ',i5/a) goto 600 gx%bmperr=0; goto 600 else write(*,320) 320 format(/'Successful calculation') endif !-------------------------------------- ! list some results ! amount of all phases statevar='NP' n1=-1 n2=0 n3=size(npf) call tqgetv(statevar,n1,n2,n3,npf,ceq) if(gx%bmperr.ne.0) goto 1000 write(*,505)n3,(npf(n),n=1,n3) 505 format(/'Amount of ',i2,' phases: ',(10F7.4)) ntup=n3 phloop: do n=1,ntup if(npf(n).gt.zero) then ! the phase is stable if it has a positive amount ... it can be stable with 0 phstable=n call tqgpn(n,phcsname,ceq) write(*,510)trim(phcsname),npf(n) 510 format(/'Stable phase: ',a,', amount: ',1PE12.4,', mole fractions:') ! composition of stable phase, n2=-1 means all fractions statevar='X' n2=-1 n4=size(xknown) call tqgetv(statevar,n,n2,n4,xknown,ceq) if(gx%bmperr.ne.0) goto 1000 write(*,520)(cnam(m2)(1:2),xknown(m2),m2=1,n4) 520 format(3(a,': ',F9.6,', ')) endif enddo phloop ! volume statevar='V' n=0 n2=0 n4=size(pxf) ! first index is phase+compset, second is component, third is dimension call tqgetv(statevar,n,n2,n4,pxf,ceq) if(gx%bmperr.ne.0) goto 1000 write(*,522)pxf(1) 522 format(/'System volume: ',1pe12.4) ! fractions, chemical potentials and mobilities ! irt is 1/(RT) irt=one/(8.31451*tp(1)) write(*,525) 525 format(/'Component, mole fraction, chemical potentials, lnac = mu/RT') do n=1,nel statevar='MU' n2=0 n4=size(pxf) ! n is the componet, n2 is redundant, n4 is size of cpot call tqgetv(statevar,n,n2,n4,pxf,ceq) if(gx%bmperr.ne.0) goto 1000 mu(n)=pxf(1) ! mole fraction statevar='X' call tqgetv(statevar,n,n2,n4,pxf,ceq) if(gx%bmperr.ne.0) goto 1000 mf(n)=pxf(1) write(*,530)cnam(n)(1:8),mf(n),mu(n),mu(n)*irt 530 format(a,2x,F10.6,4x,1PE14.6,7x,E14.6) enddo write(*,540) 540 format(/'LN(mobility of component in phase) and exp(ln(..)):') do n=1,ntup ! mobility MQ&constituent(phase) call tqgpn(n,phcsname,ceq) do n1=1,nel statevar='MQ&'//trim(cnam(n1)) call tqgetv(statevar,n,n1,n4,pxf,ceq) if(gx%bmperr.ne.0) goto 1000 write(*,550)trim(statevar),trim(phcsname),pxf(1),exp(pxf(1)) 550 format(a,'(',a,') = ',2(1PE20.6)) enddo enddo !--------------------------------- ! copied from user i/f phtup=>phasetuple(phstable) write(*,590)phstable 590 format(/'Calculating Darken stability matrix, dG_A/dN_B for phase ',i2,': ') mugrad=zero mobilities=zero ! derivatives of mu and mobilities, the .TRUE. means no output ! xknown is phase composition, mu is chemical potentials, ! nend is number of values returned in mugrad (dG_A/dN_B) call equilph1d(phtup,ceq%tpval,xknown,mu,.TRUE.,nend,mugrad,mobilities,ceq) if(gx%bmperr.ne.0) goto 1000 write(*,2096)nend 2096 format(/'Chemical potential derivative matrix, dG_I/dN_J for ',& i3,' endmembers') write(*,2094)(nv,nv=1,nend) 2094 format(3x,6(6x,i6)/(3x,6i12)) do nv=0,nend-1 ! An extra LF is generated when just 6 components!! write(*,2095)nv+1,(mugrad(nend*nv+jp),jp=1,nend) 2095 format(i3,6(1pe12.4)/(3x,6e12.4)) enddo ! mobilities, same as above write(*,2098)noel() 2098 format(/'LN(mobility) values for',i3,' components') write(*,2095)1,(mobilities(jp),jp=1,noel()) !-------------------------------------- ! testing tqgpsm write(*,2000) 2000 format(/'Testing tqgpsm') call tqgpsm(zz,xphase,xstat,xdgm,ceq) if(gx%bmperr.ne.0) stop 'error in tqgp' do n=1,zz write(*,30)n,xphase(n),xstat(n),xdgm(n) 30 format(i3,2x,a,2x,i3,E12.4) enddo !-------------------------------------- ! loop 600 continue write(*,*) ip=len(line) call gparcdx('Any more calculations?',line,ip,1,ch1,'N','dummy') if(ch1.ne.'N') goto 100 !-------------------------------------- 1000 continue if(gx%bmperr.ne.0) then if(gx%bmperr.ge.4000 .and. gx%bmperr.le.4220) then write(*,1010)gx%bmperr,bmperrmess(gx%bmperr) 1010 format(' *** Error ',i5/a) else write(*,1020)gx%bmperr 1020 format(' *** Error ',i5/'Unknown reason') endif endif write(*,*) write(*,*)'Auf wiedersehen' end program octq2 ================================================ FILE: examples/TQ4lib/F90/feni/linkmake ================================================ REM Copy libraries (compiled without OpenMP) from OC directory copy ..\..\..\..\libs\liboceq.a . REM copy ..\..\..\..\libs\liboceqplus.mod . copy ..\..\..\..\liboceqplus.mod . REM Copy tqlibrary from directory above copy ..\liboctq.F90 . REM Compile and link gfortran -c liboctq.F90 REM if some omp_* rutines are undefined add -fopenmp or recompile liboceq REM using linkmake (without -fopenmp) gfortran -o tqex2 TQ2-feni.F90 liboctq.o liboceq.a ================================================ FILE: examples/TQ4lib/F90/feni/readme.tex ================================================ \documentclass[12pt]{article} \textwidth 165mm \textheight 210mm \oddsidemargin 1mm \evensidemargin 1mm \topmargin 1mm \usepackage[latin1]{inputenc} \begin{document} \begin{center} {\Large \bf Example 2 using OCASI-TQ: Calculations in the binary Fe-Ni system including mobility data } \bigskip Bo Sundman \today \end{center} This is an example for the OCASI Fortran TQ interface. The example is based on the TQ standard for interfacing thermodynamic software with application software. A more extensive interface called OpenCalphad Application Software Interface (OCASI) is under development. If you are not familiar with compiling and linking software and do not understand the intructions here please ask some guru close to you for help. The instructions here are very brief but I do not have time to answer questions about how to compile and link software. If you find errors you are welcome to report them. To link this example you must first install the OC main program. This installation generates two files you need: {\bf liboceq.a} and {\bf liboceqplus.mod}. Both of these files are needed for these applications. You also need the {\bf liboctq.F90} source code which is on the directory above this example. \bigskip {\bf Files on this directory:} \begin{itemize} \item readme.pdf is this file. \item readme.tex is a LaTeX file to generate this pdf file. \item FENI.TDB is a small database in the TDB format. \item TQ2-feni.F90 is the test program written in Fortran95/08. \item linkmake is a text file without extention which you can use as command file a on Windows system if you add the extention .cmd and execute it a batch file in a terminal window (or if you double click on it). If you use LINUX you can edit it to create a Makefile. In the linkmake file there are some additional comments and instructions. If you do not understand these instruction please ask a local guru for help. \end{itemize} \newpage {\bf Compiling and linking the test program} \bigskip When you executing the linkmake file in a terminal window (or the corresponding Makefile) you should have a program called tqtest1.exe. The linking below assumes that the OC main program and the corresponing libraries will be two directories above this one. The output during compiling and linking will be something like: {\small \begin{verbatim} C:\Users\...\TQ4lib\F90\feni>linkmake C:\Users\...\TQ4lib\F90\feni>REM Copy libraries (compiled without OpenMP) from OC directory C:\Users\...\TQ4lib\F90\feni>copy ..\..\..\liboceq.a . 1 fil(er) kopierad(e). C:\Users\...\TQ4lib\F90\feni>copy ..\..\..\liboceqplus.mod . 1 fil(er) kopierad(e). C:\Users\...\TQ4lib\F90\feni>REM Copy tqlibrary from directory above C:\Users\...\TQ4lib\F90\feni>copy ..\liboctq.F90 . 1 fil(er) kopierad(e). C:\Users\...\TQ4lib\F90\feni>REM Compile and link C:\Users\...\TQ4lib\F90\feni>gfortran -c liboctq.F90 C:\Users\...\TQ4lib\F90\feni>gfortran -o tqex2 TQ2-feni.F90 liboctq.o liboceq.a \end{verbatim}} When you run the program it will look like {\small \begin{verbatim} C:\Users\...\TQ4lib\F90\feni>tqex2.exe Calculation of equilibria and mobility data in Fe-Ni system Fictitious mobility data for the liquid in the TDB file: PARAMETER MQ&FE(LIQUID,FE;0) 298.15 -10000*IQRT-18; 6000 N BOS ! PARAMETER MQ&FE(LIQUID,NI;0) 298.15 -12000*IQRT-19; 6000 N BOS ! PARAMETER MQ&NI(LIQUID,NI;0) 298.15 -11000*IQRT-18; 6000 N BOS ! PARAMETER MQ&NI(LIQUID,FE;0) 298.15 -13000*IQRT-19; 6000 N BOS ! PARAMETER MQ&FE(FCC_A1,FE:VA;0) 298.15 -30000*IQRT-30; 6000 N BOS ! PARAMETER MQ&FE(FCC_A1,NI:VA;0) 298.15 -32000*IQRT-32; 6000 N BOS ! PARAMETER MQ&NI(FCC_A1,NI:VA;0) 298.15 -33000*IQRT-32; 6000 N BOS ! PARAMETER MQ&NI(FCC_A1,FE:VA;0) 298.15 -25000*IQRT-31; 6000 N BOS ! tqini created: DEFAULT_EQUILIBRIUM System with 2 elements: FE, NI, and 2 phases: LIQUID, FCC_A1, Give conditions: Temperature: /1000/: Pressure: /100000/: Mole fraction of FE: /0.5/: .3 3Y Composition set(s) created: 1 3Y Gridmin: 16 points 0.00E+00 s and 0 clockcycles, T= 1000.00 Phase change: its/add/remove: 16 0 2 Equilibrium calculation 21 its, 1.5600E-02 s and 15 clockcycles Successful calculation Amount of 2 phases: 0.0000 1.0000 Stable phase: FCC_A1, amount: 1.0000E+00, mole fractions: FE: 0.300000, NI: 0.700000, System volume: 5.7000E-06 Component, mole fraction, chemical potentials, lnac = mu/RT FE 0.300000 -5.569910E+04 -6.699023E+00 NI 0.700000 -4.984943E+04 -5.995474E+00 LN(mobility of component in phase) and exp(ln(..)): MQ&FE(LIQUID) = -2.002412E+01 2.012036E-09 MQ&NI(LIQUID) = -1.974213E+01 2.667485E-09 MQ&FE(FCC_A1) = -3.517653E+01 5.284780E-16 MQ&NI(FCC_A1) = -3.538031E+01 4.310476E-16 Calculating Darken stability matrix, dG_A/dN_B for phase 2: Calculation required 6 its Chemical potential derivative matrix, dG_I/dN_J for 2 endmembers 1 2 1 3.9069E+04 -1.6744E+04 2 -1.6744E+04 7.1759E+03 LN(mobility) values for 2 components 1 -3.5177E+01 -3.5380E+01 Any more calculations? /N/: y Give conditions: Temperature: /1000/: 2000 Pressure: /100000/: Mole fraction of FE: /0.7/: .3 3Y Composition set(s) created: 1 3Y Gridmin: 16 points 0.00E+00 s and 0 clockcycles, T= 2000.00 Phase change: its/add/remove: 5 0 3 Equilibrium calculation 10 its, 1.5600E-02 s and 15 clockcycles Successful calculation Amount of 2 phases: 1.0000 0.0000 Stable phase: LIQUID, amount: 1.0000E+00, mole fractions: FE: 0.300000, NI: 0.700000, System volume: 7.7000E-06 Component, mole fraction, chemical potentials, lnac = mu/RT FE 0.300000 -1.504170E+05 -9.045449E+00 NI 0.700000 -1.343949E+05 -8.081949E+00 LN(mobility of component in phase) and exp(ln(..)): MQ&FE(LIQUID) = -1.938555E+01 3.810336E-09 MQ&NI(LIQUID) = -1.899758E+01 5.616396E-09 MQ&FE(FCC_A1) = -3.327521E+01 3.538017E-15 MQ&NI(FCC_A1) = -3.353104E+01 2.739401E-15 Calculating Darken stability matrix, dG_A/dN_B for phase 1: Calculation required 6 its Chemical potential derivative matrix, dG_I/dN_J for 2 endmembers 1 2 1 4.7487E+04 -2.0351E+04 2 -2.0351E+04 8.7221E+03 LN(mobility) values for 2 components 1 -1.9386E+01 -1.8998E+01 Any more calculations? /N/: Auf wiedersehen C:\Users\...\TQ4lib\F90\feni> \end{verbatim}} \end{document} ================================================ FILE: examples/TQ4lib/F90/liboctq.F90 ================================================ ! ! Minimal TQ interface. ! ! To compile and link this with an application one must first compile ! and form a library with of the most OC subroutines (lib\liboceq.a) ! and copy this and the corresponding "liboceqplus.mod" file ! from this compilation to the folder with this library ! ! NOTE that for the identification of phase and composition sets this ! TQ interface use a Fortran TYPE called gtp_phasetuple containing two ! integers, "phase" with the phase number and "compset" with the ! comp.set The number of phase tuples is initially equal to the number ! of phases and have the same index. This represent comp.set 1 of the ! phases as each phase has just one composition set. A phase may have ! several comp.sets created by calculations or by commands and these will ! have phase tuple index higher than the number of phases and their index ! is in the order of which they were created. ! This may cause some problems if composition sets are deleted because that ! will change the phase tuple index for those with higher index. So do not ! delete comp.sets or at least be very careful when deleting comp.sets ! ! 210328 BOS Tested ! 191101 BOS Updates some routines and added two dummy modules for C routines ! 181030 BOS Updates some routines ! 150520 BOS added a few subroutines for single phase data and calculations ! 141210 BOS changed to use phase tuples ! 140128 BOS added D2G and phase specific V and G ! 140128 BOS added possibility to calculate without invoking grid minimizer ! 140125 BOS Changed name to liboctq ! 140123 BOS Added ouput of MQ G, V and normalized !------------------------------------------------------------ ! subroutines and functions ! tqini ok initiate ! tqrfil ok read a database file ! tqrpfil ok read specified elements from database file ! ------------------------- ! tqgcom ok get number of system components and their names ! tqgnp ok get number of phase tuples (phases and comp. sets) ! tqgpn ok get name of phase tuple ! tqgpi ok get phase tuple index of phase using its name ! tqgpcn - get name of constituent of a phase using index ! tqgpci - get index of constituent of a phase using name ! tqgpcs - get stoichiometry of species as system components ! tqgccf - get stoichiometry of system component as elements ! tqgnpc - get number of constituents in phase ! tqgp + get all phase names and status ! ------------------------- ! tqcref - set reference state for component ! tqphsts ok set status of phase tuple ! tqsetc ok set condition ! tqce ok calculate equilibrium ! tqgetv ok get equilibrium results as state variable values ! ------------------------- ! tqgphc1 ok get phase constitution ! tqsphc1 ok set phase constitution ! tqcph1 ok calculate phase properties and return arrays ! tqcph2 ok calculate phase properties and return index ! tqdceq ok delete equilibrium record ! tqcceq ok copy current equilibrium to a new one ! tqselceq ok select new current equilibrium ! tqlr ok list results ! tqlc ok list conditions ! tqltdb ok list TDB file ! !------------------------------------------------------------ ! ! The name of this library module liboctq ! ! access to main OC library for equilibrium calculations and models use liboceqplus ! implicit none ! integer, parameter :: maxc=maxel,maxp=maxph ! ! This is for storage and use of components integer nel character, dimension(maxc) :: cnam*24 ! Number of phase tuples integer ntup ! use the array PHASETUPLE available from OC ! save phase constitution to speed up calculation by interpolation double precision, allocatable, dimension(:,:) :: ysave ! contains ! !\begin{verbatim} subroutine tqini(n,ceq) ! initiate workspace implicit none integer n ! Not nused, could be used for some initial allocation type(gtp_equilibrium_data), pointer :: ceq ! EXIT: current equilibrium !\end{verbatim} ! these should be provide linits and defaults integer intv(10) double precision dblv(10) intv(1)=-1 ! This call initiates the OC package !@CC if (allocated(eqlista)) then call new_gtp endif call init_gtp(intv,dblv) !@CC ceq=>firsteq write(*,*)'tqini created: ',ceq%eqname 1000 continue return end subroutine tqini !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqrfil(filename,ceq) ! read all elements from a TDB file implicit none character*(*) filename ! IN: database filename character ellista(10)*2 ! dummy type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} %+ integer iz character elname*2,name*24,refs*24 double precision a1,a2,a3 ! second argument 0 means ellista is ignored, all element read call readtdb(filename,0,ellista) ! ceq=>firsteq nel=noel() do iz=1,nel ! store the element name in the cname array call get_element_data(iz,elname,name,refs,a1,a2,a3) cnam(iz)=elname enddo ! store phase tuples ntup=nooftup() 1000 continue return end subroutine tqrfil !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} %- subroutine tqrpfil(filename,nsel,selel,ceq) ! read TDB file with selection of elements implicit none character*(*) filename ! IN: database filename integer nsel character selel(*)*2 ! IN: elements to be read from the database type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} integer iz character elname*2,name*24,refs*24 double precision a1,a2,a3 ! call readtdb(filename,nsel,selel) if(gx%bmperr.ne.0) goto 1000 ! is this really necessary?? ! ceq=>firsteq nel=noel() do iz=1,nel ! store element name in module array components call get_element_data(iz,elname,name,refs,a1,a2,a3) cnam(iz)=elname enddo ! store phase tuples and indices ntup=nooftup() 1000 continue return end subroutine tqrpfil !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgcom(n,compnames,ceq) ! get system component names. At present the elements implicit none integer n ! EXIT: number of components character*24, dimension(*) :: compnames ! EXIT: names of components type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} integer iz character elname*24,refs*24 double precision a1,a2,a3 do iz=1,nel compnames(iz)=' ' call get_element_data(iz,compnames(iz),elname,refs,a1,a2,a3) ! store name in module array components also (already done when reading TDB) cnam(iz)=compnames(iz) enddo n=nel 1000 continue return end subroutine tqgcom !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgnp(n,ceq) ! get total number of phase tuples (phases and composition sets) ! A second composition set of a phase is normally placed after all other ! phases with one composition set implicit none integer n !EXIT: n is number of phases type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} ! NOTE the number composition sets may change at a calculation or if new ! composition sets are added or deleted explicitly ! This changes the number of phase tuples! ntup=nooftup() n=ntup 1000 continue return end subroutine tqgnp !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgpn(phtupx,phasename,ceq) ! get name of phase tuple with index phtupx (ceq redundant) implicit none integer phtupx ! IN: index in phase tuple array character phasename*(*) !EXIT: phase name, max 24+8 for pre/suffix type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} call get_phasetup_name(phtupx,phasename) 1000 continue return end subroutine tqgpn !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgpi(phtupx,phasename,ceq) ! get index of phase phasename (including comp.set (ceq redundant) implicit none integer phtupx !EXIT: phase tuple index character phasename*(*) !IN: phase name type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} call find_phasetuple_by_name(phasename,phtupx) 1000 continue return end subroutine tqgpi !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgpcn2(n,c,constituentname,ceq) ! get name of consitutent with index c in phasetuple n ! NOTE An identical routine with different constituent index is tqgpcn implicit none integer n !IN: phase number (not phase tuple) integer c !IN: constituent index sequentially over all sublattices character constituentname*(24) !EXIT: costituent name type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} double precision mass call get_constituent_name(n,c,constituentname,mass) ! write(*,*)'tqgpcn not implemented yet' ! gx%bmperr=8888 1000 continue return end subroutine tqgpcn2 !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgpci(n,c,constituentname,ceq) ! get index of constituent with name in phase n implicit none integer n !IN: phase index integer c !IN: sequantial constituent index over all sublattices character constituentname*(*) type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} write(*,*)'tqgpci not implemented yet' gx%bmperr=8888 1000 continue return end subroutine tqgpci !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgpcs(n,c,stoi,mass,ceq) ! get stoichiometry of constituent c in phase n !? missing argument number of elements???? implicit none integer n !IN: phase number integer c !IN: sequantial constituent index over all sublattices double precision stoi(*) !EXIT: stoichiometry of elements double precision mass !EXIT: total mass type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} write(*,*)'tqgpcs not implemented yet' gx%bmperr=8888 1000 continue return end subroutine tqgpcs !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgccf(n1,n2,elnames,stoi,mass,ceq) ! get stoichiometry of component n1 ! n2 is number of elements (dimension of elnames and stoi) implicit none integer n1 !IN: component number integer n2 !EXIT: number of elements in component character elnames(*)*(2) ! EXIT: element symbols double precision stoi(*) ! EXIT: element stoichiometry double precision mass ! EXIT: component mass (sum of element mass) type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} write(*,*)'tqgccf not implemented yet' gx%bmperr=8888 1000 continue return end subroutine tqgccf !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgnpc(n,c,ceq) ! get number of constituents of phase n implicit none integer n !IN: Phase number integer c !EXIT: number of constituents type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} write(*,*)'tqgnpc not implemented yet' gx%bmperr=8888 1000 continue return end subroutine tqgnpc !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgpsm(n,phases,status,amdgm,ceq) ! get all phase names and their status and amounts or DGM integer n character phases(*)*24 integer status(*) double precision amdgm(*) type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} integer i character dummy*64,statevar*64 n=nooftup() ! phasetuple: lokph,compset,ixphase,lokvares,nextcs do i=1,n call get_phasetup_name(i,phases(i)) ! the status is in phase_varres record, THIS IS NOT PRIVATE ! phastate values: 2 fix, 1,0,-1 entered, -2 dormant, -3 suspended status(i)=ceq%phase_varres(phasetuple(i)%lokvares)%phstate ! if status 0 or less the phase is not stable, extract DGM if(status(i).le.0) then statevar='DGM('//trim(phases(i))//')' call get_state_var_value(statevar,amdgm(i),dummy,ceq) else ! this phase is stable, extract amount statevar='NPM('//trim(phases(i))//')' call get_state_var_value(statevar,amdgm(i),dummy,ceq) endif enddo 1000 continue return end subroutine tqgpsm !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqcref(cix,phase,tpref,ceq) ! set component reference state integer cix character phase*(*) double precision tpref(*) type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium !\end{verbatim} integer phtupx call find_phasetuple_by_name(phase,phtupx) if(gx%bmperr.ne.0) goto 1000 call set_reference_state(cix,phtupx,tpref,ceq) 1000 continue return end subroutine tqcref !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqphsts(phtupx,newstat,val,ceq) ! set status of phase tuple: SUSPEND, DORMANT, ENTERED, FIX integer phtupx,newstat double precision val type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium !\end{verbatim} integer n if(phtupx.le.0) then ! if tup<0 change status of all phases do n=1,ntup call change_phtup_status(n,newstat,val,ceq) if(gx%bmperr.ne.0) goto 1000 enddo elseif(phtupx.le.ntup) then call change_phtup_status(phtupx,newstat,val,ceq) else write(*,*)'Illegal phase tuple index',phtupx gx%bmperr=8888 endif 1000 continue return end subroutine tqphsts !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqsetc(stavar,n1,n2,value,cnum,ceq) ! set condition ! stavar is state variable as text ! n1 and n2 are auxilliary indices ! value is the value of the condition ! cnum is returned as an index of the condition. ! to remove a condition the value sould be equial to RNONE ???? ! phase index is phase tuple index (include composition set) ! see TQGETV for doucumentation of stavar etc. implicit none integer n1 ! IN: 0 or phase tuple index or component number integer n2 ! IN: 0 or component number integer cnum ! EXIT: sequential number of this condition character stavar*(*) ! IN: character with state variable symbol double precision value ! IN: value of condition type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium !\end{verbatim} integer ip,ip2 character cline*60,selvar*4,cval*24 ! ! write(*,11)'In tqsetc ',stavar(1:len_trim(stavar)),n1,n2,value 11 format(a,a,2i5,1pe14.6) cline=' ' ! extract a value after an = ip=index(stavar,'=') if(ip.gt.0) then selvar=stavar(1:ip-1) cval=stavar(ip:) !@CC ip2=index(stavar,'(') if(ip2.gt.0) then ip = ip2 selvar=stavar(1:ip-1) cval=stavar(ip:) endif !@CC ! write(*,*)'Value after = :',cval else selvar=stavar cval=' ' endif call capson(selvar) select case(selvar) case default write(*,*)'Condition wrong, not implemented or illegal: ',stavar gx%bmperr=8888; goto 1000 ! Potentials T and P case('T ','P ') if(ip.gt.0) then cline=' '//stavar else write(cline,110)selvar(1:1),value 110 format(' ',a,'=',E15.8) endif ! Total amount or amount of a component in moles case('N ') if(ip.gt.0) then cline=' '//stavar else if(n1.gt.0) then ! call get_component_name(n1,name,ceq) ! if(gx%bmperr.ne.0) goto 1000 write(cline,112)selvar(1:1),cnam(n1)(1:len_trim(cnam(n1))),value 112 format(' ',a,'(',a,')=',E15.8) ! write(*,*)'Setting condition: ',cline(1:len_trim(cline)) else write(cline,110)selvar(1:1),value endif endif ! Overall fraction of a component case('X ','W ') ! ?? fraction of phase component not implemented, n1 must be component number ! call get_component_name(n1,cnam,ceq) ! if(gx%bmperr.ne.0) goto 1000 if(ip.gt.0) then cline=' '//stavar else write(cline,120)selvar(1:1),cnam(n1)(1:len_trim(cnam(n1))),value 120 format(1x,a,'(',a,')=',1pE15.8) endif case('H ','V ') ! enthalpy or volume of system if(cval(1:1).eq.'=') then cline=' '//stavar else write(cline,130)selvar(1:1),value 130 format(1x,a,'=',1pE15.8) endif ! case .... ! ?? MORE CONDITIONS WILL BE ADDED ... end select ! write(*,*)'tqsetc condition: ',trim(cline) ip=1 call set_condition(cline,ip,ceq) if(gx%bmperr.ne.0) then write(*,*)'Error setting condition: ',cline(1:len_trim(cline)),ip endif 1000 continue return end subroutine tqsetc !@CC !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine toggle_dense_grid() if(btest(globaldata%status,GSXGRID)) then globaldata%status=ibclr(globaldata%status,GSXGRID) write(*,3110)'reset' 3110 format('Dense grid ',a) else globaldata%status=ibset(globaldata%status,GSXGRID) write(*,3110)'dense grid set' endif return end subroutine toggle_dense_grid !@CC !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqce(target,n1,n2,value,ceq) ! calculate quilibrium with possible target ! Target can be empty or a state variable with indices n1 and n2 ! value is the calculated value of target implicit none integer n1,n2,mode character target*(*) double precision value logical confirm type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} integer nyfas,j1,j2 ! mode=1 means start values using global gridminimization if(n1.lt.0) then ! this means calculate without grid minimuzer mode=0 confirm=.FALSE. ! calcqeq3 is silent, no listing of phase changes etc. call calceq3(mode,confirm,ceq) else mode=1 call calceq2(mode,ceq) if(gx%bmperr.eq.4204) then ! if the error code is "too many iterations" try without grid minimizer ! it converges in many cases ! write(*,2048)gx%bmperr 2048 format('Error ',i5,', cleaning up and trying harder') gx%bmperr=0 call calceq2(0,ceq) endif endif if(gx%bmperr.ne.0) goto 1000 ! there may be new composition sets, update ntup ! write(*,*)'Number of phase tuples: ',ntup nyfas=nooftup() ! write(*,*)'Number of phase tuples: ',ntup,nyfas if(nyfas.ne.ntup) then ! write(*,*)'Number of phase tuples changed: ',nyfas,ntup ntup=nyfas ! if(allocated(ysave)) deallocate(ysave) ! allocate(ysave(nyfas,maxconst)) endif ! copy the constitution to a local save array ! if(.not.allocated(ysave)) then ! allocate(ysave(nyfas,maxconst)) ! endif if(allocated(ysave)) deallocate(ysave) allocate(ysave(nyfas,maxconst)) ! the intention of saving constitution is to make it possible to interpolate ! the calculation of G if the constitution is changed very little do j1=1,nyfas do j2=1,size(ceq%phase_varres(phasetuple(j1)%lokvares)%yfr) ysave(j1,j2)=ceq%phase_varres(phasetuple(j1)%lokvares)%yfr(j2) enddo enddo 1000 continue return end subroutine tqce !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgetv(stavar,n1,n2,n3,values,ceq) ! get equilibrium results using state variables ! stavar is the state variable IN CAPITAL LETTERS with indices n1 and n2 ! n1 can be a phase tuple index, n2 a component index ! n3 at the call is the dimension of the array values, ! changed to number of values on exit ! value is an array with the calculated value(s), n3 set to number of values. implicit none integer n1,n2,n3 character stavar*(*) double precision values(*) type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !======================================================== ! stavar must be a symbol listed below ! IMPORTANT: some terms explained after the table ! Symbol index1,index2 Meaning (unit) !.... potentials ! T 0,0 Temperature (K) ! P 0,0 Pressure (Pa) ! MU component,0 or ext.phase.index*1,constituent*2 Chemical potential (J) ! AC component,0 or ext.phase.index,constituent Activity = EXP(MU/RT) ! LNAC component,0 or ext.phase.index,constituent LN(activity) = MU/RT !...... extensive variables ! U 0,0 or ext.phase.index,0 Internal energy (J) whole system or phase ! UM 0,0 or ext.phase.index,0 same per mole components ! UW 0,0 or ext.phase.index,0 same per kg ! UV 0,0 or ext.phase.index,0 same per m3 ! UF ext.phase.index,0 same per formula unit of phase ! S*3 0,0 or ext.phase.index,0 Entropy (J/K) ! V 0,0 or ext.phase.index,0 Volume (m3) ! H 0,0 or ext.phase.index,0 Enthalpy (J) ! A 0,0 or ext.phase.index,0 Helmholtz energy (J) ! G 0,0 or ext.phase.index,0 Gibbs energy (J) ! ..... some extra state variables ! NP ext.phase.index,0 Moles of phase ! BP ext.phase.index,0 Mass of moles (kg) ! Q ext.phase.index,0 Internal stability/RT (dimensionless) ! DG ext.phase.index,0 Driving force/RT (dimensionless) !....... amounts of components ! N 0,0 or component,0 or ext.phase.index,component Moles of component ! X component,0 or ext.phase.index,component Mole fraction of component ! B 0,0 or component,0 or ext.phase.index,component Mass of component ! W component,0 or ext.phase.index,component Mass fraction of component ! Y ext.phase.index,constituent*1 Constituent fraction !........ some parameter identifiers ! TC ext.phase.index,0 Magnetic ordering temperature ! BMAG ext.phase.index,0 Aver. Bohr magneton number ! MQ& ext.phase.index,constituent Mobility ! THET ext.phase.index,0 Debye temperature ! LNX ext.phase.index,0 Lattice parameter ! EC11 ext.phase.index,0 Elastic constant C11 ! EC12 ext.phase.index,0 Elastic constant C12 ! EC44 ext.phase.index,0 Elastic constant C44 !........ NOTES: ! *1 The phase index is the phase tuple index (extra composition sets at end) ! *2 The constituent index is 10*species_number + sublattice_number ! *3 S, V, H, A, G, NP, BP, N, B and DG can have suffixes M, W, V, F also !-------------------------------------------------------------------- ! special addition for TQ interface: d2G/dyidyj ! D2G + phase tuple !-------------------------------------------------------------------- !\end{verbatim} integer ics,mjj,nph,ki,kj,lp,lokph,lokcs character statevar*60,encoded*2048,name*24,selvar*4,norm*4 ! mjj should be the dimension of the array values ... mjj=n3 selvar=stavar call capson(selvar) ! for state variables like MQ&FE remove the part from & before the select ! write(*,11)'In tqgetv: ',selvar,n1,n2,n3 11 format(a,a,3i5) norm=' ' lp=index(selvar,'&') if(lp.gt.0) then selvar(lp:)=' ' else ! check if variable is normallized, only M (per mole) allowed ki=len_trim(selvar) if(ki.ge.2) then if(selvar(ki:ki).eq.'M') then norm='M' selvar(ki:)=' ' ki=ki-1 endif endif endif !======================================================================= kj=index(selvar,'(') if(kj.gt.0) then selvar=selvar(1:kj-1) endif ! write(*,*)'tqgetv 0: ',kj,selvar,'>',stavar,'<' select case(selvar) case default write(*,*)'Unknown state variable: ',stavar(1:20),'>:<',selvar gx%bmperr=8888; goto 1000 !-------------------------------------------------------------------- ! T or P case('T ','P ') call get_state_var_value(selvar,values(1),encoded,ceq) !-------------------------------------------------------------------- ! chemical potential for a component case('MU ','MUS ') if(n1.lt.-1 .or. n1.eq.0) then write(*,*)'tqgetv 17: component number must be positive' gx%bmperr=8888; goto 1000 elseif(n1 .eq.-1) then ! this means all components statevar=trim(selvar)//'(*)' call get_many_svar(statevar,values,mjj,n3,encoded,ceq) elseif(n1.le.noel()) then statevar=trim(selvar)//'('//trim(cnam(n1))//') ' ! write(*,*)'tqgetv 4: ',statevar(1:len_trim(statevar)) ! we must use index value(1) as the subroutine expect a single variable call get_state_var_value(statevar,values(1),encoded,ceq) else write(*,*)'No such component' endif !-------------------------------------------------------------------- !@CC ! Amount of moles /mass of components in a phase case('NP ', 'BP ') if(n1.lt.0) then ! all phases statevar=stavar(1:2)//'(*)' !@CC ! this returns all composition sets for all phases call get_many_svar(statevar,values,mjj,n3,encoded,ceq) ! this output gives the amounts for all compsets of a phase sequentially ! but here we want them in phase tuple order ! the second argument is the number of values for each phase, here is 1 but ! it can be for example compositions, then it should be number of components call sortinphtup(n3,1,values) else ! NP for just one phase call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar='NP('//trim(name)//') ' call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 endif !-------------------------------------------------------------------- ! Mole or mass fractions !@CC case('N ','B ','X ','W ') !@CC ! write(*,*)'in tqgetv n,x,w: ',n1,n2,n3 if(n2.eq.0) then if(n1.lt.0) then ! moles, mole or mass fraction of all components for all phases statevar=stavar(1:1)//'(*) ' ! write(*,*)'tqgetv 3: ',mjj,statevar(1:len_trim(statevar)) call get_many_svar(statevar,values,mjj,n3,encoded,ceq) elseif(n1.eq.0) then ! mole fraction for the state variable written as X(FE) ! n1 and n2 not used, just check for wildcard ! write(*,*)'tqgetv 20: ',stavar(1:len_trim(stavar)) if(index(stavar,'*').gt.0) then call get_many_svar(stavar,values,mjj,n3,encoded,ceq) else call get_state_var_value(stavar,values(1),encoded,ceq) endif else ! mole fraction of a single component, no phase specification n3=1 ics=1 ! call get_component_name(n1,name,ceq) ! if(gx%bmperr.ne.0) goto 1000 statevar=stavar(1:1)//'('//trim(cnam(n1))//')' ! write(*,*)'tqgetv 4: ',statevar(1:len_trim(statevar)) call get_state_var_value(statevar,values(1),encoded,ceq) endif elseif(n1.lt.0) then !........................................................ ! for all phases one or several components if(n2.lt.0) then ! this means all components all phases, for example x(*,*) statevar=stavar(1:1)//'(*,*) ' ! write(*,*)'tqgetv 5: ',mjj,statevar(1:len_trim(statevar)) call get_many_svar(statevar,values,mjj,n3,encoded,ceq) ! this output gives the composition for all compsets of a phase sequentially ! but we want them in phase tuple order ! The second argument is the number of values for each phase, noel() ! in this case ics=noel() call sortinphtup(n3,ics,values) else ! a single component in all phases. n2 must not be zero ! call get_component_name(n2,name,ceq) ! if(gx%bmperr.ne.0) goto 1000 if(n2.le.0 .or. n2.ge.noel()) then write(*,*)'No such component' goto 1000 endif ! state variable like w(*,cr), the Cr content in all (stable) phases statevar=stavar(1:1)//'(*,'//cnam(n2)(1:len_trim(cnam(n2)))//')' ! write(*,*)'tqgetv 6: ',mjj,statevar(1:len_trim(statevar)) call get_many_svar(statevar,values,mjj,n3,encoded,ceq) ! this output gives the composition for all compsets of a phase sequentially ! but we want them in phase tuple order ! The second argument is the number of values for each phase, in this case 1 ! ics=noel() ! THIS MUST BE CHECKED !!! call sortinphtup(n3,1,values) endif elseif(n2.lt.0) then ! this means all components in one phase call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=stavar(1:1)//'('//trim(name)//',*) ' call get_many_svar(statevar,values,mjj,n3,encoded,ceq) else ! one component (n2) of one phase (n1) call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=stavar(1:1)//'('//trim(name)//',' call get_component_name(n2,name,ceq) if(gx%bmperr.ne.0) goto 1000 statevar(len_trim(statevar)+1:)=trim(name)//') ' ! write(*,*)'tqgetv 8: ',statevar call get_state_var_value(statevar,values(1),encoded,ceq) endif !-------------------------------------------------------------------- ! volume case('V ') if(norm(1:1).ne.' ') then statevar='V'//norm ki=2 else statevar='V ' ki=1 endif if(n1.gt.0) then ! Volume for a specific phase call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=statevar(1:ki)//'('//trim(name)//') ' call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 else ! Total volume call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 endif !-------------------------------------------------------------------- ! Enthalpy case('H ') ! phase specifier not allowed if(norm(1:1).ne.' ') then statevar='H'//norm ki=2 else statevar='H ' ki=1 endif ! write(*,*)'tqgetv 1: ',n1,ki if(n1.gt.0) then ! Gibbs energy for a specific phase call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=statevar(1:ki)//'('//trim(name)//') ' call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 else ! Total enthalpy call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 endif !-------------------------------------------------------------------- ! Gibbs energy case('G ') ! phase specifier not allowed if(norm(1:1).ne.' ') then statevar='G'//norm ki=2 else statevar='G ' ki=1 endif ! write(*,*)'tqgetv 1: ',n1,ki if(n1.gt.0) then ! Gibbs energy for a specific phase call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=statevar(1:ki)//'('//trim(name)//') ' ! write(*,*)'tqgetv 3: ',statevar call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 else ! Total Gibbs energy call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 endif !-------------------------------------------------------------------- ! Driving force relative stable equilibrium case('DG ') ! Always normalized per mole if(norm(3:3).ne.' ') then statevar='DG'//norm ki=3 else statevar='DG ' ki=2 endif ! write(*,*)'tqgetv DGM: ',n1,ki if(n1.gt.0) then ! The driving force for a specific phase call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=statevar(1:ki)//'M('//trim(name)//') ' ! write(*,*)'tqgetv 3: ',statevar call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 else ! For all phases n3=0 if(nooftup().gt.mjj) then write(*,*)'TQGETV error, array too small for DGM',mjj,nooftup() gx%bmperr=8888 goto 1000 endif statevar='DGM(#) ' write(*,*)'tqgetv 3: ',statevar call get_many_svar(statevar,values,mjj,n3,encoded,ceq) write(*,'(a,10(1pe12.4))')'TQGETV: ',(values(ki),ki=1,n3) write(*,*)'gx%bmperr: ',gx%bmperr endif !-------------------------------------------------------------------- ! Mobilities case('MQ ') call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=stavar(1:len_trim(stavar))//'('//trim(name)//')' ! write(*,*)'statevar: ',statevar call get_state_var_value(statevar,values(1),encoded,ceq) !-------------------------------------------------------------------- ! Second derivatives of the Gibbs energy of a phase case('D2G ') lokcs=phasetuple(n1)%lokvares ! this gives wrong value!! ?? n3=size(ceq%phase_varres(lokcs)%yfr) ! write(*,*)'D2G 3: ',n3 kj=(n3*(n3+1))/2 if(kj.gt.mjj) then write(*,*)'TQGETV error, array too small for D2G',mjj,kj gx%bmperr=8888 goto 1000 endif ! write(*,*)'D2G 3: ',kj do ki=1,kj values(ki)=ceq%phase_varres(lokcs)%d2gval(ki,1) enddo end select !=========================================================================== 1000 continue return end subroutine tqgetv !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ subroutine tqgetg(lokres,n1,n2,values,ceq) ! the partial derivative of the Gibbs energy ....?? implicit none integer n1,n2,lokres double precision values(*) type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium ! double precision napfu, rgast integer count integer jl,size TYPE(gtp_phase_varres), pointer :: parres ! count = 1 ! napfu=ceq%phase_varres(lokres)%abnorm(1) rgast=globaldata%rgas*ceq%tpval(1) parres=>ceq%phase_varres(lokres) ! ! write(*,100)(rgast*parres%gval(jl,1),jl=1,4) ! write(*,200)parres%gval(1,1)/parres%abnorm(1),parres%abnorm(1) 100 format('G/N, dG/dT:',4(1PE16.8)) 200 format('G/N/RT, N:',2(1PE16.8)) ! G_m^\alpha = G_M^\alpha/N^\alpha, \frac{\partial G_m^\alpha}{\partial T}, ! \frac{\partial G_m^\alpha}{\partial P}, ! \frac{\partial^2 G_m^\alpha}{\partial T^2} values(count:count+3) = rgast*parres%gval(1:4,1)/napfu count = count + 4 if (n1>0) then ! 1/N^\alpha * \frac{\partial G_M^\alpha}{\partial y_i} values(count:count+n1-1) = rgast*parres%dgval(1,1:n1,1)/napfu count = count + n1 if (n2>0) then ! 1/N^\alpha * \frac{\partial^2 G_M^\alpha}{\partial y_i\partial y_j} values(count:count+n2-1) = rgast*parres%d2gval(1:n2,1)/napfu endif endif end subroutine tqgetg !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ subroutine tqgdmat(phtupx,tpval,xknown,cpot,tyst,nend,mugrad,mobval,& consnames,n1,ceq) ! equilibrates the constituent fractions of a phase for mole fractions xknown ! and calculates the Darken matrix and unreduced diffusivities ! phtup is phase tuple ! tpval is T and P ! ceq is a datastructure with all relevant thermodynamic data ! cpot are the (calculated) chemical potentials ! tyst is TRUE means no outut ! nend is the number of values returned in mugrad ! mugrad are the derivatives of the chemical potentials wrt mole fractions?? ! mobval are the mobilities implicit none integer phtupx ! IN: index in phase tuple array integer nend logical tyst double precision tpval(*),xknown(*),cpot(*),mugrad(*),mobval(*) character*24, dimension(*) :: consnames integer n1 TYPE(gtp_phasetuple), pointer :: phtup TYPE(gtp_equilibrium_data), pointer :: ceq integer iph, ics, ll double precision mass character*24 spname phtup=>phasetuple(phtupx) call equilph1d(phtup,tpval,xknown,cpot,tyst,nend,mugrad,mobval,ceq) iph=phasetuple(phtupx)%ixphase ics=1 n1 = noconst(iph,ics,firsteq) do ll=1,n1 call get_constituent_name(iph,ll,consnames(ll),mass) enddo end subroutine tqgdmat !@CC !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgphc1(n1,nsub,cinsub,spix,yfrac,sites,extra,ceq) ! tq_get_phase_constitution ! This subroutine returns the sublattices and constitution of a phase ! n1 is phase tuple index ! nsub is the number of sublattices (1 if no sublattices) ! cinsub is an array with the number of consttuents in each sublattice ! spix is an array with the species index of the constituents in all sublattices ! sites is an array of the site ratios for all sublattices. ! yfrac is the constituent fractions in same order as in spix ! extra is an array with some extra values: ! extra(1) is the number of moles of components per formula unit ! extra(2) is the net charge of the phase implicit none integer n1,nsub,cinsub(*),spix(*) double precision sites(*),yfrac(*),extra(*) type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} call get_phase_data(phasetuple(n1)%ixphase,phasetuple(n1)%compset,& nsub,cinsub,spix,yfrac,sites,extra,ceq) 1000 continue return end subroutine tqgphc1 !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqsphc1(n1,yfra,extra,ceq) ! tq_set_phase_constitution ! To set the constitution of a phase ! n1 is phase tuple index ! yfra is an array with the constituent fractions in all sublattices ! in the same order as obtained by tqgphc1 ! extra is an array with returned values with the same meaning as in tqgphc1 ! NOTE The constituents fractions are normallized to sum to unity for each ! sublattice and extra is calculated by tqsphc1 ! T and P must be set as conditions. implicit none integer n1 double precision yfra(*),extra(*) type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} call set_constitution(phasetuple(n1)%ixphase,phasetuple(n1)%compset,& yfra,extra,ceq) 1000 continue return end subroutine tqsphc1 !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqcph1(n1,n2,n3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,ceq) ! tq_calculate_phase_properties !vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! WARNING: this is not a subroutine to calculate chemical potentials ! those can only be made by an equilibrium calculation. ! The values returned are partial derivatives of G for the phase at the ! current T, P and phase constitution. The phase constitution has been ! obtained by a previous equilibrium calculation or ! set by the subroutine tqsphc ! It corresponds to the "calculate phase" command. ! ! NOTE that values are per formula unit divided by RT, ! divide also by extra(1) in subroutine tqsphc1 to get them per mole component ! !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! calculate G and some or all derivatives for a phase at current composition ! n1 is the phase tuple index ! n2 is 0 if only G and derivatves wrt T and P, 1 also first drivatives wrt ! compositions, 2 if also 2nd derivatives ! n3 is returned as number of constituents (dimension of returned arrays) ! gtp is an array with G, G.T, G:P, G.T.T, G.T.P and G.P.P ! dgdy is an array with G.Yi ! d2gdydt is an array with G.T.Yi ! d2gdydp is an array with G.P.Yi ! d2gdy2 is an array with the upper triangle of the symmetrix matrix G.Yi.Yj ! reurned in the order: 1,1; 1,2; 1,3; ... ! 2,2; 2,3; ... ! 3,3; ... ! for indexing one can use the integer function ixsym(i1,i2) implicit none integer n1,n2,n3 double precision gtp(6),dgdy(*),d2gdydt(*),d2gdydp(*),d2gdy2(*) type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer ij,lokres,nofc ! write(*,*)'tqcph1 1: ',ceq%eqname ! write(*,*)'tqcph1 2',phasetuple(n1)%ixphase,phasetuple(n1)%compset !---------------------------------------------------------------------- ! THIS IS NO EQUILIBRIUM, JUST G AND DERIVATIVES FOR CURRENT T, P AND Y call calcg(phasetuple(n1)%ixphase,phasetuple(n1)%compset,n2,lokres,ceq) !---------------------------------------------------------------------- ! write(*,*)'tqcph1 3A',lokres,gx%bmperr ! The inital size here can be 1000 ! n3=size(ceq%phase_varres(lokres)%yfr) ! the actual number of constituents is better to take from this call n3=noconst(phasetuple(n1)%ixphase,1,ceq) ! write(*,*)'tqcph1 3C',n3 ! gval last index is the property, other properties can also be extracted ! t.ex. mobilites ! The application program can also access these data directly ... if(gx%bmperr.eq.0) then do ij=1,6 gtp(ij)=ceq%phase_varres(lokres)%gval(ij,1) enddo do ij=1,n3 dgdy(ij)=ceq%phase_varres(lokres)%dgval(1,ij,1) d2gdydt(ij)=ceq%phase_varres(lokres)%dgval(2,ij,1) d2gdydp(ij)=ceq%phase_varres(lokres)%dgval(3,ij,1) enddo ! size of upper triangle of symetrix matrix nofc=n3*(n3+1)/2 do ij=1,nofc d2gdy2(ij)=ceq%phase_varres(lokres)%d2gval(ij,1) enddo else gtp=zero do ij=1,nofc dgdy(ij)=zero d2gdydt(ij)=zero d2gdydp(ij)=zero enddo nofc=nofc*(nofc+1)/2 do ij=1,nofc d2gdy2(ij)=zero enddo endif 1000 continue return end subroutine tqcph1 !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} %- subroutine tqcph2(n1,n2,n3,n4,ceq) ! tq_calculate_phase_properties !vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! WARNIG: this is not a subroutine to calculate chemical potentials ! those can only be made by an equilibrium calculation. ! The values returned are partial derivatives of G for the phase at the ! current T, P and phase constitution. The phase constitution has been ! obtained by a previous equilibrium calculation or ! set by the subroutine tqsphc ! It corresponds to the "calculate phase" command. ! ! NOTE that values are per formula unit divided by RT, ! divide also by extra(1) in subroutine tqsphc1 to get them per mole component ! !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! calculate G and some or all derivatives for a phase at current composition ! n1 is the phase tuple index ! n2 is type of calculation (0, 1 or 2) ! n3 is returned as number of constituents ! n4 is index to ceq%phase_varres(lokres)% with all results ! for indexing one can use the integer function ixsym(i1,i2) implicit none integer n1,n2,n3,n4 type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer ij,lokres,nofc ! write(*,*)'tqcph1 1: ',ceq%eqname ! write(*,*)'tqcph1 2',phasetuple(n1)%ixphase,phasetuple(n1)%compset !---------------------------------------------------------------------- ! THIS IS NO EQUILIBRIUM, JUST G AND DERIVATIVES FOR CURRENT T, P AND Y call calcg(phasetuple(n1)%ixphase,phasetuple(n1)%compset,n2,lokres,ceq) !---------------------------------------------------------------------- ! write(*,*)'tqcph1 3A',lokres,gx%bmperr ! this should work but gave segmentation fault, find this a more cumbersum way n3=size(ceq%phase_varres(lokres)%yfr) n4=lokres ! Uer can access results like ! ceq%phase_varres(n4)%gval(1..6,1..prop) ! prop=1 is G, other can be t.ex. Curie T, mobilites etc ! ceq%phase_varres(lokres)%dgval(1,ij,1) are dG/dy(ij) ! ceq%phase_varres(lokres)%dgval(2,ij,1) are d2G/dy(ij)dT ! ceq%phase_varres(lokres)%dgval(3,ij,1) are d2G/dy(ij)dP ! ceq%phase_varres(lokres)%d2gval(ij,1) are d2G/dy(i)dy(j) ! arranged as a single dimenion array indexed by ixsym(i,j) ! ! NEVER CHANGE THE CONSTITUTION DIRECTLY, using n4, ALWAYS CALL tqsph1(...) ! 1000 continue return end subroutine tqcph2 !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqdceq(name) ! delete equilibrium with name implicit none character name*24 ! integer n1 type(gtp_equilibrium_data), pointer :: newceq,ceq !\end{verbatim} integer n1 call findeq(name,n1) if(gx%bmperr.ne.0) goto 1000 ! do not allow delete equilibrium 1 if(n1.eq.1) then write(*,*)'No allowed to delete default equilibrium' gx%bmperr=4333 goto 1000 endif ! ceq=>eqlista(n1) call delete_equilibria(name,ceq) 1000 continue return end subroutine tqdceq !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqcceq(name,n1,newceq,ceq) ! copy_current_equilibrium to newceq ! creates a new equilibrium record with name with values same as ceq ! n1 is returned as index implicit none character name*24 integer n1 type(gtp_equilibrium_data), pointer :: newceq,ceq !\end{verbatim} !call enter_equilibrium(name,n1) !if(gx%bmperr.ne.0) goto 1000 !newceq=>eqlista(n1) call copy_equilibrium(newceq,name,ceq) 1000 continue return end subroutine tqcceq !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqcneq(name,n1,newceq) ! creates a new equilibrium record, same but simpler call than tqcceq ! n1 is returned as index in eqlista implicit none character*(*), intent(in) :: name integer, intent(out) :: n1 type(gtp_equilibrium_data), pointer, intent(out) :: newceq !\end{verbatim} call enter_equilibrium(name,n1) if(gx%bmperr.ne.0) goto 1000 newceq=>eqlista(n1) 1000 continue return end subroutine tqcneq !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqselceq(name,ceq) ! select current equilibrium to be that with name. ! Note that equilibria can be deleted and change number but not name implicit none character name type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer n1 call findeq(name,n1) if(gx%bmperr.ne.0) goto 1000 call selecteq(n1,ceq) 1000 continue return end subroutine tqselceq !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqlr(lut,ceq) ! list the equilibrium results like in OC implicit none integer lut type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer phtupx,iph,ics,lokvares,mode logical once write(lut,10) 10 format(/20('*')/'Start debug output from TQLR: ') call list_conditions(lut,ceq) call list_global_results(lut,ceq) call list_components_result(lut,1,ceq) once=.TRUE. mode=0 do phtupx=1,nooftup() lokvares=phasetuple(phtupx)%lokvares if(ceq%phase_varres(lokvares)%phstate.ge.phentstab) then iph=phasetuple(phtupx)%ixphase ics=phasetuple(phtupx)%compset call list_phase_results(iph,ics,mode,lut,once,ceq) endif enddo write(lut,20) 20 format('End debug output from TQLR'/20('*')/) 1000 continue return end subroutine tqlr !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqlc(lut,ceq) ! list conditions like in OC implicit none integer lut type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} write(lut,10) 10 format(/'Debug output from TQLC: ') call list_conditions(lut,ceq) 1000 continue return end subroutine tqlc !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqltdb ! list TDB file elements, phases and parameters on screen implicit none !\end{verbatim} integer n,kou ! n is position in text, kou is output unit n=1; kou=6 call list_many_formats(' ,,,, ',n,1,kou) write(*,10) 10 format(/' no more ',/) return end subroutine tqltdb !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqquiet(yes) ! if argument TRUE spurious output should be suppressed implicit none logical yes !\end{verbatim} if(yes) then globaldata%status=ibclr(globaldata%status,GSVERBOSE) globaldata%status=ibset(globaldata%status,GSSILENT) else globaldata%status=ibset(globaldata%status,GSVERBOSE) endif return end subroutine tqquiet !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqchange_globalbit(bit,onoff) ! set a global bit implicit none integer bit,onoff !\end{verbatim} ! list here taken from models/gtp3.F90, only some allowed!! ! BEWHEARE, the meaning of bits may have changed !!! check with gtp3.F90 ! 4 NOMERGE: no merge of gridmin result, ! 5 NODATA: not any data, ! 6 NOPHASE: no phase in system, ! 7 NOACS: no automatic creation of composition set for any phase ! 8 NOREMCS: do not remove any redundant unstable composition sets ! 9 NOSAVE: data changed after last save command ! 10 VERBOSE: maximum of listing ! 11 SETVERB: permanent setting of verbose ! 12 SILENT: as little output as possible ! 13 NOAFTEREQ: no manipulations of results after equilibrium calculation ! 14 XGRID: extra dense grid for all phases ! 15 NOPAR: do not run in parallel ! 16 NOSMGLOB do not test global equilibrium at node points ! 17 NOTELCOMP the elements are not the components ! 18 TGRID use grid minimizer to test if global after calculating equilibrium ! 19 OGRID use old grid generator ! 20 NORECALC do not recalculate equilibria even if global test after fails ! 21 OLDMAP use old map algorithm ! 22 NOAUTOSP do not generate automatic start points for mapping ! 23 GSYGRID extra dense grid ! 24 GSVIRTUAL (CCI) enables calculations with a virtual element if((bit.ge.7 .and. bit.le.16) .or. (bit.ge.18 .and. bit.le.23)) then if(onoff.gt.0) then ! set bit globaldata%status=ibset(globaldata%status,bit) else globaldata%status=ibclr(globaldata%status,bit) endif else gx%bmperr=4326 endif return end subroutine tqchange_globalbit !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqchange_phasebit(phtupx,bit,onoff) ! set a bit of phase implicit none integer phtupx,bit,onoff !\end{verbatim} ! taken from models/gtp3.F90 !-Bits in PHASE record STATUS1 there are also bits in each phase_varres record! ! BEWHEARE, the meaning of bits may have changed !!! check with gtp3.F90 ! 0 HID phase is hidden (not implemented) ! 1 IMHID phase is implictly hidden (not implemented) ! 2 ID phase is ideal, substitutional and no interaction ! 3 NOCV phase has no concentration variation (fix composition) ! 4 HASP phase has at least one parameter entered ! 5 FORD phase has 4 sublattice FCC ordering with parameter permutations ! 6 BORD phase has 4 sublattice BCC ordering with parameter permutations ! 7 SORD phase has TCP type ordering (like for sigma) ! 8 MFS phase has a disordered fraction set ! 9 GAS this is the gas phase (first in phase list) ! 10 LIQ phase is liquid (can be several but listed directly after gas) ! 11 IONLIQ phase has ionic liquid model (I2SL) ! 12 AQ1 phase has aqueous model (not implemented) ! 13 STATE elemental liquid twostate (2-state) model parameter UNUSED? ! 14 QCE phase has quasichemical SRO configurational entropy (not implemented) ! 15 CVMCE phase has some CVM ordering entropy (not implemented) ! 16 EXCB phase need explicit charge balance (has ions) ! 17 XGRID use extra dense grid for this phase ! 18 FACTCE phase has FACT quasichemical SRO model (not implemented) ! 19 NOCS not allowed to create composition sets for this phase ! 20 HELM parameters are for a Helmholz energy model (not implemented), ! 21 PHNODGDY2 phase has model with no analytical 2nd derivatives ! 22 not implemented ELMA phase has elastic model A (not implemented) ! 23 EECLIQ the condensed phase (liquid) that should have highest entropy ! 24 PHSUBO special use testing models DO NOT USE ! 25 PALM interaction records numbered by PALMTREE NEEDED FOR PERMUTATIONS !!! ! 26 MULTI may be used with care ! 27 BMAV Xion magnetic model with average Bohr magneton number ! 28 UNIQUAC The UNIQUAC fluid model ! 29 DILCE phase has dilute configigurational entropy (not implemented) ! only bittar 3 left! integer lokph if(phtupx.le.0 .or. phtupx.gt.nooftup()) then gx%bmperr=4325 elseif(bit.eq.17 .or. bit.eq.19) then lokph=phasetuple(phtupx)%lokph if(onoff.gt.0) then call set_phase_status_bit(lokph,bit) else call clear_phase_status_bit(lokph,bit) endif else gx%bmperr=4326 endif return end subroutine tqchange_phasebit !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqset_gaddition(phtupx,gadd,ceq) ! set fix addition to Gibbs energy of a phase#compset implicit none integer phtupx double precision gadd type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} ! Provided by Christophe Sigli 2018? integer lokcs lokcs=phasetuple(phtupx)%lokvares if(.not.allocated(ceq%phase_varres(lokcs)%addg)) then allocate(ceq%phase_varres(lokcs)%addg(1)) endif ceq%phase_varres(lokcs)%addg(1)=gadd ! set bit that this should be calculated ceq%phase_varres(lokcs)%status2=& ibset(ceq%phase_varres(lokcs)%status2,CSADDG) return end subroutine tqset_gaddition !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tq_add_const_energy(energy,phtupx,ceq) ! add a constant energy in J/mole double precision,intent(in) :: energy type(gtp_equilibrium_data), pointer :: ceq integer,intent(in) :: phtupx !\end{verbatim} ! Provided by Jan Herrnring 2020.12.15 integer :: lokcs lokcs=phasetuple(phtupx)%lokvares if(.not.allocated(ceq%phase_varres(lokcs)%addg)) then allocate(ceq%phase_varres(lokcs)%addg(1)) endif ! add a constant term to G, value in J/FU ! Abnorm is the number of moles of the phase ceq%phase_varres(lokcs)%addg(1)=energy*ceq%phase_varres(lokcs)%abnorm(1) ! set bit that this should be calculated ceq%phase_varres(lokcs)%status2=& ibset(ceq%phase_varres(lokcs)%status2,CSADDG) end subroutine tq_add_const_energy !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ end MODULE LIBOCTQ !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ ! dummy modules !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ module ftinyopen ! ! This module replaces a C module for a popup window to open files ! used in the interactive OC. If you want to use the original ! version for opening files please check the linkmake or Makefile ! contains subroutine getfilename(typ,sval) implicit none integer typ character sval*(*) sval=' ' return end subroutine getfilename end module ftinyopen !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ ! dummy module (only Linux) !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ module M_getkey ! ! This module replaces a C module fore single character input on Linux ! contains character function getkex() getkex=' ' return end function getkex end module M_getkey !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ ================================================ FILE: examples/TQ4lib/F90/parallel-alnipt/AlNiPt-2005.TDB ================================================ $ AL-PT FROM /alnipt/alpt-new/MSL/alpt.PAR, $ this is the only differences from alnipt-1221.TDB $ L(L12, AL:AL:NI,PT:NI,PT)=RECPTPT+V74 $ Ni-Pt from ntt6 $ Al-Ni from Nath: alni-270403.TDB $ ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT AL FCC_A1 2.6982E+01 4.5773E+03 2.8322E+01! ELEMENT NI FCC_A1 5.8690E+01 4.7870E+03 2.9796E+01! ELEMENT PT FCC_A1 1.9508E+02 5.7237E+03 4.1631E+01! FUNCTION GHSERAL 2.98150E+02 -7976.15+137.093038*T-24.3671976*T*LN(T) -.001884662*T**2-8.77664E-07*T**3+74092*T**(-1); 7.00000E+02 Y -11276.24+223.048446*T-38.5844296*T*LN(T)+.018531982*T**2 -5.764227E-06*T**3+74092*T**(-1); 9.33600E+02 Y -11278.378+188.684153*T-31.748192*T*LN(T)-1.231E+28*T**(-9); 6.00000E+03 N ! FUNCTION GBCCAL 2.98150E+02 +10083-4.813*T+GHSERAL#; 6.00000E+03 N ! FUNCTION GLIQAL 2.98140E+02 +11005.029-11.841867*T+7.934E-20*T**7 +GHSERAL#; 9.33590E+02 Y +10482.282-11.253974*T+1.231E+28*T**(-9)+GHSERAL#; 6.00000E+03 N ! FUNCTION GHSERNI 2.98150E+02 -5179.159+117.854*T-22.096*T*LN(T) -.0048407*T**2; 1.72800E+03 Y -27840.655+279.135*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 6.00000E+03 N ! FUNCTION GBCCNI 2.98150E+02 +8715.084-3.556*T+GHSERNI#; 6.00000E+03 N ! FUNCTION GHSERPT 2.98150E+02 -7595.631+124.388276*T-24.5526*T*LN(T) -.00248297*T**2-2.0138E-08*T**3+7974*T**(-1); 1.30000E+03 Y -9253.174+161.529616*T-30.2527*T*LN(T)+.002321665*T**2 -6.56947E-07*T**3-272106*T**(-1); 2.04210E+03 Y -222518.973+1021.21087*T-136.422689*T*LN(T)+.020501692*T**2 -7.60985E-07*T**3+71709819*T**(-1); 4.00000E+03 N ! FUNCTION GBCCPT 2.98150E+02 +15000-2.4*T+GHSERPT#; 6.00000E+03 N! $ disordered FCC part moved here, BCC is just B2 ordering, no disordered part TYPE_DEFINITION * GES AMEND_PHASE_DESCRIPTION FCC_4SL DIS_PART FCC_A1,,,! $alni-270403 FUNCTION LLIQ2 298.15 +81204.81-31.95713*T;,, N 95DUP3 ! FUNCTION LLIQ3 298.15 +4365.35-2.51632*T;,, N 95DUP3 ! FUNCTION LLIQ4 298.15 -22101.64+13.16341*T;,, N 95DUP3 ! FUNCTION LLIQ0 298.15 -5*LLIQ2-9*LLIQ4;,, N 95DUP3 ! FUNCTION LLIQ1 298.15 -7*UNTIER*LLIQ3;,, N 95DUP3 ! FUNCTION DEUX 298.15 2;,, N 95DUP3 ! FUNCTION UNSURDEU 298.15 +DEUX**(-1);,, N 95DUP3 ! FUNCTION GB2NINI 298.15 +GBCCNI;,, N 95DUP3 ! FUNCTION GB2ALVA 298.15 +5000-.5*T+UNSURDEU*GBCCAL;,, N 95DUP3 ! FUNCTION GB2ALNI 298.15 -76198.65+13.202875*T +UNSURDEU*GBCCAL+UNSURDEU*GBCCNI;,, N 95DUP3 ! FUNCTION GB2NIVA 298.15 -GB2ALNI+GB2NINI+GB2ALVA;,, N 95DUP3 ! FUNCTION SIX 298.15 6;,, N 95DUP3 ! FUNCTION UNSURSIX 298.15 +SIX**(-1);,, N 95DUP3 ! FUNCTION GALALVA 298.15 +5000-.5*T+5*UNSURSIX*GBCCAL;,, N 95DUP3 ! FUNCTION GALNINI 298.15 +5000+GB2ALNI;,, N 95DUP3 ! FUNCTION GALNIVA 298.15 -59620.987+11.387*T +3*UNSURSIX*GBCCAL+2*UNSURSIX*GBCCNI;,, N 95DUP3 ! FUNCTION GALALNI 298.15 -GALNIVA+GALALVA+GALNINI;,, N 95DUP3 ! FUNCTION L32ALNI 298.15 -32247.363+21.965*T;,, N 95DUP3 ! FUNCTION L32NIVA 298.15 -3666.95+1.1722*T;,, N 95DUP3 ! FUNCTION U1ALNI 298.15 -13415.515+2.0819247*T;,, N 95DUP3 ! FUNCTION UALNI 298.15 -43590+6.22*T;,, N 03SUN ! FUNCTION ALPHA 298.15 -29600;,, N 03SUN ! FUNCTION BETA 298.15 -66718+11.64*T;,, N 03SUN ! FUNCTION AL3NI 298.15 ALPHA;,, N 03SUN ! FUNCTION AL2NI2 298.15 BETA;,, N 03SUN ! FUNCTION ALNI3 298.15 UALNI;,, N 03SUN ! FUNCTION URALNI 298.15 -34575+13.22*T;,, N 03SUN ! FUNCTION LFCC0 298.15 +AL3NI+1.5*AL2NI2+ALNI3+1.5*URALNI;,, N 03SUN ! FUNCTION LFCC1 298.15 +2*AL3NI-2*ALNI3;,, N 03SUN ! FUNCTION LFCC2 298.15 +AL3NI-1.5*AL2NI2+ALNI3-1.5*URALNI;,, N 03SUN ! FUNCTION LFCC3 298.15 0.0; 6000.00 N 03SUN ! FUNCTION U3ALNI 298.15 0.0; 6000.00 N 03SUN ! FUNCTION L0ALNI 298.15 5310-1.46*T;,, N ! FUNCTION UN_ASS 298.15 0; 300 N ! $****AL-PT $ FUNCTION UAB 298.15 -13595+8.3*T; 6000 N ! $ FUNCTION UPT3AL 298.15 +3*UAB#-3913; 6000 N ! $ FUNCTION UPTAL 298.15 +4*UAB#; 6000 N ! $ FUNCTION UPTAL3 298.15 +3*UAB#; 6000 N ! $ FUNCTION UL0 298.15 +1412.8+5.7*T; 6000 N ! $ FUNCTION USRO 298.15 +UAB#; 6000 N ! $ FUNCTION ULD0 298.15 -110531-22.9*T; 6000 N ! $ FUNCTION ULD1 298.15 -25094; 6000 N ! $ FUNCTION ULD2 298.15 +21475; 6000 N ! $ FUNCTION DG0 298.15 +UPTAL3#+1.5*UPTAL#+UPT3AL#; 6000 $ N ! $ FUNCTION DG1 298.15 +2*UPTAL3#-2*UPT3AL#; 6000 N ! $ FUNCTION DG2 298.15 +UPTAL3#-1.5*UPTAL#+UPT3AL#; 6000 $ N ! FUNCTION APL0FCC 298.15 4e4+4*T; 6000 N ! FUNCTION APL1FCC 298.15 0; 6000 N ! FUNCTION APL2FCC 298.15 0; 6000 N ! FUNCTION APL3FCC 298.15 0; 6000 N ! FUNCTION RAL3PT1 298.15 -44.8e3+5*T; 6000 N ! FUNCTION RAL2PT2 298.15 -81.4e3+5*T; 6000 N ! FUNCTION RAL1PT3 298.15 -66.9e3+5*T; 6000 N ! FUNCTION GAL3PT1 298.15 RAL3PT1-0.1875*APL0FCC-0.09375*APL1FCC -0.046875*APL2FCC-0.0234375*APL3FCC; 6000 N ! FUNCTION GAL2PT2 298.15 RAL2PT2-0.25*APL0FCC; 6000 N ! FUNCTION GAL1PT3 298.15 RAL1PT3-0.1875*APL0FCC+0.09375*APL1FCC -0.046875*APL2FCC+0.0234375*APL3FCC; 6000 N ! FUNCTION ALPTG0 2.98150E+02 +GAL3PT1#+1.5*GAL2PT2#+GAL1PT3#; 6.00000E+03 N ! FUNCTION ALPTG1 2.98150E+02 +2*GAL3PT1#-2*GAL1PT3#; 6.00000E+03 N ! FUNCTION ALPTG2 2.98150E+02 +GAL3PT1#-1.5*GAL2PT2#+GAL1PT3#; 6.00000E+03 N ! FUNCTION UL0 298.15 0; 6000 N ! $ UAP only used in ternary FUNCTION UAP 298.15 -22e3+2*T; 6000 N ! FUNCTION REC 298.15 -35e3+3*T; 6000 N ! $*****NI-PT FUNCTION L0FCC 298.15 27500+10.977*T; 6000 N ! FUNCTION L1FCC 298.15 -6500; 6000 N ! FUNCTION L2FCC 298.15 0; 6000 N ! FUNCTION L3FCC 298.15 0; 6000 N ! FUNCTION RNI3PT1 298.15 -1.09000000E+04; 6000 N ! FUNCTION RNI2PT2 298.15 -1.35000000E+04-0.5*T; 6000 N ! FUNCTION RNI1PT3 298.15 -8.30000000E+03-0.5*T; 6000 N ! FUNCTION GNI3PT1 298.15 RNI3PT1-0.1875*L0FCC-0.09375*L1FCC -0.046875*L2FCC-0.0234375*L3FCC; 6000 N ! FUNCTION GNI2PT2 298.15 RNI2PT2-0.25*L0FCC; 6000 N ! FUNCTION GNI1PT3 298.15 RNI1PT3-0.1875*L0FCC+0.09375*L1FCC -0.046875*L2FCC+0.0234375*L3FCC; 6000 N ! FUNCTION NIPTG0 2.98150E+02 +GNI3PT1#+1.5*GNI2PT2#+GNI1PT3#; 6.00000E+03 N ! FUNCTION NIPTG1 2.98150E+02 +2*GNI3PT1#-2*GNI1PT3#; 6.00000E+03 N ! FUNCTION NIPTG2 2.98150E+02 +GNI3PT1#-1.5*GNI2PT2#+GNI1PT3#; 6.00000E+03 N ! FUNCTION RECNINI 298.15 -3.67000000E+03; 6000 N ! FUNCTION RECNIPT 298.15 -3.25000000E+03; 6000 N ! FUNCTION RECPTPT 298.15 -2.73000000E+03; 6000 N ! $*****NI-AL-PT FUNCTION TROIS 2.98150E+02 3; 6.00000E+03 N ! FUNCTION UNTIER 2.98150E+02 +TROIS#**(-1); 6.00000E+03 N ! FUNCTION GNIPT 298.15 GNI3PT1#*UNTIER#; 6000 N ! FUNCTION GAL2NIPT 298.15 2*UAP#+2*U1ALNI#+GNIPT#-1.1E4; 6000 N 05LU! FUNCTION GNI2ALPT 298.15 2*U1ALNI#+2*GNIPT#+UAP#-1000; 6000 N 05LU! FUNCTION GPT2ALNI 298.15 2*GNIPT#+2*UAP#+U1ALNI#-10000; 6000 N 05LU! FUNCTION LALNIALPT 298.15 0.5*U1ALNI+0.5*UAP-0.5*GNIPT+10000; 6000 N 05LU! FUNCTION LALNINIPT 298.15 0.5*U1ALNI-0.5*UAP+0.5*GNIPT+3000; 6000 N 05LU ! FUNCTION LALPTNIPT 298.15 -0.5*U1ALNI+0.5*UAP+0.5*GNIPT; 6000 N 05LU! $*************** TYPE_DEFINITION % SEQ *! $ DEFINE_SYSTEM_DEFAULT ELEMENT 4 ! DEFAULT_COMMAND DEF_SYS_ELEMENT VA ! $******************************** Liquid PHASE LIQUID:L % 1 1.0 ! CONSTITUENT LIQUID:L :AL,NI,PT : ! PARAMETER G(LIQUID,AL;0) 2.98150E+02 +11005.029-11.841867*T +7.934E-20*T**7+GHSERAL#; 9.33600E+02 Y +10482.282-11.253974*T+1.231E+28*T**(-9)+GHSERAL#; 6.00000E+03 N 91DIN ! PARAMETER G(LIQUID,NI;0) 2.98130E+02 +16414.686-9.397*T -3.82318E-21*T**7+GHSERNI#; 1.72800E+03 Y +18290.88-10.537*T-1.12754E+31*T**(-9)+GHSERNI#; 6.00E+03 N 91DIN ! PARAMETER G(LIQUID,PT;0) 2.98150E+02 +12520.614+115.114727*T -24.5526*T*LN(T)-.00248297*T**2-2.0138E-08*T**3+7974*T**(-1); 6.0E+02 Y +19019.913+33.017485*T-12.351404*T*LN(T)-.011543133*T**2+9.30579E-07*T**3 -600885*T**(-1); 2.04210E+03 Y +1404.968+205.861909*T-36.5*T*LN(T); 4.00000E+03 N REF283 ! PARAMETER L(LIQUID,AL,NI;0) 298.15 +LLIQ0;,, N 95DUP3 ! PARAMETER L(LIQUID,AL,NI;1) 298.15 +LLIQ1;,, N 95DUP3 ! PARAMETER L(LIQUID,AL,NI;2) 298.15 +LLIQ2;,, N 95DUP3 ! PARAMETER L(LIQUID,AL,NI;3) 298.15 +LLIQ3;,, N 95DUP3 ! PARAMETER L(LIQUID,AL,NI;4) 298.15 +LLIQ4;,, N 95DUP3 ! PARAMETER L(liquid,ni,pt;0) 2.98150E+02 -4.07756E+04; 6.00000E+03 N 05LU ! PARAMETER L(liquid,ni,pt;1) 2.98150E+02 -5.5E+03; 6.00000E+03 N 05LU ! PARAMETER L(liquid,ni,pt;2) 2.98150E+02 3.50E+03; 6.00000E+03 N 05LU ! PARAMETER L(liquid,al,ni,pt;0) 2.98150E+02 2.0E5; 6.00000E+03 N 05LU ! PARAMETER G(LIQUID,AL,PT;0) 298.15 -3.10000000E+05+10*T; 6.0000E+03 N REF0 ! PARAMETER G(LIQUID,AL,PT;1) 298.15 -4.00000000E+04-15*T; 6.00E+03 N REF0 ! $********************* FCC_A1 TYPE_DEFINITION ( GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! PHASE FCC_A1 %( 2 1 1 ! CONSTITUENT FCC_A1 :AL,NI%,PT : VA% : ! PARAMETER G(FCC_A1,AL:VA;0) 2.98150E+02 +GHSERAL#; 6.00000E+03 N 91DIN ! PARAMETER G(FCC_A1,NI:VA;0) 2.98150E+02 +GHSERNI#; 6.00000E+03 N 91DIN ! PARAMETER G(FCC_A1,PT:VA;0) 2.98150E+02 +GHSERPT#; 4.00000E+03 N REF283 ! $ PARAMETER TC(FCC_A1,PT:VA;0) 2.98150E+02 -307.85; 6.00000E+03 $ N REF: 0 ! PARAMETER TC(FCC_A1,NI:VA;0) 2.98150E+02 633; 6.00000E+03 N 89DIN ! PARAMETER BMAGN(FCC_A1,NI:VA;0) 2.98150E+02 .52; 6.00000E+03 N 89DIN ! $ PARAMETER L(fcc_a1,al,pt:va;0) 2.98150E+02 -262446.89; 2.90000E+03 N ! $ PARAMETER L(fcc_a1,al,pt:va;1) 2.9815E+02 102728.95-8.57*T; 2.90000E+03 N $ REF01! PARAMETER TC(FCC_A1,AL,NI:VA;0) 2.98150E+02 -1112; 6.00000E+03 N 95DUP3 ! PARAMETER TC(FCC_A1,AL,NI:VA;1) 2.98150E+02 1745; 6.00000E+03 N 95DUP3 ! PARAMETER L(FCC_A1,AL,NI:VA;0) 298.15 +LFCC0+4*L0ALNI;,, N 03SUN ! PARAMETER L(FCC_A1,AL,NI:VA;1) 298.15 +LFCC1;,, N 03SUN ! PARAMETER L(FCC_A1,AL,NI:VA;2) 298.15 +LFCC2;,, N 03SUN ! PARAMETER L(FCC_A1,AL,NI:VA;3) 298.15 +LFCC3;,, N 03SUN ! $ these ternary parameters below not included and wrong and duplicate ?? !!! PARAMETER L(fcc_a1,ni,pt:va;0) 2.98150E+02 +L0FCC+NIPTG0+0.375*RECNINI +0.75*RECNIPT#+0.375*RECPTPT#; 6.00000E+03 N 05LU ! PARAMETER L(fcc_a1,ni,pt:va;1) 2.98150E+02 +L1FCC+NIPTG1+0.75*RECNINI# -0.75*RECPTPT#; 6.00000E+03 N 05LU ! PARAMETER L(fcc_a1,ni,pt:va;2) 2.98150E+02 +L2FCC+NIPTG2-1.5*RECNIPT#; 6.00000E+03 N 05LU ! PARAMETER L(fcc_a1,ni,pt:va;3) 2.98150E+02 +L3FCC-0.75*RECNINI# +0.75*RECPTPT#; 6.00000E+03 N 05LU ! PARAMETER L(fcc_a1,ni,pt:va;4) 2.98150E+02 -0.375*RECNINI#+0.75*RECNIPT# -0.375*RECPTPT#; 6.0E+03 N 05LU ! PARAMETER L(fcc_a1,al,ni,pt:va;0) 2.98150E+02 +3.0E4; 6.00000E+03 N 05LU ! PARAMETER L(fcc_a1,al,ni,pt:va;1) 2.98150E+02 0; 6.00000E+03 N 05LU ! PARAMETER L(fcc_a1,al,ni,pt:va;2) 2.98150E+02 0; 6.00000E+03 N 05LU ! $ these ternary parameters above not included and duplicate and wrong ?? !!! PARAMETER G(FCC_A1,AL,PT:VA;0) 298.15 +APL0FCC#+ALPTG0#+1.5*REC#; 6000 N REF0 ! PARAMETER G(FCC_A1,AL,PT:VA;1) 298.15 +APL1FCC#+ALPTG1#; 6000 N REF0 ! PARAMETER G(FCC_A1,AL,PT:VA;2) 298.15 +APL2FCC#+ALPTG2#-1.5*REC#; 6000 N REF0 ! PARAMETER G(FCC_A1,AL,PT:VA;3) 298.15 +APL3FCC#; 6000 N REF0 ! $************FCC_4SL $ TYPE_DEFINITION * GES AMEND_PHASE_DESCRIPTION FCC_4SL DIS_PART FCC_A1,,,! $ TYPE_DEFINITION M GES A_P_D FCC_4SL C_S 2 NI:NI:NI:PT:VA ! $ TYPE_DEFINITION P GES A_P_D FCC_4SL C_S 3 NI:NI:PT:PT:VA ! $ TYPE_DEFINITION Q GES A_P_D FCC_4SL C_S 4 NI:PT:PT:PT:VA ! TYPE_DEFINITION Z GES A_P_D FCC_4SL MAGNETIC -3.0 2.80000E-01 ! PHASE FCC_4SL %*Z 5 .25 .25 .25 .25 1 ! CONSTITUENT FCC_4SL :AL,NI,PT:AL,NI,PT:AL,NI,PT:AL,NI,PT:VA%: ! $ PARA G(FCC_4SL,AL:AL:AL:AL:VA;0) 298.15 0; 6000 N! $ PARA G(FCC_4SL,NI:NI:NI:NI:VA;0) 298.15 0; 6000 N! $ PARA G(FCC_4SL,PT:PT:PT:PT:VA;0) 298.15 0; 6000 N! PARAMETER G(FCC_4SL,NI:AL:AL:AL:VA;0) 298.15 +AL3NI; ,, 03SUN ! PARAMETER G(FCC_4SL,AL:NI:AL:AL:VA;0) 298.15 +AL3NI; ,, 03SUN ! PARAMETER G(FCC_4SL,NI:NI:AL:AL:VA;0) 298.15 +AL2NI2; ,, 03SUN ! PARAMETER G(FCC_4SL,AL:AL:NI:AL:VA;0) 298.15 +AL3NI; ,, 03SUN ! PARAMETER G(FCC_4SL,NI:AL:NI:AL:VA;0) 298.15 +AL2NI2; ,, 03SUN ! PARAMETER G(FCC_4SL,AL:NI:NI:AL:VA;0) 298.15 +AL2NI2; ,, 03SUN ! PARAMETER G(FCC_4SL,NI:NI:NI:AL:VA;0) 298.15 +ALNI3; ,, 03SUN ! PARAMETER G(FCC_4SL,AL:AL:AL:NI:VA;0) 298.15 +AL3NI; ,, 03SUN ! PARAMETER G(FCC_4SL,NI:AL:AL:NI:VA;0) 298.15 +AL2NI2; ,, 03SUN ! PARAMETER G(FCC_4SL,AL:NI:AL:NI:VA;0) 298.15 +AL2NI2; ,, 03SUN ! PARAMETER G(FCC_4SL,NI:NI:AL:NI:VA;0) 298.15 +ALNI3; ,, 03SUN ! PARAMETER G(FCC_4SL,AL:AL:NI:NI:VA;0) 298.15 +AL2NI2; ,, 03SUN ! PARAMETER G(FCC_4SL,NI:AL:NI:NI:VA;0) 298.15 +ALNI3; ,, 03SUN ! PARAMETER G(FCC_4SL,AL:NI:NI:NI:VA;0) 298.15 +ALNI3; ,, 03SUN ! PARAMETER G(FCC_4SL,PT:AL:AL:AL:VA;0) 298.15 +GAL3PT1#; 3000 N REF0 ! PARAMETER G(FCC_4SL,AL:PT:AL:AL:VA;0) 298.15 +GAL3PT1#; 3000 N REF0 ! PARAMETER G(FCC_4SL,PT:PT:AL:AL:VA;0) 298.15 +GAL2PT2#; 3000 N REF0 ! PARAMETER G(FCC_4SL,AL:AL:PT:AL:VA;0) 298.15 +GAL3PT1#; 3000 N REF0 ! PARAMETER G(FCC_4SL,PT:AL:PT:AL:VA;0) 298.15 +GAL2PT2#; 3000 N REF0 ! PARAMETER G(FCC_4SL,AL:PT:PT:AL:VA;0) 298.15 +GAL2PT2#; 3000 N REF0 ! PARAMETER G(FCC_4SL,PT:PT:PT:AL:VA;0) 298.15 +GAL1PT3#; 3000 N REF0 ! PARAMETER G(FCC_4SL,AL:AL:AL:PT:VA;0) 298.15 +GAL3PT1#; 3000 N REF0 ! PARAMETER G(FCC_4SL,PT:AL:AL:PT:VA;0) 298.15 +GAL2PT2#; 3000 N REF0 ! PARAMETER G(FCC_4SL,AL:PT:AL:PT:VA;0) 298.15 +GAL2PT2#; 3000 N REF0 ! PARAMETER G(FCC_4SL,PT:PT:AL:PT:VA;0) 298.15 +GAL1PT3#; 3000 N REF0 ! PARAMETER G(FCC_4SL,AL:AL:PT:PT:VA;0) 298.15 +GAL2PT2#; 3000 N REF0 ! PARAMETER G(FCC_4SL,PT:AL:PT:PT:VA;0) 298.15 +GAL1PT3#; 3000 N REF0 ! PARAMETER G(FCC_4SL,AL:PT:PT:PT:VA;0) 298.15 +GAL1PT3#; 3000 N REF0 ! PARAMETER G(FCC_4SL,PT:NI:NI:NI:VA;0) 2.98150E+02 +GNI3PT1#; 6.0E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:PT:NI:NI:VA;0) 2.98150E+02 +GNI3PT1#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:PT:NI:NI:VA;0) 2.98150E+02 +GNI2PT2#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:NI:PT:NI:VA;0) 2.98150E+02 +GNI3PT1#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:NI:PT:NI:VA;0) 2.98150E+02 +GNI2PT2#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:PT:PT:NI:VA;0) 2.98150E+02 +GNI2PT2#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:PT:PT:NI:VA;0) 2.98150E+02 +GNI1PT3#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:NI:NI:PT:VA;0) 2.98150E+02 +GNI3PT1#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:NI:NI:PT:VA;0) 2.98150E+02 +GNI2PT2#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:PT:NI:PT:VA;0) 2.98150E+02 +GNI2PT2#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:PT:NI:PT:VA;0) 2.98150E+02 +GNI1PT3#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:NI:PT:PT:VA;0) 2.98150E+02 +GNI2PT2#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:NI:PT:PT:VA;0) 2.98150E+02 +GNI1PT3#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:PT:PT:PT:VA;0) 2.98150E+02 +GNI1PT3#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:NI:AL:PT:VA;0) 2.98150E+02 +GNI2ALPT#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:NI:PT:AL:VA;0) 2.98150E+02 +GNI2ALPT#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:AL:NI:PT:VA;0) 2.98150E+02 +GNI2ALPT#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:PT:NI:AL:VA;0) 2.98150E+02 +GNI2ALPT#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:AL:PT:NI:VA;0) 2.98150E+02 +GNI2ALPT#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:PT:AL:NI:VA;0) 2.98150E+02 +GNI2ALPT#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,AL:PT:NI:NI:VA;0) 2.98150E+02 +GNI2ALPT#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:AL:NI:NI:VA;0) 2.98150E+02 +GNI2ALPT#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,AL:NI:PT:NI:VA;0) 2.98150E+02 +GNI2ALPT#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:NI:AL:NI:VA;0) 2.98150E+02 +GNI2ALPT#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,AL:NI:NI:PT:VA;0) 2.98150E+02 +GNI2ALPT#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:NI:NI:AL:VA;0) 2.98150E+02 +GNI2ALPT#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,AL:AL:NI:PT:VA;0) 2.98150E+02 +GAL2NIPT#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,AL:AL:PT:NI:VA;0) 2.98150E+02 +GAL2NIPT#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,AL:NI:AL:PT:VA;0) 2.98150E+02 +GAL2NIPT#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,AL:PT:AL:NI:VA;0) 2.98150E+02 +GAL2NIPT#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,AL:NI:PT:AL:VA;0) 2.98150E+02 +GAL2NIPT#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,AL:PT:NI:AL:VA;0) 2.98150E+02 +GAL2NIPT#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:PT:AL:AL:VA;0) 2.98150E+02 +GAL2NIPT#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:NI:AL:AL:VA;0) 2.98150E+02 +GAL2NIPT#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:AL:PT:AL:VA;0) 2.98150E+02 +GAL2NIPT#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:AL:NI:AL:VA;0) 2.98150E+02 +GAL2NIPT#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:AL:AL:PT:VA;0) 2.98150E+02 +GAL2NIPT#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:AL:AL:NI:VA;0) 2.98150E+02 +GAL2NIPT#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:PT:NI:AL:VA;0) 2.98150E+02 +GPT2ALNI#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:PT:AL:NI:VA;0) 2.98150E+02 +GPT2ALNI#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:NI:PT:AL:VA;0) 2.98150E+02 +GPT2ALNI#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:AL:PT:NI:VA;0) 2.98150E+02 +GPT2ALNI#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:NI:AL:PT:VA;0) 2.98150E+02 +GPT2ALNI#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:AL:NI:PT:VA;0) 2.98150E+02 +GPT2ALNI#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:AL:PT:PT:VA;0) 2.98150E+02 +GPT2ALNI#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,AL:NI:PT:PT:VA;0) 2.98150E+02 +GPT2ALNI#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:PT:AL:PT:VA;0) 2.98150E+02 +GPT2ALNI#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,AL:PT:NI:PT:VA;0) 2.98150E+02 +GPT2ALNI#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:PT:PT:AL:VA;0) 2.98150E+02 +GPT2ALNI#; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,AL:PT:PT:NI:VA;0) 2.98150E+02 +GPT2ALNI#; 6E+03 N 05LU ! PARAMETER L(FCC_4SL,AL,NI:*:*:*:VA;0) 298.15 +L0ALNI; ,, 03SUN ! PARAMETER L(FCC_4SL,*:AL,NI:*:*:VA;0) 298.15 +L0ALNI; ,, 03SUN ! PARAMETER L(FCC_4SL,*:*:AL,NI:*:VA;0) 298.15 +L0ALNI; ,, 03SUN ! PARAMETER L(FCC_4SL,*:*:*:AL,NI:VA;0) 298.15 +L0ALNI; ,, 03SUN ! PARAMETER G(FCC_4SL,AL,PT:*:*:*:VA;0) 298.15 +UL0#; 3000 N REF0 ! PARAMETER G(FCC_4SL,*:AL,PT:*:*:VA;0) 298.15 +UL0#; 3000 N REF0 ! PARAMETER G(FCC_4SL,*:*:AL,PT:*:VA;0) 298.15 +UL0#; 3000 N REF0 ! PARAMETER G(FCC_4SL,*:*:*:AL,PT:VA;0) 298.15 +UL0#; 3000 N REF0 ! PARAMETER G(FCC_4SL,AL,PT:AL,PT:*:*:VA;0) 298.15 +REC#; 3000 N REF0 ! PARAMETER G(FCC_4SL,AL,PT:*:AL,PT:*:VA;0) 298.15 +REC#; 3000 N REF0 ! PARAMETER G(FCC_4SL,AL,PT:*:*:AL,PT:VA;0) 298.15 +REC#; 3000 N REF0 ! PARAMETER G(FCC_4SL,*:AL,PT:AL,PT:*:VA;0) 298.15 +REC#; 3000 N REF0 ! PARAMETER G(FCC_4SL,*:AL,PT:*:AL,PT:VA;0) 298.15 +REC#; 3000 N REF0 ! PARAMETER G(FCC_4SL,*:*:AL,PT:AL,PT:VA;0) 298.15 +REC#; 3000 N REF0 ! PARAMETER L(FCC_4SL,*:*:AL,NI:AL,NI:VA;0) 298.15 +URALNI;,, N 03SUN ! PARAMETER L(FCC_4SL,*:AL,NI:*:AL,NI:VA;0) 298.15 +URALNI;,, N 03SUN ! PARAMETER L(FCC_4SL,AL,NI:*:*:AL,NI:VA;0) 298.15 +URALNI;,, N 03SUN ! PARAMETER L(FCC_4SL,*:AL,NI:AL,NI:*:VA;0) 298.15 +URALNI;,, N 03SUN ! PARAMETER L(FCC_4SL,AL,NI:*:AL,NI:*:VA;0) 298.15 +URALNI;,, N 03SUN ! PARAMETER L(FCC_4SL,AL,NI:AL,NI:*:*:VA;0) 298.15 +URALNI;,, N 03SUN ! PARAMETER G(FCC_4SL,NI:NI:NI,PT:NI,PT:VA;0) 2.98150E+02 RECNINI; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:NI,PT:NI:NI,PT:VA;0) 2.98150E+02 RECNINI; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:NI,PT:NI,PT:NI:VA;0) 2.98150E+02 RECNINI; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:NI:NI:NI,PT:VA;0) 2.98150E+02 RECNINI; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:NI:NI,PT:NI:VA;0) 2.98150E+02 RECNINI; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:NI,PT:NI:NI:VA;0) 2.98150E+02 RECNINI; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:PT:NI,PT:NI,PT:VA;0) 2.98150E+02 RECPTPT; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:NI,PT:PT:NI,PT:VA;0) 2.98150E+02 RECPTPT; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:NI,PT:NI,PT:PT:VA;0) 2.98150E+02 RECPTPT; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:PT:PT:NI,PT:VA;0) 2.98150E+02 RECPTPT; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:PT:NI,PT:PT:VA;0) 2.98150E+02 RECPTPT; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:NI,PT:PT:PT:VA;0) 2.98150E+02 RECPTPT; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,AL:AL:NI,PT:NI,PT:VA;0) 2.98150E+02 RECPTPT; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,AL:NI,PT:AL:NI,PT:VA;0) 2.98150E+02 RECPTPT; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,AL:NI,PT:NI,PT:AL:VA;0) 2.98150E+02 RECPTPT; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:AL:AL:NI,PT:VA;0) 2.98150E+02 RECPTPT; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:AL:NI,PT:AL:VA;0) 2.98150E+02 RECPTPT; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:NI,PT:AL:AL:VA;0) 2.98150E+02 RECPTPT; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:PT:NI,PT:NI,PT:VA;0) 2.98150E+02 RECNIPT; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:NI:NI,PT:NI,PT:VA;0) 2.98150E+02 RECNIPT; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:NI,PT:PT:NI,PT:VA;0) 2.98150E+02 RECNIPT; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:NI,PT:NI:NI,PT:VA;0) 2.98150E+02 RECNIPT; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:NI,PT:NI,PT:PT:VA;0) 2.98150E+02 RECNIPT; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:NI,PT:NI,PT:NI:VA;0) 2.98150E+02 RECNIPT; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:NI:PT:NI,PT:VA;0) 2.98150E+02 RECNIPT; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:PT:NI:NI,PT:VA;0) 2.98150E+02 RECNIPT; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:NI:NI,PT:PT:VA;0) 2.98150E+02 RECNIPT; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:PT:NI,PT:NI:VA;0) 2.98150E+02 RECNIPT; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:NI,PT:NI:PT:VA;0) 2.98150E+02 RECNIPT; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:NI,PT:PT:NI:VA;0) 2.98150E+02 RECNIPT; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:NI,PT:AL:NI:VA;0) 2.98150E+02 RECNIPT+7000; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:NI,PT:NI:AL:VA;0) 2.98150E+02 RECNIPT+7000; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:AL:NI:NI,PT:VA;0) 2.98150E+02 RECNIPT+7000; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:NI:AL:NI,PT:VA;0) 2.98150E+02 RECNIPT+7000; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:AL:NI,PT:NI:VA;0) 2.98150E+02 RECNIPT+7000; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:NI:NI,PT:AL:VA;0) 2.98150E+02 RECNIPT+7000; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,AL:NI:NI,PT:NI,PT:VA;0) 2.98150E+02 RECNIPT+7000; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:AL:NI,PT:NI,PT:VA;0) 2.98150E+02 RECNIPT+7000; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,AL:NI,PT:NI,PT:NI:VA;0) 2.98150E+02 RECNIPT+7000; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:NI,PT:NI,PT:AL:VA;0) 2.98150E+02 RECNIPT+7000; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,AL:NI,PT:NI:NI,PT:VA;0) 2.98150E+02 RECNIPT+7000; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI:NI,PT:AL:NI,PT:VA;0) 2.98150E+02 RECNIPT+7000; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:NI,PT:AL:PT:VA;0) 2.98150E+02 RECNIPT+2000; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:NI,PT:PT:AL:VA;0) 2.98150E+02 RECNIPT+2000; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:AL:PT:NI,PT:VA;0) 2.98150E+02 RECNIPT+2000; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:PT:AL:NI,PT:VA;0) 2.98150E+02 RECNIPT+2000; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:AL:NI,PT:PT:VA;0) 2.98150E+02 RECNIPT+2000; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:PT:NI,PT:AL:VA;0) 2.98150E+02 RECNIPT+2000; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,AL:PT:NI,PT:NI,PT:VA;0) 2.98150E+02 RECNIPT+2000; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:AL:NI,PT:NI,PT:VA;0) 2.98150E+02 RECNIPT+2000; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,AL:NI,PT:NI,PT:PT:VA;0) 2.98150E+02 RECNIPT+2000; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:NI,PT:NI,PT:AL:VA;0) 2.98150E+02 RECNIPT+2000; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,AL:NI,PT:PT:NI,PT:VA;0) 2.98150E+02 RECNIPT+2000; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,PT:NI,PT:AL:NI,PT:VA;0) 2.98150E+02 RECNIPT+2000; 6.00000E+03 N 05LU ! PARAMETER G(FCC_4SL,AL,NI:AL,PT:*:*:VA;0) 2.9815E+02 LALNIALPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,AL,PT:AL,NI:*:*:VA;0) 2.9815E+02 LALNIALPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,AL,NI:*:AL,PT:*:VA;0) 2.9815E+02 LALNIALPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,AL,PT:*:AL,NI:*:VA;0) 2.9815E+02 LALNIALPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,AL,NI:*:*:AL,PT:VA;0) 2.9815E+02 LALNIALPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,AL,PT:*:*:AL,NI:VA;0) 2.9815E+02 LALNIALPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,*:AL,NI:AL,PT:*:VA;0) 2.9815E+02 LALNIALPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,*:AL,PT:AL,NI:*:VA;0) 2.9815E+02 LALNIALPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,*:*:AL,NI:AL,PT:VA;0) 2.9815E+02 LALNIALPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,*:*:AL,PT:AL,NI:VA;0) 2.9815E+02 LALNIALPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,*:AL,NI:*:AL,PT:VA;0) 2.9815E+02 LALNIALPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,*:AL,PT:*:AL,NI:VA;0) 2.9815E+02 LALNIALPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,AL,NI:NI,PT:*:*:VA;0) 2.9815E+02 LALNINIPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:AL,NI:*:*:VA;0) 2.9815E+02 LALNINIPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,AL,NI:*:NI,PT:*:VA;0) 2.9815E+02 LALNINIPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:*:AL,NI:*:VA;0) 2.9815E+02 LALNINIPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,AL,NI:*:*:NI,PT:VA;0) 2.9815E+02 LALNINIPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:*:*:AL,NI:VA;0) 2.9815E+02 LALNINIPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,*:*:AL,NI:NI,PT:VA;0) 2.9815E+02 LALNINIPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,*:*:NI,PT:AL,NI:VA;0) 2.9815E+02 LALNINIPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,*:AL,NI:*:NI,PT:VA;0) 2.9815E+02 LALNINIPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,*:NI,PT:*:AL,NI:VA;0) 2.9815E+02 LALNINIPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,*:AL,NI:NI,PT:*:VA;0) 2.9815E+02 LALNINIPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,*:NI,PT:AL,NI:*:VA;0) 2.9815E+02 LALNINIPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,AL,PT:NI,PT:*:*:VA;0) 2.9815E+02 LALPTNIPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:AL,PT:*:*:VA;0) 2.9815E+02 LALPTNIPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,AL,PT:*:NI,PT:*:VA;0) 2.9815E+02 LALPTNIPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:*:AL,PT:*:VA;0) 2.9815E+02 LALPTNIPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,AL,PT:*:*:NI,PT:VA;0) 2.9815E+02 LALPTNIPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,NI,PT:*:*:AL,PT:VA;0) 2.9815E+02 LALPTNIPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,*:*:AL,PT:NI,PT:VA;0) 2.9815E+02 LALPTNIPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,*:*:NI,PT:AL,PT:VA;0) 2.9815E+02 LALPTNIPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,*:AL,PT:*:NI,PT:VA;0) 2.9815E+02 LALPTNIPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,*:NI,PT:*:AL,PT:VA;0) 2.9815E+02 LALPTNIPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,*:AL,PT:NI,PT:*:VA;0) 2.9815E+02 LALPTNIPT; 6E+03 N 05LU ! PARAMETER G(FCC_4SL,*:NI,PT:AL,PT:*:VA;0) 2.9815E+02 LALPTNIPT; 6E+03 N 05LU ! $***********AL3NI1 PHASE AL3NI1 % 2 .75 .25 ! CONSTITUENT AL3NI1 :AL : NI : ! PARAMETER G(AL3NI1,AL:NI;0) 2.98150E+02 -48483.73+12.29913*T +.75*GHSERAL#+.25*GHSERNI#; 6.00000E+03 N 95DUP3 ! $******************** AL3NI2 PHASE AL3NI2 % 3 3 2 1 ! CONSTITUENT AL3NI2 :AL : AL,NI%,PT : NI,VA% : ! PARAMETER G(AL3NI2,AL:AL:NI;0) 298.15 +6*GALALNI;,, N 95DUP3 ! PARAMETER G(AL3NI2,AL:NI:NI;0) 298.15 +6*GALNINI;,, N 95DUP3 ! PARAMETER G(AL3NI2,AL:AL:VA;0) 298.15 +6*GALALVA;,, N 95DUP3 ! PARAMETER G(AL3NI2,AL:NI:VA;0) 298.15 +6*GALNIVA;,, N 95DUP3 ! PARAMETER G(AL3NI2,AL:PT:NI;0) 2.98150E+02 +3*GBCCAL#+GBCCNI#+2*GBCCPT#; 6.00000E+03 N 05LU ! PARAMETER G(AL3NI2,AL:PT:VA;0) 2.98150E+02 +3*GBCCAL#+2*GBCCPT#; 6.00000E+03 N 05LU ! PARAMETER L(AL3NI2,AL:AL,NI:*;0) 298.15 +6*L32ALNI;,, N 95DUP3 ! PARAMETER L(AL3NI2,AL:*:NI,VA;0) 298.15 +6*L32NIVA;,, N 95DUP3 ! $******************** AL3NI5 PHASE AL3NI5 % 2 .375 .625 ! CONSTITUENT AL3NI5 :AL : NI : ! PARAMETER G(AL3NI5,AL:NI;0) 298.15 -66520+18.9*T +.375*GHSERAL+.625*GHSERNI;,, N 03SUN ! $ PARAMETER G(AL3NI5,AL:NI;0) 2.98150E+02 +.375*GHSERAL#+.625*GHSERNI# $ -55507.7594+7.2648103*T; 6.00000E+03 N 95DUP3 ! $***************************** BCC_A2 $****************** BCC_B2 TYPE_DEFINITION W GES A_P_D BCC_A2 MAGNETIC -1.0 4.0000E-01 ! PHASE BCC_B2 %W 3 .5 .5 3 ! CONSTITUENT BCC_B2 :AL,NI%,PT,VA : AL%,NI,PT,VA : VA : ! PARA G(BCC_B2,AL:AL:VA;0) 298.15 +GBCCAL; 6000 N 91DIN ! PARA G(BCC_B2,NI:NI:VA;0) 298.15 +GBCCNI; 6000 N 91DIN ! PARA G(BCC_B2,PT:PT:VA;0) 298.15 +GBCCPT; 6000 N 91DIN ! PARA G(BCC_B2,VA:VA:VA;0) 298.15 30*T; 6000 N 13SUN! PARAMETER TC(BCC_B2,NI:VA:VA;0) 298.15 575;,, N 89DIN ! PARAMETER BMAGN(BCC_B2,NI:VA:VA;0) 298.15 .85;,, N 89DIN ! FUNCTION B2ALNI 295.15 -152397.3+26.40575*T;,, N 95DUP3 ! PARA G(BCC_B2,NI:AL:VA;0) 2.9815E+02 +.5*GBCCAL+.5*GBCCNI+.5*B2ALNI; 6000 N 95DUP3 ! PARA G(BCC_B2,AL:NI:VA;0) 2.9815E+02 +.5*GBCCAL+.5*GBCCNI+.5*B2ALNI; 6000 N 95DUP3 ! FUNCTION B2ALVA 295.15 10000-T;,,N 95DUP3 ! PARA G(BCC_B2,VA:AL:VA;0) 2.9815E+02 +0.5*GBCCAL+.5*B2ALVA; 6000 N 95DUP3 ! PARA G(BCC_B2,AL:VA:VA;0) 2.9815E+02 +0.5*GBCCAL+.5*B2ALVA; 6000 N 95DUP3 ! PARA G(BCC_B2,PT:AL:VA;0) 2.9815E+02 +.5*GBCCAL+.5*GBCCPT-98000+6*T; 6000 N 05LU ! PARA G(BCC_B2,AL:PT:VA;0) 2.9815E+02 +.5*GBCCAL+.5*GBCCPT-98000+6*T; 6000 N 05LU ! FUNCTION B2NIVA 295.15 +162397.3-27.40575*T;,, N 95DUP3 ! PARA G(BCC_B2,VA:NI:VA;0) 2.9815E+02 +.5*GBCCNI+.5*B2NIVA; 6000 N 95DUP3 ! PARA G(BCC_B2,NI:VA:VA;0) 2.9815E+02 +.5*GBCCNI+.5*B2NIVA; 6000 N 95DUP3 ! PARA G(BCC_B2,PT:NI:VA;0) 2.9815E+02 +.5*GBCCNI+.5*GBCCPT-20000; 6000 N 05LU ! PARA G(BCC_B2,NI:PT:VA;0) 2.9815E+02 +.5*GBCCNI+.5*GBCCPT-20000; 6000 N 05LU ! PARA G(BCC_B2,PT:VA:VA;0) 2.9815E+02 +.5*GBCCPT+1.0E5; 6000 N 05LU ! PARA G(BCC_B2,VA:PT:VA;0) 2.9815E+02 +.5*GBCCPT+1.0E5; 6000 N 05LU ! FUNCTION LB2ALNI 298.15 -62104+19.28*T;,, N 03SUN ! PARA G(BCC_B2,*:AL,NI:VA;0) 2.9815E+02 +.5*LB2ALNI; 6000 N 95DUP3 ! PARA G(BCC_B2,AL,NI:*:VA;0) 2.9815E+02 +.5*LB2ALNI; 6000 N 95DUP3 ! FUNCTION LB2ALVA 298.15 200000;,,N ! PARA G(BCC_B2,*:AL,VA:VA;0) 2.9815E+02 +.5*LB2ALVA; 6000 N 95DUP3 ! PARA G(BCC_B2,AL,VA:*:VA;0) 2.9815E+02 +.5*LB2ALVA; 6000 N 95DUP3 ! FUNCTION LB2NIVA 298.15 -64024.38+26.49419*T;,, N ! PARA G(BCC_B2,*:NI,VA:VA;0) 2.9815E+02 +.5*LB2NIVA; 6000 N 95DUP3 ! PARA G(BCC_B2,NI,VA:*:VA;0) 2.9815E+02 +.5*LB2NIVA; 6000 N 95DUP3 ! PARA G(BCC_B2,*:AL,PT:VA;0) 2.9815E+02 -45000; 6000 N 05LU ! PARA G(BCC_B2,AL,PT:*:VA;0) 2.9815E+02 -45000; 6000 N 05LU ! PARA G(BCC_B2,*:NI,PT:VA;0) 2.9815E+02 -5000; 6000 N 05LU ! PARA G(BCC_B2,NI,PT:*:VA;0) 2.9815E+02 -5000; 6000 N 05LU ! PARA G(BCC_B2,*:VA,PT:VA;0) 2.9815E+02 +0; 6000 N 05LU ! PARA G(BCC_B2,VA,PT:*:VA;0) 2.9815E+02 +0; 6000 N 05LU ! $******************************** Compounds in AL-Pt $ PHASE AL21PT8 % 2 .724138 .275862 ! $ CONS AL21PT8 :AL:PT NI:! $ PARAMETER G(AL21PT8,AL:NI;0) 2.98150E+02 -35000+.724138*GHSERAL# $ +.275862*GHSERNI#; 6.00000E+03 N REF: 0 ! $ PARAMETER G(AL21PT8,AL:PT;0) 298.15 -82342+23.7*T+.7242*GHSERAL# $ +.2759*GHSERPT#; 6000 N REF0 ! PHASE AL1PT1 % 2 .5 .5 ! CONS AL1PT1 :AL:PT NI:! PARAMETER G(AL1PT1,AL:NI;0) 2.98150E+02 -50000+10*T+.5*GHSERAL#+.5*GHSERNI#; 6000 N 05LU ! PARAMETER G(AL1PT1,AL:NI,PT;0) 2.98150E+02 0; 6.00000E+03 N 05LU ! PARAMETER G(AL1PT1,AL:PT;0) 298.15 -95000+6*T+.5*GHSERAL# +.5*GHSERPT#; 6000 N REF0 ! $******************* PHASE ALPT2 % 2 .33333 .66667 ! CONSTITUENT ALPT2 :AL : PT : ! PARAMETER G(ALPT2,AL:PT;0) 298.15 -8.10000000E+04+5*T +.33333*GHSERAL#+.66667*GHSERPT#; 6000 N REF0 ! PHASE AL3PT2 % 2 .6 .4 ! CONSTITUENT AL3PT2 :AL : PT : ! PARAMETER G(AL3PT2,AL:PT;0) 298.15 -9.20000000E+04+3.5*T+.6*GHSERAL# +.4*GHSERPT#; 6000 N REF0 ! PHASE AL21PT5 % 2 .8077 .1923 ! CONSTITUENT AL21PT5 :AL : PT : ! PARAMETER G(AL21PT5,AL:PT;0) 298.15 -6.00000000E+04+4*T+.8077*GHSERAL# +.1923*GHSERPT#; 6000 N REF0 ! PHASE AL3PT5 % 2 .375 .625 ! CONSTITUENT AL3PT5 :AL : PT : ! PARAMETER G(AL3PT5,AL:PT;0) 298.15 -8.70000000E+04+5*T+.375*GHSERAL# +.625*GHSERPT#; 6000 N REF0 ! PHASE AL21PT8 % 2 .7241 .2759 ! CONSTITUENT AL21PT8 :AL : PT : ! PARAMETER G(AL21PT8,AL:PT;0) 298.15 -8.30000000E+04+6*T+.7241*GHSERAL# +.2759*GHSERPT#; 6000 N REF0 ! PHASE AL2PT % 2 .66667 .33333 ! CONSTITUENT AL2PT :AL : PT : ! PARAMETER G(AL2PT,AL:PT;0) 298.15 -8.90000000E+04+5*T+.66667*GHSERAL# +.33333*GHSERPT#; 6000 N REF0 ! $************************************* $ASSESSED_SYSTEM AL-NI(;P3 STP:.8/1200/1) ! LIST_OF_REFERENCES NUMBER SOURCE REF01 'Kaisheng WU and Zhanpeng JIN, J. Phase Equil., Vol.21(3), 2000' REF02 'P.Nash and M.F.Singleton, Bulletin of Alloy Phase Diagrams, Vol.10(3),1989' REF283 'Alan Dinsdale, SGTE Data for Pure Elements, Calphad Vol 15(1991) p 317-425, also in NPL Report DMA(A)195 Rev. August 1990' 91DIN 'Alan Dinsdale, SGTE Data for Pure Elements, Calphad Vol 15(1991) p 317-425, also in NPL Report DMA(A)195 Rev. August 1990' REF95 'I Ansara, P Willemin B Sundman (1988); Al-Ni' REF295 'N. Saunders, unpublished research, COST-507, (1991); Al-Cu' REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 September 1989' 89DIN 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 September 1989' REF26 'A. Fernandez Guillermet, Z. Metallkde. Vol 79(1988) p.524-536, TRITA-MAC 362 (1988); C-CO-NI AND C-CO-FE-NI' REF293 'N. Saunders, private communication (1991); Al-Ti-V' 95DUP3 'N. Dupin, Thesis, LTPCM, France, 1995; Al-Ni, also in I. Ansara, N. Dupin, H.L. Lukas, B. Sundman J. Alloys Compds, 247 (1-2), 20-30 (1997)' 99DUP 'N. Dupin, I. Ansara, Z. metallkd., Vol 90 (1999) p 76-85; Al-Ni' 99DUP3 'N. Dupin, July 1999, unpublished revision ; Al-Ni' 03SUN 'B. Sundman, N. Dupin, JEEP 2003 Lyon' REF0 'S Prins and B Sundman, provisional Al-Pt (2003)' 05LU 'X.-G Lu, PhD thesis work, unpublished' 13SUN 'B. Sundman, Vacancy' ! ================================================ FILE: examples/TQ4lib/F90/parallel-alnipt/README.sim ================================================ This contain the instructions to compile and run the AlNiPt example. The OC-parallel2.pdf is a presentation of the example. 1. copy OC/libs/liboceq.a compiled with -fopenmp here 2. copy OC/liboceqplus.mod compiled with -fopenmp here 3. For Linux/Mac copy OC/getkey.o here 4. compile the version liboctq.F90 provided here 5. compile and link sim-alnipt as below (getkey.o needed only on Linux/Mac: gfortran -o sim-alnipt -fopenmp sim-alnipt.F90 liboctq.o getkey.o liboceq.a 6. Run with input file setup.dat which specifies databasefile, elements, gridpoints etc. 7. The diffusion simulation is for a single dimension and the model is very simple. All elements have the samë constant mobility which is used to move the elements between the gridpoints keeping the total amount of elements constant. 7. Output is written on ocsim.plt and can be plotted directly using GNUPLOT The alnipt-5000.png shows several composition profiles. ================================================ FILE: examples/TQ4lib/F90/parallel-alnipt/liboctq.F90 ================================================ ! ! Minimal TQ interface. ! ! To compile and link this with an application one must first compile ! and form a library with of the most OC subroutines (lib\liboceq.a) ! and copy this and the corresponding "liboceqplus.mod" file ! from this compilation to the folder with this library ! ! NOTE that for the identification of phase and composition sets this ! TQ interface use a Fortran TYPE called gtp_phasetuple containing two ! integers, "phase" with the phase number and "compset" with the ! comp.set The number of phase tuples is initially equal to the number ! of phases and have the same index. This represent comp.set 1 of the ! phases as each phase has just one composition set. A phase may have ! several comp.sets created by calculations or by commands and these will ! have phase tuple index higher than the number of phases and their index ! is in the order of which they were created. ! This may cause some problems if composition sets are deleted because that ! will change the phase tuple index for those with higher index. So do not ! delete comp.sets or at least be very careful when deleting comp.sets ! ! 210328 BOS Tested ! 191101 BOS Updates some routines and added two dummy modules for C routines ! 181030 BOS Updates some routines ! 150520 BOS added a few subroutines for single phase data and calculations ! 141210 BOS changed to use phase tuples ! 140128 BOS added D2G and phase specific V and G ! 140128 BOS added possibility to calculate without invoking grid minimizer ! 140125 BOS Changed name to liboctq ! 140123 BOS Added ouput of MQ G, V and normalized !------------------------------------------------------------ ! subroutines and functions ! tqini ok initiate ! tqrfil ok read a database file ! tqrpfil ok read specified elements from database file ! ------------------------- ! tqgcom ok get number of system components and their names ! tqgnp ok get number of phase tuples (phases and comp. sets) ! tqgpn ok get name of phase tuple ! tqgpi ok get phase tuple index of phase using its name ! tqgpcn - get name of constituent of a phase using index ! tqgpci - get index of constituent of a phase using name ! tqgpcs - get stoichiometry of species as system components ! tqgccf - get stoichiometry of system component as elements ! tqgnpc - get number of constituents in phase ! ------------------------- ! tqcref - set reference state for component ! tqphsts ok set status of phase tuple ! tqsetc ok set condition ! tqce ok calculate equilibrium ! tqgetv ok get equilibrium results as state variable values ! ------------------------- ! tqgphc1 ok get phase constitution ! tqsphc1 ok set phase constitution ! tqcph1 ok calculate phase properties and return arrays ! tqcph2 ok calculate phase properties and return index ! tqdceq ok delete equilibrium record ! tqcceq ok copy current equilibrium to a new one ! tqselceq ok select new current equilibrium ! tqlr ok list results ! tqlc ok list conditions ! !------------------------------------------------------------ ! ! The name of this library module liboctq ! ! access to main OC library for equilibrium calculations and models use liboceqplus ! implicit none ! integer, parameter :: maxc=maxel,maxp=maxph ! ! This is for storage and use of components integer nel character, dimension(maxc) :: cnam*24 ! Number of phase tuples integer ntup ! use the array PHASETUPLE available from OC ! save phase constitution to speed up calculation by interpolation double precision, allocatable, dimension(:,:) :: ysave ! contains ! !\begin{verbatim} subroutine tqini(n,ceq) ! initiate workspace implicit none integer n ! Not nused, could be used for some initial allocation type(gtp_equilibrium_data), pointer :: ceq ! EXIT: current equilibrium !\end{verbatim} ! these should be provide linits and defaults integer intv(10) double precision dblv(10) intv(1)=-1 ! This call initiates the OC package !@CC if (allocated(eqlista)) then call new_gtp endif call init_gtp(intv,dblv) !@CC ceq=>firsteq write(*,*)'tqini created: ',ceq%eqname 1000 continue return end subroutine tqini !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqrfil(filename,ceq) ! read all elements from a TDB file implicit none character*(*) filename ! IN: database filename character ellista(10)*2 ! dummy type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} %+ integer iz character elname*2,name*24,refs*24 double precision a1,a2,a3 ! second argument 0 means ellista is ignored, all element read call readtdb(filename,0,ellista) ! ceq=>firsteq nel=noel() do iz=1,nel ! store the element name in the cname array call get_element_data(iz,elname,name,refs,a1,a2,a3) cnam(iz)=elname enddo ! store phase tuples ntup=nooftup() 1000 continue return end subroutine tqrfil !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} %- subroutine tqrpfil(filename,nsel,selel,ceq) ! read TDB file with selection of elements implicit none character*(*) filename ! IN: database filename integer nsel character selel(*)*2 ! IN: elements to be read from the database type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} integer iz character elname*2,name*24,refs*24 double precision a1,a2,a3 ! call readtdb(filename,nsel,selel) if(gx%bmperr.ne.0) goto 1000 ! is this really necessary?? ! ceq=>firsteq nel=noel() do iz=1,nel ! store element name in module array components call get_element_data(iz,elname,name,refs,a1,a2,a3) cnam(iz)=elname enddo ! store phase tuples and indices ntup=nooftup() 1000 continue return end subroutine tqrpfil !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgcom(n,compnames,ceq) ! get system component names. At present the elements implicit none integer n ! EXIT: number of components character*24, dimension(*) :: compnames ! EXIT: names of components type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} integer iz character elname*24,refs*24 double precision a1,a2,a3 do iz=1,nel compnames(iz)=' ' call get_element_data(iz,compnames(iz),elname,refs,a1,a2,a3) ! store name in module array components also (already done when reading TDB) cnam(iz)=compnames(iz) enddo n=nel 1000 continue return end subroutine tqgcom !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgnp(n,ceq) ! get total number of phase tuples (phases and composition sets) ! A second composition set of a phase is normally placed after all other ! phases with one composition set implicit none integer n !EXIT: n is number of phases type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} ! NOTE the number composition sets may change at a calculation or if new ! composition sets are added or deleted explicitly ! This changes the number of phase tuples! ntup=nooftup() n=ntup 1000 continue return end subroutine tqgnp !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgpn(phtupx,phasename,ceq) ! get name of phase tuple with index phtupx (ceq redundant) implicit none integer phtupx ! IN: index in phase tuple array character phasename*(*) !EXIT: phase name, max 24+8 for pre/suffix type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} call get_phasetup_name(phtupx,phasename) 1000 continue return end subroutine tqgpn !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgpi(phtupx,phasename,ceq) ! get index of phase phasename (including comp.set (ceq redundant) implicit none integer phtupx !EXIT: phase tuple index character phasename*(*) !IN: phase name type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} call find_phasetuple_by_name(phasename,phtupx) 1000 continue return end subroutine tqgpi !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgpcn2(n,c,constituentname,ceq) ! get name of consitutent with index c in phasetuple n ! NOTE An identical routine with different constituent index is tqgpcn implicit none integer n !IN: phase number (not phase tuple) integer c !IN: constituent index sequentially over all sublattices character constituentname*(24) !EXIT: costituent name type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} double precision mass call get_constituent_name(n,c,constituentname,mass) ! write(*,*)'tqgpcn not implemented yet' ! gx%bmperr=8888 1000 continue return end subroutine tqgpcn2 !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgpci(n,c,constituentname,ceq) ! get index of constituent with name in phase n implicit none integer n !IN: phase index integer c !IN: sequantial constituent index over all sublattices character constituentname*(*) type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} write(*,*)'tqgpci not implemented yet' gx%bmperr=8888 1000 continue return end subroutine tqgpci !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgpcs(n,c,stoi,mass,ceq) ! get stoichiometry of constituent c in phase n !? missing argument number of elements???? implicit none integer n !IN: phase number integer c !IN: sequantial constituent index over all sublattices double precision stoi(*) !EXIT: stoichiometry of elements double precision mass !EXIT: total mass type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} write(*,*)'tqgpcs not implemented yet' gx%bmperr=8888 1000 continue return end subroutine tqgpcs !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgccf(n1,n2,elnames,stoi,mass,ceq) ! get stoichiometry of component n1 ! n2 is number of elements (dimension of elnames and stoi) implicit none integer n1 !IN: component number integer n2 !EXIT: number of elements in component character elnames(*)*(2) ! EXIT: element symbols double precision stoi(*) ! EXIT: element stoichiometry double precision mass ! EXIT: component mass (sum of element mass) type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} write(*,*)'tqgccf not implemented yet' gx%bmperr=8888 1000 continue return end subroutine tqgccf !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgnpc(n,c,ceq) ! get number of constituents of phase n implicit none integer n !IN: Phase number integer c !EXIT: number of constituents type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} write(*,*)'tqgnpc not implemented yet' gx%bmperr=8888 1000 continue return end subroutine tqgnpc !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqcref(cix,phase,tpref,ceq) ! set component reference state integer cix character phase*(*) double precision tpref(*) type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium !\end{verbatim} integer phtupx call find_phasetuple_by_name(phase,phtupx) if(gx%bmperr.ne.0) goto 1000 call set_reference_state(cix,phtupx,tpref,ceq) 1000 continue return end subroutine tqcref !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqphsts(phtupx,newstat,val,ceq) ! set status of phase tuple: SUSPEND, DORMANT, ENTERED, FIX integer phtupx,newstat double precision val type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium !\end{verbatim} integer n if(phtupx.le.0) then ! if tup<0 change status of all phases do n=1,ntup call change_phtup_status(n,newstat,val,ceq) if(gx%bmperr.ne.0) goto 1000 enddo elseif(phtupx.le.ntup) then call change_phtup_status(phtupx,newstat,val,ceq) else write(*,*)'Illegal phase tuple index',phtupx gx%bmperr=8888 endif 1000 continue return end subroutine tqphsts !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqsetc(stavar,n1,n2,value,cnum,ceq) ! set condition ! stavar is state variable as text ! n1 and n2 are auxilliary indices ! value is the value of the condition ! cnum is returned as an index of the condition. ! to remove a condition the value sould be equial to RNONE ???? ! phase index is phase tuple index (include composition set) ! see TQGETV for doucumentation of stavar etc. implicit none integer n1 ! IN: 0 or phase tuple index or component number integer n2 ! IN: 0 or component number integer cnum ! EXIT: sequential number of this condition UNUSED character stavar*(*) ! IN: character with state variable symbol double precision value ! IN: value of condition type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium !\end{verbatim} integer ip,ip2,ip3 character cline*60,selvar*24,cval*24 ! ! write(*,11)'In tqsetc ',stavar(1:len_trim(stavar)),n1,n2,value 11 format(a,a,2i5,1pe14.6) cline=' ' ! extract a value after an = ip=index(stavar,'=') if(ip.gt.0) then selvar=stavar(1:ip-1) cval=stavar(ip:) !@CC ip2=index(stavar,'(') if(ip2.gt.0) then ip = ip2 selvar=stavar(1:ip-1) cval=stavar(ip:) endif !@CC ! write(*,*)'Value after = :',cval else ip3=index(stavar,'(') if(ip3.gt.0) then selvar=stavar(1:ip3-1) else selvar=stavar endif cval=' ' endif call capson(selvar) ! write(*,*)'TQSETC selvar: ',trim(selvar),value select case(selvar) case default write(*,*)'Condition wrong, not implemented or illegal: ',stavar gx%bmperr=8888; goto 1000 ! Potentials T and P case('T ','P ') if(ip.gt.0) then cline=' '//stavar else write(cline,110)selvar(1:1),value 110 format(' ',a,'=',E15.8) endif ! Total amount or amount of a component in moles case('N ') if(ip.gt.0) then cline=' '//stavar else if(n1.gt.0) then ! call get_component_name(n1,name,ceq) ! if(gx%bmperr.ne.0) goto 1000 write(cline,112)selvar(1:1),cnam(n1)(1:len_trim(cnam(n1))),value 112 format(' ',a,'(',a,')=',E15.8) ! write(*,*)'Setting condition: ',cline(1:len_trim(cline)) else write(cline,110)selvar(1:1),value endif endif ! Overall fraction of a component case('X ','W ') ! ?? fraction of phase component not implemented, n1 must be component number ! call get_component_name(n1,cnam,ceq) ! if(gx%bmperr.ne.0) goto 1000 if(ip.gt.0) then cline=' '//stavar elseif(ip3.gt.0) then write(cline,119)trim(stavar),value 119 format(1x,a,'=',1pE15.8) else write(cline,120)selvar(1:1),cnam(n1)(1:len_trim(cnam(n1))),value 120 format(1x,a,'(',a,')=',1pE15.8) endif case('H ','V ') ! enthalpy or volume of system if(cval(1:1).eq.'=') then cline=' '//stavar else write(cline,130)selvar(1:1),value 130 format(1x,a,'=',1pE15.8) endif ! case .... ! ?? MORE CONDITIONS WILL BE ADDED ... end select ! write(*,*)'tqsetc condition: ',trim(cline) ! This is quite clumsy ... and time costly ! write(*,*)'TQSETC debug: ',trim(cline) ip=1 call set_condition(cline,ip,ceq) if(gx%bmperr.ne.0) then write(*,*)'Error setting condition: ',cline(1:len_trim(cline)),ip endif 1000 continue return end subroutine tqsetc !@CC !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine toggle_dense_grid() if(btest(globaldata%status,GSXGRID)) then globaldata%status=ibclr(globaldata%status,GSXGRID) write(*,3110)'reset' 3110 format('Dense grid ',a) else globaldata%status=ibset(globaldata%status,GSXGRID) write(*,3110)'dense grid set' endif return end subroutine toggle_dense_grid !@CC !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqce(target,n1,n2,value,ceq) ! calculate quilibrium with possible target ! Target can be empty or a state variable with indices n1 and n2 ! value is the calculated value of target implicit none integer n1,n2,mode character target*(*) double precision value logical confirm type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !\end{verbatim} integer nyfas,j1,j2 ! mode=1 means start values using global gridminimization if(n1.lt.0) then ! this means calculate without grid minimuzer mode=0 confirm=.FALSE. ! calcqeq3 is silent, no listing of phase changes etc. call calceq3(mode,confirm,ceq) ! skip allocation of ysave goto 1000 else mode=1 call calceq2(mode,ceq) if(gx%bmperr.eq.4204) then ! if the error code is "too many iterations" try without grid minimizer ! it converges in many cases ! write(*,2048)gx%bmperr 2048 format('Error ',i5,', cleaning up and trying harder') gx%bmperr=0 call calceq2(0,ceq) endif endif if(gx%bmperr.ne.0) goto 1000 ! there may be new composition sets, update ntup ! write(*,*)'Number of phase tuples: ',ntup nyfas=nooftup() ! write(*,*)'Number of phase tuples: ',ntup,nyfas if(nyfas.ne.ntup) then ! write(*,*)'Number of phase tuples changed: ',nyfas,ntup ntup=nyfas ! if(allocated(ysave)) deallocate(ysave) ! allocate(ysave(nyfas,maxconst)) endif ! copy the constitution to a local save array ! if(.not.allocated(ysave)) then ! allocate(ysave(nyfas,maxconst)) ! endif ! THIS IS BAD FOR PARALLELIZATION if(allocated(ysave)) deallocate(ysave) allocate(ysave(nyfas,maxconst)) ! the intention of saving constitution is to make it possible to interpolate ! the calculation of G if the constitution is changed very little do j1=1,nyfas do j2=1,size(ceq%phase_varres(phasetuple(j1)%lokvares)%yfr) ysave(j1,j2)=ceq%phase_varres(phasetuple(j1)%lokvares)%yfr(j2) enddo enddo 1000 continue return end subroutine tqce !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgetv(stavar,n1,n2,n3,values,ceq) ! get equilibrium results using state variables ! stavar is the state variable IN CAPITAL LETTERS with indices n1 and n2 ! n1 can be a phase tuple index, n2 a component index ! n3 at the call is the dimension of the array values, ! changed to number of values on exit ! value is an array with the calculated value(s), n3 set to number of values. implicit none integer n1,n2,n3 character stavar*(*) double precision values(*) type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium !======================================================== ! stavar must be a symbol listed below ! IMPORTANT: some terms explained after the table ! Symbol index1,index2 Meaning (unit) !.... potentials ! T 0,0 Temperature (K) ! P 0,0 Pressure (Pa) ! MU component,0 or ext.phase.index*1,constituent*2 Chemical potential (J) ! AC component,0 or ext.phase.index,constituent Activity = EXP(MU/RT) ! LNAC component,0 or ext.phase.index,constituent LN(activity) = MU/RT !...... extensive variables ! U 0,0 or ext.phase.index,0 Internal energy (J) whole system or phase ! UM 0,0 or ext.phase.index,0 same per mole components ! UW 0,0 or ext.phase.index,0 same per kg ! UV 0,0 or ext.phase.index,0 same per m3 ! UF ext.phase.index,0 same per formula unit of phase ! S*3 0,0 or ext.phase.index,0 Entropy (J/K) ! V 0,0 or ext.phase.index,0 Volume (m3) ! H 0,0 or ext.phase.index,0 Enthalpy (J) ! A 0,0 or ext.phase.index,0 Helmholtz energy (J) ! G 0,0 or ext.phase.index,0 Gibbs energy (J) ! ..... some extra state variables ! NP ext.phase.index,0 Moles of phase ! BP ext.phase.index,0 Mass of moles (kg) ! Q ext.phase.index,0 Internal stability/RT (dimensionless) ! DG ext.phase.index,0 Driving force/RT (dimensionless) !....... amounts of components ! N 0,0 or component,0 or ext.phase.index,component Moles of component ! X component,0 or ext.phase.index,component Mole fraction of component ! B 0,0 or component,0 or ext.phase.index,component Mass of component ! W component,0 or ext.phase.index,component Mass fraction of component ! Y ext.phase.index,constituent*1 Constituent fraction !........ some parameter identifiers ! TC ext.phase.index,0 Magnetic ordering temperature ! BMAG ext.phase.index,0 Aver. Bohr magneton number ! MQ& ext.phase.index,constituent Mobility ! THET ext.phase.index,0 Debye temperature ! LNX ext.phase.index,0 Lattice parameter ! EC11 ext.phase.index,0 Elastic constant C11 ! EC12 ext.phase.index,0 Elastic constant C12 ! EC44 ext.phase.index,0 Elastic constant C44 !........ NOTES: ! *1 The phase index is the phase tuple index (extra composition sets at end) ! *2 The constituent index is 10*species_number + sublattice_number ! *3 S, V, H, A, G, NP, BP, N, B and DG can have suffixes M, W, V, F also !-------------------------------------------------------------------- ! special addition for TQ interface: d2G/dyidyj ! D2G + phase tuple !-------------------------------------------------------------------- !\end{verbatim} integer ics,mjj,nph,ki,kj,lp,lokph,lokcs character statevar*60,encoded*2048,name*24,selvar*4,norm*4 ! mjj should be the dimension of the array values ... mjj=n3 selvar=stavar call capson(selvar) ! for state variables like MQ&FE remove the part from & before the select ! write(*,11)'In tqgetv: ',selvar,n1,n2,n3 11 format(a,a,3i5) norm=' ' lp=index(selvar,'&') if(lp.gt.0) then selvar(lp:)=' ' else ! check if variable is normallized, only M (per mole) allowed ki=len_trim(selvar) if(ki.ge.2) then if(selvar(ki:ki).eq.'M') then norm='M' selvar(ki:)=' ' ki=ki-1 endif endif endif !======================================================================= kj=index(selvar,'(') if(kj.gt.0) then selvar=selvar(1:kj-1) endif ! write(*,*)'tqgetv 0: ',kj,selvar,'>',stavar,'<' select case(selvar) case default write(*,*)'Unknown state variable: ',stavar(1:20),'>:<',selvar gx%bmperr=8888; goto 1000 !-------------------------------------------------------------------- ! T or P case('T ','P ') call get_state_var_value(selvar,values(1),encoded,ceq) !-------------------------------------------------------------------- ! chemical potential for a component case('MU ','MUS ') if(n1.lt.-1 .or. n1.eq.0) then write(*,*)'tqgetv 17: component number must be positive' gx%bmperr=8888; goto 1000 elseif(n1 .eq.-1) then ! this means all components statevar=trim(selvar)//'(*)' call get_many_svar(statevar,values,mjj,n3,encoded,ceq) elseif(n1.le.noel()) then statevar=trim(selvar)//'('//trim(cnam(n1))//') ' ! write(*,*)'tqgetv 4: ',statevar(1:len_trim(statevar)) ! we must use index value(1) as the subroutine expect a single variable call get_state_var_value(statevar,values(1),encoded,ceq) else write(*,*)'No such component' endif !-------------------------------------------------------------------- !@CC ! Amount of moles /mass of components in a phase case('NP ', 'BP ') if(n1.lt.0) then ! all phases statevar=stavar(1:2)//'(*)' !@CC ! this returns all composition sets for all phases call get_many_svar(statevar,values,mjj,n3,encoded,ceq) ! this output gives the amounts for all compsets of a phase sequentially ! but here we want them in phase tuple order ! the second argument is the number of values for each phase, here is 1 but ! it can be for example compositions, then it should be number of components call sortinphtup(n3,1,values) else ! NP for just one phase call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar='NP('//trim(name)//') ' call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 endif !-------------------------------------------------------------------- ! Mole or mass fractions !@CC case('N ','B ','X ','W ') !@CC ! write(*,*)'in tqgetv n,x,w: ',n1,n2,n3 if(n2.eq.0) then if(n1.lt.0) then ! moles, mole or mass fraction of all components for all phases statevar=stavar(1:1)//'(*) ' ! write(*,*)'tqgetv 3: ',mjj,statevar(1:len_trim(statevar)) call get_many_svar(statevar,values,mjj,n3,encoded,ceq) elseif(n1.eq.0) then ! mole fraction for the state variable written as X(FE) ! n1 and n2 not used, just check for wildcard ! write(*,*)'tqgetv 20: ',stavar(1:len_trim(stavar)) if(index(stavar,'*').gt.0) then call get_many_svar(stavar,values,mjj,n3,encoded,ceq) else call get_state_var_value(stavar,values(1),encoded,ceq) endif else ! mole fraction of a single component, no phase specification n3=1 ics=1 ! call get_component_name(n1,name,ceq) ! if(gx%bmperr.ne.0) goto 1000 statevar=stavar(1:1)//'('//trim(cnam(n1))//')' ! write(*,*)'tqgetv 4: ',statevar(1:len_trim(statevar)) call get_state_var_value(statevar,values(1),encoded,ceq) endif elseif(n1.lt.0) then !........................................................ ! for all phases one or several components if(n2.lt.0) then ! this means all components all phases, for example x(*,*) statevar=stavar(1:1)//'(*,*) ' ! write(*,*)'tqgetv 5: ',mjj,statevar(1:len_trim(statevar)) call get_many_svar(statevar,values,mjj,n3,encoded,ceq) ! this output gives the composition for all compsets of a phase sequentially ! but we want them in phase tuple order ! The second argument is the number of values for each phase, noel() ! in this case ics=noel() call sortinphtup(n3,ics,values) else ! a single component in all phases. n2 must not be zero ! call get_component_name(n2,name,ceq) ! if(gx%bmperr.ne.0) goto 1000 if(n2.le.0 .or. n2.ge.noel()) then write(*,*)'No such component' goto 1000 endif ! state variable like w(*,cr), the Cr content in all (stable) phases statevar=stavar(1:1)//'(*,'//cnam(n2)(1:len_trim(cnam(n2)))//')' ! write(*,*)'tqgetv 6: ',mjj,statevar(1:len_trim(statevar)) call get_many_svar(statevar,values,mjj,n3,encoded,ceq) ! this output gives the composition for all compsets of a phase sequentially ! but we want them in phase tuple order ! The second argument is the number of values for each phase, in this case 1 ! ics=noel() ! THIS MUST BE CHECKED !!! call sortinphtup(n3,1,values) endif elseif(n2.lt.0) then ! this means all components in one phase call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=stavar(1:1)//'('//trim(name)//',*) ' call get_many_svar(statevar,values,mjj,n3,encoded,ceq) else ! one component (n2) of one phase (n1) call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=stavar(1:1)//'('//trim(name)//',' call get_component_name(n2,name,ceq) if(gx%bmperr.ne.0) goto 1000 statevar(len_trim(statevar)+1:)=trim(name)//') ' ! write(*,*)'tqgetv 8: ',statevar call get_state_var_value(statevar,values(1),encoded,ceq) endif !-------------------------------------------------------------------- ! volume case('V ') if(norm(1:1).ne.' ') then statevar='V'//norm ki=2 else statevar='V ' ki=1 endif if(n1.gt.0) then ! Volume for a specific phase call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=statevar(1:ki)//'('//trim(name)//') ' call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 else ! Total volume call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 endif !-------------------------------------------------------------------- ! Enthalpy case('H ') ! phase specifier not allowed if(norm(1:1).ne.' ') then statevar='H'//norm ki=2 else statevar='H ' ki=1 endif ! write(*,*)'tqgetv 1: ',n1,ki if(n1.gt.0) then ! Gibbs energy for a specific phase call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=statevar(1:ki)//'('//trim(name)//') ' call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 else ! Total enthalpy call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 endif !-------------------------------------------------------------------- ! Gibbs energy case('G ') ! phase specifier not allowed if(norm(1:1).ne.' ') then statevar='G'//norm ki=2 else statevar='G ' ki=1 endif ! write(*,*)'tqgetv 1: ',n1,ki if(n1.gt.0) then ! Gibbs energy for a specific phase call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=statevar(1:ki)//'('//trim(name)//') ' ! write(*,*)'tqgetv 3: ',statevar call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 else ! Total Gibbs energy call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 endif !-------------------------------------------------------------------- ! Driving force relative stable equilibrium case('DG ') ! Always normalized per mole if(norm(3:3).ne.' ') then statevar='DG'//norm ki=3 else statevar='DG ' ki=2 endif write(*,*)'tqgetv DGM: ',n1,ki if(n1.gt.0) then ! The driving force for a specific phase call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=statevar(1:ki)//'M('//trim(name)//') ' ! write(*,*)'tqgetv 3: ',statevar call get_state_var_value(statevar,values(1),encoded,ceq) n3=1 else ! For all phases n3=0 if(nooftup().gt.mjj) then write(*,*)'TQGETV error, array too small for DGM',mjj,nooftup() gx%bmperr=8888 goto 1000 endif statevar='DGM(#) ' write(*,*)'tqgetv 3: ',statevar call get_many_svar(statevar,values,mjj,n3,encoded,ceq) write(*,'(a,10(1pe12.4))')'TQGETV: ',(values(ki),ki=1,n3) write(*,*)'gx%bmperr: ',gx%bmperr endif !-------------------------------------------------------------------- ! Mobilities case('MQ ') call get_phasetup_name(n1,name) if(gx%bmperr.ne.0) goto 1000 statevar=stavar(1:len_trim(stavar))//'('//trim(name)//')' ! write(*,*)'statevar: ',statevar call get_state_var_value(statevar,values(1),encoded,ceq) !-------------------------------------------------------------------- ! Second derivatives of the Gibbs energy of a phase case('D2G ') lokcs=phasetuple(n1)%lokvares ! this gives wrong value!! ?? n3=size(ceq%phase_varres(lokcs)%yfr) ! write(*,*)'D2G 3: ',n3 kj=(n3*(n3+1))/2 if(kj.gt.mjj) then write(*,*)'TQGETV error, array too small for D2G',mjj,kj gx%bmperr=8888 goto 1000 endif ! write(*,*)'D2G 3: ',kj do ki=1,kj values(ki)=ceq%phase_varres(lokcs)%d2gval(ki,1) enddo end select !=========================================================================== 1000 continue return end subroutine tqgetv !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ subroutine tqgetg(lokres,n1,n2,values,ceq) ! the partial derivative of the Gibbs energy ....?? implicit none integer n1,n2,lokres double precision values(*) type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium ! double precision napfu, rgast integer count integer jl,size TYPE(gtp_phase_varres), pointer :: parres ! count = 1 ! napfu=ceq%phase_varres(lokres)%abnorm(1) rgast=globaldata%rgas*ceq%tpval(1) parres=>ceq%phase_varres(lokres) ! ! write(*,100)(rgast*parres%gval(jl,1),jl=1,4) ! write(*,200)parres%gval(1,1)/parres%abnorm(1),parres%abnorm(1) 100 format('G/N, dG/dT:',4(1PE16.8)) 200 format('G/N/RT, N:',2(1PE16.8)) ! G_m^\alpha = G_M^\alpha/N^\alpha, \frac{\partial G_m^\alpha}{\partial T}, ! \frac{\partial G_m^\alpha}{\partial P}, ! \frac{\partial^2 G_m^\alpha}{\partial T^2} values(count:count+3) = rgast*parres%gval(1:4,1)/napfu count = count + 4 if (n1>0) then ! 1/N^\alpha * \frac{\partial G_M^\alpha}{\partial y_i} values(count:count+n1-1) = rgast*parres%dgval(1,1:n1,1)/napfu count = count + n1 if (n2>0) then ! 1/N^\alpha * \frac{\partial^2 G_M^\alpha}{\partial y_i\partial y_j} values(count:count+n2-1) = rgast*parres%d2gval(1:n2,1)/napfu endif endif end subroutine tqgetg !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ subroutine tqgdmat(phtupx,tpval,xknown,cpot,tyst,nend,mugrad,mobval,& consnames,n1,ceq) ! equilibrates the constituent fractions of a phase for mole fractions xknown ! and calculates the Darken matrix and unreduced diffusivities ! phtup is phase tuple ! tpval is T and P ! ceq is a datastructure with all relevant thermodynamic data ! cpot are the (calculated) chemical potentials ! tyst is TRUE means no outut ! nend is the number of values returned in mugrad ! mugrad are the derivatives of the chemical potentials wrt mole fractions?? ! mobval are the mobilities implicit none integer phtupx ! IN: index in phase tuple array integer nend logical tyst double precision tpval(*),xknown(*),cpot(*),mugrad(*),mobval(*) character*24, dimension(*) :: consnames integer n1 TYPE(gtp_phasetuple), pointer :: phtup TYPE(gtp_equilibrium_data), pointer :: ceq integer iph, ics, ll double precision mass character*24 spname phtup=>phasetuple(phtupx) call equilph1d(phtup,tpval,xknown,cpot,tyst,nend,mugrad,mobval,ceq) iph=phasetuple(phtupx)%ixphase ics=1 n1 = noconst(iph,ics,firsteq) do ll=1,n1 call get_constituent_name(iph,ll,consnames(ll),mass) enddo end subroutine tqgdmat !@CC !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqgphc1(n1,nsub,cinsub,spix,yfrac,sites,extra,ceq) ! tq_get_phase_constitution ! This subroutine returns the sublattices and constitution of a phase ! n1 is phase tuple index ! nsub is the number of sublattices (1 if no sublattices) ! cinsub is an array with the number of consttuents in each sublattice ! spix is an array with the species index of the constituents in all sublattices ! sites is an array of the site ratios for all sublattices. ! yfrac is the constituent fractions in same order as in spix ! extra is an array with some extra values: ! extra(1) is the number of moles of components per formula unit ! extra(2) is the net charge of the phase implicit none integer n1,nsub,cinsub(*),spix(*) double precision sites(*),yfrac(*),extra(*) type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} call get_phase_data(phasetuple(n1)%ixphase,phasetuple(n1)%compset,& nsub,cinsub,spix,yfrac,sites,extra,ceq) 1000 continue return end subroutine tqgphc1 !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqsphc1(n1,yfra,extra,ceq) ! tq_set_phase_constitution ! To set the constitution of a phase ! n1 is phase tuple index ! yfra is an array with the constituent fractions in all sublattices ! in the same order as obtained by tqgphc1 ! extra is an array with returned values with the same meaning as in tqgphc1 ! NOTE The constituents fractions are normallized to sum to unity for each ! sublattice and extra is calculated by tqsphc1 ! T and P must be set as conditions. implicit none integer n1 double precision yfra(*),extra(*) type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} call set_constitution(phasetuple(n1)%ixphase,phasetuple(n1)%compset,& yfra,extra,ceq) 1000 continue return end subroutine tqsphc1 !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqcph1(n1,n2,n3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,ceq) ! tq_calculate_phase_properties !vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! WARNING: this is not a subroutine to calculate chemical potentials ! those can only be made by an equilibrium calculation. ! The values returned are partial derivatives of G for the phase at the ! current T, P and phase constitution. The phase constitution has been ! obtained by a previous equilibrium calculation or ! set by the subroutine tqsphc ! It corresponds to the "calculate phase" command. ! ! NOTE that values are per formula unit divided by RT, ! divide also by extra(1) in subroutine tqsphc1 to get them per mole component ! !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! calculate G and some or all derivatives for a phase at current composition ! n1 is the phase tuple index ! n2 is 0 if only G and derivatves wrt T and P, 1 also first drivatives wrt ! compositions, 2 if also 2nd derivatives ! n3 is returned as number of constituents (dimension of returned arrays) ! gtp is an array with G, G.T, G:P, G.T.T, G.T.P and G.P.P ! dgdy is an array with G.Yi ! d2gdydt is an array with G.T.Yi ! d2gdydp is an array with G.P.Yi ! d2gdy2 is an array with the upper triangle of the symmetrix matrix G.Yi.Yj ! reurned in the order: 1,1; 1,2; 1,3; ... ! 2,2; 2,3; ... ! 3,3; ... ! for indexing one can use the integer function ixsym(i1,i2) implicit none integer n1,n2,n3 double precision gtp(6),dgdy(*),d2gdydt(*),d2gdydp(*),d2gdy2(*) type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer ij,lokres,nofc ! write(*,*)'tqcph1 1: ',ceq%eqname ! write(*,*)'tqcph1 2',phasetuple(n1)%ixphase,phasetuple(n1)%compset !---------------------------------------------------------------------- ! THIS IS NO EQUILIBRIUM, JUST G AND DERIVATIVES FOR CURRENT T, P AND Y call calcg(phasetuple(n1)%ixphase,phasetuple(n1)%compset,n2,lokres,ceq) !---------------------------------------------------------------------- ! write(*,*)'tqcph1 3A',lokres,gx%bmperr ! The inital size here can be 1000 ! n3=size(ceq%phase_varres(lokres)%yfr) ! the actual number of constituents is better to take from this call n3=noconst(phasetuple(n1)%ixphase,1,ceq) ! write(*,*)'tqcph1 3C',n3 ! gval last index is the property, other properties can also be extracted ! t.ex. mobilites ! The application program can also access these data directly ... if(gx%bmperr.eq.0) then do ij=1,6 gtp(ij)=ceq%phase_varres(lokres)%gval(ij,1) enddo do ij=1,n3 dgdy(ij)=ceq%phase_varres(lokres)%dgval(1,ij,1) d2gdydt(ij)=ceq%phase_varres(lokres)%dgval(2,ij,1) d2gdydp(ij)=ceq%phase_varres(lokres)%dgval(3,ij,1) enddo ! size of upper triangle of symetrix matrix nofc=n3*(n3+1)/2 do ij=1,nofc d2gdy2(ij)=ceq%phase_varres(lokres)%d2gval(ij,1) enddo else gtp=zero do ij=1,nofc dgdy(ij)=zero d2gdydt(ij)=zero d2gdydp(ij)=zero enddo nofc=nofc*(nofc+1)/2 do ij=1,nofc d2gdy2(ij)=zero enddo endif 1000 continue return end subroutine tqcph1 !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} %- subroutine tqcph2(n1,n2,n3,n4,ceq) ! tq_calculate_phase_properties !vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! WARNIG: this is not a subroutine to calculate chemical potentials ! those can only be made by an equilibrium calculation. ! The values returned are partial derivatives of G for the phase at the ! current T, P and phase constitution. The phase constitution has been ! obtained by a previous equilibrium calculation or ! set by the subroutine tqsphc ! It corresponds to the "calculate phase" command. ! ! NOTE that values are per formula unit divided by RT, ! divide also by extra(1) in subroutine tqsphc1 to get them per mole component ! !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! calculate G and some or all derivatives for a phase at current composition ! n1 is the phase tuple index ! n2 is type of calculation (0, 1 or 2) ! n3 is returned as number of constituents ! n4 is index to ceq%phase_varres(lokres)% with all results ! for indexing one can use the integer function ixsym(i1,i2) implicit none integer n1,n2,n3,n4 type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer ij,lokres,nofc ! write(*,*)'tqcph1 1: ',ceq%eqname ! write(*,*)'tqcph1 2',phasetuple(n1)%ixphase,phasetuple(n1)%compset !---------------------------------------------------------------------- ! THIS IS NO EQUILIBRIUM, JUST G AND DERIVATIVES FOR CURRENT T, P AND Y call calcg(phasetuple(n1)%ixphase,phasetuple(n1)%compset,n2,lokres,ceq) !---------------------------------------------------------------------- ! write(*,*)'tqcph1 3A',lokres,gx%bmperr ! this should work but gave segmentation fault, find this a more cumbersum way n3=size(ceq%phase_varres(lokres)%yfr) n4=lokres ! Uer can access results like ! ceq%phase_varres(n4)%gval(1..6,1..prop) ! prop=1 is G, other can be t.ex. Curie T, mobilites etc ! ceq%phase_varres(lokres)%dgval(1,ij,1) are dG/dy(ij) ! ceq%phase_varres(lokres)%dgval(2,ij,1) are d2G/dy(ij)dT ! ceq%phase_varres(lokres)%dgval(3,ij,1) are d2G/dy(ij)dP ! ceq%phase_varres(lokres)%d2gval(ij,1) are d2G/dy(i)dy(j) ! arranged as a single dimenion array indexed by ixsym(i,j) ! ! NEVER CHANGE THE CONSTITUTION DIRECTLY, using n4, ALWAYS CALL tqsph1(...) ! 1000 continue return end subroutine tqcph2 !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqdceq(name) ! delete equilibrium with name implicit none character name*24 ! integer n1 type(gtp_equilibrium_data), pointer :: newceq,ceq !\end{verbatim} integer n1 call findeq(name,n1) if(gx%bmperr.ne.0) goto 1000 ! do not allow delete equilibrium 1 if(n1.eq.1) then write(*,*)'No allowed to delete default equilibrium' gx%bmperr=4333 goto 1000 endif ! ceq=>eqlista(n1) call delete_equilibria(name,ceq) 1000 continue return end subroutine tqdceq !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqcceq(name,n1,newceq,ceq) ! copy_current_equilibrium to newceq ! creates a new equilibrium record with name with values same as ceq ! n1 is returned as index implicit none character name*24 integer n1 type(gtp_equilibrium_data), pointer :: newceq,ceq !\end{verbatim} ! call enter_equilibrium(name,n1) ! if(gx%bmperr.ne.0) goto 1000 ! newceq=>eqlista(n1) call copy_equilibrium(newceq,name,ceq) 1000 continue return end subroutine tqcceq !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqcneq(name,n1,newceq) ! creates a new equilibrium record, same but simpler call than tqcceq ! n1 is returned as index in eqlista implicit none character*(*), intent(in) :: name integer, intent(out) :: n1 type(gtp_equilibrium_data), pointer, intent(out) :: newceq !\end{verbatim} call enter_equilibrium(name,n1) if(gx%bmperr.ne.0) goto 1000 newceq=>eqlista(n1) 1000 continue return end subroutine tqcneq !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqselceq(name,ceq) ! select current equilibrium to be that with name. ! Note that equilibria can be deleted and change number but not name implicit none character name type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer n1 call findeq(name,n1) if(gx%bmperr.ne.0) goto 1000 call selecteq(n1,ceq) 1000 continue return end subroutine tqselceq !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqlr(lut,ceq) ! list the equilibrium results like in OC implicit none integer lut type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer phtupx,iph,ics,lokvares,mode logical once write(lut,10) 10 format(/20('*')/'Start debug output from TQLR: ') call list_conditions(lut,ceq) call list_global_results(lut,ceq) call list_components_result(lut,1,ceq) once=.TRUE. mode=0 do phtupx=1,nooftup() lokvares=phasetuple(phtupx)%lokvares if(ceq%phase_varres(lokvares)%phstate.ge.phentstab) then iph=phasetuple(phtupx)%ixphase ics=phasetuple(phtupx)%compset call list_phase_results(iph,ics,mode,lut,once,ceq) endif enddo write(lut,20) 20 format('End debug output from TQLR'/20('*')/) 1000 continue return end subroutine tqlr !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqlc(lut,ceq) ! list conditions like in OC implicit none integer lut type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} write(lut,10) 10 format(/'Debug output from TQLC: ') call list_conditions(lut,ceq) 1000 continue return end subroutine tqlc !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqquiet(yes) ! if argument TRUE spurious output should be suppressed implicit none logical yes !\end{verbatim} if(yes) then globaldata%status=ibclr(globaldata%status,GSVERBOSE) globaldata%status=ibset(globaldata%status,GSSILENT) else globaldata%status=ibset(globaldata%status,GSVERBOSE) endif return end subroutine tqquiet !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqchange_globalbit(bit,onoff) ! set a global bit implicit none integer bit,onoff !\end{verbatim} ! list here taken from models/gtp3.F90, only some allowed!! ! BEWHEARE, the meaning of bits may have changed !!! check with gtp3.F90 ! 4 NOMERGE: no merge of gridmin result, ! 5 NODATA: not any data, ! 6 NOPHASE: no phase in system, ! 7 NOACS: no automatic creation of composition set for any phase ! 8 NOREMCS: do not remove any redundant unstable composition sets ! 9 NOSAVE: data changed after last save command ! 10 VERBOSE: maximum of listing ! 11 SETVERB: permanent setting of verbose ! 12 SILENT: as little output as possible ! 13 NOAFTEREQ: no manipulations of results after equilibrium calculation ! 14 XGRID: extra dense grid for all phases ! 15 NOPAR: do not run in parallel ! 16 NOSMGLOB do not test global equilibrium at node points ! 17 NOTELCOMP the elements are not the components ! 18 TGRID use grid minimizer to test if global after calculating equilibrium ! 19 OGRID use old grid generator ! 20 NORECALC do not recalculate equilibria even if global test after fails ! 21 OLDMAP use old map algorithm ! 22 NOAUTOSP do not generate automatic start points for mapping ! 23 GSYGRID extra dense grid ! 24 GSVIRTUAL (CCI) enables calculations with a virtual element if((bit.ge.7 .and. bit.le.16) .or. (bit.ge.18 .and. bit.le.23)) then if(onoff.gt.0) then ! set bit globaldata%status=ibset(globaldata%status,bit) else globaldata%status=ibclr(globaldata%status,bit) endif else gx%bmperr=4326 endif return end subroutine tqchange_globalbit !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqchange_phasebit(phtupx,bit,onoff) ! set a bit of phase implicit none integer phtupx,bit,onoff !\end{verbatim} ! taken from models/gtp3.F90 !-Bits in PHASE record STATUS1 there are also bits in each phase_varres record! ! BEWHEARE, the meaning of bits may have changed !!! check with gtp3.F90 ! 0 HID phase is hidden (not implemented) ! 1 IMHID phase is implictly hidden (not implemented) ! 2 ID phase is ideal, substitutional and no interaction ! 3 NOCV phase has no concentration variation (fix composition) ! 4 HASP phase has at least one parameter entered ! 5 FORD phase has 4 sublattice FCC ordering with parameter permutations ! 6 BORD phase has 4 sublattice BCC ordering with parameter permutations ! 7 SORD phase has TCP type ordering (like for sigma) ! 8 MFS phase has a disordered fraction set ! 9 GAS this is the gas phase (first in phase list) ! 10 LIQ phase is liquid (can be several but listed directly after gas) ! 11 IONLIQ phase has ionic liquid model (I2SL) ! 12 AQ1 phase has aqueous model (not implemented) ! 13 STATE elemental liquid twostate (2-state) model parameter UNUSED? ! 14 QCE phase has quasichemical SRO configurational entropy (not implemented) ! 15 CVMCE phase has some CVM ordering entropy (not implemented) ! 16 EXCB phase need explicit charge balance (has ions) ! 17 XGRID use extra dense grid for this phase ! 18 FACTCE phase has FACT quasichemical SRO model (not implemented) ! 19 NOCS not allowed to create composition sets for this phase ! 20 HELM parameters are for a Helmholz energy model (not implemented), ! 21 PHNODGDY2 phase has model with no analytical 2nd derivatives ! 22 not implemented ELMA phase has elastic model A (not implemented) ! 23 EECLIQ the condensed phase (liquid) that should have highest entropy ! 24 PHSUBO special use testing models DO NOT USE ! 25 PALM interaction records numbered by PALMTREE NEEDED FOR PERMUTATIONS !!! ! 26 MULTI may be used with care ! 27 BMAV Xion magnetic model with average Bohr magneton number ! 28 UNIQUAC The UNIQUAC fluid model ! 29 DILCE phase has dilute configigurational entropy (not implemented) ! only bittar 3 left! integer lokph if(phtupx.le.0 .or. phtupx.gt.nooftup()) then gx%bmperr=4325 elseif(bit.eq.17 .or. bit.eq.19) then lokph=phasetuple(phtupx)%lokph if(onoff.gt.0) then call set_phase_status_bit(lokph,bit) else call clear_phase_status_bit(lokph,bit) endif else gx%bmperr=4326 endif return end subroutine tqchange_phasebit !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqset_gaddition(phtupx,gadd,ceq) ! set fix addition to Gibbs energy of a phase#compset implicit none integer phtupx double precision gadd type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} ! Provided by Christophe Sigli 2018? integer lokcs lokcs=phasetuple(phtupx)%lokvares if(.not.allocated(ceq%phase_varres(lokcs)%addg)) then allocate(ceq%phase_varres(lokcs)%addg(1)) endif ceq%phase_varres(lokcs)%addg(1)=gadd ! set bit that this should be calculated ceq%phase_varres(lokcs)%status2=& ibset(ceq%phase_varres(lokcs)%status2,CSADDG) return end subroutine tqset_gaddition !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tq_add_const_energy(energy,phtupx,ceq) ! add a constant energy in J/mole double precision,intent(in) :: energy type(gtp_equilibrium_data), pointer :: ceq integer,intent(in) :: phtupx !\end{verbatim} ! Provided by Jan Herrnring 2020.12.15 integer :: lokcs lokcs=phasetuple(phtupx)%lokvares if(.not.allocated(ceq%phase_varres(lokcs)%addg)) then allocate(ceq%phase_varres(lokcs)%addg(1)) endif ! add a constant term to G, value in J/FU ! Abnorm is the number of moles of the phase ceq%phase_varres(lokcs)%addg(1)=energy*ceq%phase_varres(lokcs)%abnorm(1) ! set bit that this should be calculated ceq%phase_varres(lokcs)%status2=& ibset(ceq%phase_varres(lokcs)%status2,CSADDG) end subroutine tq_add_const_energy !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ ! Added for this simulation !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ !\begin{verbatim} subroutine tqdarken(itup,xval,verbose,muval,nend,darken,mobval,ceq) ! calculates the equilibrium for a phase specified by a phase tuple ! and with composition xval in mole fractions. ! It returns the chemical potentials, the Darken stability matix and ! the mobilities (copied from the equilibrium_data record) ! The whole Darken matrix is returned in Darken(1:nend) ! Internally a new set of constituent fractions are stored. ! ! use liboctq implicit none integer itup,nend logical verbose double precision xval(*),muval(*),mobval(*),darken(*) type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} double precision tpval(2) type(gtp_phasetuple), pointer :: phtup ! ! use the current values of T and P tpval=ceq%tpval phtup=>phasetuple(itup) ! write(*,20)itup,gx%bmperr,tpval(1),xval(1) 20 format('TQDARKEN: ',i3,i7,F10.2,F10.6) call equilph1d(phtup,tpval,xval,muval,verbose,nend,darken,mobval,ceq) ! write(*,20)itup,gx%bmperr,tpval(1),xval(1) return end subroutine tqdarken !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ ! ! QUESTION: When this routine is not included in liboctq.F90 ! the compiler requires that there is an explicit INTERFACE required ! because there is a pointer argument (ceq?) ! and I have no idea how to do that. When including it here it is ! not required ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ subroutine diffcoef(itup,xval,dc,ceq) ! binary diffusion coefficient ! use liboctq implicit none integer nend,itup type(gtp_equilibrium_data), pointer :: ceq integer, parameter :: mm=10 double precision xval(*),muval(mm),darken(mm*(mm+1)/2),mobval(mm),dc(*) logical silent double precision tildem double precision, parameter :: vm=1e-5 ! use mole fractions x_i = c_i/V_m ! mobility \tildeM_ii = (c_1 c_2/V_M)(c_1 M_2 + c_2 M_i) ! D_ii = V_M \tildeM_ii * det(Darken) ! ! \tilde M_ii = V_m**2 x_1 x_2 (x_1 M_2 + x_2 M_1) !!?? ! D_ii = V_m**3 \tildeM_ii det(Darken) ! silent=.TRUE. call tqdarken(itup,xval,silent,muval,nend,darken,mobval,ceq) if(gx%bmperr.ne.0) goto 1000 ! For a binary system the diffusion coefficient is ! \tildeM = (xval(1)*mobval(2)+xval(2)*mobval(1))*xval(1)*xval(2) ! DC = \tildeM *(Darken(1)*Darken(4)-Darken(2)*Darken(3)) ! NOTE the Darken matrix is symmetrical and thus Darken(2)=Darken(4) tildem=xval(1)*xval(2)*(xval(1)*mobval(2)+xval(2)*mobval(1)) dc(1)=vm*tildem*(darken(1)*darken(4)-darken(2)*darken(3)) ! write(*,20)xval(1),xval(2),muval(1),muval(2),darken(1),darken(2),darken(3),& ! darken(4),mobval(1),mobval(2),dc(1) 20 format('Composition: ',8x,2F10.6/'Chemical potentials: ',2(1pe14.6)/& 'Darken matrix: ',6x,2e14.6/21x,2e14.6/& 'Mobilities: ',9x,2e14.6/& 'Diffusion coef: ',5x,e14.6) 1000 continue return end subroutine diffcoef !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ end MODULE LIBOCTQ !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ ! dummy modules !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ module ftinyopen ! ! This module replaces a C module for a popup window to open files ! used in the interactive OC. If you want to use the original ! version for opening files please check the linkmake or Makefile ! contains subroutine getfilename(typ,sval) implicit none integer typ character sval*(*) sval=' ' return end subroutine getfilename end module ftinyopen !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ ! dummy module (only Linux) !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ module M_getkey ! ! This module replaces a C module fore single character input on Linux ! contains character function getkex() getkex=' ' return end function getkex end module M_getkey !\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ ================================================ FILE: examples/TQ4lib/F90/parallel-alnipt/linksim ================================================ REM C:\Users\bosun\Documents\OC\OC6\examples\TQ4lib\F90\parasim\ REM Compile the OC program REM copy ..\..\..\..\libs\liboceq.a REM copy ..\..\..\..\liboceqplus.mod REM on Linux or Mac you need also REM copy ..\..\..\..\getkey.o REM DO NOT COPY liboctq.F90 as there are a few subroutines added REM REM copy ..\liboctq.F90 gfortran -c -fopenmp liboctq.F90 gfortran -o sim1 -fopenmp sim-alnipt.F90 liboctq.o liboceq.a REM on Linux and Mac you need gfortran -o sim1 -fopenmp sim-alnipt.F90 getkey.o liboctq.o liboceq.a REM In the setup file you specify the output. This can be plotted by GNUPLOT ================================================ FILE: examples/TQ4lib/F90/parallel-alnipt/setup.input ================================================ # This is input file for the Al-Ni-Pt simulation # A line starting with a # character is a comment line # # database file name alnipt-2005.TDB # each element to be selected from the database on a separate line # end with empty line al ni pt # the stable phase in the simulation fcc # number of gridpoints (max 50) 40 # Mole fractions in alphabetical order, * means fraction is "rest" # fractions of Al and Pt, Ni rest on the left hand side 0.1 * 0.01 # Mole fraction of Al and Ni on the right hand side, Pt rest 0.1 0.05 * # Temperature (K) 1073 # Mobilities of Al, Ni and Pt (mol per second and J) # These are multiplied with the difference in chemical potential 0.001 0.001 0.001 # Maximum number of timesteps 10000 # Minimum change in fractions to continue (condition to terminate) .001 # GNUPLOT file name for plotting (empty line no intermediate results) ocsim.plt # Empty line if run in parallel # end of setup file # this is not included on github ================================================ FILE: examples/TQ4lib/F90/parallel-alnipt/sim-alnipt.F90 ================================================ ! ! Small program to simulate diffusion in 1D using OC ! Ternary system Al-Ni-Pt coating of superallys ! program sim2 ! use liboctq !$ use omp_lib ! implicit none integer, parameter :: gpmax=100,cmax=10,sfile=31 integer notused,cnum(10),nsel,gpix(gpmax),gp,gp1,gp2,nt,cc1,cc2 integer howmany,plut,modmod,maxloop,half,phtup,jj,jp,gpcur,nrow,ioerr character database*60,selel(cmax)*2,gpname*24,line*60 character setupfile*60,profiles*60,phasename*24 double precision tpval(2),nval,xval(cmax),dx(cmax),dxmax double precision xxx,xxy,dmu,dff,sum,gpxval(cmax) double precision sumpos,sumneg,sdxp,sdxn,mobi(cmax),xin(cmax) double precision eqcpu1,eqcpu2,eqcpusum double precision xleft(cmax),xright(cmax),xsum integer eqcc1, eqcc2,eqccsum,lrest,rrest,iel,rest double precision, parameter :: mumin=1.0d-4 logical parallel type(gtp_equilibrium_data), pointer :: ceq,gridceq ! type grid ! This has a pointer to one equilibrium per gridpoint ! and has an array of mole fractions in that gridpoint for diffusion type(gtp_equilibrium_data), pointer :: eqp double precision xval(cmax) end type grid type(grid), dimension(gpmax), target :: gpp type(grid), pointer :: gridpoint ! write(*,1) 1 format('Simulation of uphill diffusion Al-Ni-Pt, OC example 2021'/& 'Surface coating of Pt-Al on an Al-Ni turbine blade (see PDF)'//& 'In the input file is specified on separate lines:'/& 'database file, symbol of each element'/& 'name of stable phase,'/& 'number of gridpoints'/& 'Al and Pt mole fractions in the blade (Ni rest),'/& 'Al and Ni mole fractions of the surface layer (Pt rest),'/& 'Mobilities (mol/(J s)) of Al, Ni and Pt,'/& 'Maximum number of timesteps'/& 'Minimal change of fractions'/& 'file name for intermediate output (empty line means no output),'/& 'empty line means run in parallel,'//& 'Any lines starting with a hash caracter "#" are ignored.'//) ! write(*,2,advance='no') 2 format('Setup file name:') read(*,3)setupfile 3 format(a) ! open input file open(sfile,file=setupfile,access='sequential',status='old',iostat=ioerr) if(ioerr.ne.0) stop 'Error opening input file' ! !------------------------------------- ! initiate call tqini(notused,ceq) if(gx%bmperr.ne.0) stop 'Cannot initiate TQ interface' ! read database and elements call readline(sfile,database) nsel=1 eloop: do while(.true.) call readline(sfile,selel(nsel)) if(selel(nsel)(1:1).eq.' ') exit eloop call capson(selel(nsel)) nsel=nsel+1 enddo eloop nsel=nsel-1 rest=nsel ! read database with selected elements, rest is zet to zero! call tqrpfil(database,rest,selel,ceq) if(gx%bmperr.ne.0) stop 'Cannot read selected elememts from database' !----------------- ! suspend all phases except the specified phase call tqphsts(-1,-2,zero,ceq) if(gx%bmperr.ne.0) stop 'TQ error suspending phases' ! set specified phase as ENTERED call readline(sfile,phasename) call tqgpi(phtup,phasename,ceq) if(gx%bmperr.ne.0) stop 'TQ error finding stable phase' call tqphsts(phtup,1,one,ceq) if(gx%bmperr.ne.0) stop 'TQ error entering stable phase' !----------------- ! set phasename as reference state for all elements ? !----------------- ! number of gridpoints call readline(sfile,line) jp=1 call getint(line,jp,gpcur) if(buperr.ne.0) stop 'Input error 1' if(gpcur.lt.10 .or. gpcur.gt.100) then write(*,*)'Gridpoints must be between 10 and 100' stop 'Error in input file' endif !----------------- ! Left side (interior) initial composition in alphabetical order call readline(sfile,line) jp=1 xsum=zero xleft=zero lrest=0 do iel=1,nsel call getrel(line,jp,xleft(iel)) ! the metlib routines have a global error code buperr if(buperr.ne.0) then if(line(jp:jp).eq.'*') then lrest=iel buperr=0 jp=jp+1 else write(*,*)'Error reading left side fractions for element ',iel stop endif elseif(xleft(iel).le.zero .or. xleft(iel).ge.one) then write(*,'(a,i3)')'Mole fraction must be between 0 and 1 for element',iel stop 'Error in setup file' endif xsum=xsum+xleft(iel) enddo if(lrest.eq.0) stop 'No element defined as "rest" on left hand side' xleft(lrest)=one-xsum if(xleft(lrest).ge.one) then write(*,*)'Fractions should add up to unity' stop 'Error in setup file' endif !----------------- ! Right side (surface) initial composition in alphabetical order call readline(sfile,line) jp=1 xsum=zero xright=zero rrest=0 do iel=1,nsel call getrel(line,jp,xright(iel)) if(buperr.ne.0) then if(line(jp:jp).eq.'*') then rrest=iel buperr=0 jp=jp+1 else write(*,*)'Error reading right side fractions for element ',iel stop endif elseif(xright(iel).le.zero .or. xright(iel).ge.one) then write(*,'(a,i3)')'Mole fraction must be between 0 and 1 for element',iel stop 'Error in setup file' endif xsum=xsum+xright(iel) enddo if(rrest.eq.0) stop 'No element defines as "rest" on right hand side' xright(rrest)=one-xsum if(xright(rrest).le.zero) then write(*,*)'Fractions on right hand side should add up to unity' stop 'Error in setup file' endif !---------------------------- ! Temperature call readline(sfile,line) jp=1 call getrel(line,jp,tpval(1)) if(buperr.ne.0) stop 'Input errot 7' if(tpval(1).lt.2.0D2 .or. tpval(1).gt.3.0D3) then write(*,*)'T must be between 200 and 3000 K' stop 'Error in setup file' endif ! Pressure tpval(2)=1.0D5 !---------------------------- ! Mobilities in alphabetical order call readline(sfile,line) jp=1 do iel=1,nsel call getrel(line,jp,mobi(iel)) if(buperr.ne.0) stop 'Input error 8' if(mobi(iel).gt.0.1 .or. mobi(iel).lt.1.0D-6) then write(*,*)'Mobility data out of range for element ',iel stop 'Error in setup file' endif enddo !---------------------------- ! Max timesteps call readline(sfile,line) jp=1 call getint(line,jp,maxloop) if(buperr.ne.0) stop 'Input error 8' if(maxloop.lt.10) stop 'Too few timesteps' ! Minimal change in fractions call readline(sfile,line) jp=1 call getrel(line,jp,dff) if(dff.le.zero .or. dff.gt.0.1) stop 'Fraction change out of range' !---------------------------- ! intermediate output call readline(sfile,profiles) if(profiles(1:1).ne.' ') then modmod=1 plut=30 open(plut,file=profiles,access='sequential',status='unknown',iostat=ioerr) if(ioerr.ne.0) stop 'Cannot open profile output file' ! start GNUPLOT graphics write(30,10) 10 format('# GNUPLOT file for plotting profiles'/& 'set terminal wxt size 840,700 font "Arial,16"'/& 'set title "OpenCalphad simulator"'/& 'set origin 0.0, 0.0 '/'set size 1.0, 1.0'/& 'set xlabel "Gridpoint"'/'set ylabel "Fractions"'/& 'set key top right font "Arial,12"') else plut=0 modmod=maxloop endif !---------------------------- ! run sequentially/parallel call readline(sfile,line) if(line(1:1).ne.' ') then parallel=.FALSE. else parallel=.TRUE. endif !------------------------------------- end of input ! Echo input on screen and output file (if any) write(*,17)trim(database),(selel(iel),iel=1,nsel) write(*,18)trim(phasename),gpcur,(xleft(iel),iel=1,nsel) write(*,19)(xright(iel),iel=1,nsel) write(*,20)(mobi(iel),iel=1,nsel) write(*,21)tpval(1),maxloop,dff if(plut.gt.0) write(*,22)trim(profiles) 17 format(/'# Input values: '/'# ',a,1x,10(1x,a)) 18 format('# ',a,i5/'# ',10(F7.4)) 19 format('# ',10(F7.4)) 20 format('# ',10(1PD12.4)) 21 format('# ',F8.2,i8,D12.4) 22 format('# ',a//) if(plut.gt.0) then write(plut,17)trim(database),(selel(iel),iel=1,nsel) write(plut,18)trim(phasename),gpcur,(xleft(iel),iel=1,nsel) write(plut,19)(xright(iel),iel=1,nsel) write(plut,20)(mobi(iel),iel=1,nsel) write(plut,21)tpval(1),maxloop,dff ! Start data for graphics if(plut.gt.0) write(plut,23) 23 format(/'$profile << EOD') endif eqcpusum=zero eqccsum=0 !--------------------------------------- ! set conditions nval=1.0D0 ! cnum not used at all!! call tqsetc('T ',0,0,tpval(1),cnum(1),ceq) if(gx%bmperr.ne.0) goto 1000 call tqsetc('P ',0,0,tpval(2),cnum(2),ceq) if(gx%bmperr.ne.0) goto 1000 call tqsetc('N ',0,0,nval,cnum(3),ceq) if(gx%bmperr.ne.0) goto 1000 ! do iel=1,nsel if(iel.ne.lrest) then call tqsetc('X ',iel,0,xleft(iel),cnum(4),ceq) endif enddo if(gx%bmperr.ne.0) goto 1000 !--------------------------------------- ! calculate an equilibrium just to test write(*,*)'Calculating equilibrium with gridminimizer' call tqlc(kou,ceq) call tqce(' ',0,0,zero,ceq) if(gx%bmperr.ne.0) goto 1000 !--------------------------------------- ! list the equilibrium results as a check call tqlr(kou,ceq) if(gx%bmperr.ne.0) goto 1000 !--------------------------------------- ! create grid with gpcur equilibria with initial composition ! half the gridpoints has the left hand composition, the other the right hand gpname='GP_001' half=gpcur/2 write(*,43) 43 format(/'Creating grid'/'Gridpoint name Fractions in alphabetical order') xval=xleft rest=lrest do gp=1,gpcur ! copy the "ceq" equilibrium to a new record in gpp(gp)%eqp ! the list of conditions are not copied but linked to original equilibrium call tqcceq(gpname,gpix(gp),gpp(gp)%eqp,ceq) if(gx%bmperr.ne.0) goto 1000 ! To ensure the conditions are unique in each gridpoint nullify the list ! (it creates som lost memory ...) nullify(gpp(gp)%eqp%lastcondition) ! Set new conditions in equilibrium for this gridpoint call tqsetc('T ',0,0,tpval(1),cnum(1),gpp(gp)%eqp) if(gx%bmperr.ne.0) goto 1000 call tqsetc('P ',0,0,tpval(2),cnum(2),gpp(gp)%eqp) if(gx%bmperr.ne.0) goto 1000 call tqsetc('N ',0,0,nval,cnum(3),gpp(gp)%eqp) if(gx%bmperr.ne.0) goto 1000 ! halfway change compositions if(gp.gt.half) then xval=xright rest=rrest endif do iel=1,nsel if(iel.ne.rest) then call tqsetc('X ',iel,0,xval(iel),cnum(4),gpp(gp)%eqp) endif enddo if(gx%bmperr.ne.0) goto 1000 ! this is a way to check the gridpoint conditions ! write(*,*)'Conditions for equilibrium ',gp ! call tqlc(kou,gpp(gp)%eqp) ! if(gx%bmperr.ne.0) goto 1000 ! calculate without gridmin ! because start values for the phases were copied above call tqce(' ',-1,0,zero,gpp(gp)%eqp) if(gx%bmperr.ne.0) goto 1000 ! write(*,44)gp,trim(gpname),(xval(iel),iel=1,nsel) 44 format(i5,6x,a,10F7.4) do iel=1,nsel gpp(gp)%xval(iel)=xval(iel) enddo ! increment the equilibrium name index call incname(gpname,6) enddo ! write intitial profile for all 3 components for all gridpoints nt=0 nrow=1 write(*,*)'Initial composition profile:',nsel,gpcur ! do iel=1,nsel write(*,51)(gpp(gp)%xval(iel),gp=1,gpcur) enddo if(plut.gt.0) then write(plut,'("# ",2i10)')nt,nrow do iel=1,nsel write(plut,51)(gpp(gp)%xval(iel),gp=1,gpcur) enddo endif 51 format(100(0pF6.3)) 52 format(i10,': ',100(0pF6.3)) ! if(parallel) then write(*,*)'Calculations will be made in parallel' else write(*,*)'Calculations will be made sequentially' endif !--------------------------------------- simulation starts call cpu_time(xxx) call system_clock(count=cc1) ! Take a time step, calculate diffusion and modify compositions ! Use the difference in chemical potential between two adjacent gridpoints ! to calculate the flow of elements simulate: do while(.TRUE.) nt=nt+1 dxmax=zero diff: do gp1=1,gpcur-1 gp2=gp1+1 sumneg=zero sumpos=zero do jj=1,nsel gpxval(jj)=gpp(gp1)%xval(jj) dmu=gpp(gp2)%eqp%cmuval(jj)-gpp(gp1)%eqp%cmuval(jj) dx(jj)=mobi(jj)*dmu if(abs(dx(jj)).gt.1.0d-2) then write(*,*)'Very strong diffusion!',nt,jj,dx(jj) endif ! dxmax is used to check convergence, if max dxmax small then terminate if(abs(dx(jj)).gt.dxmax) dxmax=abs(dx(jj)) if(dx(jj).gt.zero) then sumpos=sumpos+dx(jj) else sumneg=sumneg-dx(jj) endif enddo ! The sum of the fractions should always be unity, make the sum of all if(sumpos.le.1.0D-12 .or. sumneg.le.1.0D-12) then ! There is no diffusion sdxp=zero; sdxn=zero elseif(sumpos.gt.sumneg) then ! scale the maximal flow to be the same as the minimal sdxp=sumneg/sumpos sdxn=one else sdxp=one sdxn=sumpos/sumneg endif ! move the atoms!! do jj=1,nsel if(dx(jj).ge.zero) then gpp(gp1)%xval(jj)=gpp(gp1)%xval(jj)+dx(jj)*sdxp gpp(gp2)%xval(jj)=gpp(gp2)%xval(jj)-dx(jj)*sdxp else gpp(gp1)%xval(jj)=gpp(gp1)%xval(jj)+dx(jj)*sdxn gpp(gp2)%xval(jj)=gpp(gp2)%xval(jj)-dx(jj)*sdxn endif enddo ! Check fractions are in range and sum is unity sum=zero do jj=1,nsel if(gpp(gp1)%xval(jj).ge.one .or.gpp(gp1)%xval(jj).le.zero) then write(*,69)gp1,jj,gpp(gp1)%xval(jj) 69 format('Fraction outside limits at gridpoint ',2i3,F10.4) ! stop 'katastrof 1!' if(gpp(gp1)%xval(jj).ge.one) gpp(gp1)%xval(jj)=1.0-1.0D-8 if(gpp(gp1)%xval(jj).le.zero) gpp(gp1)%xval(jj)=1.0D-8 endif sum=sum+gpp(gp1)%xval(jj) enddo if(abs(sum-one).gt.1.0D-7) then write(*,*)'Sum of fractions not unity at gridpoint ',gp1,sum write(*,'(a,3F10.5)')'Fractions: ',(gpxval(jj),jj=1,3) write(*,'(a,3F10.5)')'Fractions: ',(gpp(gp1)%xval(jj),jj=1,3) stop 'katastrof 2!' endif enddo diff ! modmod controls output ! initially write each profile, then every 10, then every 100, then 1000 if(nt.eq.10) then modmod=10 elseif(nt.eq.100) then modmod=100 elseif(nt.eq.1000) then modmod=1000 elseif(nt.eq.10000) then modmod=10000 endif if(modmod.gt.maxloop) modmod=maxloop if(mod(nt,modmod).eq.0) then if(plut.gt.0) then modmod=2*modmod nrow=nrow+1 write(plut,'("# ",2i10)')nt,nrow do iel=1,nsel write(plut,51)(gpp(gp)%xval(iel),gp=1,gpcur) enddo endif write(*,*)'Done ',nt,' timesteps' ! debug output ! write(*,50)nt,dxmax,(gpp(gp)%xval(1),gp=1,gpcur) ! do iel=2,nsel ! write(*,51)(gpp(gp)%xval(iel),gp=1,gpcur) ! enddo endif !--------------------------------------- ! the equilibrium with the new composition in all gridpoints (parallel?) rest=lrest newx: do gp1=1,gpcur gridpoint=>gpp(gp1) if(gp1.gt.half) then rest=rrest endif do iel=1,nsel if(iel.ne.rest) then call tqsetc('X ',iel,0,gridpoint%xval(iel),cnum(4),gridpoint%eqp) if(gx%bmperr.ne.0) then write(*,*)'Error setting condition: ',gridpoint%eqp%eqname gx%bmperr=0 endif endif enddo ! possible debug output of conditions .... ! write(*,*)'Conditions for equilibrium ',gp1 ! call tqlc(kou,gridpoint%eqp) ! if(gx%bmperr.ne.0) goto 1000 enddo newx ! alternative running without parallel call cpu_time(eqcpu1) call system_clock(count=eqcc1) pos: if(parallel) then !$OMP parallel do private(gridceq) neweq: do gp1=1,gpcur gridceq=>gpp(gp1)%eqp ! This give new chemical potentials ! the number of threads must be obtained inside the loop otherwize 1 or 0 !$ howmany=omp_get_num_threads() ! calculate without gridmin call tqce(' ',-1,0,zero,gridceq) if(gx%bmperr.ne.0) then write(*,*)'Error calculating equil: ',gridceq%eqname gx%bmperr=0 endif enddo neweq !$omp end parallel do else howmany=1 seqloop: do gp1=1,gpcur gridceq=>gpp(gp1)%eqp ! Calculate equilibrium for new chemical potentials for next diffusion calc call tqce(' ',-1,0,zero,gridceq) if(gx%bmperr.ne.0) then write(*,*)'Error calculating equil: ',gridceq%eqname,gx%bmperr gx%bmperr=0 endif enddo seqloop endif pos call cpu_time(eqcpu2) call system_clock(count=eqcc2) eqcpusum=eqcpusum+eqcpu2-eqcpu1 eqccsum=eqccsum+eqcc2-eqcc1 ! loop back until simulation timestep exceeded or no change in composition if(abs(dxmax).lt.1.0D-5 .or. nt.gt.maxloop) exit simulate enddo simulate !--------------------------------------- ! Output of results and repeat input (if already forgotten) call system_clock(count=cc2) call cpu_time(xxy) write(*,190)nt,dxmax,xxy-xxx,cc2-cc1 write(*,193)eqcpusum,eqccsum,howmany write(*,17)trim(database),(selel(iel),iel=1,nsel) write(*,18)trim(phasename),gpcur,(xleft(iel),iel=1,nsel) write(*,19)(xright(iel),iel=1,nsel) write(*,20)(mobi(iel),iel=1,nsel) write(*,21)tpval(1),maxloop,dff if(plut.gt.0) then ! Results saved on file, finish the graphics output and CPU times write(plut,195)nsel 195 format('EOD'//& 'set style line 1 linetype 1 linecolor rgb "#000000" linewidth 1',& ' pointtype 10'/& 'set style line 2 lt 1 lc rgb "#4169E1" lw 1 pt 7'/& 'set style line 3 lt 1 lc rgb "#00C000" lw 1 pt 6'//& 'plot for [myRow=0:',i3,'] $profile matrix using 1:3 ',& ' every :::myRow::myRow with linespoints linestyle 1+myRow ',& ' title sprintf("Row number %d",myRow)'//'pause mouse') write(plut,190)nt,dxmax,xxy-xxx,cc2-cc1 190 format(/'# Timesteps:',i6,', Dmax=',1E12.4/& '# CPU time:',F12.4,'s, clockcycles: ',i8) write(plut,193)eqcpusum,eqccsum,howmany 193 format(/'# For equilibrium calculation: CPU time ',F12.4,' s and cc: ',i8/& '# Number of thread(s): ',i3) close(plut) endif ! ! Remind the file name for graphics write(*,'(/"Graphics output on ",a)')trim(profiles) write(*,991) 991 format(/'All well that ends well'/) stop !----------------------------------------- ! OC error 1000 continue write(*,1001)gx%bmperr,trim(bmperrmess(gx%bmperr)) 1001 format('Error code ',i5/'Message: ',a) stop ! end program sim2 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ subroutine incname(name,pos) ! increment sequential index in equilibrium name implicit none character name*(*) integer pos,jpos,iv jpos=pos loop: do while(jpos.gt.1) iv=ichar(name(jpos:jpos))-ichar('0') if(iv.lt.9) then iv=iv+1 name(jpos:jpos)=char(iv+ichar('0')); exit loop else name(jpos:jpos)='0' jpos=jpos-1 endif enddo loop return end subroutine incname !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ subroutine readline(setup,line) ! read seup file ingnoring comment lines implicit none integer setup integer :: nl=0 save nl character line*(*) do while(.TRUE.) read(setup,10,end=1000)line 10 format(a) nl=nl+1 ! write(*,*)'Echo input line: "',trim(line),'"' if(line(1:1).ne.'#') return enddo 1000 continue write(*,*)'Found EOF of setup file after line ',nl return end subroutine readline ================================================ FILE: examples/TQ4lib/readme.tex ================================================ \documentclass[12pt]{article} \textwidth 165mm \textheight 210mm \oddsidemargin 1mm \evensidemargin 1mm \topmargin 1mm \usepackage[latin1]{inputenc} \begin{document} \begin{center} {\Large \bf The Open Calphad Application Software Interface (OCASI) Based on the TQ standard for interfacing thermodynamic software} \bigskip Bo Sundman \today \end{center} There is a Fortran version and a tentative iso-C version for C++. In the future it may be possible to merge these. If you are not familiar with compiling and linking software and do not understand the intructions here please ask someone close to you for help. The instructions here are very brief but I am too busy to answer questions about handling such things and I know nothing about C++ To link any of the examples you must first compile and link the OC main program. When this works you must compile a special library excluding the file browser ``tinyfiledialogs'' and this is done (on Windiws) by the command file {\bf makeocasilib}. You must first add the extension ``.cmd'' to this file and then execute it as a command/batch file. This generates the library files: {\bf libocasi.a} and {\bf liboceqplus.mod} Both of these files are needed to compile and link the applications. The initial iso-C version of the library was provided by Teslos in 2014 and it has been extended by Matthias Stratmann at RUB, Germany and Christophe Sigli at Constellium, France to handle more calls to different subroutines. As things are still under development there may be slightly different versions on various subdirectories. Files on this directory: \begin{itemize} \item readme.pdf is this file. There are specific readme files on the subdirectories. \item readme.tex is LaTeX source for this file. Subdirectories: \begin{itemize} \item F90 has the source code for the TQ library, liboctq.F90 that was updated 1019.10.31 (Halloween) and three subqdirectories with examples. \begin{itemize} \item The crfe/ was updated in October, 2019. \item feni/ has not been upd ated for a long time. \item parallel-alnipt/ simulating diffusion in Al-Ni-Pt in parallel added August 2021. There are instructions how to use it in the directory. \end{itemize} \item Cpp has one C++ example provided by Matthias Stratmann at RUB, Germany and one from Cristophe Sigli, Consillium, France. There is a separate version of the Fortran TQ library and an isoC interface. I tested the Scheil program in February 2020 and it works but it generates some error messages I do not understand and as I do not know C++ I cannit fix that. I would be greateful for any help. Note that STEP SCHEIL is now available as a command in OC. \end{itemize} \end{itemize} \end{document} ================================================ FILE: examples/macros/AlC-OC.TDB ================================================ $ Database file written 2020-09-10 $ Tentative assessment of AlC using Einstein model ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT AL FCC_A1 2.6982E+01 4.5773E+03 2.8322E+01! ELEMENT C GRAPHITE 1.2011E+01 1.0540E+03 5.7423E+00! FUNCTION TEMP 10 +T**(-1); 6000 N ! FUNCTION RTEMP 10 +R#**(-1)*TEMP#; 6000 N ! $ EINSTEIN FOR ALFCC $ FUNCTION TESERAL 10 +283; 6000 N ! $ G-FUN FOR ALFCC, without Einstein FUNCTION GTSERAL 10 -.001478307*T**2-7.83339395E-07*T**3; 6000 N ! $ FUNCTION G0SERAL 10 -8160+GTSERAL; 6000 N ! FUNCTION GHSERAL 10 -8160+GTSERAL; 6000 N ! $ EINSTEIN FOR ALBCC $ FUNCTION TEBCCAL 10 +233; 6000 N ! $ G-FUN FOR ALBCC adding Kaufman lattice stability without Einstein FUNCTION G0BCCAL 10 +GHSERAL+10083; 6000 N ! $ EINSTEIN FOR ALHCP $ FUNCTION TEHCPAL 10 +263; 6000 N ! $ G-FUN FOR ALHCP without Einstein FUNCTION G0HCPAL 10 +GHSERAL+5481; 6000 N ! $ EINSTEIN FOR ALLIQ $ FUNCTION TELIQAL 10 +254; 6000 N ! FUNCTION G0LIQAL 10 -209-3.777*T-4.5E-4*T**2; 6000 N ! $ These are incorporated in the GEIN functions for Graphite $ FUNCTION FESERCC1 10 +.484047107; 6000 N ! $ FUNCTION TESERCC1 10 +1953.2502; 6000 N ! $ FUNCTION FESERCC2 10 +.121581878; 6000 N ! $ FUNCTION TESERCC2 10 +447.96926; 6000 N ! $ FUNCTION FESERCC3 10 +.349684332; 6000 N ! $ FUNCTION TESERCC3 10 +947.01605; 6000 N ! $ FUNCTION FESERCC4 10 +.0388463641; 6000 N ! $ FUNCTION TESERCC4 10 +192.65039; 6000 N ! $ FUNCTION FESERCC5 10 +.00584032345; 6000 N ! $ FUNCTION TESERCC5 10 +64.463356; 6000 N ! $ The first coefficient for THETA=1952.2502 is negative 0.484047107-1.0 $ as the argument of LNTH with the factor 1.0 FUNCTION GEGRACC 10 -0.5159523*GEIN(1953.2502) +0.121519*GEIN(447.96926) +0.3496843*GEIN(947.01605)+0.0388463*GEIN(192.65039) +0.005840323*GEIN(64.463356); 6000 N ! $ This is used in metastable phases with C FUNCTION GTSERCC 10 -2.9531332E-04*T**2-3.3998492E-16*T**5; 6000 N ! FUNCTION GHSERCC 10 -17752.213 +GEGRACC +GTSERCC; 6000 N ! $ These are incorporated in the GEIN functions for Diamond $ the factor for the highest Einstein THETA negative as used in LNTH parameter $ FUNCTION FEDIACC1 10 +.231791; 6000 N ! $ FUNCTION TEDIACC1 10 +813.63716; 6000 N ! $ FUNCTION FEDIACC2 10 +.0114797; 6000 N ! $ FUNCTION TEDIACC2 10 +345.35022; 6000 N ! $ FUNCTION FEDIACC3 10 +.763257386; 6000 N ! $ FUNCTION TEDIACC3 10 +1601.4467; 6000 N ! FUNCTION GEDIACC 10 0.2318*GEIN(813.63716)+0.01148*GEIN(345.35022) -.236743*GEIN(1601.4467); 6000 N ! FUNCTION G0DIACC 10 -16275.202-9.1299452E-05*T**2 -2.1653414E-16*T**5; 6000 N ! $ EINSTEIN FOR LIQCC the TELIQCC replaced by GEIN function $ FUNCTION TELIQCC 10 +1400; 6000 N ! FUNCTION G0LIQCC 10 +63887-8.2*T-4.185E-4*T**2; 6000 N ! $ EINSTEIN FOR ALCFCC replaced by GEIN functions $ FUNCTION TEFCCALC 10 +549; 6000 N ! $ FUNCTION GEFCALC1 10 +1-1*EXP(-TEFCCALC#*T**(-1)); 6000 N ! $ FUNCTION GEFCALC2 10 +1*LN(GEFCALC1#); 6000 N ! $ FUNCTION GEFCALC3 10 +3*R#*T*GEFCALC2#; 6000 N ! $ FUNCTION GEFCCALC 10 +1.5*R#*TEFCCALC#+GEFCALC3#; 6000 N ! $ EINSTEIN FOR ALCBCC reolaced by GEIN functions $ FUNCTION TEBCCALC 10 +863; 6000 N ! $ FUNCTION GEALCBC1 10 +1-1*EXP(-TEBCCALC#*T**(-1)); 6000 N ! $ FUNCTION GEALCBC2 10 +1*LN(GEALCBC1#); 6000 N ! $ FUNCTION GEALCBC3 10 +3*R#*T*GEALCBC2#; 6000 N ! $ FUNCTION GEBCCALC 10 +1.5*R#*TEBCCALC#+GEALCBC3#; 6000 N ! $ EINSTEIN FOR ALCHCP FUNCTION TEHCPALC 10 +452; 6000 N ! $ EINSTEIN FOR AL4C3 , these are replaces by GEIN functions $ FUNCTION TEAL4C1 10 +401; 6000 N ! $ FUNCTION TEAL4C2 10 +1077; 6000 N ! $ G-FUN FOR AL4C3 FUNCTION G0AL4C3 10 -277339-5.423368E-003*T**2; 6000 N ! TYPE_DEFINITION % SEQ *! DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! PHASE AL4C3 % 2 4 3 ! CONSTITUENT AL4C3 :AL : C : ! $ there are 7 atoms/FU and a factor 7 has been multiplied by the weights $ of the GEIN functions. $ The Einstein contribution from LNTH is also multiplied by 7 $ No need for an LNTH parameter unless solubility of a 3rd element $ PARAMETER G(AL4C3,AL:C) 10 +G0AL4C3+3.92*GEIN(401)+3.08*GEIN(1077); $ 6000 N 20HE ! PARAMETER G(AL4C3,AL:C) 10 +G0AL4C3-3.08*GEIN(401)+3.08*GEIN(1077); 6000 N 20HE ! PARAMETER LNTH(AL4C3,AL:C) 10 LN(401); 6000 N 20HE ! PHASE BCC_A2 % 2 1 3 ! CONSTITUENT BCC_A2 :AL : C,VA : ! PARAMETER G(BCC_A2,AL:C) 10 +GTSERAL+3*GTSERCC+1006844; 6000 N 20HE ! $ the LNTH parameter should be multiplied atomes/FU in the software $ For pure Al this is 1.0, for the metastable endmember Al:C it is 4.0 PARAMETER LNTH(BCC_A2,AL:C) 10 LN(863); 6000 N 20HE ! PARAMETER G(BCC_A2,AL:VA) 10 +G0BCCAL; 6000 N 20HE ! PARAMETER LNTH(BCC_A2,AL:VA) 10 LN(233); 6000 N 20HE ! PARAMETER G(BCC_A2,AL:C,VA;0) 10 -819896+14*T; 6000 N 20HE ! PHASE HCP_A3 % 2 1 .5 ! CONSTITUENT HCP_A3 :AL : C,VA : ! PARAMETER G(HCP_A3,AL:C) 10 +GTSERAL+.5*GTSERCC+2176775; 6000 N 20HE ! $ this parameter should be multiplied by 1.5 (atoms/FU) PARAMETER LNTH(HCP_A3,AL:C) 10 LN(452); 6000 N 20HE ! PARAMETER G(HCP_A3,AL:VA) 10 +G0HCPAL; 6000 N 20HE ! PARAMETER LNTH(HCP_A3,AL:VA) 10 LN(263); 6000 N 20HE ! PARAMETER G(HCP_A3,AL:C,VA;0) 10 0; 6000 N 20HE ! PHASE FCC_A1 % 2 1 1 ! CONSTITUENT FCC_A1 :AL : C,VA : ! PARAMETER G(FCC_A1,AL:C) 10 +GTSERAL+GTSERCC+57338; 6000 N 20HE ! $ this parameter should be multiplied by 2 (atoms/FU) PARAMETER LNTH(FCC_A1,AL:C) 10 LN(549); 6000 N 20HE ! PARAMETER G(FCC_A1,AL:VA;0) 10 +GHSERAL; 6000 N 20HE ! PARAMETER LNTH(FCC_A1,AL:VA) 10 LN(283); 6000 N 20HE ! PARAMETER G(FCC_A1,AL:C,VA;0) 10 -70345; 6000 N 20HE ! PHASE GRAPHITE % 1 1.0 ! CONSTITUENT GRAPHITE :C : ! PARAMETER G(GRAPHITE,C) 10 +GHSERCC; 6000 N 20HE ! PARAMETER LNTH(GRAPHITE,C) 10 LN(1953.2502); 6000 N 20HE ! PHASE DIAMOND % 1 1.0 ! CONSTITUENT DIAMOND :C : ! PARAMETER G(DIAMOND,C) 10 G0DIACC+GEDIACC; 6000 N 20HE ! PARAMETER LNTH(DIAMOND,C) 10 LN(1601.4467); 6000 N 20HE ! PHASE LIQUID:L % 1 1.0 ! CONSTITUENT LIQUID:L :AL,C : ! $ described by the liquid 2-state model, G2 describes the real liquid PARAMETER G(LIQUID,AL) 10 +G0LIQAL; 6000 N 20HE ! PARAMETER LNTH(LIQUID,AL) 10 LN(254); 6000 N 20HE ! $ NOTE! G2 is the same as GD in Thermo-Calc PARAMETER G2(LIQUID,AL) 10 +13398-R*T-.16597*T*LN(T); 6000 N 20HE ! PARAMETER G(LIQUID,C;0) 10 +G0LIQCC; 6000 N 20HE ! PARAMETER LNTH(LIQUID,C) 10 LN(1400); 6000 N 20HE ! PARAMETER G2(LIQUID,C;0) 10 +59147-49.61*T+2.9806*T*LN(T); 6000 N 20HE ! PARAMETER G(LIQUID,AL,C) 10 +20994-22*T; 6000 N 20HE ! LIST_OF_REFERENCES NUMBER SOURCE 20HE 'Zhangting He, Bartek Kaplan, Huahai Mao and Malin Selleby, Calphad Vol 72, (2021) 102250' ! ================================================ FILE: examples/macros/AlC-diagrams.OCM ================================================ @$======================================================================= @$ Example calculating Al-C phase diagram and heat capacities @$ down to low T using the new unary database @$ new Y set echo Y @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$======================================================================= r t ./AlC-OC @$ @$ There are warnings because LNTH and G2 parameters has no model @$ This will be amended with a new database format. @$ At present the models are set below as commands. @& @$ Add the two-state model to the liquid am ph liq add two Y @$ Add the Einstein model to the FCC am ph fcc add low Y @$ Add the Einstein model to the Al4C3 am ph al4c3 add low Y @$ Add the Einstein model for BCC Am ph bcc add low Y @$ Add the Einstein model for Diamond Am ph diam add low Y @$ Add the Einstein model for graphite Am ph graph add low Y @$ Add the Einstein model for hcp Am ph hcp add low Y l d @$ @$ Note that the is a line " + Einsten Cp model" or " + Liquid 2 state model" @$ Explaining the models used for these parameters @& @$ Calculate the phase diagram set c t=1000 p=1e5 n=1 x(c)=.1 c e set ax 1 x(c) 0 1 .025 set ax 2 T 100 5000 25 map plot pos left Title Al-C phase diagram Fig 1 @& @$ =========================================================== @$ Calculate heat capacity for pure Al down to 10 K for liquid and FCC set c x(c)=1e-6 c e ent sym cp=hm.t; set ax 1 t 10 5000 10 set ax 2 none @$ OC has some problems to calculate with several phases, calculate one by one set st ph *=sus set st ph liq=e 1 step N Y plot cp text 1500 32 2 0 Heat capacity for liquid Al text N 500 14 2 0 In the metastable range below 933~K text N 500 12 2 0 there is a transformation to the amorphous state Title Heat capacity for liquid Al Fig 2 @$ Note that Cp goes to zero t T=0 @$ The bump in the Cp curve is du to the liquid/amorpheus transiton @& set st ph liq=sus set st ph fcc=ent 1 c e step N Y plot t cp text 500 140 2 0 FCC heat capacity for Al text N 500 130 2 0 Above T=933 K it is metastable text N 1500 30 2 0 The Equi Entropy Criteria is used to text N 1500 20 2 0 prevent FCC to become stable at high T Title Heat capacity for FCC Al Fig 3 @$ The extrapolation of the heat capacity of metatstable FCC @$ at high T is unphysical. @$ It can be eliminated by the Equi Entropy Criterion @& @$ =========================================================== @$ Calculate heat capacity for pure C for liquid, graphite and diamone new Y r t ./AlC-OC C @$ Add the two-state model to the liquid, graphite and diamond am ph liq add two Y am ph dia add lowt Y am ph gra add lowt Y set c t=1000 p=1e5 n=1 @$ Step separate does not work well, calculate phases one by one set st ph *=sus set st ph liq=e 1 c e enter symb cp=hm.t; set ax 1 t 10 5000 10 step norm set st ph liq=sus set st ph dia=e 1 c e step norm N set st ph dia=sus set st ph gra=e 1 c e step norm N plot cp text 2400 42 2 0 Heat capacity for liquid C text N 1300 26 2 6 Heat capacity for graphite text N 2000 23 2 5 Heat capacity for diamond text N 800 10 2 0 Liquid and diamond are metastable for pure C Title Heat capacity for C as graphite, liquid and diamond Fig 4 @& plot S text 1000 85 2 0 Pure C text N 2800 80 2 17 Entropy as Liquid text N 2500 37 2 15 Entropy as diamond text N 2500 52 2 17 Entropy C as graphite text N 200 10 0.95 90 Liquid is not crystalline and can have non-zero entropy at T=0K Title Entropy for C as graphite liquid and diamond Fig 5 @$========================================================================== @$ end of AlC-diagrams macro @$========================================================================== set inter ================================================ FILE: examples/macros/AlFe-4SLBF.TDB ================================================ $ Database file written 2008- 8-15 $ From database: User data 2008. 8. 1 ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT AL FCC_A1 2.6982E+01 4.5773E+03 2.8322E+01! ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! FUNCTION GHSERAL 298.15 -7976.15+137.093038*T-24.3671976*T*LN(T) -.001884662*T**2-8.77664E-07*T**3+74092*T**(-1); 7.00000E+02 Y -11276.24+223.048446*T-38.5844296*T*LN(T)+.018531982*T**2 -5.764227E-06*T**3+74092*T**(-1); 9.33470E+02 Y -11278.378+188.684153*T-31.748192*T*LN(T)-1.230524E+28*T**(-9); 2.90000E+03 N ! FUNCTION GALLIQ 298.15 +11005.029-11.841867*T+7.934E-20*T**7 +GHSERAL#; 9.33470E+02 Y +10482.382-11.253974*T+1.231E+28*T**(-9)+GHSERAL#; 6000 N ! FUNCTION GALBCC 298.15 +10083-4.813*T+GHSERAL#; 6000 N ! FUNCTION GHSERFE 298.15 +1225.7+124.134*T-23.5143*T*LN(T) -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6000 N ! FUNCTION GFELIQ 298.15 +12040.17-6.55843*T-3.6751551E-21*T**7 +GHSERFE#; 1.81100E+03 Y -10839.7+291.302*T-46*T*LN(T); 6000 N ! FUNCTION GFEFCC 298.15 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2 +GHSERFE#; 1.81100E+03 Y -27097.396+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6000 N ! FUNCTION LFALFE0 298.15 -104700+30.65*T; 6000 N ! FUNCTION LFALFE1 298.15 +30000-7*T; 6000 N ! FUNCTION LFALFE2 298.15 +32200-17*T; 6000 N ! FUNCTION UFALFE 298.15 -4000+T; 6000 N ! FUNCTION GAL3FE 298.15 +3*UFALFE#+9000; 6000 N ! FUNCTION GAL2FE2 298.15 +4*UFALFE#; 6000 N ! FUNCTION GALFE3 298.15 +3*UFALFE#-3500; 6000 N ! FUNCTION SFALFE 298.15 +UFALFE#; 6000 N ! FUNCTION UBALFE1 298.15 -4023-1.14*T; 6000 N ! FUNCTION UBALFE2 298.15 -1973-2*T; 6000 N ! FUNCTION GD03ALFE 298.15 +2*UBALFE1#+UBALFE2#+3900; 6000 N ! FUNCTION GB2ALFE 298.15 +4*UBALFE1#; 6000 N ! FUNCTION GB32ALFE 298.15 +2*UBALFE1#+2*UBALFE2#; 6000 N ! FUNCTION GD03FEAL 298.15 +2*UBALFE1#+UBALFE2#-70+0.5*T; 6000 N ! FUNCTION BMALFE 298.15 -1.36; 6000 N ! FUNCTION BLALFE0 298.15 -0.3; 6000 N ! FUNCTION BLALFE1 298.15 -0.8; 6000 N ! FUNCTION BLALFE2 298.15 0.2; 6000 N ! FUNCTION ZERO 298.15 0.0; 6000.00 N ! FUNCTION UN_ASS 298.15 0.0 ; 3.00000E+02 N ! TYPE_DEFINITION % SEQ *! DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! TYPE_DEFINITION X GES AMEND_PHASE_DESCRIPTION BCC_4SL DIS_PART A2_BCC,,,! TYPE_DEFINITION Y GES AMEND_PHASE_DESCRIPTION FCC_4SL DIS_PART A1_FCC,,,! PHASE LIQUID:L % 1 1.0 ! CONSTITUENT LIQUID:L :AL,FE : ! PARAMETER G(LIQUID,AL;0) 298.15 +GALLIQ#; 6000 N 91Din ! PARAMETER G(LIQUID,FE;0) 298.15 +GFELIQ#; 6000 N 91Din ! PARAMETER G(LIQUID,AL,FE;0) 298.15 -88090+19.8*T; 6000 N 08Sun ! PARAMETER G(LIQUID,AL,FE;1) 298.15 -3800+3*T; 6000 N 08Sun ! PARAMETER G(LIQUID,AL,FE;2) 298.15 -2000; 6000 N 08Sun ! TYPE_DEFINITION F GES A_P_D @ MAGNETIC -3.0 2.80000E-01 ! PHASE A1_FCC %F 2 1 1 ! CONSTITUENT A1_FCC :AL,FE : VA : ! PARAMETER G(A1_FCC,AL:VA;0) 298.15 +GHSERAL#; 6000 N 91Din ! PARAMETER G(A1_FCC,FE:VA;0) 298.15 +GFEFCC#; 6000 N 91Din ! PARAMETER TC(A1_FCC,FE:VA;0) 298.15 -201; 6000 N 91Din ! PARAMETER BMAGN(A1_FCC,FE:VA;0) 298.15 -2.1; 6000 N 91Din ! PARAMETER G(A1_FCC,AL,FE:VA;0) 298.15 +LFALFE0#; 6000 N 08Sun ! PARAMETER G(A1_FCC,AL,FE:VA;1) 298.15 +LFALFE1#; 6000 N 08Sun ! PARAMETER G(A1_FCC,AL,FE:VA;2) 298.15 +LFALFE2#; 6000 N 08Sun ! TYPE_DEFINITION B GES A_P_D @ MAGNETIC -1.0 4.00000E-01 ! PHASE A2_BCC %B 2 1 3 ! CONSTITUENT A2_BCC :AL,FE : VA : ! PARAMETER G(A2_BCC,AL:VA;0) 298.15 +GALBCC#; 2.90000E+03 N 91Din ! PARAMETER G(A2_BCC,FE:VA;0) 298.15 +GHSERFE#; 6000 N 91Din ! PARAMETER TC(A2_BCC,FE:VA;0) 298.15 1043; 6000 N 91Din ! PARAMETER BMAGN(A2_BCC,FE:VA;0) 298.15 2.22; 6000 N 91Din ! PARAMETER G(A2_BCC,AL,FE:VA;0) 298.15 -122960+32*T; 6000 N 93Sei ! PARAMETER G(A2_BCC,AL,FE:VA;1) 298.15 2945.2; 6000 N 93Sei ! PARAMETER TC(A2_BCC,AL,FE:VA;0) 298.15 -438; 6000 N 01Ohn ! PARAMETER TC(A2_BCC,AL,FE:VA;1) 298.15 -1720; 6000 N 01Ohn ! PHASE AL13FE4 % 3 .6275 .235 .1375 ! CONSTITUENT AL13FE4 :AL : FE : AL,VA : ! PARAMETER G(AL13FE4,AL:FE:AL;0) 298.15 -30680+7.4*T+.765*GHSERAL# +.235*GHSERFE#; 6000 N 08Sun ! PARAMETER G(AL13FE4,AL:FE:VA;0) 298.15 -28100+7.4*T+.6275*GHSERAL# +.235*GHSERFE#; 6000 N 08Sun ! PHASE AL2FE % 2 2 1 ! CONSTITUENT AL2FE :AL : FE : ! PARAMETER G(AL2FE,AL:FE;0) 298.15 -104000+23*T+2*GHSERAL#+GHSERFE#; 6000 N 08Sun ! PHASE AL5FE2 % 2 5 2 ! CONSTITUENT AL5FE2 :AL : FE : ! PARAMETER G(AL5FE2,AL:FE;0) 298.15 -235600+54*T+5*GHSERAL# +2*GHSERFE#; 6000 N 08Sun ! PHASE AL8FE5_D82 % 2 8 5 ! CONSTITUENT AL8FE5_D82 :AL,FE : AL,FE : ! PARAMETER G(AL8FE5_D82,AL:AL;0) 298.15 +13*GALBCC#; 6000 N 08Sun ! PARAMETER G(AL8FE5_D82,FE:AL;0) 298.15 +200000+36*T+5*GALBCC# +8*GHSERFE#; 6000 N 08Sun ! PARAMETER G(AL8FE5_D82,AL:FE;0) 298.15 -394000+36*T+8*GALBCC# +5*GHSERFE#; 6000 N 08Sun ! PARAMETER G(AL8FE5_D82,FE:FE;0) 298.15 +13*GHSERFE#+13000; 6000 N 08Sun ! PARAMETER G(AL8FE5_D82,AL:AL,FE;0) 298.15 -100000; 6000 N 08Sun ! PARAMETER G(AL8FE5_D82,AL,FE:FE;0) 298.15 -174000; 6000 N 08Sun ! $ THIS PHASE HAS A DISORDERED CONTRIBUTION FROM A2_BCC PHASE BCC_4SL:B %BX 5 .25 .25 .25 .25 3 ! CONSTITUENT BCC_4SL:B :AL,FE : AL,FE : AL,FE : AL,FE : VA : ! PARAMETER G(BCC_4SL,AL:AL:AL:FE:VA;0) 298.15 +GD03ALFE#; 6000 N 08Sun ! PARAMETER TC(BCC_4SL,AL:AL:AL:FE:VA;0) 298.15 -125; 6000 N 01Ohn ! PARAMETER BMAGN(BCC_4SL,AL:AL:AL:FE:VA;0) 298.15 BMALFE; 6000 N 08Sun ! PARAMETER G(BCC_4SL,AL:AL:FE:FE:VA;0) 298.15 +GB2ALFE#; 6000 N 08Sun ! PARAMETER TC(BCC_4SL,AL:AL:FE:FE:VA;0) 298.15 -250; 6000 N 01Ohn ! PARAMETER BMAGN(BCC_4SL,AL:AL:FE:FE:VA;0) 298.15 2*BMALFE; 6000 N 08Sun ! PARAMETER G(BCC_4SL,AL:FE:AL:FE:VA;0) 298.15 +GB32ALFE#; 6000 N 08Sun ! PARAMETER TC(BCC_4SL,AL:FE:AL:FE:VA;0) 298.15 -125; 6000 N 01Ohn ! PARAMETER BMAGN(BCC_4SL,AL:FE:AL:FE:VA;0) 298.15 BMALFE; 6000 N 08Sun ! PARAMETER G(BCC_4SL,AL:FE:FE:FE:VA;0) 298.15 +GD03FEAL#; 6000 N 08Sun ! PARAMETER TC(BCC_4SL,AL:FE:FE:FE:VA;0) 298.15 -125; 6000 N 01Ohn ! PARAMETER BMAGN(BCC_4SL,AL:FE:FE:FE:VA;0) 298.15 BMALFE; 6000 N 08Sun ! PARAMETER G(BCC_4SL,AL,FE:*:*:*:VA;1) 298.15 -634+0.68*T; 6000 N 08Sun ! PARAMETER G(BCC_4SL,AL,FE:*:*:*:VA;2) 298.15 -190; 6000 N 08Sun ! PARAMETER TC(BCC_4SL,AL,FE:*:*:*:VA;0) 298.15 +125; 6000 N 01Ohn ! PARAMETER BMAGN(BCC_4SL,AL,FE:*:*:*:VA;0) 298.15 BLALFE0; 6000 N 08Sun ! PARAMETER BMAGN(BCC_4SL,AL,FE:*:*:*:VA;1) 298.15 BLALFE1; 6000 N 08Sun ! PARAMETER BMAGN(BCC_4SL,AL,FE:*:*:*:VA;2) 298.15 BLALFE2; 6000 N 08Sun ! $ THIS PHASE HAS A DISORDERED CONTRIBUTION FROM A1_FCC PHASE FCC_4SL:F %FY 5 .25 .25 .25 .25 1 ! CONSTITUENT FCC_4SL:F :AL,FE : AL,FE : AL,FE : AL,FE : VA : ! PARAMETER G(FCC_4SL,AL:AL:AL:AL:VA;0) 298.15 +ZERO#; 6000 N 08Con ! PARAMETER G(FCC_4SL,FE:AL:AL:AL:VA;0) 298.15 +GAL3FE#; 6000 N 08Con ! PARAMETER G(FCC_4SL,FE:FE:AL:AL:VA;0) 298.15 +GAL2FE2#; 6000 N 08Con ! PARAMETER G(FCC_4SL,FE:FE:FE:AL:VA;0) 298.15 +GALFE3#; 6000 N 08Con ! PARAMETER G(FCC_4SL,FE:FE:FE:FE:VA;0) 298.15 +ZERO#; 6000 N 08Con ! PARAMETER G(FCC_4SL,AL,FE:AL,FE:*:*:VA;0) 298.15 +SFALFE#; 6000 N 08Con ! ASSESSED_SYSTEM AL-FE(TDB -A2_B2 -A2_VA -BCC_VA -B2_BCC ;G5 C_S:BCC_4/AL:AL:FE:FE:VA: C_S:BCC_4/AL:FE:FE:FE:VA: ;P3 TMM:300/3000 STP:0.99/1400/-1 STP:0.77/600/1 STP:0.45/500/1 ) ! LIST_OF_REFERENCES NUMBER SOURCE 91Din 'A T Dinsdale, Calphad 1991' 93Sei 'M Seiersten, unpublished 1993' 01Ohn 'I Ohnuma, unpublished 2001' 08Con 'D Connetable et al, Calphad 2008; AL-C-Fe' 08Sun 'B Sundman, to be published' 08Dup 'N Dupin, vacancies in bcc' ! ================================================ FILE: examples/macros/BEF.TDB ================================================ $ $ Mo-Ni-Re ND 2017 June 1st - to be used with OC $ $ Mo-Re Mathieu 2013, sigma slightly modified $ Mo-Ni Frisk 1994 $ Ni-Re Yakoob 2012 $ $ CHI and SIGMA $ with disordered contribution $ DIS_CHI and DIS_SIGMA $ H:DFT S: assessed $ CHI $ all compounds from DFT $ SIGMA $ BEF $ ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT MO BCC_A2 9.5940E+01 4.5890E+03 2.8560E+01! ELEMENT NI FCC_A1 5.8690E+01 4.7870E+03 2.9796E+01! ELEMENT RE HCP_A3 1.8621E+02 5.3555E+03 3.6526E+01! FUNCTION GHSERMO 298.15 -7746.302+131.9197*T-23.56414*T*LN(T)-.003443396*T**2+5.66283E-07*T**3 +65812*T**(-1)-1.30927E-10*T**4; 2896 Y -30556.41+283.559746*T-42.63829*T*LN(T)-4.849315E+33*T**(-9);,, N ! FUNCTION GFCCMO 298.15 +7453.698+132.5497*T-23.56414*T*LN(T)-.003443396*T**2+5.66283E-07*T**3 +65812*T**(-1)-1.30927E-10*T**4; 2896 Y -15356.41+284.189746*T-42.63829*T*LN(T)-4.849315E+33*T**(-9);,, N REF1 ! FUNCTION GHCPMO 298.15 +3803.698+131.9197*T-23.56414*T*LN(T)-.003443396*T**2+5.66283E-07*T**3 +65812*T**(-1)-1.30927E-10*T**4; 2896 Y -19006.41+283.559746*T-42.63829*T*LN(T)-4.849315E+33*T**(-9);,, N REF1 ! FUNCTION GLIQMO 298.15 +34085.045+117.224788*T-23.56414*T*LN(T)-.003443396*T**2+5.66283E-07*T**3 +65812*T**(-1)-1.30927E-10*T**4+4.24519E-22*T**7; 2896 Y +3538.963+271.6697*T-42.63829*T*LN(T);,, N REF1 ! FUNCTION GHSERNI 298.15 -5179.159+117.854*T-22.096*T*LN(T)-.0048407*T**2; 1.72800E+03 Y -27840.655+279.135*T-43.1*T*LN(T)+1.12754E+31*T**(-9);,, N ! FUNCTION GBCCNI 298.15 +3535.925+114.298*T-22.096*T*LN(T)-4.8407E-3*T**2; 1728.00 Y -19125.571+275.579*T-43.1*T*LN(T)+1127.54E28*T**(-9);,, N ! FUNCTION GHCPNI 298.15 -4133.159+119.109*T-22.096*T*LN(T)-.0048407*T**2; 1.72800E+03 Y -26794.655+280.39*T-43.1*T*LN(T)+1.12754E+31*T**(-9);,, N ! FUNCTION GLIQNI 298.15 +11235.527+108.457*T-22.096*T*LN(T)-.0048407*T**2-3.82318E-21*T**7; 1.72800E+03 Y -9549.775+268.598*T-43.1*T*LN(T);,, N REF1 ! FUNCTION GHSERRE 298.15 -7695.279+128.421589*T-24.348*T*LN(T)-.00253505*T**2+1.92818E-07*T**3 +32915*T**(-1); 1200 Y -15775.998+194.667426*T-33.586*T*LN(T)+.00224565*T**2-2.81835E-07*T**3 +1376270*T**(-1); 2400 Y -70882.739+462.110749*T-67.956*T*LN(T)+.01184945*T**2-7.88955E-07*T**3 +18075200*T**(-1); 3458 Y +346325.888-1211.37186*T+140.831655*T*LN(T)-.033764567*T**2 +1.053726E-06*T**3-1.34548866E+08*T**(-1); 5000 Y -78564.296+346.997842*T-49.519*T*LN(T);,, N ! FUNCTION GFCCRE 298.15 +3304.721+126.921589*T-24.348*T*LN(T)-.00253505*T**2+1.92818E-07*T**3 +32915*T**(-1); 1200 Y -4775.998+193.167426*T-33.586*T*LN(T)+.00224565*T**2-2.81835E-07*T**3 +1376270*T**(-1); 2400 Y -59882.739+460.610749*T-67.956*T*LN(T)+.01184945*T**2-7.88955E-07*T**3 +18075200*T**(-1); 3458 Y +357325.888-1212.87186*T+140.831655*T*LN(T)-.033764567*T**2 +1.053726E-06*T**3-1.34548866E+08*T**(-1); 5000 Y -67564.296+345.497842*T-49.519*T*LN(T);,, N REF1 ! FUNCTION GBCCRE 298.15 +9304.721+124.721589*T-24.348*T*LN(T)-.00253505*T**2+1.92818E-07*T**3 +32915*T**(-1); 1200 Y +1224.002+190.967426*T-33.586*T*LN(T)+.00224565*T**2-2.81835E-07*T**3 +1376270*T**(-1); 2400 Y -53882.739+458.410749*T-67.956*T*LN(T)+.01184945*T**2-7.88955E-07*T**3 +18075200*T**(-1); 3458 Y +363325.888-1215.07186*T+140.831655*T*LN(T)-.033764567*T**2 +1.053726E-06*T**3-1.34548866E+08*T**(-1); 5000 Y -61564.296+343.297842*T-49.519*T*LN(T);,, N REF1 ! FUNCTION GLIQRE 298.15 +16125.604+122.076209*T-24.348*T*LN(T)-.00253505*T**2+1.92818E-07*T**3 +32915*T**(-1); 1200 Y +8044.885+188.322047*T-33.586*T*LN(T)+.00224565*T**2-2.81835E-07*T**3 +1376270*T**(-1); 2000 Y +568842.665-2527.83846*T+314.178898*T*LN(T)-.08939817*T**2 +3.92854E-06*T**3-1.63100987E+08*T**(-1); 3458 Y -39044.888+335.723691*T-49.519*T*LN(T);,, N REF1 ! FUN M1R2 298.15 +680;,, N ! FUN M1R3 298.15 +16094;,, N ! FUN M2R3 298.15 -14434;,, N ! FUN M1R4 298.15 +0;,, N ! FUN M2R4 298.15 -81839;,, N ! FUN M3R4 298.15 -86837;,, N ! FUN M1R5 298.15 +4361;,, N ! FUN M2R5 298.15 -28743;,, N ! FUN M3R5 298.15 -73358;,, N ! FUN M4R5 298.15 +21024;,, N ! FUN R1M2 298.15 -22076;,, N ! FUN R1M3 298.15 -19297;,, N ! FUN R1M4 298.15 +5847;,, N ! FUN R1M5 298.15 -30827;,, N ! FUN R2M3 298.15 +6571;,, N ! FUN R2M4 298.15 +42569;,, N ! FUN R2M5 298.15 -25482;,, N ! FUN R3M4 298.15 -1467;,, N ! FUN R3M5 298.15 -62108;,, N ! FUN R4M5 298.15 -119768;,, N ! FUN M1N2 298.15 -112309;,, N ! FUN M1N3 298.15 +29525;,, N ! FUN M2N3 298.15 -109029;,, N ! FUN M1N4 298.15 -965;,, N ! FUN M2N4 298.15 -134018;,, N ! FUN M3N4 298.15 -167595;,, N ! FUN M1N5 298.15 -40910;,, N ! FUN M2N5 298.15 -2219;,, N ! FUN M3N5 298.15 +66189;,, N ! FUN M4N5 298.15 -16596;,, N ! FUN N1M2 298.15 -73811;,, N ! FUN N1M3 298.15 -7043;,, N ! FUN N1M4 298.15 -41875;,, N ! FUN N1M5 298.15 +17271;,, N ! FUN N2M3 298.15 +82688;,, N ! FUN N2M4 298.15 +63970;,, N ! FUN N2M5 298.15 +97740;,, N ! FUN N3M4 298.15 +19008;,, N ! FUN N3M5 298.15 +55865;,, N ! FUN N4M5 298.15 -114625;,, N ! FUN R1N2 298.15 -2123;,, N ! FUN R1N3 298.15 -19973;,, N ! FUN R2N3 298.15 +5210;,, N ! FUN R1N4 298.15 -1351;,, N ! FUN R2N4 298.15 -89153;,, N ! FUN R3N4 298.15 -89828;,, N ! FUN R1N5 298.15 -61558;,, N ! FUN R2N5 298.15 -2026;,, N ! FUN R3N5 298.15 +75934;,, N ! FUN R4N5 298.15 -24700;,, N ! FUN N1R2 298.15 -103625;,, N ! FUN N1R3 298.15 +20648;,, N ! FUN N1R4 298.15 -88284;,, N ! FUN N1R5 298.15 +32709;,, N ! FUN N2R3 298.15 -46120;,, N ! FUN N2R4 298.15 +91951;,, N ! FUN N2R5 298.15 +36182;,, N ! FUN N3R4 298.15 +70531;,, N ! FUN N3R5 298.15 +136624;,, N ! FUN N4R5 298.15 -77381;,, N ! TYPE_DEFINITION % SEQ *! DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! PHASE LIQUID % 1 1.0 ! CONST LIQUID :MO,RE,NI : ! TYPE_DEFINITION ( GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! PHASE FCC_A1 %( 2 1 1 ! CONST FCC_A1 :MO,RE,NI : VA : ! TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! PHASE BCC_A2 %& 2 1 3 ! CONSTITUENT BCC_A2 :MO,RE,NI : VA : ! TYPE_DEFINITION ) GES A_P_D HCP_A3 MAGNETIC -3.0 2.80000E-01 ! PHASE HCP_A3 %) 2 1 .5 ! CONST HCP_A3 :MO,RE,NI : VA : ! PHASE MONI_DELTA % 3 24 20 12 ! CONST MONI_DELTA :NI : MO,NI : MO : ! TYPE_DEFINITION + GES AMEND_PHASE_DESCRIPTION CHI NEVER DIS_CHI,,,! PHASE DIS_CHI % 1 1.0 ! CONSTITUENT DIS_CHI :MO,RE,NI : ! PHASE CHI %+ 4 2 8 24 24 ! CONST CHI :MO,RE,NI : MO,RE,NI : MO,RE,NI : MO,RE,NI : ! TYPE_DEFINITION * GES AMEND_PHASE_DESCRIPTION SIGMA NEVER DIS_SIG,,,! PHASE DIS_SIG % 1 1.0 ! CONST DIS_SIG :MO,RE,NI : ! PHASE SIGMA %* 5 2 4 8 8 8 ! CONST SIGMA :MO,RE,NI : MO,RE,NI : MO,RE,NI : MO,RE,NI : MO,RE,NI : ! $========================================================================= $ Unary parameters $========================================================================= $-------------------------------------------------------------------- SGTE PARAMETER G(BCC_A2,MO:VA;0) 298.15 +GHSERMO;,, N REF1 ! PARAMETER G(BCC_A2,NI:VA;0) 298.15 +GBCCNI;,, N REF1 ! PARAMETER TC(BCC_A2,NI:VA;0) 2.98150E+02 575;,, N REF1 ! PARAMETER BMAGN(BCC_A2,NI:VA;0) 2.98150E+02 .85;,, N REF1 ! PARAMETER G(BCC_A2,RE:VA;0) 298.15 +GBCCRE;,, N REF1 ! PARAMETER G(FCC_A1,MO:VA;0) 298.15 +GFCCMO;,, N REF1 ! PARAMETER G(FCC_A1,NI:VA;0) 298.15 +GHSERNI;,, N REF1 ! PARAMETER TC(FCC_A1,NI:VA;0) 2.98150E+02 633;,, N REF1 ! PARAMETER BMAGN(FCC_A1,NI:VA;0) 2.98150E+02 .52;,, N REF1 ! PARAMETER G(FCC_A1,RE:VA;0) 298.15 GFCCRE;,, N REF1 ! PARAMETER G(HCP_A3,MO:VA;0) 298.15 +GHCPMO;,, N REF1 ! PARAMETER G(HCP_A3,NI:VA;0) 298.15 +GHCPNI;,, N REF1 ! PARAMETER G(HCP_A3,RE:VA;0) 298.15 +GHSERRE;,, N REF1 ! PARAMETER G(LIQUID,MO;0) 298.15 GLIQMO;,, N REF1 ! PARAMETER G(LIQUID,NI;0) 298.15 GLIQNI;,, N REF1 ! PARAMETER G(LIQUID,RE;0) 298.15 GLIQRE;,, N REF1 ! $-------------------------------------------------------------------- DFT $ PARA G(DIS_CHI,MO;0) 298.15 +26126+GHSERMO;,, N DFTCHI ! $ PARA G(DIS_CHI,NI;0) 298.15 +13550+GHSERNI;,, N DFTCHI ! $ PARA G(DIS_CHI,RE;0) 298.15 +4903+GHSERRE;,, N DFTCHI ! $ PARA G(DIS_SIG,MO;0) 298.15 +16098+GHSERMO;,, N DFTSIG ! $ PARA G(DIS_SIG,NI;0) 298.15 +13582+GHSERNI;,, N DFTSIG ! $ PARA G(DIS_SIG,RE;0) 298.15 +9331+GHSERRE;,, N DFTSIG ! $---------------------------------------------------------------------------- $ S assessed in Mo-Re PARA G(DIS_CHI,MO;0) 298.15 +26126+GHSERMO-0.5596*T;,, N REF9 ! PARA G(DIS_CHI,RE;0) 298.15 +4903+GHSERRE+0.00905*T;,, N REF9 ! PARA G(DIS_SIG,MO;0) 298.15 +16098+GHSERMO+1.251*T;,, N REF9 ! PARA G(DIS_SIG,RE;0) 298.15 +9331+GHSERRE-1.205*T;,, N REF9 ! $---------------------------------------------------------------------------- $ Ni sigma and chi - test for S PARA G(DIS_SIG,NI;0) 298.15 +13582+GHSERNI+3*T;,, N MONIRE ! PARA G(DIS_CHI,NI;0) 298.15 +13550+GHSERNI+6*T;,, N MONIRE! $========================================================================= $ Binary parameters $========================================================================= $------------------------------------------------------------------- Mo-Ni PARA L(LIQUID,MO,NI;0) 298.15 -46540+19.53*T;,, N 90Fri4 ! PARA L(LIQUID,MO,NI;1) 298.15 2915;,, N 90Fri4 ! PARA L(FCC_A1,MO,NI:VA;0) 298.15 +4803.7-5.96*T;,, N 90Fri4 ! PARA L(FCC_A1,MO,NI:VA;1) 298.15 10880;,, N 90Fri4 ! PARA L(BCC_A2,MO,NI:VA;0) 298.15 46422;,, N 90Fri4 ! PARA G(MONI_DELTA,NI:MO:MO;0) 298.15 +24*GHSERNI+32*GHSERMO-212100+1089*T-142*T*LN(T);,, N 90Fri4 ! PARA G(MONI_DELTA,NI:NI:MO;0) 298.15 +24*GHSERNI+20*GBCCNI+12*GHSERMO-1030-93.5*T+13.5*T*LN(T);,, N 90Fri4 ! $ ID to FCC PARA L(HCP_A3,MO,NI:VA;0) 298.15 +4803.7-5.96*T;,, N MONIRE ! PARA L(HCP_A3,MO,NI:VA;1) 298.15 +10880;,, N MONIRE ! PARA G(CHI,NI:MO:MO:MO;0) 298.15 +219710;,, N DFTCHI ! PARA G(CHI,MO:NI:MO:MO;0) 298.15 +814131;,, N DFTCHI ! PARA G(CHI,NI:NI:MO:MO;0) 298.15 +965490;,, N DFTCHI ! PARA G(CHI,MO:MO:NI:MO;0) 298.15 -172228;,, N DFTCHI ! PARA G(CHI,MO:MO:MO:NI;0) 298.15 -481244;,, N DFTCHI ! PARA G(CHI,NI:MO:NI:MO;0) 298.15 -43099;,, N DFTCHI ! PARA G(CHI,NI:MO:MO:NI;0) 298.15 -352925;,, N DFTCHI ! PARA G(CHI,MO:NI:NI:MO;0) 298.15 -163370;,, N DFTCHI ! PARA G(CHI,MO:NI:MO:NI;0) 298.15 -532188;,, N DFTCHI ! PARA G(CHI,NI:NI:NI:MO;0) 298.15 +14892;,, N DFTCHI ! PARA G(CHI,NI:NI:MO:NI;0) 298.15 -271198;,, N DFTCHI ! PARA G(CHI,MO:MO:NI:NI;0) 298.15 -877718;,, N DFTCHI ! PARA G(CHI,NI:MO:NI:NI;0) 298.15 -849987;,, N DFTCHI ! PARA G(CHI,MO:NI:NI:NI;0) 298.15 -221731;,, N DFTCHI ! PARA G(SIGMA,MO:NI:*:*:*;0) 298.15 -112309;,, N ND ! PARA G(SIGMA,MO:*:NI:*:*;0) 298.15 +29525;,, N ND ! PARA G(SIGMA,MO:*:*:NI:*;0) 298.15 -965;,, N ND ! PARA G(SIGMA,MO:*:*:*:NI;0) 298.15 -40910;,, N ND ! PARA G(SIGMA,*:MO:NI:*:*;0) 298.15 -109029;,, N ND ! PARA G(SIGMA,*:MO:*:NI:*;0) 298.15 -134018;,, N ND ! PARA G(SIGMA,*:MO:*:*:NI;0) 298.15 -2219;,, N ND ! PARA G(SIGMA,*:*:MO:NI:*;0) 298.15 -167595;,, N ND ! PARA G(SIGMA,*:*:MO:*:NI;0) 298.15 +66189;,, N ND ! PARA G(SIGMA,*:*:*:MO:NI;0) 298.15 -16596;,, N ND ! PARA G(SIGMA,NI:MO:*:*:*;0) 298.15 -73811;,, N ND ! PARA G(SIGMA,NI:*:MO:*:*;0) 298.15 -7043;,, N ND ! PARA G(SIGMA,NI:*:*:MO:*;0) 298.15 -41875;,, N ND ! PARA G(SIGMA,NI:*:*:*:MO;0) 298.15 +17271;,, N ND ! PARA G(SIGMA,*:NI:MO:*:*;0) 298.15 +82688;,, N ND ! PARA G(SIGMA,*:NI:*:MO:*;0) 298.15 +63970;,, N ND ! PARA G(SIGMA,*:NI:*:*:MO;0) 298.15 +97740;,, N ND ! PARA G(SIGMA,*:*:NI:MO:*;0) 298.15 +19008;,, N ND ! PARA G(SIGMA,*:*:NI:*:MO;0) 298.15 +55865;,, N ND ! PARA G(SIGMA,*:*:*:NI:MO;0) 298.15 -114625;,, N ND ! $------------------------------------------------------------------- Mo-Re PARAMETER L(BCC_A2,MO,RE:VA;0) 298.15 -15025+11.404*T;,, N REF9 ! PARAMETER L(BCC_A2,MO,RE:VA;1) 298.15 +8.07*T;,, N REF9 ! PARAMETER L(HCP_A3,MO,RE:VA;0) 298.15 +12740+1.951*T;,, N REF9 ! PARAMETER L(LIQUID,MO,RE;0) 298.15 -15025+11.404*T-2610;,, N REF9 ! PARAMETER L(LIQUID,MO,RE;1) 298.15 +8.07*T-7790;,, N REF9 ! $ ID to HCP PARA L(FCC_A1,MO,RE:VA;0) 298.15 +12740+1.951*T;,, N MONIRE ! PARA G(CHI,RE:MO:MO:MO;0) 298.15 +72898;,, N DFTCHI ! PARA G(CHI,MO:RE:MO:MO;0) 298.15 +238327;,, N DFTCHI ! PARA G(CHI,RE:RE:MO:MO;0) 298.15 +327082;,, N DFTCHI ! PARA G(CHI,MO:MO:RE:MO;0) 298.15 -194830;,, N DFTCHI ! PARA G(CHI,MO:MO:MO:RE;0) 298.15 -681482;,, N DFTCHI ! PARA G(CHI,RE:MO:RE:MO;0) 298.15 -127372;,, N DFTCHI ! PARA G(CHI,RE:MO:MO:RE;0) 298.15 -583384;,, N DFTCHI ! PARA G(CHI,MO:RE:RE:MO;0) 298.15 +141480;,, N DFTCHI ! PARA G(CHI,MO:RE:MO:RE;0) 298.15 -300477;,, N DFTCHI ! PARA G(CHI,RE:RE:RE:MO;0) 298.15 +239483;,, N DFTCHI ! PARA G(CHI,RE:RE:MO:RE;0) 298.15 -165184;,, N DFTCHI ! PARA G(CHI,MO:MO:RE:RE;0) 298.15 -569681;,, N DFTCHI ! PARA G(CHI,RE:MO:RE:RE;0) 298.15 -468084;,, N DFTCHI ! PARA G(CHI,MO:RE:RE:RE;0) 298.15 -125904;,, N DFTCHI ! PARA G(SIGMA,MO:RE:*:*:*;0) 298.15 +680;,, N ND ! PARA G(SIGMA,MO:*:RE:*:*;0) 298.15 +16094;,, N ND ! PARA G(SIGMA,MO:*:*:RE:*;0) 298.15 +0;,, N ND ! PARA G(SIGMA,MO:*:*:*:RE;0) 298.15 +4361;,, N ND ! PARA G(SIGMA,*:MO:RE:*:*;0) 298.15 -14434;,, N ND ! PARA G(SIGMA,*:MO:*:RE:*;0) 298.15 -81839;,, N ND ! PARA G(SIGMA,*:MO:*:*:RE;0) 298.15 -28743;,, N ND ! PARA G(SIGMA,*:*:MO:RE:*;0) 298.15 -86837;,, N ND ! PARA G(SIGMA,*:*:MO:*:RE;0) 298.15 -73358;,, N ND ! PARA G(SIGMA,*:*:*:MO:RE;0) 298.15 +21024;,, N ND ! PARA G(SIGMA,RE:MO:*:*:*;0) 298.15 -22076;,, N ND ! PARA G(SIGMA,RE:*:MO:*:*;0) 298.15 -19297;,, N ND ! PARA G(SIGMA,RE:*:*:MO:*;0) 298.15 +5847;,, N ND ! PARA G(SIGMA,RE:*:*:*:MO;0) 298.15 -30827;,, N ND ! PARA G(SIGMA,*:RE:MO:*:*;0) 298.15 +6571;,, N ND ! PARA G(SIGMA,*:RE:*:MO:*;0) 298.15 +42569;,, N ND ! PARA G(SIGMA,*:RE:*:*:MO;0) 298.15 -25482;,, N ND ! PARA G(SIGMA,*:*:RE:MO:*;0) 298.15 -1467;,, N ND ! PARA G(SIGMA,*:*:RE:*:MO;0) 298.15 -62108;,, N ND ! PARA G(SIGMA,*:*:*:RE:MO;0) 298.15 -119768;,, N ND ! $------------------------------------------------------------------- Ni-Re PARA L(LIQUID,NI,RE;0) 298.15 21480.3504;,, N NIRE ! PARA L(FCC_A1,NI,RE:VA;0) 298.15 5054.48711+8.28748232*T;,, N NIRE ! PARA L(HCP_A3,NI,RE:VA;0) 298.15 9968.56426+7.59954301*T;,, N NIRE ! $ ID to LIQ PARA L(BCC_A2,NI,RE:VA;0) 298.15 +21480.3504;,, N MONIRE ! PARA G(CHI,RE:NI:NI:NI;0) 298.15 -89694;,, N DFTCHI ! PARA G(CHI,NI:RE:NI:NI;0) 298.15 -393802;,, N DFTCHI ! PARA G(CHI,RE:RE:NI:NI;0) 298.15 -511876;,, N DFTCHI ! PARA G(CHI,NI:NI:RE:NI;0) 298.15 +232248;,, N DFTCHI ! PARA G(CHI,NI:NI:NI:RE;0) 298.15 +59918;,, N DFTCHI ! PARA G(CHI,RE:NI:RE:NI;0) 298.15 +163650;,, N DFTCHI ! PARA G(CHI,RE:NI:NI:RE;0) 298.15 -40656;,, N DFTCHI ! PARA G(CHI,NI:RE:RE:NI;0) 298.15 -135674;,, N DFTCHI ! PARA G(CHI,NI:RE:NI:RE;0) 298.15 +217732;,, N DFTCHI ! PARA G(CHI,RE:RE:RE:NI;0) 298.15 -276649;,, N DFTCHI ! PARA G(CHI,RE:RE:NI:RE;0) 298.15 +262496;,, N DFTCHI ! PARA G(CHI,NI:NI:RE:RE;0) 298.15 -36360;,, N DFTCHI ! PARA G(CHI,RE:NI:RE:RE;0) 298.15 -99055;,, N DFTCHI ! PARA G(CHI,NI:RE:RE:RE;0) 298.15 +78569;,, N DFTCHI ! PARA G(SIGMA,NI:RE:*:*:*;0) 298.15 -103625;,, N ND ! PARA G(SIGMA,NI:*:RE:*:*;0) 298.15 +20648;,, N ND ! PARA G(SIGMA,NI:*:*:RE:*;0) 298.15 -88284;,, N ND ! PARA G(SIGMA,NI:*:*:*:RE;0) 298.15 +32709;,, N ND ! PARA G(SIGMA,*:NI:RE:*:*;0) 298.15 -46120;,, N ND ! PARA G(SIGMA,*:NI:*:RE:*;0) 298.15 +91951;,, N ND ! PARA G(SIGMA,*:NI:*:*:RE;0) 298.15 +36182;,, N ND ! PARA G(SIGMA,*:*:NI:RE:*;0) 298.15 +70531;,, N ND ! PARA G(SIGMA,*:*:NI:*:RE;0) 298.15 +136624;,, N ND ! PARA G(SIGMA,*:*:*:NI:RE;0) 298.15 -77381;,, N ND ! PARA G(SIGMA,RE:NI:*:*:*;0) 298.15 -2123;,, N ND ! PARA G(SIGMA,RE:*:NI:*:*;0) 298.15 -19973;,, N ND ! PARA G(SIGMA,RE:*:*:NI:*;0) 298.15 -1351;,, N ND ! PARA G(SIGMA,RE:*:*:*:NI;0) 298.15 -61558;,, N ND ! PARA G(SIGMA,*:RE:NI:*:*;0) 298.15 +5210;,, N ND ! PARA G(SIGMA,*:RE:*:NI:*;0) 298.15 -89153;,, N ND ! PARA G(SIGMA,*:RE:*:*:NI;0) 298.15 -2026;,, N ND ! PARA G(SIGMA,*:*:RE:NI:*;0) 298.15 -89828;,, N ND ! PARA G(SIGMA,*:*:RE:*:NI;0) 298.15 +75934;,, N ND ! PARA G(SIGMA,*:*:*:RE:NI;0) 298.15 -24700;,, N ND ! $========================================================================= $ Ternary parameters $========================================================================= PARA G(CHI,NI:MO:MO:RE;0) 298.15 -519693;,, N DFTCHI ! PARA G(CHI,NI:RE:MO:RE;0) 298.15 -106844;,, N DFTCHI ! PARA G(CHI,NI:MO:RE:MO;0) 298.15 +35426;,, N DFTCHI ! PARA G(CHI,NI:RE:MO:MO;0) 298.15 +496740;,, N DFTCHI ! PARA G(CHI,NI:MO:RE:RE;0) 298.15 -409153;,, N DFTCHI ! PARA G(CHI,NI:RE:RE:MO;0) 298.15 +366739;,, N DFTCHI ! PARA G(CHI,RE:NI:MO:RE;0) 298.15 +16373;,, N DFTCHI ! PARA G(CHI,MO:NI:RE:MO;0) 298.15 +533241;,, N DFTCHI ! PARA G(CHI,MO:NI:RE:RE;0) 298.15 -211610;,, N DFTCHI ! PARA G(CHI,RE:NI:RE:MO;0) 298.15 +600355;,, N DFTCHI ! PARA G(CHI,RE:NI:MO:MO;0) 298.15 +913000;,, N DFTCHI ! PARA G(CHI,MO:NI:MO:RE;0) 298.15 -113332;,, N DFTCHI ! PARA G(CHI,NI:NI:RE:MO;0) 298.15 +632479;,, N DFTCHI ! PARA G(CHI,NI:NI:MO:RE;0) 298.15 +16967;,, N DFTCHI ! PARA G(CHI,RE:MO:NI:RE;0) 298.15 -31431;,, N DFTCHI ! PARA G(CHI,MO:RE:NI:RE;0) 298.15 +124857;,, N DFTCHI ! PARA G(CHI,RE:RE:NI:MO;0) 298.15 +85119;,, N DFTCHI ! PARA G(CHI,RE:MO:NI:MO;0) 298.15 -105163;,, N DFTCHI ! PARA G(CHI,MO:RE:NI:MO;0) 298.15 -19854;,, N DFTCHI ! PARA G(CHI,MO:MO:NI:RE;0) 298.15 -145816;,, N DFTCHI ! PARA G(CHI,RE:MO:RE:NI;0) 298.15 -458236;,, N DFTCHI ! PARA G(CHI,MO:MO:RE:NI;0) 298.15 -524528;,, N DFTCHI ! PARA G(CHI,MO:RE:RE:NI;0) 298.15 -344447;,, N DFTCHI ! PARA G(CHI,RE:MO:MO:NI;0) 298.15 -425639;,, N DFTCHI ! PARA G(CHI,MO:RE:MO:NI;0) 298.15 -447354;,, N DFTCHI ! PARA G(CHI,RE:RE:MO:NI;0) 298.15 -400043;,, N DFTCHI ! PARA G(CHI,NI:RE:NI:MO;0) 298.15 +144227;,, N DFTCHI ! PARA G(CHI,NI:MO:NI:RE;0) 298.15 -89466;,, N DFTCHI ! PARA G(CHI,NI:RE:MO:NI;0) 298.15 -234016;,, N DFTCHI ! PARA G(CHI,NI:MO:RE:NI;0) 298.15 -393733;,, N DFTCHI ! PARA G(CHI,RE:NI:NI:MO;0) 298.15 -122124;,, N DFTCHI ! PARA G(CHI,MO:NI:NI:RE;0) 298.15 -194827;,, N DFTCHI ! PARA G(CHI,RE:NI:MO:NI;0) 298.15 -389947;,, N DFTCHI ! PARA G(CHI,MO:NI:RE:NI;0) 298.15 +3924;,, N DFTCHI ! PARA G(CHI,RE:MO:NI:NI;0) 298.15 -862872;,, N DFTCHI ! PARA G(CHI,MO:RE:NI:NI;0) 298.15 -559164;,, N DFTCHI ! $============================================================================ LIST_OF_REFERENCES NUMBER SOURCE REF1 'PURE4 - SGTE Pure Elements (Unary) Database (Version 4.6), developed by SGTE (Scientific Group Thermodata Europe), 1991-2008, and provided by TCSAB (Jan. 2008). ' REF5 'JC Crivello 2012 march, Armide project v1.13 chi phase' REF9 'R. Mathieu et al., Armide project Calphad, 43 (2013) 18-31' DFTSIG 'JC Crivello 2012 march, Armide project v1.9 sigma phase' DFTCHI 'JC Crivello 2012 march, Armide project v1.13 chi phase' 90Fri4 'K Frisk, Calphad 14(1990)3 p 311-320; Mo-Ni' NIRE 'K. Yaqoob and JM Joubert' MONIRE 'ND Mo-Ni-Re tests' ND 'N. Dupin , BEF testing' ! ================================================ FILE: examples/macros/CHO-gas.TDB ================================================ $ Database file written 2015- 8-29 $ From database: SSUB3 DATABASE_INFO about the CHO-gas database It is an extract for the elements C, H and O from the SGTE substance database the year 2001. It contains a large number of gas species and a few condenced phases.! $ ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT C GRAPHITE 1.2011E+01 1.0540E+03 5.7400E+00! ELEMENT H 1/2_MOLE_H2(GAS) 1.0079E+00 4.2340E+03 6.5285E+01! ELEMENT O 1/2_MOLE_O2(GAS) 1.5999E+01 4.3410E+03 1.0252E+02! SPECIES C1H1 C1H1! SPECIES C1H1O1 C1H1O1! SPECIES C1H1O2 C1H1O2! SPECIES C1H2 C1H2! SPECIES C1H2O1 C1H2O1! SPECIES C1H2O2 C1H2O2! SPECIES C1H2O2_CIS C1H2O2! SPECIES C1H2O2_DIOXIRANE C1H2O2! SPECIES C1H2O2_TRANS C1H2O2! SPECIES C1H3 C1H3! SPECIES C1H3O1_CH2OH C1H3O1! SPECIES C1H3O1_CH3O C1H3O1! SPECIES C1H4 C1H4! SPECIES C1H4O1 C1H4O1! SPECIES C1O1 C1O1! SPECIES C1O2 C1O2! SPECIES C2 C2! SPECIES C2H1 C2H1! SPECIES C2H2 C2H2! SPECIES C2H2O1 C2H2O1! SPECIES C2H3 C2H3! SPECIES C2H4 C2H4! SPECIES C2H4O1_ACETALDEHYDE C2H4O1! SPECIES C2H4O1_OXIRANE C2H4O1! SPECIES C2H4O2 C2H4O2! SPECIES C2H4O2_ACETICACID C2H4O2! SPECIES C2H4O2_DIOXETANE C2H4O2! SPECIES C2H4O3_123TRIOXOLANE C2H4O3! SPECIES C2H4O3_124TRIOXOLANE C2H4O3! SPECIES C2H5 C2H5! SPECIES C2H6 C2H6! SPECIES C2H6O1 C2H6O1! SPECIES C2H6O2 C2H6O2! SPECIES C2O1 C2O1! SPECIES C3 C3! SPECIES C3H1 C3H1! SPECIES C3H4_1 C3H4! SPECIES C3H4_2 C3H4! SPECIES C3H6 C3H6! SPECIES C3H6O1 C3H6O1! SPECIES C3H6_2 C3H6! SPECIES C3H8 C3H8! SPECIES C3O2 C3O2! SPECIES C4 C4! SPECIES C4H1 C4H1! SPECIES C4H10_1 C4H10! SPECIES C4H10_2 C4H10! SPECIES C4H2 C4H2! SPECIES C4H4 C4H4! SPECIES C4H4_1_3 C4H4! SPECIES C4H6_1 C4H6! SPECIES C4H6_2 C4H6! SPECIES C4H6_3 C4H6! SPECIES C4H6_4 C4H6! SPECIES C4H6_5 C4H6! SPECIES C4H8 C4H8! SPECIES C4H8_1 C4H8! SPECIES C4H8_2 C4H8! SPECIES C4H8_3 C4H8! SPECIES C4H8_4 C4H8! SPECIES C4H8_5 C4H8! SPECIES C5 C5! SPECIES C60 C60! SPECIES C6H6 C6H6! SPECIES C6H6O1 C6H6O1! SPECIES H1O1 H1O1! SPECIES H1O2 H1O2! SPECIES H2 H2! SPECIES H2O1 H2O1! SPECIES H2O2 H2O2! SPECIES O2 O2! SPECIES O3 O3! FUNCTION F3895T 2.98150E+02 +710430.933-17.7062919*T-20.97529*T*LN(T) +1.998237E-04*T**2-3.34617167E-08*T**3+1680.6515*T**(-1); 3.40000E+03 Y +698015.711+2.57175186*T-23.05071*T*LN(T)-6.04604E-05*T**2 +6.74291667E-10*T**3+8558245*T**(-1); 1.00000E+04 Y +736197.571-32.7975309*T-19.44529*T*LN(T)-1.5396035E-04*T**2 -6.15402167E-11*T**3-56188350*T**(-1); 2.00000E+04 N ! FUNCTION F4246T 2.98150E+02 +589091.036+6.37586112*T-28.31773*T*LN(T) +2.3216165E-04*T**2-7.36439667E-07*T**3-27186.245*T**(-1); 9.00000E+02 Y +591708.657-35.2925324*T-21.90158*T*LN(T)-.00592793*T**2 +2.9876E-07*T**3-172733.6*T**(-1); 2.80000E+03 Y +579194.621+42.13831*T-32.13932*T*LN(T)-.002507963*T**2 +9.59279833E-08*T**3+2285342*T**(-1); 6.40000E+03 Y +409696.643+452.714152*T-79.92745*T*LN(T)+.003347292*T**2 -3.63044167E-08*T**3+1.115888E+08*T**(-1); 1.20000E+04 Y +800166.03-30.0457765*T-28.18561*T*LN(T)+2.7641345E-04*T**2 -1.923675E-09*T**3-4.4613505E+08*T**(-1); 2.00000E+04 N ! FUNCTION F4282T 2.98150E+02 +34663.1187-68.3993353*T-21.87253*T*LN(T) -.018848125*T**2+1.978875E-06*T**3-112550.6*T**(-1); 1.10000E+03 Y +10875.4517+145.536698*T-52.16378*T*LN(T)-.001376625*T**2 +4.73872167E-08*T**3+3443852*T**(-1); 3.60000E+03 Y +3695.68232+174.659191*T-55.81562*T*LN(T)-5.33191E-04*T**2 +1.07304333E-08*T**3+6222210*T**(-1); 6.00000E+03 N ! FUNCTION F4287T 2.98150E+02 -224579.294-49.1626181*T-27.13519*T*LN(T) -.03548659*T**2+5.02649167E-06*T**3+89572.2*T**(-1); 7.00000E+02 Y -239557.575+145.651699*T-56.49751*T*LN(T)-.00960395*T**2 +6.83389333E-07*T**3+1534296*T**(-1); 1.90000E+03 Y -268690.124+327.648549*T-80.82941*T*LN(T)-3.4153865E-04*T**2 +9.43135333E-09*T**3+8273490*T**(-1); 6.00000E+03 N ! FUNCTION F4298T 2.98150E+02 +381898.015-5.8112289*T-27.63198*T*LN(T) -.007897355*T**2-3.87669333E-08*T**3-62547*T**(-1); 9.00000E+02 Y +378165.881+8.88081456*T-29.13698*T*LN(T)-.00988883*T**2 +6.15529E-07*T**3+710779*T**(-1); 2.20000E+03 Y +340850.246+220.65528*T-57.01662*T*LN(T)-4.862414E-04*T**2 +1.48344217E-08*T**3+10277000*T**(-1); 6.00000E+03 N ! FUNCTION F4308T 2.98150E+02 -113219.01-136.968085*T-9.266226*T*LN(T) -.039279425*T**2+4.39612833E-06*T**3-223966.05*T**(-1); 9.00000E+02 Y -140078.823+144.485426*T-50.12368*T*LN(T)-.01134191*T**2 +7.60462333E-07*T**3+3113545*T**(-1); 2.00000E+03 Y -178622.186+374.929455*T-80.70841*T*LN(T)-3.54568E-04*T**2 +9.67480833E-09*T**3+12424215*T**(-1); 6.00000E+03 N ! FUNCTION F4315T 2.98150E+02 -388781.001-103.90421*T-16.81765*T*LN(T) -.05671885*T**2+7.970165E-06*T**3+48801.55*T**(-1); 7.00000E+02 Y -409999.916+178.628265*T-59.57362*T*LN(T)-.0180534*T**2 +1.33848133E-06*T**3+2039066.5*T**(-1); 1.70000E+03 Y -459640.338+500.116138*T-102.7958*T*LN(T)-8.65375E-04*T**2 +2.308845E-08*T**3+13013465*T**(-1); 6.00000E+03 N ! FUNCTION F4320T 2.98150E+02 +27318.4015-158.350101*T-6.392688*T*LN(T) -.07291625*T**2+1.17752067E-05*T**3-12222.075*T**(-1); 6.00000E+02 Y +5573.92678+166.117642*T-56.49072*T*LN(T)-.021391445*T**2 +1.77927667E-06*T**3+1762681*T**(-1); 1.60000E+03 Y -1463919.16+9430.16255*T-1294.007*T*LN(T)+.4412455*T**2 -3.07016E-05*T**3+3.279501E+08*T**(-1); 1.80000E+03 Y -36820.5158+492.992794*T-101.3071*T*LN(T)-.0012632635*T**2 +4.60931667E-08*T**3+8156590*T**(-1); 3.80000E+03 N ! FUNCTION F4326T 2.98150E+02 -372453.966-100.891302*T-17.32496*T*LN(T) -.05637795*T**2+7.91681333E-06*T**3+42419.085*T**(-1); 7.00000E+02 Y -393558.584+180.039941*T-59.83597*T*LN(T)-.01795244*T**2 +1.330329E-06*T**3+2022398*T**(-1); 1.70000E+03 Y -442917.663+499.668746*T-102.8073*T*LN(T)-8.671225E-04*T**2 +2.304695E-08*T**3+12935575*T**(-1); 6.00000E+03 N ! FUNCTION F4331T 2.98150E+02 +137013.412-8.99457393*T-25.84363*T*LN(T) -.021245325*T**2+1.58670483E-06*T**3-33266.495*T**(-1); 1.60000E+03 Y +84303.6035+343.362209*T-73.42088*T*LN(T)-.0017754415*T**2 +6.12003E-08*T**3+11112475*T**(-1); 4.40000E+03 Y +64161.9832+414.726089*T-82.17617*T*LN(T)-1.024296E-04*T**2 +2.10901667E-09*T**3+19781775*T**(-1); 6.00000E+03 N ! FUNCTION F4342T 2.98150E+02 -31298.3817-55.7322048*T-24.61425*T*LN(T) -.04353285*T**2+5.34829833E-06*T**3+55658.25*T**(-1); 7.00000E+02 Y -43832.867+109.01195*T-49.49554*T*LN(T)-.02127646*T**2 +1.55219067E-06*T**3+1252337.5*T**(-1); 1.70000E+03 Y -103097.337+489.690506*T-100.6003*T*LN(T)-.0011952165*T**2 +3.56136E-08*T**3+14443730*T**(-1); 5.30000E+03 Y -120483.247+545.193751*T-107.3055*T*LN(T)-7.377055E-05*T**2 +1.335003E-09*T**3+22773150*T**(-1); 6.00000E+03 N ! FUNCTION F4348T 2.98150E+02 +10647.9115-220.041163*T+2.897875*T*LN(T) -.0631791*T**2+7.98735833E-06*T**3-294680.9*T**(-1); 7.00000E+02 Y -8352.38175+27.9795444*T-34.49142*T*LN(T)-.03027099*T**2 +2.51015167E-06*T**3+1523708*T**(-1); 1.40000E+03 Y -65111.0776+451.440995*T-92.64558*T*LN(T)-.003388665*T**2 +1.41701483E-07*T**3+12047630*T**(-1); 3.50000E+03 Y -92729.9649+564.732519*T-106.8476*T*LN(T)-1.4186865E-04*T**2 +3.13837167E-09*T**3+22203380*T**(-1); 6.00000E+03 N ! FUNCTION F4354T 2.98150E+02 -77295.563-147.095197*T-2.234656*T*LN(T) -.048463265*T**2+4.33754333E-06*T**3-305431.45*T**(-1); 1.00000E+03 Y -110499.85+168.104152*T-47.22933*T*LN(T)-.021108925*T**2 +1.1779525E-06*T**3+4316954*T**(-1); 2.00000E+03 Y -181918.388+576.950971*T-101.1311*T*LN(T)-.002684469*T**2 -2.361885E-08*T**3+22404635*T**(-1); 6.00000E+03 N ! FUNCTION F4361T 2.98150E+02 -205205.838-196.101493*T-1.169187*T*LN(T) -.06931275*T**2+8.62977667E-06*T**3-275306.2*T**(-1); 7.00000E+02 Y -225205.951+67.2670437*T-40.94166*T*LN(T)-.033860495*T**2 +2.6413E-06*T**3+1622706*T**(-1); 1.50000E+03 Y -296381.314+570.842619*T-109.5301*T*LN(T)-.0039814965*T**2 +1.5649925E-07*T**3+15683740*T**(-1); 3.70000E+03 Y -332630.415+711.963927*T-127.0897*T*LN(T)-1.98456E-04*T**2 +4.28468667E-09*T**3+29832830*T**(-1); 6.00000E+03 N ! FUNCTION F4504T 2.98150E+02 -118162.143-23.1824004*T-25.84624*T*LN(T) -.003281553*T**2-1.63612533E-07*T**3-55604.1*T**(-1); 8.00000E+02 Y -122211.036+7.61017665*T-29.9366*T*LN(T)-.0027053115*T**2 +1.75559167E-07*T**3+541480.5*T**(-1); 2.20000E+03 Y -131274.213+62.1198833*T-37.17593*T*LN(T)-1.020237E-04*T**2 -6.44914833E-10*T**3+2724014*T**(-1); 6.00000E+03 N ! FUNCTION F4525T 2.98150E+02 -404733.623-4.69677711*T-29.32959*T*LN(T) -.01996358*T**2+2.45837833E-06*T**3+124430.9*T**(-1); 9.00000E+02 Y -421187.23+168.064895*T-54.43846*T*LN(T)-.002556694*T**2 +1.34184133E-07*T**3+2179368*T**(-1); 2.70000E+03 Y -462626.164+339.502796*T-76.00339*T*LN(T)+.0026074805*T**2 -1.06680183E-07*T**3+17540465*T**(-1); 7.60000E+03 Y +322101.769-1097.44815*T+85.62125*T*LN(T)-.01226122*T**2 +1.50875083E-07*T**3-7.00947E+08*T**(-1); 1.00000E+04 N ! FUNCTION F4656T 2.98150E+02 +803005.137+419.915369*T-97.48141*T*LN(T) +.08202995*T**2-1.97357E-05*T**3+690749.5*T**(-1); 5.00000E+02 Y +826732.964-2.78397075*T-30.08349*T*LN(T)-.002621389*T**2 +8.30959667E-08*T**3-868501*T**(-1); 4.30000E+03 Y +850321.493-26.7776267*T-27.96957*T*LN(T)-.0019408995*T**2 +3.222655E-08*T**3-22380050*T**(-1); 1.20000E+04 Y +409662.376+520.53814*T-86.66656*T*LN(T)+.0015642485*T**2 -7.28093667E-09*T**3+6.04612E+08*T**(-1); 2.00000E+04 N ! FUNCTION F4935T 2.98150E+02 +555907.867+57.0634842*T-39.08261*T*LN(T) -.00569665*T**2-4.27085667E-07*T**3+135750.65*T**(-1); 1.00000E+03 Y +560368.69-14.5499453*T-28.12154*T*LN(T)-.015627865*T**2 +1.1143725E-06*T**3-38275.195*T**(-1); 2.10000E+03 Y +500130.672+354.303072*T-77.12859*T*LN(T)+.001864081*T**2 -4.41159667E-08*T**3+13617155*T**(-1); 6.40000E+03 Y +548031.854+234.921123*T-63.15948*T*LN(T)+6.031155E-05*T**2 -8.38662167E-10*T**3-17395655*T**(-1); 1.00000E+04 N ! FUNCTION F4946T 2.98150E+02 +210657.364+102.660059*T-43.33318*T*LN(T) -.015969725*T**2+1.09745783E-06*T**3+366936*T**(-1); 1.70000E+03 Y +162805.829+400.859267*T-83.17592*T*LN(T)-8.50672E-04*T**2 -8.40052167E-09*T**3+11371695*T**(-1); 4.70000E+03 Y +284779.332+156.173741*T-55.55581*T*LN(T)-.003209261*T**2 +1.402618E-08*T**3-81696300*T**(-1); 9.20000E+03 Y +643212.249-464.67941*T+13.72962*T*LN(T)-.009112535*T**2 +1.07541683E-07*T**3-4.2679415E+08*T**(-1); 1.00000E+04 N ! FUNCTION F4952T 2.98150E+02 +151415.125+72.4381635*T-43.81075*T*LN(T) -.03613022*T**2+4.79519333E-06*T**3+382398.4*T**(-1); 7.00000E+02 Y +142101.575+203.310692*T-63.80547*T*LN(T)-.01690562*T**2 +1.30392183E-06*T**3+1202199*T**(-1); 1.60000E+03 Y -521002.261+4278.76381*T-605.9819*T*LN(T)+.17949305*T**2 -1.20661517E-05*T**3+1.523018E+08*T**(-1); 1.90000E+03 Y +103618.901+480.915312*T-101.4818*T*LN(T)-.001202355*T**2 +4.295965E-08*T**3+7646635*T**(-1); 3.80000E+03 N ! FUNCTION F4958T 2.98150E+02 +253597.563-148.811942*T-7.989506*T*LN(T) -.0560301*T**2+7.22032833E-06*T**3-86107.5*T**(-1); 7.00000E+02 Y +237578.897+66.4331994*T-40.61565*T*LN(T)-.026213335*T**2 +2.05575833E-06*T**3+1400582*T**(-1); 1.50000E+03 Y +180976.129+465.400317*T-94.92649*T*LN(T)-.0026392345*T**2 +1.00493533E-07*T**3+12635730*T**(-1); 3.90000E+03 Y +155481.051+562.46419*T-106.9625*T*LN(T)-1.2237275E-04*T**2 +2.58523833E-09*T**3+22815630*T**(-1); 6.00000E+03 N ! FUNCTION F4964T 2.98150E+02 +47209.5269-186.336653*T+1.510335*T*LN(T) -.0796424*T**2+1.11523633E-05*T**3-126378.45*T**(-1); 6.00000E+02 Y +30955.0457+58.8547956*T-36.41994*T*LN(T)-.040167385*T**2 +3.41469333E-06*T**3+1183016*T**(-1); 1.30000E+03 Y -31590.202+549.033592*T-104.2592*T*LN(T)-.007018595*T**2 +3.29534167E-07*T**3+12115675*T**(-1); 3.00000E+03 Y -77650.6893+755.842185*T-130.5377*T*LN(T)-3.066123E-04*T**2 +7.24598833E-09*T**3+27459580*T**(-1); 6.00000E+03 N ! FUNCTION F4970T 2.98150E+02 -173989.405-156.99242*T-9.305309*T*LN(T) -.08173745*T**2+1.02731833E-05*T**3-121696.15*T**(-1); 7.00000E+02 Y -197927.136+155.523133*T-56.42274*T*LN(T)-.040210435*T**2 +3.34282833E-06*T**3+2170644*T**(-1); 1.40000E+03 Y -274280.51+724.192005*T-134.4989*T*LN(T)-.004176673*T**2 +1.71613167E-07*T**3+16359150*T**(-1); 3.60000E+03 Y -316924.333+892.309086*T-155.4574*T*LN(T)+4.1221575E-04*T**2 -1.63666333E-08*T**3+32783160*T**(-1); 4.00000E+03 N ! FUNCTION F4976T 2.98150E+02 -52606.8578-367.498257*T+29.36196*T*LN(T) -.136964*T**2+2.35275833E-05*T**3-323036.9*T**(-1); 5.00000E+02 Y -77630.9831+56.9543113*T-37.71421*T*LN(T)-.0571355*T**2 +5.70833667E-06*T**3+1424051.5*T**(-1); 1.00000E+03 Y -108375.735+371.761128*T-83.21364*T*LN(T)-.027068305*T**2 +1.96504167E-06*T**3+5337015*T**(-1); 1.60000E+03 Y -2858294.25+17650.9728*T-2389.988*T*LN(T)+.8305585*T**2 -5.77916333E-05*T**3+6.17399E+08*T**(-1); 1.80000E+03 Y -171464.932+825.2504*T-144.5405*T*LN(T)-.0025049425*T**2 +9.14716E-08*T**3+15298245*T**(-1); 3.80000E+03 N ! FUNCTION F4986T 2.98150E+02 -443770.401-168.903162*T-8.022861*T*LN(T) -.10740745*T**2+1.413715E-05*T**3+49334.8*T**(-1); 7.00000E+02 Y -479189.377+285.05528*T-76.23373*T*LN(T)-.048655465*T**2 +4.55710833E-06*T**3+3510111*T**(-1); 1.50000E+03 N ! FUNCTION F4990T 2.98150E+02 +8600.55198-384.321458*T+31.14058*T*LN(T) -.16008725*T**2+2.74520167E-05*T**3-311796.05*T**(-1); 5.00000E+02 Y -20873.1918+111.496997*T-47.09066*T*LN(T)-.06790435*T**2 +7.07247833E-06*T**3+1765445*T**(-1); 1.00000E+03 Y -61239.1701+527.756432*T-107.3236*T*LN(T)-.027785625*T**2 +2.04065167E-06*T**3+6859500*T**(-1); 1.60000E+03 Y -2974981.48+18839.9139*T-2552.066*T*LN(T)+.8813205*T**2 -6.13141333E-05*T**3+6.552305E+08*T**(-1); 1.80000E+03 Y -124376.871+989.457025*T-169.8804*T*LN(T)-.0024329025*T**2 +8.888945E-08*T**3+16386475*T**(-1); 3.80000E+03 N ! FUNCTION F4998T 2.98150E+02 -114416.512-173.280628*T-6.921309*T*LN(T) -.14411235*T**2+2.31421167E-05*T**3+114636*T**(-1); 6.00000E+02 Y -153978.555+424.109101*T-99.34723*T*LN(T)-.047880135*T**2 +4.28756333E-06*T**3+3296112*T**(-1); 1.30000E+03 Y -196415.878+798.997011*T-152.2039*T*LN(T)-.018563915*T**2 +1.23563633E-06*T**3+9703745*T**(-1); 1.60000E+03 Y -3028548.52+18573.7356*T-2524.618*T*LN(T)+.8618175*T**2 -5.99569833E-05*T**3+6.40709E+08*T**(-1); 1.80000E+03 Y -241127.366+1118.82388*T-195.2168*T*LN(T)-.0023590335*T**2 +8.61798667E-08*T**3+16030240*T**(-1); 3.80000E+03 N ! FUNCTION F5006T 2.98150E+02 -213887.084-386.194788*T+29.65119*T*LN(T) -.18332665*T**2+3.2053E-05*T**3-278756.65*T**(-1); 5.00000E+02 Y -248977.395+204.108404*T-63.48805*T*LN(T)-.07357715*T**2 +7.78997833E-06*T**3+2194321*T**(-1); 1.00000E+03 Y -294026.156+670.832149*T-131.0756*T*LN(T)-.02832299*T**2 +2.08569167E-06*T**3+7847720*T**(-1); 1.60000E+03 Y -3346139.56+19853.1461*T-2691.994*T*LN(T)+.923992*T**2 -6.42789E-05*T**3+6.86977E+08*T**(-1); 1.80000E+03 Y -357660.046+1139.67333*T-194.6438*T*LN(T)-.0024674455*T**2 +9.01985167E-08*T**3+17218070*T**(-1); 3.80000E+03 N ! FUNCTION F5014T 2.98150E+02 +103695.78-248.192017*T+6.535456*T*LN(T) -.0876786*T**2+1.08003583E-05*T**3-293497.1*T**(-1); 7.00000E+02 Y +80275.9858+60.5182301*T-40.0912*T*LN(T)-.046084495*T**2 +3.772465E-06*T**3+1925892*T**(-1); 1.40000E+03 Y -4338.1575+691.320485*T-126.6998*T*LN(T)-.00614309*T**2 +2.665555E-07*T**3+17610670*T**(-1); 3.30000E+03 Y -50997.0146+888.071661*T-151.4679*T*LN(T)-2.7785525E-04*T**2 +6.34659667E-09*T**3+34266230*T**(-1); 6.00000E+03 N ! FUNCTION F5026T 2.98150E+02 -90150.09-192.644467*T+2.384174*T*LN(T) -.0962022*T**2+1.15030917E-05*T**3-161159.75*T**(-1); 7.00000E+02 Y -114140.24+121.641652*T-45.03662*T*LN(T)-.05415545*T**2 +4.43007333E-06*T**3+2130084*T**(-1); 1.40000E+03 Y -212082.164+853.908038*T-145.619*T*LN(T)-.007637925*T**2 +3.37957333E-07*T**3+20220470*T**(-1); 3.20000E+03 Y -268113.331+1093.5554*T-175.8524*T*LN(T)-3.4791075E-04*T**2 +8.02933833E-09*T**3+39919465*T**(-1); 6.00000E+03 N ! FUNCTION F5034T 2.98150E+02 -243272.597-221.374773*T+.7796648*T*LN(T) -.12058845*T**2+1.72144833E-05*T**3-164276.9*T**(-1); 6.00000E+02 Y -269097.38+168.629562*T-59.56378*T*LN(T)-.05772375*T**2 +4.884735E-06*T**3+1912790*T**(-1); 1.30000E+03 Y -358292.955+867.098816*T-156.2194*T*LN(T)-.010522415*T**2 +4.92514167E-07*T**3+17521960*T**(-1); 3.00000E+03 Y -427579.406+1177.35994*T-195.6293*T*LN(T)-4.820784E-04*T**2 +1.14137917E-08*T**3+40682500*T**(-1); 6.00000E+03 N ! FUNCTION F5044T 2.98150E+02 -416598.432+134.357846*T-60.84898*T*LN(T) -.0824635*T**2+9.70528667E-06*T**3+345719.2*T**(-1); 1.00000E+03 N ! FUNCTION F5081T 2.98150E+02 +277813.193+28.9798334*T-37.78569*T*LN(T) -.01453685*T**2+1.57701533E-06*T**3+112606.3*T**(-1); 1.00000E+03 Y +264063.563+160.518573*T-56.6296*T*LN(T)-.0026141425*T**2 +9.85593667E-08*T**3+2048364*T**(-1); 3.50000E+03 Y +234215.001+257.69025*T-68.43674*T*LN(T)-4.895632E-04*T**2 +2.485785E-08*T**3+16450450*T**(-1); 6.00000E+03 N ! FUNCTION F5113T 2.98150E+02 +829826.554-14.7696351*T-32.21563*T*LN(T) -.014548565*T**2+1.77806833E-06*T**3-100277.6*T**(-1); 1.00000E+03 Y +809388.444+179.25291*T-59.93982*T*LN(T)+.0025413955*T**2 -2.54139667E-07*T**3+2769455*T**(-1); 2.80000E+03 Y +959399.017-367.175865*T+7.286391*T*LN(T)-.010483215*T**2 +2.00694833E-07*T**3-58720050*T**(-1); 5.10000E+03 Y +645204.419+237.848566*T-60.73106*T*LN(T)-.0047721765*T**2 +1.3846755E-07*T**3+1.945987E+08*T**(-1); 8.00000E+03 Y -79243.2062+1580.27099*T-211.8741*T*LN(T)+.009202285*T**2 -1.030498E-07*T**3+8.44019E+08*T**(-1); 1.00000E+04 N ! FUNCTION F5130T 2.98150E+02 +611989.348+96.3308561*T-48.29552*T*LN(T) -.020416105*T**2+2.40121167E-06*T**3+286785.6*T**(-1); 9.00000E+02 Y +603734.835+194.753441*T-62.91113*T*LN(T)-.008746555*T**2 +6.34741E-07*T**3+1176564*T**(-1); 1.60000E+03 Y +428832.638+1236.10822*T-200.7133*T*LN(T)+.03914231*T**2 -2.50175333E-06*T**3+42232610*T**(-1); 2.10000E+03 Y +581080.642+349.628056*T-83.7538*T*LN(T)-6.025005E-04*T**2 +2.010855E-08*T**3+5274980*T**(-1); 4.00000E+03 N ! FUNCTION F5142T 2.98150E+02 +181410.617-122.851573*T-10.20607*T*LN(T) -.09533745*T**2+1.50758583E-05*T**3; 6.00000E+02 Y +166868.714+123.51993*T-49.16033*T*LN(T)-.048685235*T**2 +4.554395E-06*T**3+1025661.5*T**(-1); 1.35000E+03 N ! FUNCTION F5145T 2.98150E+02 +173490.978-86.0624782*T-17.22925*T*LN(T) -.0839689*T**2+1.23994933E-05*T**3; 6.00000E+02 Y +164149.935+76.784887*T-43.11068*T*LN(T)-.05198975*T**2 +4.980055E-06*T**3+635844.5*T**(-1); 1.35000E+03 N ! FUNCTION F5148T 2.98150E+02 +9960.10176-169.389262*T-5.296785*T*LN(T) -.11043535*T**2+1.3915705E-05*T**3-29916.7*T**(-1); 7.00000E+02 Y -20079.5568+230.805154*T-65.85768*T*LN(T)-.05571235*T**2 +4.55149E-06*T**3+2783191*T**(-1); 1.40000E+03 Y -123982.893+1002.03018*T-171.6758*T*LN(T)-.00713415*T**2 +3.037055E-07*T**3+22144770*T**(-1); 3.40000E+03 Y -176512.668+1224.25918*T-199.6496*T*LN(T)-5.34708E-04*T**2 +1.37195383E-08*T**3+40697190*T**(-1); 4.00000E+03 N ! FUNCTION F5154T 2.98150E+02 -230878.388-155.527401*T-10.67908*T*LN(T) -.1200629*T**2+1.5123685E-05*T**3+38056.18*T**(-1); 6.00000E+02 Y -239483.66-23.861997*T-31.11135*T*LN(T)-.09829625*T**2 +1.0728685E-05*T**3+723035.5*T**(-1); 1.00000E+03 N ! FUNCTION F5157T 2.98150E+02 +14789.4507-271.642378*T+11.34939*T*LN(T) -.13386645*T**2+2.00341833E-05*T**3-272154.55*T**(-1); 6.00000E+02 Y -5877.08746+63.1182105*T-41.1683*T*LN(T)-.07381185*T**2 +7.01085E-06*T**3+1272695.5*T**(-1); 1.35000E+03 N ! FUNCTION F5161T 2.98150E+02 -109364.396-321.907815*T+21.52618*T*LN(T) -.1721779*T**2+2.66239E-05*T**3-291993*T**(-1); 6.00000E+02 Y -136284.127+126.13378*T-49.09882*T*LN(T)-.08908635*T**2 +8.15831167E-06*T**3+1652173.5*T**(-1); 1.00000E+03 Y -139266.757+270.053278*T-72.22463*T*LN(T)-.0649997*T**2 +4.53440333E-06*T**3; 1.47310E+03 Y +257891.373-1948.43811*T+217.2249*T*LN(T)-.15124325*T**2 +8.672805E-06*T**3-96828650*T**(-1); 2.20000E+03 Y +99792.4667-390.62824*T+2.18137*T*LN(T)-.0596624*T**2 +2.314065E-06*T**3-1.0470605E+08*T**(-1); 2.80000E+03 Y +4552037.53-17003.1518*T+2055.691*T*LN(T)-.47848015*T**2 +1.82760667E-05*T**3-1.903921E+09*T**(-1); 3.40000E+03 Y -224887.496+1106.77062*T-188.6147*T*LN(T)-.01046*T**2; 4.00000E+03 N ! FUNCTION F5180T 2.98150E+02 -118237.391+100.762627*T-53.19108*T*LN(T) -.030805495*T**2+3.59023833E-06*T**3+332492.95*T**(-1); 1.00000E+03 Y -150856.91+416.603392*T-98.47748*T*LN(T)-.0022049665*T**2 +1.09623667E-07*T**3+4818702*T**(-1); 3.30000E+03 Y -164679.617+482.276431*T-106.8785*T*LN(T)+2.986764E-05*T**2 +4.29362E-10*T**3+9089650*T**(-1); 6.00000E+03 N ! FUNCTION F5190T 2.98150E+02 +1015583.43+114.927796*T-53.39543*T*LN(T) -.01399763*T**2+8.26027167E-07*T**3+181008.25*T**(-1); 2.50000E+03 Y +937071.116+522.054721*T-106.1735*T*LN(T)+.0016641645*T**2 -4.03015E-08*T**3+21906740*T**(-1); 7.00000E+03 Y +974994.003+406.652032*T-92.4518*T*LN(T)-2.6888155E-04*T**2 +7.07303167E-09*T**3+7587140*T**(-1); 1.00000E+04 N ! FUNCTION F5205T 2.98150E+02 +751541.722+252.532282*T-73.01*T*LN(T) -.0216856*T**2+2.96625833E-06*T**3+733430*T**(-1); 8.00000E+02 Y +739011.333+395.36198*T-94.137*T*LN(T)-.00478225*T**2+2.37405E-07*T**3 +2194465*T**(-1); 3.20000E+03 Y +712634.362+524.463672*T-110.728*T*LN(T)-2.049E-04*T**2+5.39E-09*T**3 +10118465*T**(-1); 4.00000E+03 N ! FUNCTION F5195T 2.98150E+02 -137766.886-262.245087*T+8.962001*T*LN(T) -.1969312*T**2+2.74147E-05*T**3-206440*T**(-1); 6.00000E+02 Y -178579.034+346.123228*T-84.951*T*LN(T)-.10048435*T**2 +8.73554E-06*T**3+3128305*T**(-1); 1.30000E+03 Y -258789.548+1055.24805*T-184.924*T*LN(T)-.04513245*T**2 +2.99413E-06*T**3+15193975*T**(-1); 1.50000E+03 N ! FUNCTION F5200T 2.98150E+02 -146155.003-277.516061*T+14.289*T*LN(T) -.2069239*T**2+2.98628333E-05*T**3-154585*T**(-1); 6.00000E+02 Y -195079.37+449.056779*T-97.801*T*LN(T)-.09222675*T**2 +7.70571667E-06*T**3+3862255*T**(-1); 1.50000E+03 N ! FUNCTION F5210T 2.98150E+02 +420839.085+277.118737*T-75.491*T*LN(T) -.02448245*T**2+1.97030333E-06*T**3+682970*T**(-1); 1.60000E+03 Y +367789.415+651.154953*T-126.464*T*LN(T)-.00206835*T**2 +7.59616667E-08*T**3+11366585*T**(-1); 4.00000E+03 N ! FUNCTION F5218T 2.98150E+02 +288051.702-62.1217039*T-23.51726*T*LN(T) -.10484665*T**2+1.70475E-05*T**3+166261.7*T**(-1); 6.00000E+02 Y +271269.255+222.99465*T-68.63141*T*LN(T)-.05050485*T**2 +4.70099667E-06*T**3+1349256.5*T**(-1); 1.35000E+03 N ! FUNCTION F5213T 2.98150E+02 +370172.153-109.109385*T-11.397*T*LN(T) -.1111325*T**2+1.61656983E-05*T**3+358940*T**(-1); 7.00000E+02 Y +325301.98+486.389913*T-101.491*T*LN(T)-.0296325*T**2 +2.12065333E-06*T**3+4595505*T**(-1); 1.90000E+03 Y +243710.536+1013.16655*T-172.226*T*LN(T)-.00194705*T**2 +6.80733333E-08*T**3+22628525*T**(-1); 4.00000E+03 N ! FUNCTION F5222T 2.98150E+02 +148974.923-154.988667*T-9.679935*T*LN(T) -.13252255*T**2+1.875805E-05*T**3-64604.3*T**(-1); 7.00000E+02 Y +143586.528-18.9490501*T-32.19739*T*LN(T)-.0996706*T**2 +1.0683635E-05*T**3; 1.35000E+03 N ! FUNCTION F5225T 2.98150E+02 +121653.925-773.246123*T+98.0989*T*LN(T) -.3288666*T**2+8.00427167E-05*T**3-1078152*T**(-1); 5.00000E+02 Y +69670.1413+288.910378*T-76.01784*T*LN(T)-.06784355*T**2 +6.41405167E-06*T**3+1865350.5*T**(-1); 1.35000E+03 N ! FUNCTION F5229T 2.98150E+02 +171954.749-626.535566*T+70.21254*T*LN(T) -.27331145*T**2+6.370085E-05*T**3-1007086.5*T**(-1); 5.00000E+02 Y +134813.21+143.300138*T-56.40032*T*LN(T)-.0793759*T**2 +7.720665E-06*T**3+1073901*T**(-1); 1.35000E+03 N ! FUNCTION F5232T 2.98150E+02 +137810.196-224.576236*T+2.364458*T*LN(T) -.14050145*T**2+2.03154833E-05*T**3-328490*T**(-1); 6.00000E+02 Y +121325.209+49.3857422*T-40.8135*T*LN(T)-.0897223*T**2 +9.02328333E-06*T**3+865653*T**(-1); 1.35000E+03 N ! FUNCTION F5235T 2.98150E+02 +151050.533-349.7586*T+27.653*T*LN(T) -.17688495*T**2+2.748815E-05*T**3-55550*T**(-1); 6.00000E+02 Y +103768.902+358.874068*T-81.845*T*LN(T)-.0637295*T**2 +5.44480167E-06*T**3+3783270*T**(-1); 1.40000E+03 Y -17659.4864+1268.26244*T-206.872*T*LN(T)-.0052678*T**2 +2.01658333E-07*T**3+26324075*T**(-1); 4.00000E+03 N ! FUNCTION F5240T 2.98150E+02 +7830.75067-135.953552*T-5.378*T*LN(T) -.1516055*T**2+1.77087667E-05*T**3+697635*T**(-1); 1.00000E+03 N ! FUNCTION F5242T 2.98150E+02 +12533.4694-811.558153*T+99.93819*T*LN(T) -.3308519*T**2+7.42945833E-05*T**3-1242512*T**(-1); 5.00000E+02 Y -34223.5657+125.568769*T-53.29244*T*LN(T)-.1034473*T**2 +1.02151667E-05*T**3+1500742*T**(-1); 1.35000E+03 N ! FUNCTION F5246T 2.98150E+02 -9954.98882-420.389759*T+33.53622*T*LN(T) -.19866405*T**2+3.05487167E-05*T**3-458273.5*T**(-1); 6.00000E+02 Y -41465.8704+91.7966661*T-46.86917*T*LN(T)-.10633385*T**2 +1.0445635E-05*T**3+1888323*T**(-1); 1.35000E+03 N ! FUNCTION F5250T 2.98150E+02 -19845.8404-271.195989*T+10.01855*T*LN(T) -.17302075*T**2+2.49936167E-05*T**3-356884.75*T**(-1); 6.00000E+02 Y -46739.5847+154.950922*T-56.55596*T*LN(T)-.09892585*T**2 +9.35312333E-06*T**3+1703068*T**(-1); 1.35000E+03 N ! FUNCTION F5254T 2.98150E+02 +25802.6842-440.237142*T+43.351*T*LN(T) -.2105867*T**2+3.14729833E-05*T**3-227945*T**(-1); 6.00000E+02 Y -29324.4938+373.689954*T-82.076*T*LN(T)-.08318905*T**2 +7.05010833E-06*T**3+4327090*T**(-1); 1.50000E+03 N ! FUNCTION F5257T 2.98150E+02 -6.10167508-885.983713*T+114.5039*T*LN(T) -.3592508*T**2+8.41611667E-05*T**3-1525313*T**(-1); 5.00000E+02 Y -47563.4441+107.259988*T-49.09213*T*LN(T)-.1065104*T**2 +1.0644305E-05*T**3+1115990*T**(-1); 1.35000E+03 N ! FUNCTION F5280T 2.98150E+02 +1028316.51+169.994576*T-62.97185*T*LN(T) -.0317015*T**2+4.09694E-06*T**3+186275.3*T**(-1); 9.00000E+02 Y +999750.247+470.150388*T-106.5965*T*LN(T)-.0014783715*T**2 +7.07236167E-08*T**3+3747842.5*T**(-1); 3.50000E+03 Y +990603.918+513.736611*T-112.1708*T*LN(T)-6.611165E-06*T**2 +1.10554567E-10*T**3+6565820*T**(-1); 1.00000E+04 N ! FUNCTION F5304T 2.98150E+02 +2466802.51+88.4522193*T+10.293*T*LN(T) -1.15472*T**2+1.77008333E-04*T**3+4621630*T**(-1); 8.00000E+02 Y +1709986.12+9262.28939*T-1356.31*T*LN(T)-.0366229*T**2 +1.98371667E-06*T**3+84578000*T**(-1); 3.30000E+03 N ! FUNCTION F5325T 2.98150E+02 +71643.2857-315.496947*T+25.001*T*LN(T) -.2161207*T**2+3.431025E-05*T**3+151720*T**(-1); 6.00000E+02 Y +13101.0393+567.138312*T-111.518*T*LN(T)-.07424425*T**2 +6.56452833E-06*T**3+4867785*T**(-1); 1.30000E+03 Y -109518.172+1531.0277*T-245.03*T*LN(T)-.00845165*T**2 +3.60173333E-07*T**3+26305545*T**(-1); 3.50000E+03 Y -158376.968+1751.98658*T-273.057*T*LN(T)-.0015082*T**2 +4.57316667E-08*T**3+41807370*T**(-1); 4.00000E+03 N ! FUNCTION F5331T 2.98150E+02 -115232.054-209.218178*T+2.935807*T*LN(T) -.222882*T**2+3.73738333E-05*T**3+285881.45*T**(-1); 6.00000E+02 Y -166306.578+593.403695*T-122.2293*T*LN(T)-.0853405*T**2 +8.77358E-06*T**3+4226408.5*T**(-1); 9.00000E+02 N ! FUNCTION F10447T 2.98150E+02 +211801.621+24.4989816*T-20.78611*T*LN(T); 6.00000E+03 N ! FUNCTION F10666T 2.98150E+02 +30698.6898+15.9096451*T-29.97699*T*LN(T) +.001713168*T**2-6.799205E-07*T**3-25503.82*T**(-1); 1.00000E+03 Y +31735.5127-12.686636*T-25.42186*T*LN(T)-.003149545*T**2 +1.34404917E-07*T**3+116618.65*T**(-1); 3.00000E+03 Y +41016.0783-20.7343256*T-24.94216*T*LN(T)-.0023107985*T**2 +5.91863E-08*T**3-6415210*T**(-1); 8.60000E+03 Y -154907.953+370.326117*T-69.24542*T*LN(T)+.0019361405*T**2 -1.47539017E-08*T**3+1.4391015E+08*T**(-1); 1.80000E+04 Y +326722.277-65.0792741*T-24.2768*T*LN(T)+6.42189E-05*T**2 -1.30298483E-10*T**3-8.292415E+08*T**(-1); 2.00000E+04 N ! FUNCTION F10729T 2.98150E+02 +1075.64106-55.242048*T-24.45435*T*LN(T) -.018507875*T**2+2.36297E-06*T**3-29469.05*T**(-1); 8.00000E+02 Y -7932.99164+54.2016233*T-40.775*T*LN(T)-.00501027*T**2 +2.122915E-07*T**3+925845*T**(-1); 3.60000E+03 Y -67875.8961+275.406716*T-68.1173*T*LN(T)+6.12331E-04*T**2 -6.573855E-09*T**3+26048030*T**(-1); 6.00000E+03 N ! FUNCTION F10854T 2.98150E+02 -9522.97393+78.5273873*T-31.35707*T*LN(T) +.0027589925*T**2-7.46390667E-07*T**3+56582.3*T**(-1); 1.00000E+03 Y +180.10884-15.6128262*T-17.84857*T*LN(T)-.00584168*T**2 +3.14618667E-07*T**3-1280036*T**(-1); 2.10000E+03 Y -18840.1661+92.3120249*T-32.05082*T*LN(T)-.0010728235*T**2 +1.14281783E-08*T**3+3561002.5*T**(-1); 6.00000E+03 N ! FUNCTION F10963T 2.98150E+02 -250423.434+4.45470312*T-28.40916*T*LN(T) -.00623741*T**2-6.01526167E-08*T**3-64163.45*T**(-1); 1.10000E+03 Y -256145.879+30.1894682*T-31.43044*T*LN(T)-.007055445*T**2 +3.05535833E-07*T**3+1246309.5*T**(-1); 2.80000E+03 Y -268423.418+116.690197*T-42.96842*T*LN(T)-.003069987*T**2 +6.97594167E-08*T**3+2458230.5*T**(-1); 8.40000E+03 Y -489068.882+553.259882*T-92.4077*T*LN(T)+.0016703495*T**2 -1.32333233E-08*T**3+1.765625E+08*T**(-1); 1.80000E+04 Y -165728.771+239.645643*T-59.77872*T*LN(T)+2.213599E-04*T**2 -1.2921095E-09*T**3-4.1931655E+08*T**(-1); 2.00000E+04 N ! FUNCTION F10983T 2.98150E+02 -147258.971-37.1497212*T-26.10636*T*LN(T) -.036948065*T**2+6.659505E-06*T**3+65357.65*T**(-1); 7.00000E+02 Y -156470.505+120.191295*T-50.94271*T*LN(T)-.007931945*T**2 +4.29733833E-07*T**3+684985.5*T**(-1); 1.50000E+03 N ! FUNCTION F13469T 2.98150E+02 +243206.494-20.8612587*T-21.01555*T*LN(T) +1.2687055E-04*T**2-1.23131283E-08*T**3-42897.09*T**(-1); 2.95000E+03 Y +252301.423-52.0847285*T-17.21188*T*LN(T)-5.413565E-04*T**2 +7.64520667E-09*T**3-3973170.5*T**(-1); 6.00000E+03 N ! FUNCTION F13839T 2.98150E+02 -6960.69252-51.1831473*T-22.25862*T*LN(T) -.01023867*T**2+1.339947E-06*T**3-76749.55*T**(-1); 9.00000E+02 Y -13136.0172+24.743296*T-33.55726*T*LN(T)-.0012348985*T**2 +1.66943333E-08*T**3+539886*T**(-1); 3.70000E+03 Y +14154.6461-51.4854586*T-24.47978*T*LN(T)-.002634759*T**2 +6.01544333E-08*T**3-15120935*T**(-1); 9.60000E+03 Y -314316.628+515.068037*T-87.56143*T*LN(T)+.0025787245*T**2 -1.878765E-08*T**3+2.9052515E+08*T**(-1); 1.85000E+04 Y -108797.175+288.483019*T-63.737*T*LN(T)+.0014375*T**2-9E-09*T**3 +.25153895*T**(-1); 2.00000E+04 N ! FUNCTION F14145T 2.98150E+02 +130696.944-37.9096651*T-27.58118*T*LN(T) -.02763076*T**2+4.60539333E-06*T**3+99530.45*T**(-1); 7.00000E+02 Y +114760.623+176.626736*T-60.10286*T*LN(T)+.00206456*T**2 -5.17486667E-07*T**3+1572175*T**(-1); 1.30000E+03 Y +49468.3958+710.094819*T-134.3696*T*LN(T)+.039707355*T**2 -4.10457667E-06*T**3+12362250*T**(-1); 2.10000E+03 Y +866367.075-3566.80563*T+421.2001*T*LN(T)-.1284109*T**2 +5.44768833E-06*T**3-2.1304835E+08*T**(-1); 2.80000E+03 Y +409416.384-1950.70834*T+223.4437*T*LN(T)-.0922361*T**2 +4.306855E-06*T**3-21589870*T**(-1); 3.50000E+03 Y -1866338.6+6101.13383*T-764.8435*T*LN(T)+.09852775*T**2 -2.59784667E-06*T**3+9.610855E+08*T**(-1); 4.90000E+03 Y +97590.0432+890.79836*T-149.9608*T*LN(T)+.01283575*T**2 -3.555105E-07*T**3-2.1699975E+08*T**(-1); 6.00000E+03 N ! FUNCTION F4313T 2.98150E+02 -452357.992+535.146046*T-99.1608*T*LN(T); 1.50000E+03 N ! FUNCTION F4359T 2.98150E+02 -262897.462+419.668519*T-81.588*T*LN(T); 4.00000E+02 N ! FUNCTION F4984T 2.98150E+02 -520876.535+666.560666*T-123.386*T*LN(T); 5.00000E+02 N ! FUNCTION F5032T 2.98150E+02 -310828.243+585.538554*T-111.4199*T*LN(T); 4.00000E+02 N ! FUNCTION F5042T 2.98150E+02 -484027.237+267.60133*T-47.07*T*LN(T) -.1834684*T**2+1.43650667E-05*T**3-23012*T**(-1); 8.00000E+02 N ! FUNCTION F5302T 2.98150E+02 +2232387.45+1624.15871*T-217.988*T*LN(T) -.88971*T**2+1.13199333E-04*T**3+7681900*T**(-1); 1.00000E+03 N ! FUNCTION F5323T 2.98150E+02 +8456.49693+740.043096*T-136.106*T*LN(T); 3.53000E+02 N ! FUNCTION F3871T 2.98150E+02 -17368.4408+170.730317*T-24.3*T*LN(T) -4.723E-04*T**2+2562600*T**(-1)-2.643E+08*T**(-2)+1.2E+10*T**(-3); 4.76530E+03 Y -17368.4408+170.730317*T-24.3*T*LN(T)-4.723E-04*T**2+2562600*T**(-1) -2.643E+08*T**(-2)+1.2E+10*T**(-3); 6.00000E+03 N ! FUNCTION F3893T 2.98150E+02 -16359.4285+175.609805*T-24.31*T*LN(T) -4.723E-04*T**2+2698000*T**(-1)-2.61E+08*T**(-2)+1.11E+10*T**(-3); 6.00000E+03 N ! FUNCTION F10952T 2.98150E+02 -332319.671+1078.59563*T-186.8669*T*LN(T) +.2320948*T**2-9.14296167E-05*T**3+978019*T**(-1); 5.00000E+02 Y -62418.8788-3288.18729*T+495.1304*T*LN(T)-.504926*T**2 +4.917665E-05*T**3-18523425*T**(-1); 5.40000E+02 Y -8528143.9+142414.45*T-22596.19*T*LN(T)+27.48508*T**2 -.00631160667*T**3+5.63356E+08*T**(-1); 6.00000E+02 Y -331037.282+741.178604*T-117.41*T*LN(T); 6.01000E+02 N ! FUNCTION F10981T 2.98150E+02 -214494.862+488.664597*T-89.3284*T*LN(T); 1.50000E+03 N ! FUNCTION UN_ASS 298.15 0; 300 N ! TYPE_DEFINITION % SEQ *! DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! PHASE GAS:G % 1 1.0 ! CONSTITUENT GAS:G :C,C1H1,C1H1O1,C1H1O2,C1H2,C1H2O1,C1H2O2_CIS, C1H2O2_DIOXIRANE,C1H2O2_TRANS,C1H3,C1H3O1_CH2OH,C1H3O1_CH3O,C1H4,C1H4O1, C1O1,C1O2,C2,C2H1,C2H2,C2H2O1,C2H3,C2H4,C2H4O1_ACETALDEHYDE, C2H4O1_OXIRANE,C2H4O2_ACETICACID,C2H4O2_DIOXETANE,C2H4O3_123TRIOXOLANE, C2H4O3_124TRIOXOLANE,C2H5,C2H6,C2H6O1,C2H6O2,C2O1,C3,C3H1,C3H4_1,C3H4_2, C3H6,C3H6O1,C3H6_2,C3H8,C3O2,C4,C4H1,C4H10_1,C4H10_2,C4H2,C4H4,C4H4_1_3, C4H6_1,C4H6_2,C4H6_3,C4H6_4,C4H6_5,C4H8,C4H8_1,C4H8_2,C4H8_3,C4H8_4, C4H8_5,C5,C60,C6H6,C6H6O1,H,H1O1,H1O2,H2,H2O1,H2O2,O,O2,O3 : ! PARAMETER G(GAS,C;0) 2.98150E+02 +F3895T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2437 ! PARAMETER G(GAS,C1H1;0) 2.98150E+02 +F4246T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2556 ! PARAMETER G(GAS,C1H1O1;0) 2.98150E+02 +F4282T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2566 ! PARAMETER G(GAS,C1H1O2;0) 2.98150E+02 +F4287T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2568 ! PARAMETER G(GAS,C1H2;0) 2.98150E+02 +F4298T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2571 ! PARAMETER G(GAS,C1H2O1;0) 2.98150E+02 +F4308T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2574 ! PARAMETER G(GAS,C1H2O2_CIS;0) 2.98150E+02 +F4315T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2579 ! PARAMETER G(GAS,C1H2O2_DIOXIRANE;0) 2.98150E+02 +F4320T# +R#*T*LN(1E-05*P); 6.00000E+03 N REF2580 ! PARAMETER G(GAS,C1H2O2_TRANS;0) 2.98150E+02 +F4326T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2581 ! PARAMETER G(GAS,C1H3;0) 2.98150E+02 +F4331T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2582 ! PARAMETER G(GAS,C1H3O1_CH2OH;0) 2.98150E+02 +F4342T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2585 ! PARAMETER G(GAS,C1H3O1_CH3O;0) 2.98150E+02 +F4348T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2586 ! PARAMETER G(GAS,C1H4;0) 2.98150E+02 +F4354T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2587 ! PARAMETER G(GAS,C1H4O1;0) 2.98150E+02 +F4361T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2591 ! PARAMETER G(GAS,C1O1;0) 2.98150E+02 +F4504T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2659 ! PARAMETER G(GAS,C1O2;0) 2.98150E+02 +F4525T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2668 ! PARAMETER G(GAS,C2;0) 2.98150E+02 +F4656T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2743 ! PARAMETER G(GAS,C2H1;0) 2.98150E+02 +F4935T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2820 ! PARAMETER G(GAS,C2H2;0) 2.98150E+02 +F4946T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2823 ! PARAMETER G(GAS,C2H2O1;0) 2.98150E+02 +F4952T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2825 ! PARAMETER G(GAS,C2H3;0) 2.98150E+02 +F4958T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2826 ! PARAMETER G(GAS,C2H4;0) 2.98150E+02 +F4964T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2827 ! PARAMETER G(GAS,C2H4O1_ACETALDEHYDE;0) 2.98150E+02 +F4970T# +R#*T*LN(1E-05*P); 6.00000E+03 N REF2829 ! PARAMETER G(GAS,C2H4O1_OXIRANE;0) 2.98150E+02 +F4976T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2830 ! PARAMETER G(GAS,C2H4O2_ACETICACID;0) 2.98150E+02 +F4986T# +R#*T*LN(1E-05*P); 6.00000E+03 N REF2834 ! PARAMETER G(GAS,C2H4O2_DIOXETANE;0) 2.98150E+02 +F4990T# +R#*T*LN(1E-05*P); 6.00000E+03 N REF2835 ! PARAMETER G(GAS,C2H4O3_123TRIOXOLANE;0) 2.98150E+02 +F4998T# +R#*T*LN(1E-05*P); 6.00000E+03 N REF2836 ! PARAMETER G(GAS,C2H4O3_124TRIOXOLANE;0) 2.98150E+02 +F5006T# +R#*T*LN(1E-05*P); 6.00000E+03 N REF2837 ! PARAMETER G(GAS,C2H5;0) 2.98150E+02 +F5014T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2838 ! PARAMETER G(GAS,C2H6;0) 2.98150E+02 +F5026T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2840 ! PARAMETER G(GAS,C2H6O1;0) 2.98150E+02 +F5034T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2844 ! PARAMETER G(GAS,C2H6O2;0) 2.98150E+02 +F5044T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2852 ! PARAMETER G(GAS,C2O1;0) 2.98150E+02 +F5081T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2874 ! PARAMETER G(GAS,C3;0) 2.98150E+02 +F5113T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2892 ! PARAMETER G(GAS,C3H1;0) 2.98150E+02 +F5130T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2903 ! PARAMETER G(GAS,C3H4_1;0) 2.98150E+02 +F5142T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2905 ! PARAMETER G(GAS,C3H4_2;0) 2.98150E+02 +F5145T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2908 ! PARAMETER G(GAS,C3H6;0) 2.98150E+02 +F5148T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2911 ! PARAMETER G(GAS,C3H6O1;0) 2.98150E+02 +F5154T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2913 ! PARAMETER G(GAS,C3H6_2;0) 2.98150E+02 +F5157T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2916 ! PARAMETER G(GAS,C3H8;0) 2.98150E+02 +F5161T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2919 ! PARAMETER G(GAS,C3O2;0) 2.98150E+02 +F5180T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2928 ! PARAMETER G(GAS,C4;0) 2.98150E+02 +F5190T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2932 ! PARAMETER G(GAS,C4H1;0) 2.98150E+02 +F5205T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2938 ! PARAMETER G(GAS,C4H10_1;0) 2.98150E+02 +F5195T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2933 ! PARAMETER G(GAS,C4H10_2;0) 2.98150E+02 +F5200T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2935 ! PARAMETER G(GAS,C4H2;0) 2.98150E+02 +F5210T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2940 ! PARAMETER G(GAS,C4H4;0) 2.98150E+02 +F5218T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2944 ! PARAMETER G(GAS,C4H4_1_3;0) 2.98150E+02 +F5213T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2942 ! PARAMETER G(GAS,C4H6_1;0) 2.98150E+02 +F5222T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2947 ! PARAMETER G(GAS,C4H6_2;0) 2.98150E+02 +F5225T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2950 ! PARAMETER G(GAS,C4H6_3;0) 2.98150E+02 +F5229T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2953 ! PARAMETER G(GAS,C4H6_4;0) 2.98150E+02 +F5232T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2956 ! PARAMETER G(GAS,C4H6_5;0) 2.98150E+02 +F5235T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2959 ! PARAMETER G(GAS,C4H8;0) 2.98150E+02 +F5240T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2961 ! PARAMETER G(GAS,C4H8_1;0) 2.98150E+02 +F5242T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2963 ! PARAMETER G(GAS,C4H8_2;0) 2.98150E+02 +F5246T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2966 ! PARAMETER G(GAS,C4H8_3;0) 2.98150E+02 +F5250T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2969 ! PARAMETER G(GAS,C4H8_4;0) 2.98150E+02 +F5254T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2972 ! PARAMETER G(GAS,C4H8_5;0) 2.98150E+02 +F5257T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2974 ! PARAMETER G(GAS,C5;0) 2.98150E+02 +F5280T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF2988 ! PARAMETER G(GAS,C60;0) 2.98150E+02 +F5304T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF3010 ! PARAMETER G(GAS,C6H6;0) 2.98150E+02 +F5325T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF3042 ! PARAMETER G(GAS,C6H6O1;0) 2.98150E+02 +F5331T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF3044 ! PARAMETER G(GAS,H;0) 2.98150E+02 +F10447T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF5999 ! PARAMETER G(GAS,H1O1;0) 2.98150E+02 +F10666T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF6072 ! PARAMETER G(GAS,H1O2;0) 2.98150E+02 +F10729T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF6089 ! PARAMETER G(GAS,H2;0) 2.98150E+02 +F10854T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF6138 ! PARAMETER G(GAS,H2O1;0) 2.98150E+02 +F10963T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF6189 ! PARAMETER G(GAS,H2O2;0) 2.98150E+02 +F10983T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF6196 ! PARAMETER G(GAS,O;0) 2.98150E+02 +F13469T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF7675 ! PARAMETER G(GAS,O2;0) 2.98150E+02 +F13839T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF7802 ! PARAMETER G(GAS,O3;0) 2.98150E+02 +F14145T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF7957 ! PHASE C1H2O2_L % 1 1.0 ! CONSTITUENT C1H2O2_L :C1H2O2 : ! PARAMETER G(C1H2O2_L,C1H2O2;0) 2.98150E+02 +F4313T#; 6.00000E+03 N REF2576 ! PHASE C1H4O1_L % 1 1.0 ! CONSTITUENT C1H4O1_L :C1H4O1 : ! PARAMETER G(C1H4O1_L,C1H4O1;0) 2.98150E+02 +F4359T#; 6.00000E+03 N REF2589 ! PHASE C2H4O2_L % 1 1.0 ! CONSTITUENT C2H4O2_L :C2H4O2 : ! PARAMETER G(C2H4O2_L,C2H4O2;0) 2.98150E+02 +F4984T#; 6.00000E+03 N REF2831 ! PHASE C2H6O1_L % 1 1.0 ! CONSTITUENT C2H6O1_L :C2H6O1 : ! PARAMETER G(C2H6O1_L,C2H6O1;0) 2.98150E+02 +F5032T#; 6.00000E+03 N REF2841 ! PHASE C2H6O2_L % 1 1.0 ! CONSTITUENT C2H6O2_L :C2H6O2 : ! PARAMETER G(C2H6O2_L,C2H6O2;0) 2.98150E+02 +F5042T#; 6.00000E+03 N REF2849 ! PHASE C60_S % 1 1.0 ! CONSTITUENT C60_S :C60 : ! PARAMETER G(C60_S,C60;0) 2.98150E+02 +F5302T#; 6.00000E+03 N REF2996 ! PHASE C6H6_L % 1 1.0 ! CONSTITUENT C6H6_L :C6H6 : ! PARAMETER G(C6H6_L,C6H6;0) 2.98150E+02 +F5323T#; 6.00000E+03 N REF3039 ! PHASE CARBON_L % 1 1.0 ! CONSTITUENT CARBON_L :C : ! PARAMETER G(CARBON_L,C;0) 2.98150E+02 +F3871T#+117369-24.6299289*T; 6.00000E+03 N REF2421 ! PHASE GRAPHITE % 1 1.0 ! CONSTITUENT GRAPHITE :C : ! PARAMETER G(GRAPHITE,C;0) 2.98150E+02 +F3871T#; 6.00000E+03 N REF2421 ! PHASE DIAMOND % 1 1.0 ! CONSTITUENT DIAMOND :C : ! PARAMETER G(DIAMOND,C;0) 2.98150E+02 +F3893T#; 6.00000E+03 N REF2433 ! PHASE H2O1_L % 1 1.0 ! CONSTITUENT H2O1_L :H2O1 : ! PARAMETER G(H2O1_L,H2O1;0) 2.98150E+02 +F10952T#; 6.00000E+03 N REF6184 ! PHASE H2O2_L % 1 1.0 ! CONSTITUENT H2O2_L :H2O2 : ! PARAMETER G(H2O2_L,H2O2;0) 2.98150E+02 +F10981T#; 6.00000E+03 N REF6193 ! LIST_OF_REFERENCES NUMBER SOURCE REF2437 'C1 T.C.R.A.S. Class: 1' REF2556 'C1H1 T.C.R.A.S. Class: 2' REF2566 'C1H1O1 T.C.R.A.S. Class: 4 FORMYL ' REF2568 'C1H1O2 T.C.R.A.S. Class: 6' REF2571 'C1H2 T.C.R.A.S. Class: 5 METHYLENE ' REF2574 'C1H2O1 T.C.R.A.S. Class: 5 FORMALDEHYDE ' REF2579 'C1H2O2_CIS T.C.R.A.S. Class: 5' REF2580 'C1H2O2_DIOXIRANE T.C.R.A.S. Class: 6' REF2581 'C1H2O2_TRANS T.C.R.A.S. Class: 5' REF2582 'C1H3 T.C.R.A.S. Class: 5 METHYL ' REF2585 'C1H3O1_CH2OH T.C.R.A.S. Class: 6' REF2586 'C1H3O1_CH3O T.C.R.A.S. Class: 5' REF2587 'C1H4 T.C.R.A.S. Class: 5 METHANE ' REF2591 'C1H4O1 T.C.R.A.S. Class: 5 METHANOL ' REF2659 'C1O1 JANAF THERMOCHEMICAL TABLES SGTE ** CARBON MONOXIDE STANDARD STATE : CODATA KEY VALUE. /CP FROM JANAF PUB. 9/65' REF2668 'C1O2 T.C.R.A.S. Class: 2 CARBON DIOXIDE ' REF2743 'C2 T.C.R.A.S. Class: 2 CARBON ' REF2820 'C2H1 T.C.R.A.S. Class: 6 CCH RADICAL ' REF2823 'C2H2 T.C.R.A.S. Class: 2 ACETYLENE ' REF2825 'C2H2O1 T.C.R.A.S. Class: 6' REF2826 'C2H3 T.C.R.A.S. Class: 6' REF2827 'C2H4 T.C.R.A.S. Class: 6 ETHYLENE ' REF2829 'C2H4O1_ACETALDEHYDE T.C.R.A.S. Class: 5' REF2830 'C2H4O1_OXIRANE T.C.R.A.S. Class: 6' REF2834 'C2H4O2_ACETICACID T.C.R.A.S. Class: 5' REF2835 'C2H4O2_DIOXETANE T.C.R.A.S. Class: 6' REF2836 'C2H4O3_123TRIOXOLANE T.C.R.A.S. Class: 7' REF2837 'C2H4O3_124TRIOXOLANE T.C.R.A.S. Class: 7' REF2838 'C2H5 T.C.R.A.S. Class: 6' REF2840 'C2H6 T.C.R.A.S. Class: 6' REF2844 'C2H6O1 T.C.R.A.S. Class: 6 ETHANOL ' REF2852 'C2H6O2 THERMODATA E-GLYCOL .Data revised by THDA.' REF2874 'C2O1 T.C.R.A.S. Class: 5' REF2892 'C3 T.C.R.A.S. Class: 6 CARBON ' REF2903 'C3H1 T.C.R.A.S. Class: 6' REF2905 'C3H4_1 STULL WESTRUM SINKE 1969 SGTE ALLENE = 1,2-PROPADIENE EXTRAPOLATION BY THERMODATA FROM 1000 TO 1350K.' REF2908 'C3H4_2 STULL WESTRUM SINKE 1969 SGTE PROPYNE (METHYLACETYLENE) EXTRAPOLATION BY THERMODATA FROM 1000 TO 1350K.' REF2911 'C3H6 T.C.R.A.S. Class: 5 CYCLOPROPANE ' REF2913 'C3H6O1 THERMODATA 01/93 ACETONE 28/01/93' REF2916 'C3H6_2 STULL WESTRUM SINKE 1969 SGTE PROPENE EXTRAPOLATION BY THERMODATA FROM 1000 TO 1350K.' REF2919 'C3H8 THERMODATA SGTE PROPANE PROPANE' REF2928 'C3O2 T.C.R.A.S. Class: 6' REF2932 'C4 T.C.R.A.S. Class: 7' REF2938 'C4H1 T.C.R.A.S Class: 6 1,3-BUTADIYNYL. Data provided by T.C.R.A.S. in 2000' REF2933 'C4H10_1 T.C.R.A.S Class: 4 BUTANE. Data provided by T.C.R.A.S. in 2000' REF2935 'C4H10_2 T.C.R.A.S Class: 4 METHYLPROPANE N-BUTANE. Data provided by T.C.R.A.S. in 2000' REF2940 'C4H2 T.C.R.A.S Class: 6 1,3-BUTADIYNE. Data provided by T.C.R.A.S. in 2000' REF2944 'C4H4 STULL WESTRUM SINKE 1969 SGTE 1-BUTEN-3-YNE VINYLACETYLENE EXTRAPOLATION BY THERMODATA FROM 1000 TO 1350K.' REF2942 'C4H4_1,3 T.C.R.A.S Class: 6 1,3-CYCLOBUTADIENE. Data provided by T.C.R.A.S. in 2000' REF2947 'C4H6_1 STULL WESTRUM SINKE 1969 SGTE 1,2-BUTADIENE EXTRAPOLATION BY THERMODATA FROM 1000 TO 1350K.' REF2950 'C4H6_2 STULL WESTRUM SINKE 1969 SGTE 1,3-BUTADIENE EXTRAPOLATION BY THERMODATA FROM 1000 TO 1350K.' REF2953 'C4H6_3 STULL WESTRUM SINKE 1969 SGTE 1-BUTYNE ETHYLACETYLENE EXTRAPOLATION BY THERMODATA FROM 1000 TO 1350K.' REF2956 'C4H6_4 STULL WESTRUM SINKE 1969 SGTE 2-BUTYNE DIMETHYLACETYLENE EXTRAPOLATION BY THERMODATA FROM 1000 TO 1350K.' REF2959 'C4H6_5 T.C.R.A.S Class: 6 CYCLOBUTENE. Data provided by T.C.R.A.S. in 2000' REF2961 'C4H8 I. BARIN 3rd. Edition CYCLOBUTANE Data taken from BARIN 3rd. Ed. (1995)' REF2963 'C4H8_1 STULL WESTRUM SINKE 1969 SGTE 1-BUTENE EXTRAPOLATION BY THERMODATA FROM 1000 TO 1350K.' REF2966 'C4H8_2 STULL WESTRUM SINKE 1969 SGTE 2-BUTENE,CIS EXTRAPOLATION BY THERMODATA FROM 1000 TO 1350K.' REF2969 'C4H8_3 STULL WESTRUM SINKE 1969 SGTE 2-BUTENE,TRANS EXTRAPOLATION BY THERMODATA FROM 1000 TO 1350K.' REF2972 'C4H8_ T.C.R.A.S Class: 6 CYCLOBUTANE. Data provided by T.C.R.A.S. in 2000' REF2974 'C4H8_5 STULL WESTRUM SINKE 1969 SGTE 2-METHYLPROPENE EXTRAPOLATION BY THERMODATA FROM 1000 TO 1350K.' REF2988 'C5 T.C.R.A.S. Class: 7' REF3010 'C60 MHR-95 Data processed from [94Kor/Sid] M.V. Korobov, L.N. sidorov, J. Chem. Thermo, 26, 61-73 (1994). Recalculated from the rotational data in [91McK] and vibration frequencies in [94Kor/Sid]. Note that a frequency with degeneracy 5 is missing from list in [94Kor/Sid]; taken to be 419 cm-1, which gives very good, though not exact, agreement with values quoted in [94Kor/Sid]. Note discrepancy between calculated DrS(298) = -8943.5 J mol K-1 for the reaction 60C=C60and that given by [94Kor/Sid] in their Table 5, -8950 J mol K-1. Enthalpy of formation: DfH = 2588 kJ/mol from DsubH(298.15K) = 166 +/- 11 kJ mol-1 [94Kor/Sid]. Vapour pressure values reproduced very well. [91McK] J.T. McKinnon, J. Phys. Chem. 95 8941(1993)'. REF3042 'C6H6 T.C.R.A.S Class: 5 BENZENE. Data provided by T.C.R.A.S. in 2000' REF3044 'C6H6O1 THERMODATA 01/93 PHENOL 28/01/93' REF5999 'H1 JANAF 1982; ASSESSMENT DATED 3/77 SGTE ** HYDROGEN ' REF6072 'H1O1 T.C.R.A.S. Class: 1' REF6089 'H1O2 T.C.R.A.S. Class: 4' REF6138 'H2 JANAF THERMOCHEMICAL TABLES SGTE ** HYDROGEN STANDARD STATE FROM CODATA KEY VALUES. CP FROM JANAF PUB. 3/61' REF6189 'H2O1 T.C.R.A.S. Class: 1 WATER ' REF6196 'H2O2 JANAF SECOND EDIT SGTE HYDROGEN PEROXIDE ' REF7675 'O1 JANAF 1982; ASSESSMENT DATED 3/77 SGTE OXYGEN ' REF7802 'O2 T.C.R.A.S. Class: 1 OXYGEN ' REF7957 'O3 T.C.R.A.S. Class: 4 OZONE ' REF2576 'C1H2O2 THERMODATA 01/93 FORMIC ACID MONOMERIC 28/01/93' REF2589 'C1H4O1 I. BARIN 3rd. Edition METHANOL. H298 and S298 modified.' REF2831 'C2H4O2 THERMODATA 01/93 ACETIC ACID 28/01/93 Tb=389K.' REF2841 'C2H6O1 THERMODATA 01/93 ETHANOL 28/01/93' REF2849 'C2H6O2 THERMODATA E-GLYCOL Data revised by THDA.' REF2996 'C60 MHR-95 Data processed from [94Kor/Sid] M.V. Korobov, L.N. sidorov, J. Chem. Thermo, 26, 61-73 (1994). Fitted to the data in [94Kor/Sid], who took the phase transition at 257K to be first-order with DtrsH = (7+/-1) kJ mol-1. Note that [94Kor/Sid] do not give an explicit value for S(298.15K). S(298.15K) = 422.6 J mol K-1 was calculated from S(300) =425.8 and Cp expression, but there is a discrepancy with S(298.15K) calculated from DrS(298) for 60C=C60 given by [94Kor/Sid] in their Table 5, which gives S(298.15K) = 425.4 J mol K-1. Enthalpy of formation : DfH = +2422 +/- 14 kJ/mol from [92Ste/Chi], the value preferred, if obliquely, by [94Kor/Sid]. [92Ste/Chi]W.V. Steele, R.D. Chirico, N.K. Smith, W.e. Billups, P.R. Elmore, A.E. Wheeler, J. Phys. Chem. 96 4731 (1993).' REF3039 'C6H6 R.W.T.H.-94 Knacke, Kubaschewski, Hesselmann, 1991. In previous versions power of Cp was missing.' REF2421 'C1 S.G.T.E. ** Data from SGTE Unary DB, pressure dependent data added by atd 7/9/95' REF2433 'C1 S.G.T.E. ** Data from SGTE Unary DB, data added by atd 7/9/95, H298-H0 taken from 1994 database (ex THERMODATA 01/93)' REF6184 'H2O1 T.C.R.A.S. Class: 4 WATER T.C.R.A.S. Class: 4 modified by atd 12/9/94' REF6193 'H2O2 THERMODATA 01/93 HYDROGEN PEROXIDE 28/01/93' ! ================================================ FILE: examples/macros/MgNaCl.TDB ================================================ $ MgCl2-NaCl.TDB $ File converted by dat2TDB_ND2021 on 2021-12-15 11:33 $ from file MgCl2-NaCl.dat $ $ System Cl-Mg-Na $ ELEMENT /- ELECTRON_GAS 0.0 0.0 0.0 ! ELEMENT VA VACUUM 0.0 0.0 0.0 ! ELEMENT CL SER 35.45300000 0.0 0.0 ! ELEMENT MG SER 24.30500000 0.0 0.0 ! ELEMENT NA SER 22.98976928 0.0 0.0 ! TYPE_DEFINITION % SEQ *! DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! $ Functions to express not integer T powers $ T**i = EXP(i*LN(T)) FUN LNT 298.15 LN(T);,, N ! FUN HALFLNT 298.15 0.5*LNT;,, N ! FUN SQRT 298.15 EXP(HALFLNT);,, N ! FUN ONE5LNT 298.15 1.5*LNT;,, N ! FUN SSQRT 298.15 EXP(ONE5LNT);,, N ! $============================================================================== $ FUNCTIONS FOR MQMQA $============================================================================== FUNCTION GLIQNACL 298.15 -417806.48+442.50770*T-77.763600*T*LN(T)+0.37656000E-02*T**2; 1500.0000 Y -409333.88+359.89172*T-66.466800*T*LN(T); 3500.0000 N REF ! FUNCTION GLIQMGCL 298.15 -658788.27+1093.7361*T-193.40890*T*LN(T)+0.18100695*T**2 -.53331179E-04*T**3+1894252.0*T**(-1); 660.00000 Y -634331.55+499.20330*T-92.048000*T*LN(T); 3500.0000 N REF ! PHASE SALT:Q % 1 1.0 ! CONST SALT:Q : NA/CL 6.000000 6.000000 2.40000 MG/CL 6.000000 3.000000 2.40000 $ 1 2 3 3 3.0000000 6.0000000 3.0000000 3.0000000 MG,NA/CL 6.000000 3.000000 3.000000 $ QUADRUPLETS with default Z : ! $ 1 1 3 3 6.0000000 6.0000000 6.0000000 6.0000000 PARAMETER G(SALT,NA/CL-Q) 298.15 0.33333333*GLIQNACL;,, N REF ! $ 2 2 3 3 6.0000000 6.0000000 3.0000000 3.0000000 PARAMETER G(SALT,MG/CL-Q) 298.15 0.33333333*GLIQMGCL;,, N REF ! $ G 1 2 3 3 0 0 0 0 $ 0 0 -10395.800 0.00000000 0.00000000 0.00000000 PARAMETER G(SALT,MGNA/CL-Q) 298.15 -5197.9000;,, N REF ! $ G 1 2 3 3 1 0 0 0 $ 0 0 660.50000 0.00000000 0.00000000 0.00000000 PARAMETER L(SALT,MGNA/CL-Q,NA/CL-Q;0) 298.15 330.2500;,, N REF ! $ G 1 2 3 3 0 1 0 0 $ 0 0 -4641.5000 0.00000000 0.00000000 0.00000000 PARAMETER L(SALT,MGNA/CL-Q,MG/CL-Q;0) 298.15 -2320.7500;,, N REF ! PHASE NACL % 2 1.0 1.0 ! CONST NACL :NA:CL: ! PARAMETER G(NACL,NA:CL) 298.15 -425542.29 +240.42080*T -45.940000*T*LN(T) -.81590000E-02*T**2; 1500 Y -443900.04 +419.42650*T -70.417000*T*LN(T); 6000 N REF2 ! PHASE MGCL2 % 2 1.0 2.0 ! CONST MGCL2 :MG:CL: ! PARAMETER G(MgCl2,MG:CL) 298.15 -676336.86+242.25622*T-54.584300*T*LN(T) -.10710650E-01*T**2 +0.39278333E-06*T**2 +556059.50*T**(-1) +1596.7080*SQRT; 1500 Y -678190.36+537.75324*T -91.226106*T*LN(T); 6000 N REF2 ! PHASE NaMgCl3 % 3 1.0 1.0 3.0 ! CONST NAMGCL3 :NA:MG:CL: ! PARAMETER G(NAMGCL3,NA:MG:CL) 298.15 -1083303.0+455.19995*T-90.000000*T*LN(T) -0.0375*T**2; 1500 Y -1167678.0+1277.9372*T-202.50000*T*LN(T); 6000 N REF2 ! PHASE Na2MgCl4 % 3 2.0 1.0 4.0 ! CONST NA2MGCL4 :NA:MG:CL: ! PARAMETER G(NA2MGCL4,NA:MG:CL) 298.15 -1508686.5+693.72143*T-135.00000*T*LN(T) -.56250000E-01*T**2; 1500 Y -1635249.0+1927.8274*T-303.75000*T*LN(T); 6000 N REF2 ! $ These 2 phases MUST BE SET DORMANT but are useful for chemical potentials PHASE LIQREF_NACL % 2 1.0 1.0 ! CONST LIQREF_NACL :NA:CL: ! PARAMETER G(LIQREF_NACL,NA:CL) 298.15 GLIQNACL; 6000 N REF ! PHASE LIQREF_MGCL2 % 2 1.0 2.0 ! CONST LIQREF_MGCL2 :MG:CL: ! PARAMETER G(LIQREF_MGCL2,MG:CL) 298.15 GLIQMGCL; 6000 N REF ! $======================================================== Stoichiometric phases LIST_OF_REFERENCES NUMBER SOURCE REF 'Automatic conversion with dat2TDB from MgCl2-NaCl.dat' REF2 'Manual conversion by Bosse' ! ================================================ FILE: examples/macros/MgNaClX.TDB ================================================ $ MgCl2-NaCl.TDB $ File converted by dat2TDB_ND2021 on 2021-12-15 11:33 $ from file MgCl2-NaCl.dat $ $ System Cl-Mg-Na $ ELEMENT /- ELECTRON_GAS 0.0 0.0 0.0 ! ELEMENT VA VACUUM 0.0 0.0 0.0 ! ELEMENT CL SER 35.45300000 0.0 0.0 ! ELEMENT MG SER 24.30500000 0.0 0.0 ! ELEMENT NA SER 22.98976928 0.0 0.0 ! SPECIES NA/CL NA/CL 6.000000 6.000000 2.40000 ! SPECIES mg/cl MG/CL 6.000000 3.000000 2.40000 ! $ 1 2 3 3 3.0000000 6.0000000 3.0000000 3.0000000 SPECIES MGNA/CL MG,NA/CL 6.000000 3.000000 3.000000 ! $ QUADRUPLETS with default Z TYPE_DEFINITION % SEQ *! DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! PHASE SALT:Q % 1 1.0 ! CONST SALT:Q : NA/CL-Q MG/CL-Q MGNA/CL-Q : ! PARAMETER G(SALT,NA/CL-Q) 298.15 0.33333333*GLIQNACL;,, N REF ! $ 2 2 3 3 6.0000000 6.0000000 3.0000000 3.0000000 PARAMETER G(SALT,MG/CL-Q) 298.15 0.33333333*GLIQMGCL;,, N REF ! $ G 1 2 3 3 0 0 0 0 $ 0 0 -10395.800 0.00000000 0.00000000 0.00000000 PARAMETER G(SALT,MGNA/CL-Q) 298.15 -5197.9000;,, N REF ! $ G 1 2 3 3 1 0 0 0 $ 0 0 660.50000 0.00000000 0.00000000 0.00000000 PARAMETER L(SALT,MGNA/CL-Q,NA/CL-Q;0) 298.15 330.2500;,, N REF ! $ G 1 2 3 3 0 1 0 0 $ 0 0 -4641.5000 0.00000000 0.00000000 0.00000000 PARAMETER L(SALT,MGNA/CL-Q,MG/CL-Q;0) 298.15 -2320.7500;,, N REF ! $ Functions to express not integer T powers $ T**i = EXP(i*LN(T)) FUN LNT 298.15 LN(T);,, N ! FUN HALFLNT 298.15 0.5*LNT;,, N ! FUN SQRT 298.15 EXP(HALFLNT);,, N ! FUN ONE5LNT 298.15 1.5*LNT;,, N ! FUN SSQRT 298.15 EXP(ONE5LNT);,, N ! $============================================================================== $ FUNCTIONS FOR MQMQA $============================================================================== FUNCTION GLIQNACL 298.15 -417806.48+442.50770*T-77.763600*T*LN(T)+0.37656000E-02*T**2; 1500.0000 Y -409333.88+359.89172*T-66.466800*T*LN(T); 3500.0000 N REF ! FUNCTION GLIQMGCL 298.15 -658788.27+1093.7361*T-193.40890*T*LN(T)+0.18100695*T**2 -.53331179E-04*T**3+1894252.0*T**(-1); 660.00000 Y -634331.55+499.20330*T-92.048000*T*LN(T); 3500.0000 N REF ! PHASE NACL % 2 1.0 1.0 ! CONST NACL :NA:CL: ! PARAMETER G(NACL,NA:CL) 298.15 -425542.29 +240.42080*T -45.940000*T*LN(T) -.81590000E-02*T**2; 1500 Y -443900.04 +419.42650*T -70.417000*T*LN(T); 6000 N REF2 ! PHASE MGCL2 % 2 1.0 2.0 ! CONST MGCL2 :MG:CL: ! PARAMETER G(MgCl2,MG:CL) 298.15 -676336.86+242.25622*T-54.584300*T*LN(T) -.10710650E-01*T**2 +0.39278333E-06*T**2 +556059.50*T**(-1) +1596.7080*SQRT; 1500 Y -678190.36+537.75324*T -91.226106*T*LN(T); 6000 N REF2 ! PHASE NaMgCl3 % 3 1.0 1.0 3.0 ! CONST NAMGCL3 :NA:MG:CL: ! PARAMETER G(NAMGCL3,NA:MG:CL) 298.15 -1083303.0+455.19995*T-90.000000*T*LN(T) -0.0375*T**2; 1500 Y -1167678.0+1277.9372*T-202.50000*T*LN(T); 6000 N REF2 ! PHASE Na2MgCl4 % 3 2.0 1.0 4.0 ! CONST NA2MGCL4 :NA:MG:CL: ! PARAMETER G(NA2MGCL4,NA:MG:CL) 298.15 -1508686.5+693.72143*T-135.00000*T*LN(T) -.56250000E-01*T**2; 1500 Y -1635249.0+1927.8274*T-303.75000*T*LN(T); 6000 N REF2 ! $ These 2 phases MUST BE SET DORMANT but are useful for chemical potentials PHASE LIQREF_NACL % 2 1.0 1.0 ! CONST LIQREF_NACL :NA:CL: ! PARAMETER G(LIQREF_NACL,NA:CL) 298.15 GLIQNACL; 6000 N REF ! PHASE LIQREF_MGCL2 % 2 1.0 2.0 ! CONST LIQREF_MGCL2 :MG:CL: ! PARAMETER G(LIQREF_MGCL2,MG:CL) 298.15 GLIQMGCL; 6000 N REF ! $======================================================== Stoichiometric phases LIST_OF_REFERENCES NUMBER SOURCE REF 'Automatic conversion with dat2TDB from MgCl2-NaCl.dat' REF2 'Manual conversion by Bosse' ! ================================================ FILE: examples/macros/MoRe.TDB ================================================ $ Database file written by Open Calphad 2023-09-21 ELEMENT /- Electron_gas 0.0000E+00 0.0000E+00 0.0000E+00 ! ELEMENT VA Vacuum 0.0000E+00 0.0000E+00 0.0000E+00 ! ELEMENT MO BCC_A2 9.5940E+01 4.5890E+03 2.8560E+01 ! ELEMENT RE HCP_A3 1.8621E+02 5.3555E+03 3.6526E+01 ! $ ================= $ ================= FUNCTION RTLNP 10 R*T*LN(1.0D-5*P); 20000 N ! FUNCTION GHSERMO 298.15 -7746.302+131.9197*T-23.56414*T*LN(+T) -.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)-1.30927E-10*T**4; 2896 Y -30556.41+283.559746*T-42.63829*T*LN(+T)-4.849315E+33*T**(-9); 5000 N ! FUNCTION EVTOJ 298.15 +96485.5547; 6000 N ! FUNCTION GCHIMO 298.15 +G58CHIMO*UNS58; 6000 N ! FUNCTION GCHIRE 298.15 +G58CHIRE*UNS58; 6000 N ! FUNCTION GSERMO 298.15 -10.949432*EVTOJ; 6000 N ! FUNCTION GSERRE 298.15 -12.4224915*EVTOJ; 6000 N ! FUNCTION GHSERRE 298.15 -7695.279+128.421589*T-24.348*T*LN(+T) -.00253505*T**2+1.92818E-07*T**3+32915*T**(-1); 1200 Y -15775.998 +194.667426*T-33.586*T*LN(+T)+.00224565*T**2-2.81835E-07*T**3 +1376270*T**(-1); 2400 Y -70882.739+462.110749*T-67.956*T*LN(+T) +.01184945*T**2-7.88955E-07*T**3+18075200*T**(-1); 3458 Y +346325.888 -1211.37186*T+140.831655*T*LN(+T)-.033764567*T**2+1.053726E-06*T**3 -134548866*T**(-1); 5000 Y -78564.296+346.997842*T-49.519*T*LN(+T); 6000 N ! FUNCTION GSIGMO 298.15 +G30SIGMO*UNS30; 6000 N ! FUNCTION GSIGRE 298.15 +G30SIGRE*UNS30; 6000 N ! FUNCTION G58CHIRE 298.15 -717.557146*EVTOJ; 6000 N ! FUNCTION UNS58 298.15 +CINQ8**(-1); 6000 N ! FUNCTION G58CHIMO 298.15 -619.36214*EVTOJ; 6000 N ! FUNCTION G30SIGRE 298.15 -369.773611*EVTOJ; 6000 N ! FUNCTION UNS30 298.15 +TRENTE**(-1); 6000 N ! FUNCTION G30SIGMO 298.15 -323.477558*EVTOJ; 6000 N ! FUNCTION CINQ8 298.15 +58; 6000 N ! FUNCTION TRENTE 298.15 +30; 6000 N ! $ ================= TYPE_DEFINITION % SEQ * ! DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! $ ================= $ + Volume model P*V0(x)*exp(VA(x,T)) PHASE LIQUID:L % 1 1.000 ! CONSTITUENT LIQUID:L :MO RE:! PARAMETER G(LIQUID,MO;0) 298.15 +34085.045+117.224788*T -23.56414*T*LN(+T)-.003443396*T**2+5.66283E-07*T**3+65812*T**(-1) -1.30927E-10*T**4+4.24519E-22*T**7; 2896 Y +3538.963+271.6697*T -42.63829*T*LN(+T); 5000 N REF1 ! PARAMETER G(LIQUID,RE;0) 298.15 +16125.604+122.076209*T-24.348*T*LN(+T) -.00253505*T**2+1.92818E-07*T**3+32915*T**(-1); 1200 Y +8044.885 +188.322047*T-33.586*T*LN(+T)+.00224565*T**2-2.81835E-07*T**3 +1376270*T**(-1); 2000 Y +568842.665-2527.83846*T +314.178898*T*LN(+T)-.08939817*T**2+3.92854E-06*T**3 -163100987*T**(-1); 3458 Y -39044.888+335.723691*T -49.519*T*LN(+T); 6000 N REF1 ! PARAMETER G(LIQUID,MO,RE;0) 298.15 -15025+11.404*T-2610; 6000 N RM2013 ! PARAMETER G(LIQUID,MO,RE;1) 298.15 +8.07*T-7790; 6000 N RM2013 ! $ + Volume model P*V0(x)*exp(VA(x,T)) TYPE_DEFINITION 1 GES A_P_D BCC_A2 MAGNETIC -1 0.4000! PHASE BCC_A2 %1 2 1.000 3.000 ! CONSTITUENT BCC_A2 :MO RE: VA:! PARAMETER G(BCC_A2,MO:VA;0) 298.15 +GHSERMO; 5000 N REF1 ! PARAMETER G(BCC_A2,RE:VA;0) 298.15 +9304.721+124.721589*T -24.348*T*LN(+T)-.00253505*T**2+1.92818E-07*T**3+32915*T**(-1); 1200 Y +1224.002+190.967426*T-33.586*T*LN(+T)+.00224565*T**2 -2.81835E-07*T**3+1376270*T**(-1); 2400 Y -53882.739+458.410749*T -67.956*T*LN(+T)+.01184945*T**2-7.88955E-07*T**3+18075200*T**(-1); 3458 Y +363325.888-1215.07186*T+140.831655*T*LN(+T) -.033764567*T**2+1.053726E-06*T**3-134548866*T**(-1); 5000 Y -61564.296+343.297842*T-49.519*T*LN(+T); 6000 N REF1 ! PARAMETER G(BCC_A2,MO,RE:VA;0) 298.15 -15025+11.404*T; 6000 N RM2013 ! PARAMETER G(BCC_A2,MO,RE:VA;1) 298.15 +8.07*T; 6000 N RM2013 ! $ *** Warning: disordered fraction sets need manual editing! $- TYPE_DEFINITION 2 GES A_P_D CHI DIS_PART DIS_CHI ! TYPE_DEFINITION 2 GES A_P_D CHI NEVER DIS_CHI ! $ + Volume model P*V0(x)*exp(VA(x,T)) PHASE CHI %2 4 2.000 8.000 24.000 24.000 ! CONSTITUENT CHI :MO RE: MO RE: MO RE: MO RE:! PARAMETER G(CHI,MO:MO:MO:RE;0) 298.15 -667.0576*EVTOJ-2*GCHIMO-8*GCHIMO -24*GCHIMO-24*GCHIRE; 6000 N DFTCHI ! PARAMETER G(CHI,MO:MO:RE:MO;0) 298.15 -662.013824*EVTOJ-2*GCHIMO -8*GCHIMO-24*GCHIRE-24*GCHIMO; 6000 N DFTCHI ! PARAMETER G(CHI,MO:MO:RE:RE;0) 298.15 -706.53129*EVTOJ-2*GCHIMO -8*GCHIMO-24*GCHIRE-24*GCHIRE; 6000 N DFTCHI ! PARAMETER G(CHI,MO:RE:MO:MO;0) 298.15 -630.436204*EVTOJ-2*GCHIMO -8*GCHIRE-24*GCHIMO-24*GCHIMO; 6000 N DFTCHI ! PARAMETER G(CHI,MO:RE:MO:RE;0) 298.15 -676.652914*EVTOJ-2*GCHIMO -8*GCHIRE-24*GCHIMO-24*GCHIRE; 6000 N DFTCHI ! PARAMETER G(CHI,MO:RE:RE:MO;0) 298.15 -672.07236*EVTOJ-2*GCHIMO -8*GCHIRE-24*GCHIRE-24*GCHIMO; 6000 N DFTCHI ! PARAMETER G(CHI,MO:RE:RE:RE;0) 298.15 -715.47601*EVTOJ-2*GCHIMO -8*GCHIRE-24*GCHIRE-24*GCHIRE; 6000 N DFTCHI ! PARAMETER G(CHI,RE:MO:MO:MO;0) 298.15 -621.992644*EVTOJ -2*GCHIRE-8*GCHIMO-24*GCHIMO-24*GCHIMO; 6000 N DFTCHI ! PARAMETER G(CHI,RE:MO:MO:RE;0) 298.15 -669.426922*EVTOJ -2*GCHIRE-8*GCHIMO-24*GCHIMO-24*GCHIRE; 6000 N DFTCHI ! PARAMETER G(CHI,RE:MO:RE:MO;0) 298.15 -664.700708*EVTOJ -2*GCHIRE-8*GCHIMO-24*GCHIRE-24*GCHIMO; 6000 N DFTCHI ! PARAMETER G(CHI,RE:MO:RE:RE;0) 298.15 -708.864342*EVTOJ -2*GCHIRE-8*GCHIMO-24*GCHIRE-24*GCHIRE; 6000 N DFTCHI ! PARAMETER G(CHI,RE:RE:MO:MO;0) 298.15 -632.902352*EVTOJ -2*GCHIRE-8*GCHIRE-24*GCHIMO-24*GCHIMO; 6000 N DFTCHI ! PARAMETER G(CHI,RE:RE:MO:RE;0) 298.15 -678.636738*EVTOJ -2*GCHIRE-8*GCHIRE-24*GCHIMO-24*GCHIRE; 6000 N DFTCHI ! PARAMETER G(CHI,RE:RE:RE:MO;0) 298.15 -674.442674*EVTOJ -2*GCHIRE-8*GCHIRE-24*GCHIRE-24*GCHIMO; 6000 N DFTCHI ! $ disordered part PHASE DIS_CHI % 1 1.0 ! CONSTITUENT DIS_CHI :MO RE: ! $ Disordered fraction parameters:-------------------- PARAMETER G(DIS_CHI,MO;0) 298.15 +GCHIMO-GSERMO+GHSERMO-0.5596*T; 6000 N RM2013 ! PARAMETER G(DIS_CHI,RE;0) 298.15 +GCHIRE-GSERRE+GHSERRE+.0905*T; 6000 N RM2013 ! $ + Volume model P*V0(x)*exp(VA(x,T)) TYPE_DEFINITION 3 GES A_P_D HCP_A3 MAGNETIC -3 0.2800! PHASE HCP_A3 %3 2 1.000 0.500 ! CONSTITUENT HCP_A3 :MO RE: VA:! PARAMETER G(HCP_A3,MO:VA;0) 298.15 +3803.698+131.9197*T -23.56414*T*LN(+T)-.003443396*T**2+5.66283E-07*T**3+65812*T**(-1) -1.30927E-10*T**4; 2896 Y -19006.41+283.559746*T -42.63829*T*LN(+T)-4.849315E+33*T**(-9); 5000 N REF1 ! PARAMETER G(HCP_A3,RE:VA;0) 298.15 +GHSERRE; 6000 N REF1 ! PARAMETER G(HCP_A3,MO,RE:VA;0) 298.15 +12740+1.95*T; 6000 N RM2013 ! $ *** Warning: disordered fraction sets need manual editing! $ TYPE_DEFINITION 4 GES A_P_D SIGMA DIS_PART DIS_SIGMA ! TYPE_DEFINITION 4 GES A_P_D SIGMA NEVER DIS_SIG ! $ + Volume model P*V0(x)*exp(VA(x,T)) PHASE SIGMA %4 5 2.000 4.000 8.000 8.000 8.000 ! CONSTITUENT SIGMA :MO RE: MO RE: MO RE: MO RE: MO RE:! PARAMETER G(SIGMA,MO:MO:MO:MO:RE;0) 298.15 -336.420911*EVTOJ-2*GSIGMO -4*GSIGMO-8*GSIGMO-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:MO:MO:RE:MO;0) 298.15 -338.810302*EVTOJ-2*GSIGMO -4*GSIGMO-8*GSIGMO-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:MO:MO:RE:RE;0) 298.15 -350.940389*EVTOJ-2*GSIGMO -4*GSIGMO-8*GSIGMO-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:MO:RE:MO:MO;0) 298.15 -336.272469*EVTOJ-2*GSIGMO -4*GSIGMO-8*GSIGRE-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:MO:RE:MO:RE;0) 298.15 -348.274113*EVTOJ-2*GSIGMO -4*GSIGMO-8*GSIGRE-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:MO:RE:RE:MO;0) 298.15 -350.877403*EVTOJ-2*GSIGMO -4*GSIGMO-8*GSIGRE-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:MO:RE:RE:RE;0) 298.15 -361.705173*EVTOJ-2*GSIGMO -4*GSIGMO-8*GSIGRE-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:RE:MO:MO:MO;0) 298.15 -329.386161*EVTOJ-2*GSIGMO -4*GSIGRE-8*GSIGMO-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:RE:MO:MO:RE;0) 298.15 -341.899815*EVTOJ-2*GSIGMO -4*GSIGRE-8*GSIGMO-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:RE:MO:RE:MO;0) 298.15 -344.381107*EVTOJ-2*GSIGMO -4*GSIGRE-8*GSIGMO-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:RE:MO:RE:RE;0) 298.15 -355.892909*EVTOJ-2*GSIGMO -4*GSIGRE-8*GSIGMO-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:RE:RE:MO:MO;0) 298.15 -342.25167*EVTOJ-2*GSIGMO -4*GSIGRE-8*GSIGRE-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:RE:RE:MO:RE;0) 298.15 -353.543856*EVTOJ-2*GSIGMO -4*GSIGRE-8*GSIGRE-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:RE:RE:RE:MO;0) 298.15 -356.308695*EVTOJ-2*GSIGMO -4*GSIGRE-8*GSIGRE-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:RE:RE:RE:RE;0) 298.15 -366.47672*EVTOJ-2*GSIGMO -4*GSIGRE-8*GSIGRE-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:MO:MO:MO:MO;0) 298.15 -327.229897*EVTOJ -2*GSIGRE-4*GSIGMO-8*GSIGMO-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:MO:MO:MO:RE;0) 298.15 -340.042158*EVTOJ -2*GSIGRE-4*GSIGMO-8*GSIGMO-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:MO:MO:RE:MO;0) 298.15 -342.644194*EVTOJ -2*GSIGRE-4*GSIGMO-8*GSIGMO-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:MO:MO:RE:RE;0) 298.15 -354.494334*EVTOJ -2*GSIGRE-4*GSIGMO-8*GSIGMO-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:MO:RE:MO:MO;0) 298.15 -340.103152*EVTOJ -2*GSIGRE-4*GSIGMO-8*GSIGRE-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:MO:RE:MO:RE;0) 298.15 -351.792339*EVTOJ -2*GSIGRE-4*GSIGMO-8*GSIGRE-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:MO:RE:RE:MO;0) 298.15 -354.690887*EVTOJ -2*GSIGRE-4*GSIGMO-8*GSIGRE-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:MO:RE:RE:RE;0) 298.15 -365.120645*EVTOJ -2*GSIGRE-4*GSIGMO-8*GSIGRE-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:RE:MO:MO:MO;0) 298.15 -332.95143*EVTOJ -2*GSIGRE-4*GSIGRE-8*GSIGMO-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:RE:MO:MO:RE;0) 298.15 -345.245205*EVTOJ -2*GSIGRE-4*GSIGRE-8*GSIGMO-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:RE:MO:RE:MO;0) 298.15 -347.970121*EVTOJ -2*GSIGRE-4*GSIGRE-8*GSIGMO-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:RE:MO:RE:RE;0) 298.15 -359.220781*EVTOJ -2*GSIGRE-4*GSIGRE-8*GSIGMO-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:RE:RE:MO:MO;0) 298.15 -345.809448*EVTOJ -2*GSIGRE-4*GSIGRE-8*GSIGRE-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:RE:RE:MO:RE;0) 298.15 -356.822818*EVTOJ -2*GSIGRE-4*GSIGRE-8*GSIGRE-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:RE:RE:RE:MO;0) 298.15 -359.887484*EVTOJ -2*GSIGRE-4*GSIGRE-8*GSIGRE-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG ! $ disordered part PHASE DIS_SIG % 1 1.0 ! CONSTITUENT DIS_SIG :MO RE: ! $ Disordered fraction parameters:-------------------- PARAMETER G(DIS_SIG,MO;0) 298.15 +GSIGMO-GSERMO+GHSERMO+1.251*T; 6000 N RM2013 ! PARAMETER G(DIS_SIG,RE;0) 298.15 +GSIGRE-GSERRE+GHSERRE-1.205*T; 6000 N RM2013 ! $ ================= LIST_OF_REFERENCES NUMBER SOURCE REF1 'PURE4 - SGTE Pure Elements (Unary) Database (Version 4.6), developed by SGTE (Scientific Group Thermodata Europe), 1991 -2008, and provided by TCSAB (Jan. 2008).' RM2013 '*** Not set by database or user' DFTCHI 'JC Crivello 2012 march, Armide project v1.13 chi phase' DFTSIG 'JC Crivello 2012 march, Armide project v1.9 sigma phase' ! ================================================ FILE: examples/macros/MoRe1.PDB ================================================ $ Database file written by Open Calphad 2016-10-17 ELEMENT /- Electron_gas 0.0000E+00 0.0000E+00 0.0000E+00 ! ELEMENT VA Vaccum 0.0000E+00 0.0000E+00 0.0000E+00 ! ELEMENT MO BCC_A2 9.5940E+01 4.5890E+03 2.8560E+01 ! ELEMENT RE HCP_A3 1.8621E+02 5.3555E+03 3.6526E+01 ! $ ================= FUNCTION RTLNP 10 8.31451*R*LN(1.0D-5*P); 20000 N ! FUNCTION GHSERMO 298.15 -7746.302+131.9197*T-23.56414*T*LN(+T) -.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)-1.30927E-10*T**4; 2896 Y -30556.41+283.559746*T-42.63829*T*LN(+T)-4.849315E+33*T**(-9); 5000 N ! FUNCTION GHSERRE 298.15 -7695.279+128.421589*T-24.348*T*LN(+T) -.00253505*T**2+1.92818E-07*T**3+32915*T**(-1); 1200 Y -15775.998 +194.667426*T-33.586*T*LN(+T)+.00224565*T**2-2.81835E-07*T**3 +1376270*T**(-1); 2400 Y -70882.739+462.110749*T-67.956*T*LN(+T) +.01184945*T**2-7.88955E-07*T**3+18075200*T**(-1); 3458 Y +346325.888 -1211.37186*T+140.831655*T*LN(+T)-.033764567*T**2+1.053726E-06*T**3 -134548866*T**(-1); 5000 Y -78564.296+346.997842*T-49.519*T*LN(+T); 6000 N ! FUNCTION EVTOJ 298.15 +96485.5547; 6000 N ! FUNCTION GCHIRE 298.15 +G58CHIRE*UNS58; 6000 N ! FUNCTION GCHIMO 298.15 +G58CHIMO*UNS58; 6000 N ! FUNCTION GSIGRE 298.15 +G30SIGRE*UNS30; 6000 N ! FUNCTION GSIGMO 298.15 +G30SIGMO*UNS30; 6000 N ! FUNCTION GSERMO 298.15 -10.949432*EVTOJ; 6000 N ! FUNCTION GSERRE 298.15 -12.4224915*EVTOJ; 6000 N ! FUNCTION G58CHIMO 298.15 -619.36214*EVTOJ; 6000 N ! FUNCTION UNS58 298.15 +CINQ8**(-1); 6000 N ! FUNCTION G58CHIRE 298.15 -717.557146*EVTOJ; 6000 N ! FUNCTION G30SIGMO 298.15 -323.477558*EVTOJ; 6000 N ! FUNCTION UNS30 298.15 +TRENTE**(-1); 6000 N ! FUNCTION G30SIGRE 298.15 -369.773611*EVTOJ; 6000 N ! FUNCTION CINQ8 298.15 +58; 6000 N ! FUNCTION TRENTE 298.15 +30; 6000 N ! $ ================= $ The proposed PDB format for model. CEF2 means CEF model with 2 sublattices $ The site ratios inside the parenthesis $ IMAGB means Inden's BCC model for magnetic ordering PHASE BCC_A2 CEF2( 1.000 3.000 ) IMAGB ! CONSTITUENT BCC_A2 :MO RE: VA:! PARAMETER G(BCC_A2,MO:VA;0) 298.15 +GHSERMO; 5000 N REF1 ! PARAMETER G(BCC_A2,RE:VA;0) 298.15 +9304.721+124.721589*T -24.348*T*LN(+T)-.00253505*T**2+1.92818E-07*T**3+32915*T**(-1); 1200 Y +1224.002+190.967426*T-33.586*T*LN(+T)+.00224565*T**2 -2.81835E-07*T**3+1376270*T**(-1); 2400 Y -53882.739+458.410749*T -67.956*T*LN(+T)+.01184945*T**2-7.88955E-07*T**3+18075200*T**(-1); 3458 Y +363325.888-1215.07186*T+140.831655*T*LN(+T) -.033764567*T**2+1.053726E-06*T**3-134548866*T**(-1); 5000 Y -61564.296+343.297842*T-49.519*T*LN(+T); 6000 N REF1 ! PARAMETER G(BCC_A2,MO,RE:VA;0) 298.15 -15025+11.404*T; 6000 N RM2013 ! PARAMETER G(BCC_A2,MO,RE:VA;1) 298.15 +8.07*T; 6000 N RM2013 ! $ The N in CEF4N means disordered a contribution. All sublattices are added $ together for the disordered part and the ordered part as disordered $ is not subtracted. PHASE CHI CEF4N( 2.000 8.000 24.000 24.000 ) ! CONSTITUENT CHI :MO RE: MO RE: MO RE: MO RE:! PARAMETER G(CHI,MO:MO:MO:RE;0) 298.15 -667.0576*EVTOJ-2*GCHIMO-8*GCHIMO -24*GCHIMO-24*GCHIRE; 6000 N DFTCHI ! PARAMETER G(CHI,MO:MO:RE:MO;0) 298.15 -662.013824*EVTOJ-2*GCHIMO -8*GCHIMO-24*GCHIRE-24*GCHIMO; 6000 N DFTCHI ! PARAMETER G(CHI,MO:MO:RE:RE;0) 298.15 -706.53129*EVTOJ-2*GCHIMO -8*GCHIMO-24*GCHIRE-24*GCHIRE; 6000 N DFTCHI ! PARAMETER G(CHI,MO:RE:MO:MO;0) 298.15 -630.436204*EVTOJ-2*GCHIMO -8*GCHIRE-24*GCHIMO-24*GCHIMO; 6000 N DFTCHI ! PARAMETER G(CHI,MO:RE:MO:RE;0) 298.15 -676.652914*EVTOJ-2*GCHIMO -8*GCHIRE-24*GCHIMO-24*GCHIRE; 6000 N DFTCHI ! PARAMETER G(CHI,MO:RE:RE:MO;0) 298.15 -672.07236*EVTOJ-2*GCHIMO -8*GCHIRE-24*GCHIRE-24*GCHIMO; 6000 N DFTCHI ! PARAMETER G(CHI,MO:RE:RE:RE;0) 298.15 -715.47601*EVTOJ-2*GCHIMO -8*GCHIRE-24*GCHIRE-24*GCHIRE; 6000 N DFTCHI ! PARAMETER G(CHI,RE:MO:MO:MO;0) 298.15 -621.992644*EVTOJ -2*GCHIRE-8*GCHIMO-24*GCHIMO-24*GCHIMO; 6000 N DFTCHI ! PARAMETER G(CHI,RE:MO:MO:RE;0) 298.15 -669.426922*EVTOJ -2*GCHIRE-8*GCHIMO-24*GCHIMO-24*GCHIRE; 6000 N DFTCHI ! PARAMETER G(CHI,RE:MO:RE:MO;0) 298.15 -664.700708*EVTOJ -2*GCHIRE-8*GCHIMO-24*GCHIRE-24*GCHIMO; 6000 N DFTCHI ! PARAMETER G(CHI,RE:MO:RE:RE;0) 298.15 -708.864342*EVTOJ -2*GCHIRE-8*GCHIMO-24*GCHIRE-24*GCHIRE; 6000 N DFTCHI ! PARAMETER G(CHI,RE:RE:MO:MO;0) 298.15 -632.902352*EVTOJ -2*GCHIRE-8*GCHIRE-24*GCHIMO-24*GCHIMO; 6000 N DFTCHI ! PARAMETER G(CHI,RE:RE:MO:RE;0) 298.15 -678.636738*EVTOJ -2*GCHIRE-8*GCHIRE-24*GCHIMO-24*GCHIRE; 6000 N DFTCHI ! PARAMETER G(CHI,RE:RE:RE:MO;0) 298.15 -674.442674*EVTOJ -2*GCHIRE-8*GCHIRE-24*GCHIRE-24*GCHIMO; 6000 N DFTCHI ! $ Disordered fraction parameters:-------------------- PARAMETER GD(CHI,MO;0) 298.15 +GCHIMO-GSERMO+GHSERMO-0.5596*T; 6000 N RM2013 ! PARAMETER GD(CHI,RE;0) 298.15 +GCHIRE-GSERRE+GHSERRE+.0905*T; 6000 N RM2013 ! $ Nothing special here PHASE HCP_A3 CEF2( 1.000 0.500 ) IMAGF ! CONSTITUENT HCP_A3 :MO RE: VA:! PARAMETER G(HCP_A3,MO:VA;0) 298.15 +3803.698+131.9197*T -23.56414*T*LN(+T)-.003443396*T**2+5.66283E-07*T**3+65812*T**(-1) -1.30927E-10*T**4; 2896 Y -19006.41+283.559746*T -42.63829*T*LN(+T)-4.849315E+33*T**(-9); 5000 N REF1 ! PARAMETER G(HCP_A3,RE:VA;0) 298.15 +GHSERRE; 6000 N REF1 ! PARAMETER G(HCP_A3,MO,RE:VA;0) 298.15 +12740+1.95*T; 6000 N RM2013 ! $ The model SUBRKM means substitution model with Redlich-Kister binary excess $ and_Muggianu ternary extrapolation. PHASE LIQUID SUBRKM ! CONSTITUENT LIQUID :MO RE:! PARAMETER G(LIQUID,MO;0) 298.15 +34085.045+117.224788*T -23.56414*T*LN(+T)-.003443396*T**2+5.66283E-07*T**3+65812*T**(-1) -1.30927E-10*T**4+4.24519E-22*T**7; 2896 Y +3538.963+271.6697*T -42.63829*T*LN(+T); 5000 N REF1 ! PARAMETER G(LIQUID,RE;0) 298.15 +16125.604+122.076209*T-24.348*T*LN(+T) -.00253505*T**2+1.92818E-07*T**3+32915*T**(-1); 1200 Y +8044.885 +188.322047*T-33.586*T*LN(+T)+.00224565*T**2-2.81835E-07*T**3 +1376270*T**(-1); 2000 Y +568842.665-2527.83846*T +314.178898*T*LN(+T)-.08939817*T**2+3.92854E-06*T**3 -163100987*T**(-1); 3458 Y -39044.888+335.723691*T -49.519*T*LN(+T); 6000 N REF1 ! PARAMETER G(LIQUID,MO,RE;0) 298.15 -15025+11.404*T-2610; 6000 N RM2013 ! PARAMETER G(LIQUID,MO,RE;1) 298.15 +8.07*T-7790; 6000 N RM2013 ! $ This model is the same as for the CHI_PHASE but with 5 sublattices PHASE SIGMA CEF5N( 2.000 4.000 8.000 8.000 8.000) ! CONSTITUENT SIGMA :MO RE: MO RE: MO RE: MO RE: MO RE:! PARAMETER G(SIGMA,MO:MO:MO:MO:RE;0) 298.15 -336.420911*EVTOJ-2*GSIGMO -4*GSIGMO-8*GSIGMO-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:MO:MO:RE:MO;0) 298.15 -338.810302*EVTOJ-2*GSIGMO -4*GSIGMO-8*GSIGMO-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:MO:MO:RE:RE;0) 298.15 -350.940389*EVTOJ-2*GSIGMO -4*GSIGMO-8*GSIGMO-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:MO:RE:MO:MO;0) 298.15 -336.272469*EVTOJ-2*GSIGMO -4*GSIGMO-8*GSIGRE-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:MO:RE:MO:RE;0) 298.15 -348.274113*EVTOJ-2*GSIGMO -4*GSIGMO-8*GSIGRE-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:MO:RE:RE:MO;0) 298.15 -350.877403*EVTOJ-2*GSIGMO -4*GSIGMO-8*GSIGRE-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:MO:RE:RE:RE;0) 298.15 -361.705173*EVTOJ-2*GSIGMO -4*GSIGMO-8*GSIGRE-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:RE:MO:MO:MO;0) 298.15 -329.386161*EVTOJ-2*GSIGMO -4*GSIGRE-8*GSIGMO-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:RE:MO:MO:RE;0) 298.15 -341.899815*EVTOJ-2*GSIGMO -4*GSIGRE-8*GSIGMO-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:RE:MO:RE:MO;0) 298.15 -344.381107*EVTOJ-2*GSIGMO -4*GSIGRE-8*GSIGMO-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:RE:MO:RE:RE;0) 298.15 -355.892909*EVTOJ-2*GSIGMO -4*GSIGRE-8*GSIGMO-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:RE:RE:MO:MO;0) 298.15 -342.25167*EVTOJ-2*GSIGMO -4*GSIGRE-8*GSIGRE-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:RE:RE:MO:RE;0) 298.15 -353.543856*EVTOJ-2*GSIGMO -4*GSIGRE-8*GSIGRE-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:RE:RE:RE:MO;0) 298.15 -356.308695*EVTOJ-2*GSIGMO -4*GSIGRE-8*GSIGRE-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,MO:RE:RE:RE:RE;0) 298.15 -366.47672*EVTOJ-2*GSIGMO -4*GSIGRE-8*GSIGRE-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:MO:MO:MO:MO;0) 298.15 -327.229897*EVTOJ -2*GSIGRE-4*GSIGMO-8*GSIGMO-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:MO:MO:MO:RE;0) 298.15 -340.042158*EVTOJ -2*GSIGRE-4*GSIGMO-8*GSIGMO-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:MO:MO:RE:MO;0) 298.15 -342.644194*EVTOJ -2*GSIGRE-4*GSIGMO-8*GSIGMO-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:MO:MO:RE:RE;0) 298.15 -354.494334*EVTOJ -2*GSIGRE-4*GSIGMO-8*GSIGMO-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:MO:RE:MO:MO;0) 298.15 -340.103152*EVTOJ -2*GSIGRE-4*GSIGMO-8*GSIGRE-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:MO:RE:MO:RE;0) 298.15 -351.792339*EVTOJ -2*GSIGRE-4*GSIGMO-8*GSIGRE-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:MO:RE:RE:MO;0) 298.15 -354.690887*EVTOJ -2*GSIGRE-4*GSIGMO-8*GSIGRE-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:MO:RE:RE:RE;0) 298.15 -365.120645*EVTOJ -2*GSIGRE-4*GSIGMO-8*GSIGRE-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:RE:MO:MO:MO;0) 298.15 -332.95143*EVTOJ -2*GSIGRE-4*GSIGRE-8*GSIGMO-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:RE:MO:MO:RE;0) 298.15 -345.245205*EVTOJ -2*GSIGRE-4*GSIGRE-8*GSIGMO-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:RE:MO:RE:MO;0) 298.15 -347.970121*EVTOJ -2*GSIGRE-4*GSIGRE-8*GSIGMO-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:RE:MO:RE:RE;0) 298.15 -359.220781*EVTOJ -2*GSIGRE-4*GSIGRE-8*GSIGMO-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:RE:RE:MO:MO;0) 298.15 -345.809448*EVTOJ -2*GSIGRE-4*GSIGRE-8*GSIGRE-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:RE:RE:MO:RE;0) 298.15 -356.822818*EVTOJ -2*GSIGRE-4*GSIGRE-8*GSIGRE-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG ! PARAMETER G(SIGMA,RE:RE:RE:RE:MO;0) 298.15 -359.887484*EVTOJ -2*GSIGRE-4*GSIGRE-8*GSIGRE-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG ! $ Disordered fraction parameters:-------------------- PARAMETER GD(SIGMA,MO;0) 298.15 +GSIGMO-GSERMO+GHSERMO+1.251*T; 6000 N RM2013 ! PARAMETER GD(SIGMA,RE;0) 298.15 +GSIGRE-GSERRE+GHSERRE-1.205*T; 6000 N RM2013 ! $ ================= BIBLIOGRAPHY DUMMY 'OC BUG not reading first line ...' REF1 'PURE4 - SGTE Pure Elements (Unary) Database (Version 4.6), developed by SGTE (Scientific Group Thermodata Europe), 1991 -2008, and provided by TCSAB (Jan. 2008).' DFTCHI 'JC Crivello 2012 march, Armide project v1.13 chi phase' RM2013 '*** Not set by database or user' DFTSIG 'JC Crivello 2012 march, Armide project v1.9 sigma phase' ! ================================================ FILE: examples/macros/OU.TDB ================================================ $ Database file written 2013- 3-10 $ From database: USER ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT O GAS_1/2_MOLE_O2 1.5999E+01 4.3410E+03 1.0252E+02! ELEMENT U ORTHORHOMBIC_A20 2.3803E+02 6.3640E+03 5.0200E+01! SPECIES O-2 O1/-2! SPECIES O2 O2! SPECIES O3 O3! SPECIES U+3 U1/+3! SPECIES U+4 U1/+4! SPECIES U+5 U1/+5! SPECIES UO O1U1! SPECIES UO2 O2U1! SPECIES UO3 O3U1! FUNCTION OGAS 298.15 +243206.494-20.8612587*T-21.01555*T*LN(T) +1.2687055E-04*T**2-1.23131283E-08*T**3-42897.09*T**(-1); 2950 Y +252301.423-52.0847285*T-17.21188*T*LN(T)-5.413565E-04*T**2 +7.64520667E-09*T**3-3973170.5*T**(-1); 6000 N ! FUNCTION O2GAS 298.15 -6960.69252-51.1831473*T-22.25862*T*LN(T) -.01023867*T**2+1.339947E-06*T**3-76749.55*T**(-1); 9.00000E+02 Y -13136.0172+24.743296*T-33.55726*T*LN(T)-.0012348985*T**2 +1.66943333E-08*T**3+539886*T**(-1); 3.70000E+03 Y +14154.6461-51.4854586*T-24.47978*T*LN(T)-.002634759*T**2 +6.01544333E-08*T**3-15120935*T**(-1); 9.60000E+03 Y -314316.628+515.068037*T-87.56143*T*LN(T)+.0025787245*T**2 -1.878765E-08*T**3+2.9052515E+08*T**(-1); 1.85000E+04 Y -108797.175+288.483019*T-63.737*T*LN(T)+.0014375*T**2-9E-09*T**3 +.25153895*T**(-1); 2.00000E+04 N ! FUNCTION O3GAS 298.15 +130696.944-37.9096651*T-27.58118*T*LN(T) -.02763076*T**2+4.60539333E-06*T**3+99530.45*T**(-1); 4.00000E+02 Y +114760.623+176.626736*T-60.10286*T*LN(T)+.00206456*T**2 -5.17486667E-07*T**3+1572175*T**(-1); 1.30000E+03 Y +49468.3958+710.094819*T-134.3696*T*LN(T)+.039707355*T**2 -4.10457667E-06*T**3+12362250*T**(-1); 2.10000E+03 Y +866367.075-3566.80563*T+421.2001*T*LN(T)-.1284109*T**2 +5.44768833E-06*T**3-2.1304835E+08*T**(-1); 2.80000E+03 Y +409416.384-1950.70834*T+223.4437*T*LN(T)-.0922361*T**2 +4.306855E-06*T**3-21589870*T**(-1); 3.50000E+03 Y -1866338.6+6101.13383*T-764.8435*T*LN(T)+.09852775*T**2 -2.59784667E-06*T**3+9.610855E+08*T**(-1); 4.90000E+03 Y +97590.0432+890.79836*T-149.9608*T*LN(T)+.01283575*T**2 -3.555105E-07*T**3-2.1699975E+08*T**(-1); 6000 N ! FUNCTION GHSEROO 298.15 -3480.87-25.503038*T-11.136*T*LN(T) -.005098888*T**2+6.61846E-07*T**3-38365*T**(-1); 1.00000E+03 Y -6568.763+12.65988*T-16.8138*T*LN(T)-5.95798E-04*T**2+6.781E-09*T**3 +262905*T**(-1); 3.30000E+03 Y -13986.728+31.259625*T-18.9536*T*LN(T)-4.25243E-04*T**2 +1.0721E-08*T**3+4383200*T**(-1); 6000 N ! FUNCTION GASU 298.15 +523164.925+13.603288*T-32.513*T*LN(T) +.01126565*T**2-2.43328E-06*T**3+151130*T**(-1); 9.00000E+02 Y +541065.13-173.693179*T-5.336*T*LN(T)-.00723615*T**2-4.306E-08*T**3 -2072960*T**(-1); 2.10000E+03 Y +605452.662-512.542339*T+38.748*T*LN(T)-.0208079*T**2+7.5045E-07*T**3 -19886375*T**(-1); 4.50000E+03 Y -41328.1657+1300.29089*T-176.856*T*LN(T)+.0113664*T**2 -1.56178333E-07*T**3+3.4654725E+08*T**(-1); 9.20000E+03 Y +410972.67+537.324611*T-92.012*T*LN(T)+.0043702*T**2 -4.90033333E-08*T**3-99572850*T**(-1); 1.20000E+04 N ! FUNCTION GLIQUU 298.15 +3947.766+120.631251*T-26.9182*T*LN(T) +.00125156*T**2-4.42605E-06*T**3+38568*T**(-1); 9.55000E+02 Y -10166.3+281.797193*T-48.66*T*LN(T); 3.00000E+03 N ! FUNCTION GFCCUU 298.15 -3407.734+130.955151*T-26.9182*T*LN(T) +.00125156*T**2-4.42605E-06*T**3+38568*T**(-1); 9.55000E+02 Y -17521.8+292.121093*T-48.66*T*LN(T); 3.00000E+03 N ! FUNCTION GBCCUU 298.15 -752.767+131.5381*T-27.5152*T*LN(T) -.00835595*T**2+9.67907E-07*T**3+204611*T**(-1); 1.04900E+03 Y -4698.365+202.685635*T-38.2836*T*LN(T); 3.00000E+03 N ! FUNCTION GHSERUU 298.15 -8407.734+130.955151*T-26.9182*T*LN(T) +.00125156*T**2-4.42605E-06*T**3+38568*T**(-1); 9.55000E+02 Y -22521.8+292.121093*T-48.66*T*LN(T); 3.00000E+03 N ! FUNCTION GTETUU 298.15 -5156.136+106.976316*T-22.841*T*LN(T) -.01084475*T**2+2.7889E-08*T**3+81944*T**(-1); 9.41500E+02 Y -14327.309+244.16802*T-42.9278*T*LN(T); 3.00000E+03 N ! FUNCTION UOGAS 298.15 +7058.467+16.66929*T-38.48092*T*LN(T) -.01650935*T**2+6.74198333E-06*T**3-1.22913333E-09*T**4+257767*T**(-1); 1.30000E+03 Y +10617.823+76.4054808*T-50.04939*T*LN(T)+.0090553*T**2 -2.0628666E-06*T**3+1.42865E-10*T**4-1254735*T**(-1); 4.00000E+03 N ! FUNCTION UO2GAS 298.15 -477055.313+30.72281*T-44.35744*T*LN(T) -.018817925*T**2+3.85927167E-06*T**3-4.58556667E-10*T**4 +37425.465*T**(-1); 1.50000E+03 Y -483042.479+128.845816*T-59.57586*T*LN(T)-.0026962*T**2 -1.57719683E-08*T**3+8.57269167E-12*T**4+315972.55*T**(-1); 4000 N ! FUNCTION UO3GAS 298.15 -813296.059+27.9636972*T-46.69199*T*LN(T) -.047347135*T**2+1.58195017E-05*T**3-2.84654167E-09*T**4 +139692.15*T**(-1); 9.00000E+02 Y -827058.826+248.932783*T-81.70962*T*LN(T)-.001004739*T**2 +1.85084167E-07*T**3-1.8022825E-11*T**4+1290177.5*T**(-1); 4000 N ! FUNCTION LOWLIQ 298.15 +G4OV#+79775-25.0114*T-2.62269566E-21*T**7; 2.60000E+03 N ! FUNCTION O2ULIQ 298.15 -1590418+3618.8*T-480*T*LN(T)+.07*T**2 -1E-06*T**3; 6000 N ! FUNCTION G3OO 298.15 +G3OV#+GHSEROO#; 6000 N ! FUNCTION G4OO 298.15 +G4OV#+GHSEROO#; 6000 N ! FUNCTION G5OO 298.15 +G5OV#+GHSEROO#; 6000 N ! FUNCTION G3OV 298.15 +G4OV#-G4VV#+G3VV#; 6000 N ! FUNCTION G4OV 298.15 +GUO2#; 6000 N ! FUNCTION G5OV 298.15 +GUO25#-.5*GHSEROO#+.69315*R#*T; 6000 N ! FUNCTION G3VV 298.15 +GUO15#-1.5*GHSEROO#+1.12467*R#*T; 6000 N ! FUNCTION G4VV 298.15 +G4OV#-2*GHSEROO#+545210.5; 6000 N ! FUNCTION G5VV 298.15 +G5OV#-2*GHSEROO#+700000; 6000 N ! FUNCTION GU3O8 298.15 -3674804.49+1600.50059*T -276.747749*T*LN(T)-.0136644165*T**2+2036667.44*T**(-1); 2000 N ! FUNCTION GU4O9 298.15 -4621329.3+1786.83274*T-311.20912*T*LN(T) -.0311301013*T**2+1741269.49*T**(-1); 2.00000E+03 N ! FUNCTION GUO15 298.15 +GUO2#-.5*GHSEROO#+747127-70.22618*T; 6000 N ! FUNCTION GUO2 298.15 -1118940.2+554.00559*T-93.268*T*LN(T) +.0101704254*T**2-2.03335671E-06*T**3+1091073.7*T**(-1); 6000 N ! FUNCTION GUO25 298.15 +GUO2#+.5*GHSEROO#-58351.62+39.67611*T; 6000 N ! FUNCTION UN_ASS 298.15 0; 300 N ! TYPE_DEFINITION % SEQ *! DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! PHASE GAS:G % 1 1.0 ! CONSTITUENT GAS:G :O,O2,O3,U,UO,UO2,UO3 : ! PARAMETER G(GAS,O;0) 298.15 +OGAS#+RTLNP#; 6000 N REF174 ! PARAMETER G(GAS,O2;0) 298.15 +O2GAS#+RTLNP#; 6000 N REF175 ! PARAMETER G(GAS,O3;0) 298.15 +O3GAS#+RTLNP#; 6000 N REF176 ! PARAMETER G(GAS,U;0) 298.15 +GASU#+RTLNP#; 6000 N REF160 ! PARAMETER G(GAS,UO;0) 298.15 +UOGAS#+RTLNP#; 6000 N REF208 ! PARAMETER G(GAS,UO2;0) 298.15 +UO2GAS#+RTLNP#; 6000 N REF209 ! PARAMETER G(GAS,UO3;0) 298.15 +UO3GAS#+RTLNP#; 6000 N REF210 ! PHASE IONIC_LIQUID:Y % 2 6 4 ! CONSTITUENT IONIC_LIQUID:Y :U+4 : O-2,VA,O : ! PARAMETER G(IONIC_LIQUID,U+4:O-2;0) 298.15 +2*LOWLIQ#; 2.60000E+03 Y +2*O2ULIQ#; 6000 N REF425 ! PARAMETER G(IONIC_LIQUID,U+4:VA;0) 298.15 +GLIQUU#; 6000 N REF10 ! PARAMETER G(IONIC_LIQUID,O;0) 298.15 +GHSEROO#-2648.9+31.44*T; 6000 N REF10 ! PARAMETER G(IONIC_LIQUID,U+4:O-2,VA;0) 298.15 +1773475.9-516*T; 6000 N REF425 ! PARAMETER G(IONIC_LIQUID,U+4:O-2,VA;1) 298.15 +46774.9-120.37888*T; 6000 N REF425 ! PARAMETER G(IONIC_LIQUID,U+4:O-2,VA;2) 298.15 -500000; 6000 N REF425 ! PARAMETER G(IONIC_LIQUID,U+4:O-2,O;0) 298.15 -370000; 6000 N REF425 ! TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! PHASE BCC_A2 %& 2 1 3 ! CONSTITUENT BCC_A2 :U : O,VA% : ! PARAMETER G(BCC_A2,U:O;0) 298.15 +GBCCUU#+GHSEROO#+100000; 6000 N REF70 ! PARAMETER G(BCC_A2,U:VA;0) 298.15 +GBCCUU#; 6000 N REF10 ! PHASE C1_MO2 % 3 1 2 1 ! CONSTITUENT C1_MO2 :U+3,U+4%,U+5 : O-2%,VA : O-2,VA% : ! PARAMETER G(C1_MO2,U+3:O-2:O-2;0) 298.15 +G3OO#; 6000 N REF425 ! PARAMETER G(C1_MO2,U+4:O-2:O-2;0) 298.15 +G4OO#; 6000 N REF425 ! PARAMETER G(C1_MO2,U+5:O-2:O-2;0) 298.15 +G5OO#; 6000 N REF425 ! PARAMETER G(C1_MO2,U+3:VA:O-2;0) 298.15 100000; 6000 N REF425 ! PARAMETER G(C1_MO2,U+4:VA:O-2;0) 298.15 100000; 6000 N REF425 ! PARAMETER G(C1_MO2,U+5:VA:O-2;0) 298.15 100000; 6000 N REF425 ! PARAMETER G(C1_MO2,U+3:O-2:VA;0) 298.15 +G3OV#; 6000 N REF425 ! PARAMETER G(C1_MO2,U+4:O-2:VA;0) 298.15 +G4OV#; 6000 N REF425 ! PARAMETER G(C1_MO2,U+5:O-2:VA;0) 298.15 +G5OV#; 6000 N REF425 ! PARAMETER G(C1_MO2,U+3:VA:VA;0) 298.15 +G3VV#; 6000 N REF425 ! PARAMETER G(C1_MO2,U+4:VA:VA;0) 298.15 +G4VV#; 6000 N REF425 ! PARAMETER G(C1_MO2,U+5:VA:VA;0) 298.15 +G5VV#; 6000 N REF425 ! PARAMETER G(C1_MO2,U+4,U+5:O-2:O-2;0) 298.15 -124936.9-21.6838*T; 6000 N REF425 ! PARAMETER G(C1_MO2,U+3,U+4:O-2:VA;0) 298.15 40133.7; 6000 N REF425 ! PARAMETER G(C1_MO2,U+3,U+4:O-2:VA;1) 298.15 1076.4; 6000 N REF425 ! TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! PHASE FCC_A1 %' 2 1 1 ! CONSTITUENT FCC_A1 :U : O,VA : ! PARAMETER G(FCC_A1,U:O;0) 298.15 -504526+100*T+GHSEROO#+GHSERUU#; 6000 N REF0 ! PARAMETER G(FCC_A1,U:VA;0) 298.15 +GFCCUU#; 3.00000E+03 N REF10 ! PHASE ORTHORHOMBIC_A20 % 1 1.0 ! CONSTITUENT ORTHORHOMBIC_A20 :U% : ! PARAMETER G(ORTHORHOMBIC_A20,U;0) 298.15 +GHSERUU#; 4.00000E+03 N REF10 ! PHASE TETRAGONAL_U % 1 1.0 ! CONSTITUENT TETRAGONAL_U :U% : ! PARAMETER G(TETRAGONAL_U,U;0) 298.15 +GTETUU#; 3.00000E+03 N REF10 ! PHASE U3O8_S1 % 2 8 3 ! CONSTITUENT U3O8_S1 :O : U : ! PARAMETER G(U3O8_S1,O:U;0) 298.15 +GU3O8#; 6000 N REF425 ! PHASE U3O8_S2 % 2 8 3 ! CONSTITUENT U3O8_S2 :O : U : ! PARAMETER G(U3O8_S2,O:U;0) 298.15 +GU3O8#+135-.279503106*T; 6000 N REF212 ! PHASE U3O8_S3 % 2 8 3 ! CONSTITUENT U3O8_S3 :O : U : ! PARAMETER G(U3O8_S3,O:U;0) 298.15 +GU3O8#+283-.540066486*T; 6000 N REF212 ! PHASE U3O8_S4 % 2 8 3 ! CONSTITUENT U3O8_S4 :O : U : ! PARAMETER G(U3O8_S4,O:U;0) 298.15 +GU3O8#+597-.918379739*T; 6000 N REF212 ! PHASE U4O9_S1 % 2 9 4 ! CONSTITUENT U4O9_S1 :O : U : ! PARAMETER G(U4O9_S1,O:U;0) 298.15 +GU4O9#; 6000 N REF425 ! PHASE U4O9_S2 % 2 9 4 ! CONSTITUENT U4O9_S2 :O : U : ! PARAMETER G(U4O9_S2,O:U;0) 298.15 +GU4O9#+2594-7.45402299*T; 6000 N REF213 ! PHASE U4O9_S3 % 2 9 4 ! CONSTITUENT U4O9_S3 :O : U : ! PARAMETER G(U4O9_S3,O:U;0) 298.15 +GU4O9#+2684.25-7.5602*T; 6000 N REF213 ! PHASE UO3 % 2 3 1 ! CONSTITUENT UO3 :O : U : ! PARAMETER G(UO3,O:U;0) 298.15 -1260394.62+616.475675*T -105.7368*T*LN(T)+.0104274*T**2-3.18099167E-06*T**3+868736*T**(-1); 3.00000E+03 N REF211 ! LIST_OF_REFERENCES NUMBER SOURCE REF174 'O1 JANAF 1982; ASSESSMENT DATED 3/77 SGTE OXYGEN , from SSUB' REF175 'O2 T.C.R.A.S. Class: 1 OXYGEN , from SSUB' REF176 'O3 T.C.R.A.S. Class: 4 OZONE , from SSUB' REF10 'A T Dinsdale, SGTE Data for Pure Elements, Calphad 15(1991)4 p 317-425; also in NPL Report DMA(A)195 Rev. August 1990' REF160 'U1 T.C.R.A.S Class: 4 Data provided by T.C.R.A.S. in 2000, from SSUB' REF208 'O1U1 T.C.R.A.S Class: 6 Data provided by T.C.R.A.S. in 2000, from SSUB, different of Tbase' REF209 'O2U1 T.C.R.A.S. Class: 6 URANIUM DIOXIDE , from SSUB, slightly different of Tbase' REF210 'O3U1 T.C.R.A.S Class: 6 Data provided by T.C.R.A.S. in 2000, from SSUB, different of Tbase' REF425 'C. Guéneau, N. Dupin, B. Sundman, C. Martial, J.-C. Dumas, S. Gossé,2 S. Chatain, F. De Bruycker, D. Manara, R.J.M. Konings, J. Nucl. Mat. 419 (1-3), 145-167 (2011); C-O-Pu-U' REF70 'fixing some parameters of low importance' REF211 'O3U1 T.C.R.A.S. Class: 7 URANIUM TRIOXIDE, from SSUB' REF212 'SSUB 3-URANIUM 8-OXIDE : M.H.Rand March 1994, taken from Cordfunke. In the fuelbase, the expression relative to the alpha form has been kept identical to SSUB for the higher temperatures forms but the alpha form expression has been modified in 11GUE' REF213 'SSUB 4-URANIUM 9-OXIDE : M.H.Rand March 1994, taken from Cordfunke. In the fuelbase, the expression relative to the alpha form has been kept identical to SSUB for beta and to 08GUE for gamma but the alpha form expression has been modified in 11GUE' ! ================================================ FILE: examples/macros/SGTE-unary1991-2010.TDB ================================================ $ Database file written 2021- 5- 4 $ From database: PURE5 ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT AC 1_MOLE_AC(AC_S) 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT AG FCC_A1 1.0787E+02 5.7446E+03 4.2551E+01! ELEMENT AL FCC_A1 2.6982E+01 4.5773E+03 2.8322E+01! ELEMENT AM DHCP 2.4306E+02 0.0000E+00 0.0000E+00! ELEMENT AR 1_MOLE_AR(GAS) 3.9948E+01 0.0000E+00 3.6982E+01! ELEMENT AS RHOMBOHEDRAL_A7 7.4922E+01 0.0000E+00 0.0000E+00! ELEMENT AT 1/2_MOLE_AT2(AT2_S) 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT AU FCC_A1 1.9697E+02 6.0166E+03 4.7488E+01! ELEMENT B BETA_RHOMBO_B 1.0811E+01 1.2220E+03 5.9000E+00! ELEMENT BA BCC_A2 1.3733E+02 0.0000E+00 0.0000E+00! ELEMENT BE HCP_A3 9.0122E+00 0.0000E+00 0.0000E+00! ELEMENT BI RHOMBOHEDRAL_A7 2.0898E+02 6.4266E+03 5.6735E+01! ELEMENT BR 1/2_MOLE_BR2(LIQ) 7.9904E+01 1.2260E+04 7.6105E+01! ELEMENT C GRAPHITE 1.2011E+01 1.0540E+03 5.7400E+00! ELEMENT CA FCC_A1 4.0078E+01 6.1965E+03 4.1589E+01! ELEMENT CD HCP_A3 1.1241E+02 6.2509E+03 5.1798E+01! ELEMENT CE FCC_A1 1.4011E+02 0.0000E+00 0.0000E+00! ELEMENT CF 1_MOLE_CF(CF_S) 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT CL 1/2_MOLE_CL2(GAS) 3.5453E+01 4.5900E+03 1.1148E+02! ELEMENT CM 1_MOLE_CM(CM_S) 2.4700E+02 0.0000E+00 1.7200E+01! ELEMENT CO HCP_A3 5.8933E+01 0.0000E+00 0.0000E+00! ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01! ELEMENT CS BCC_A2 1.3291E+02 7.7153E+03 8.5149E+01! ELEMENT CU FCC_A1 6.3546E+01 5.0041E+03 3.3150E+01! ELEMENT D 1/2_MOLE_D2_GAS 2.0140E+00 0.0000E+00 1.7310E+01! ELEMENT DY HCP_A3 1.6250E+02 0.0000E+00 0.0000E+00! ELEMENT ER HCP_A3 1.6726E+02 7.3923E+03 7.3178E+01! ELEMENT ES 1_MOLE_ES(ES_S) 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT EU BCC_A2 1.5197E+02 0.0000E+00 8.0793E+01! ELEMENT F 1/2_MOLE_F2(GAS) 1.8998E+01 4.4125E+03 1.0134E+02! ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! ELEMENT FM 1_MOLE_FM(FM_S) 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT FR 1_MOLE_FR(FR_S) 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT GA ORTHORHOMBIC_GA 6.9723E+01 5.5731E+03 4.0828E+01! ELEMENT GD HCP_A3 1.5725E+02 0.0000E+00 0.0000E+00! ELEMENT GE DIAMOND_A4 7.2610E+01 4.6275E+03 3.1087E+01! ELEMENT H 1/2_MOLE_H2(GAS) 1.0079E+00 4.2340E+03 6.5285E+01! ELEMENT HE 1_MOLE_HE(GAS) 4.0026E+00 0.0000E+00 3.0124E+01! ELEMENT HF HCP_A3 1.7849E+02 0.0000E+00 0.0000E+00! ELEMENT HG LIQUID 2.0059E+02 0.0000E+00 0.0000E+00! ELEMENT HO HCP_A3 1.6493E+02 0.0000E+00 0.0000E+00! ELEMENT I 1/2_MOLE_I2(I2_S) 1.2690E+02 6.5980E+03 1.1614E+02! ELEMENT IN TETRAGONAL_A6 1.1482E+02 6.6100E+03 5.7650E+01! ELEMENT IR FCC_A1 1.9222E+02 5.2677E+03 3.5505E+01! ELEMENT K BCC_A2 3.9098E+01 7.0835E+03 6.4672E+01! ELEMENT KR 1_MOLE_KR(GAS) 8.3800E+01 0.0000E+00 3.9191E+01! ELEMENT LA DHCP 1.3891E+02 0.0000E+00 0.0000E+00! ELEMENT LI BCC_A2 6.9410E+00 4.6233E+03 2.9095E+01! ELEMENT LU HCP_A3 1.7497E+02 0.0000E+00 0.0000E+00! ELEMENT MG HCP_A3 2.4305E+01 4.9980E+03 3.2671E+01! ELEMENT MN CBCC_A12 5.4938E+01 4.9960E+03 3.2008E+01! ELEMENT MO BCC_A2 9.5940E+01 4.5890E+03 2.8560E+01! ELEMENT N 1/2_MOLE_N2(GAS) 1.4007E+01 4.3350E+03 9.5751E+01! ELEMENT NA BCC_A2 2.2990E+01 6.4475E+03 5.1447E+01! ELEMENT NB BCC_A2 9.2906E+01 5.2200E+03 3.6270E+01! ELEMENT ND DHCP 1.4424E+02 0.0000E+00 0.0000E+00! ELEMENT NE 1_MOLE_NE(GAS) 2.0179E+01 0.0000E+00 3.4947E+01! ELEMENT NI FCC_A1 5.8690E+01 4.7870E+03 2.9796E+01! ELEMENT NP ORTHORHOMBIC_AC 2.3705E+02 0.0000E+00 0.0000E+00! ELEMENT O 1/2_MOLE_O2(GAS) 1.5999E+01 4.3410E+03 1.0252E+02! ELEMENT OS HCP_A3 1.9020E+02 0.0000E+00 3.2635E+01! ELEMENT P WHITE_P 3.0974E+01 0.0000E+00 0.0000E+00! ELEMENT PA BCT_AA 2.3104E+02 0.0000E+00 0.0000E+00! ELEMENT PB FCC_A1 2.0720E+02 6.8785E+03 6.4785E+01! ELEMENT PD FCC_A1 1.0642E+02 5.4685E+03 3.7823E+01! ELEMENT PM 1_MOLE_PM(PM_S) 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT PO 1_MOLE_PO(PO_S) 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT PR DHCP 1.4091E+02 0.0000E+00 0.0000E+00! ELEMENT PT FCC_A1 1.9508E+02 5.7237E+03 4.1631E+01! ELEMENT PU ALPHA_PU 2.4406E+02 0.0000E+00 0.0000E+00! ELEMENT RA 1_MOLE_RA(RA_S) 2.2603E+02 0.0000E+00 0.0000E+00! ELEMENT RB BCC_A2 8.5468E+01 7.4894E+03 7.6776E+01! ELEMENT RE HCP_A3 1.8621E+02 5.3555E+03 3.6526E+01! ELEMENT RH FCC_A1 1.0291E+02 4.9204E+03 3.1505E+01! ELEMENT RN 1_MOLE_RN(GAS) 2.2200E+02 0.0000E+00 4.2100E+01! ELEMENT RU HCP_A3 1.0107E+02 4.6024E+03 2.8535E+01! ELEMENT S ORTHORHOMBIC_S 3.2066E+01 0.0000E+00 0.0000E+00! ELEMENT SB RHOMBOHEDRAL_A7 1.2175E+02 5.8702E+03 4.5522E+01! ELEMENT SC HCP_A3 4.4956E+01 0.0000E+00 0.0000E+00! ELEMENT SE HEXAGONAL_A8 7.8960E+01 5.5145E+03 4.1966E+01! ELEMENT SI DIAMOND_A4 2.8085E+01 3.2175E+03 1.8820E+01! ELEMENT SM RHOMBOHEDRAL_C19 1.5036E+02 0.0000E+00 0.0000E+00! ELEMENT SN BCT_A5 1.1871E+02 6.3220E+03 5.1195E+01! ELEMENT SR FCC_A1 8.7620E+01 0.0000E+00 0.0000E+00! ELEMENT T 1/2_MOLE_T2(GAS) 3.0160E+00 0.0000E+00 0.0000E+00! ELEMENT TA BCC_A2 1.8095E+02 5.6819E+03 4.1472E+01! ELEMENT TB HCP_A3 1.5893E+02 0.0000E+00 0.0000E+00! ELEMENT TC HCP_A3 9.7907E+01 0.0000E+00 0.0000E+00! ELEMENT TE HEXAGONAL_A8 1.2760E+02 6.1212E+03 4.9497E+01! ELEMENT TH FCC_A1 2.3204E+02 0.0000E+00 0.0000E+00! ELEMENT TI HCP_A3 4.7880E+01 4.8100E+03 3.0648E+01! ELEMENT TL HCP_A3 2.0438E+02 6.8283E+03 6.4183E+01! ELEMENT TM HCP_A3 1.6893E+02 7.3973E+03 7.4015E+01! ELEMENT U ORTHORHOMBIC_A20 2.3803E+02 0.0000E+00 0.0000E+00! ELEMENT V BCC_A2 5.0941E+01 4.5070E+03 3.0890E+01! ELEMENT W BCC_A2 1.8385E+02 4.9700E+03 3.2620E+01! ELEMENT XE 1_MOLE_XE(GAS) 1.3129E+02 0.0000E+00 4.0519E+01! ELEMENT Y HCP_A3 8.8906E+01 0.0000E+00 0.0000E+00! ELEMENT YB FCC_A1 1.7304E+02 0.0000E+00 0.0000E+00! ELEMENT ZN HCP_A3 6.5390E+01 5.6568E+03 4.1631E+01! ELEMENT ZR HCP_A3 9.1224E+01 5.5663E+03 3.9181E+01! SPECIES AT2 AT2! SPECIES BR2 BR2! SPECIES CL2 CL2! SPECIES D2 D2! SPECIES F2 F2! SPECIES FR2 FR2! SPECIES H2 H2! SPECIES I2 I2! SPECIES N2 N2! SPECIES O2 O2! SPECIES S2 S2! SPECIES T2 T2! SPECIES T3 T3! SPECIES XE2 XE2! FUNCTION GHSERAC 298.15 -7572.61519+100.596131*T-23.799*T*LN(T) -.00536685*T**2-20*T**(-1); 1323 Y -22258.8152+235.419006*T-42*T*LN(T); 5000 N ! FUNCTION GGASAC1 298.15 +394647.668-60.6626295*T-19.162*T*LN(T) +.00210035*T**2-3.30984E-06*T**3-52110*T**(-1); 500 Y +404538.095-237.073904*T+8.974*T*LN(T)-.0333095*T**2 +5.00220167E-06*T**3-701330*T**(-1); 900 Y +361650.543+216.644574*T-56.947*T*LN(T)+.0117893*T**2 -7.96733333E-07*T**3+4533895*T**(-1); 1700 Y +407253.396-43.3903783*T-22.778*T*LN(T)+6.1595E-04*T**2 -1.2757E-07*T**3-6712740*T**(-1); 3300 Y +448231.858-220.95179*T-.374*T*LN(T)-.0047424005*T**2 +1.09546667E-07*T**3-20498780*T**(-1); 6000 N ! FUNCTION GLIQAG 298.15 +GHSERAG#+11025.076-8.89102*T-1.033905E-20*T**7; 1234.93 Y -3587.111+180.964656*T-33.472*T*LN(T); 3000 N ! FUNCTION GHSERAG 298.15 -7209.512+118.202013*T-23.8463314*T*LN(T) -.001790585*T**2-3.98587E-07*T**3-12011*T**(-1); 1234.93 Y -15095.252+190.266404*T-33.472*T*LN(T)+1.411773E+29*T**(-9); 3000 N ! FUNCTION GBCCAG 298.15 +GHSERAG#+3400-1.05*T; 3000 N ! FUNCTION GHCPAG 298.15 +GHSERAG#+300+.3*T; 3000 N ! FUNCTION GLIQAL 298.15 +GHSERAL#+11005.045-11.84185*T+7.9337E-20*T**7; 933.47 Y -795.991+177.430209*T-31.748192*T*LN(T); 2900 N ! FUNCTION GHSERAL 298.15 -7976.15+137.093038*T-24.3671976*T*LN(T) -.001884662*T**2-8.77664E-07*T**3+74092*T**(-1); 700 Y -11276.24+223.048446*T-38.5844296*T*LN(T)+.018531982*T**2 -5.764227E-06*T**3+74092*T**(-1); 933.47 Y -11278.361+188.684136*T-31.748192*T*LN(T)-1.230622E+28*T**(-9); 2900 N ! FUNCTION GBCCAL 298.15 +GHSERAL#+10083-4.813*T; 2900 N ! FUNCTION GHCPAL 298.15 +GHSERAL#+5481-1.8*T; 2900 N ! FUNCTION GLIQAM 298.15 +GHSERAM#+19910.7-14.1205*T; 3000 N ! FUNCTION GFCCAM 298.15 -5224.899+99.204329*T-23.1377*T*LN(T) -.00294694*T**2-6.64773E-07*T**3-18507*T**(-1); 1018 Y -2935.853+73.800069*T-19.4406*T*LN(T)-.005418*T**2-3.75233E-07*T**3 -260435*T**(-1); 1548.70 Y -22179.593+241.353807*T-41.84*T*LN(T); 3000 N ! FUNCTION GBCCAM 298.15 -665.396+85.114354*T-21.1868*T*LN(T) -.0055995*T**2-5.41033E-07*T**3-30424*T**(-1); 999 Y -7800.332+63.93115*T-15.8832*T*LN(T)-.0190671*T**2+2.291117E-06*T**3 +2287195*T**(-1); 1339 Y -13153.887+219.600832*T-39.748*T*LN(T); 1449 Y +70352.138-326.394464*T+33.413*T*LN(T)-.02736485*T**2 +1.801717E-06*T**3-17379450*T**(-1); 2183.60 Y -16925.244+237.367028*T-41.84*T*LN(T); 3000 N ! FUNCTION GHSERAM 298.15 -6639.201+89.645685*T-21.1868*T*LN(T) -.00559955*T**2-5.41038E-07*T**3-30424*T**(-1); 1329 Y -21702.938+241.107269*T-41.84*T*LN(T); 3000 N ! FUNCTION GHSERAR 298.15 -6197.37857-15.6250184*T-20.78611*T*LN(T); 6000 N ! FUNCTION GLIQAS 298.15 +GHSERAS#+24442.9-22.424679*T; 1200 N ! FUNCTION GFCCAS 298.15 +GHSERAS#+24874-14.74*T; 1200 N ! FUNCTION GBCCAS 298.15 +GHSERAS#+24874-16.1*T; 1200 N ! FUNCTION GHCPAS 298.15 +GHSERAS#+24874-14*T; 1200 N ! FUNCTION GHSERAS 298.15 -7270.447+122.211069*T-23.3144*T*LN(T) -.00271613*T**2+11600*T**(-1); 1090 Y -10454.913+163.457433*T-29.216037*T*LN(T); 1200 N ! FUNCTION GHSERAT 298.15 +.5*GSOLAT2#; 1000 N ! FUNCTION GGASAT1 298.15 +107251.654-47.8507551*T-20.786*T*LN(T); 2200 Y +106809.233-44.861522*T-21.185*T*LN(T)+1.413E-04*T**2 -8.74833333E-09*T**3+68430*T**(-1); 6000 N ! FUNCTION GGASAT2 298.15 +98748.2165-26.3818276*T-37.39*T*LN(T) -3.393E-04*T**2-7.28666667E-08*T**3+10425*T**(-1); 1400 Y +90660.8304+12.5493655*T-42.258*T*LN(T)+2.9515E-04*T**2 +9.71333333E-09*T**3+2088660*T**(-1); 3200 Y +93624.973-9.03098507*T-39.433*T*LN(T)-5.026E-04*T**2 +4.55333333E-08*T**3+2495695*T**(-1); 6000 N ! FUNCTION GLIQAU 298.15 +GHSERAU#+12552-9.385866*T; 3200 N ! FUNCTION GHSERAU 298.15 -6938.856+106.830098*T-22.75455*T*LN(T) -.00385924*T**2+3.79625E-07*T**3-25097*T**(-1); 929.40 Y -93586.481+1021.69543*T-155.706745*T*LN(T)+.08756015*T**2 -1.1518713E-05*T**3+10637210*T**(-1); 1337.33 Y +314067.829-2016.37825*T+263.252259*T*LN(T)-.118216828*T**2 +8.923844E-06*T**3-67999832*T**(-1); 1735.80 Y -12133.783+165.272524*T-30.9616*T*LN(T); 3200 N ! FUNCTION GBCCAU 298.15 +GHSERAU#+4250-1.1*T; 3200 N ! FUNCTION GHCPAU 298.15 +GHSERAU#+240.75+1.6*T; 3200 N ! FUNCTION GLIQBB 298.15 +40723.275+86.843839*T-15.6641*T*LN(T) -.006864515*T**2+6.18878E-07*T**3+370843*T**(-1); 500 Y +41119.703+82.101722*T-14.9827763*T*LN(T)-.007095669*T**2 +5.07347E-07*T**3+335484*T**(-1); 2348 Y +28842.012+200.94731*T-31.4*T*LN(T); 6000 N ! FUNCTION GFCCBB 298.15 +GHSERBB#+43514-12.217*T; 6000 N ! FUNCTION GBCCBB 298.15 +GHSERBB#+43514-12.217*T; 3000 N ! FUNCTION GHCPBB 298.15 +GHSERBB#+50208-9.706*T; 6000 N ! FUNCTION GHSERBB 298.15 -7735.284+107.111864*T-15.6641*T*LN(T) -.006864515*T**2+6.18878E-07*T**3+370843*T**(-1); 1100 Y -16649.474+184.801744*T-26.6047*T*LN(T)-7.9809E-04*T**2-2.556E-08*T**3 +1748270*T**(-1); 2348 Y -36667.582+231.336244*T-31.5957527*T*LN(T)-.00159488*T**2 +1.34719E-07*T**3+11205883*T**(-1); 3000 Y -21530.653+222.396264*T-31.4*T*LN(T); 6000 N ! FUNCTION GLIQBA 298.15 -9738.988+229.540143*T-43.4961089*T*LN(T) -.002346416*T**2+9.91223E-07*T**3+723016*T**(-1); 1000 Y -7381.093+235.49642*T-45.103*T*LN(T)+.002154*T**2+2.7E-11*T**3 -365*T**(-1); 2995 Y +11940.282+132.212*T-32.2*T*LN(T); 4000 N ! FUNCTION GFCCBA 298.15 +GHSERBA#+1800+.6*T; 4000 N ! FUNCTION GHSERBA 298.15 -17685.226+233.78606*T-42.889*T*LN(T) -.0018314*T**2-9.5E-11*T**3+705880*T**(-1); 1000 Y -64873.614+608.188389*T-94.2824199*T*LN(T)+.019504772*T**2 -1.051353E-06*T**3+8220192*T**(-1); 2995 Y +8083.889+136.780042*T-32.2*T*LN(T); 4000 N ! FUNCTION GHCPBA 298.15 +GHSERBA#+2000+1.3*T; 4000 N ! FUNCTION GLIQBE 298.15 +7511.838+120.362788*T-20.0497038*T*LN(T) -.004821347*T**2+4.15958E-07*T**3+281044*T**(-1); 1560 Y +5364.713+156.961141*T-25.486*T*LN(T)-.0010572*T**2-1.117E-09*T**3 +15920*T**(-1); 3000 N ! FUNCTION GFCCBE 298.15 +GHSERBE#+6349-1.085*T; 3000 N ! FUNCTION GBCCBE 298.15 -1076.057+109.411712*T-17.1727841*T*LN(T) -.008672487*T**2+9.61427E-07*T**3+242309*T**(-1); 1527 Y -6970.378+196.411689*T-30*T*LN(T); 1560 Y -2609.973+178.131722*T-27.7823769*T*LN(T)-1.03629E-04*T**2 -5.9331E-08*T**3-1250847*T**(-1); 3000 N ! FUNCTION GHSERBE 298.15 -8553.651+137.560219*T-21.204*T*LN(T) -.00284715*T**2-1.60413E-07*T**3+293690*T**(-1); 1527 Y -121305.858+772.405844*T-103.9843*T*LN(T)+.021078651*T**2 -1.119065E-06*T**3+27251743*T**(-1); 3000 N ! FUNCTION GLIQBI 298.15 +GHSERBI#+11246.017-20.636399*T-5.9608E-19*T**7; 544.55 Y +40629.667-400.415652*T+49.678*T*LN(T)-.0730245*T**2 +1.3052833E-05*T**3-3544705*T**(-1); 800 Y +250.689+162.14485*T-36.041*T*LN(T)+.0074641*T**2-1.05047E-06*T**3 +5175*T**(-1); 1200 Y +3755.434+103.960336*T-27.196*T*LN(T); 3000 N ! FUNCTION GFCCBI 298.15 +GHSERBI#+9900-12.5*T; 3000 N ! FUNCTION GBCCBI 298.15 +GHSERBI#+11297-13.9*T; 3000 N ! FUNCTION GHCPBI 298.15 +GHSERBI#+9900-11.8*T; 3000 N ! FUNCTION GHSERBI 298.15 -7817.776+128.418925*T-28.4096529*T*LN(T) +.012338888*T**2-8.381598E-06*T**3; 544.55 Y +29293.369-379.605174*T+49.678*T*LN(T)-.0730245*T**2 +1.3052833E-05*T**3-3544705*T**(-1)+1.66309E+25*T**(-9); 800 Y -11085.609+182.955328*T-36.041*T*LN(T)+.0074641*T**2-1.05047E-06*T**3 +5175*T**(-1)+1.66309E+25*T**(-9); 1200 Y -7580.864+124.770814*T-27.196*T*LN(T)+1.66309E+25*T**(-9); 3000 N ! FUNCTION GGASBR2 298.15 +19077.8949+9.66580068*T-37.98897*T*LN(T) +3.824891E-04*T**2-1.125315E-07*T**3+79565.75*T**(-1); 2100 Y +61807.3693-219.344992*T-8.183614*T*LN(T)-.008666065*T**2 +3.90366833E-07*T**3-11184485*T**(-1); 4300 Y -203404.068+619.894219*T-109.6234*T*LN(T)+.008605745*T**2 -1.61313517E-07*T**3+1.1921565E+08*T**(-1); 6000 N ! FUNCTION GHSERBR 298.15 +.5*GLIQBR2#; 6000 N ! FUNCTION GLIQCC 298.15 +GHSERCC#+117369-24.63*T; 6000 N ! FUNCTION GHSERCC 298.15 -17368.441+170.73*T-24.3*T*LN(T)-4.723E-04*T**2 +2562600*T**(-1)-2.643E+08*T**(-2)+1.2E+10*T**(-3); 6000 N ! FUNCTION GDIACC 298.15 -16359.441+175.61*T-24.31*T*LN(T)-4.723E-04*T**2 +2698000*T**(-1)-2.61E+08*T**(-2)+1.11E+10*T**(-3); 6000 N ! FUNCTION GGASC1 298.15 +710430.933-17.7062919*T-20.97529*T*LN(T) +1.998237E-04*T**2-3.34617167E-08*T**3+1680.6515*T**(-1); 3400 Y +698015.711+2.57175186*T-23.05071*T*LN(T)-6.04604E-05*T**2 +6.74291667E-10*T**3+8558245*T**(-1); 10000 Y +736197.571-32.7975309*T-19.44529*T*LN(T)-1.5396035E-04*T**2 -6.15402167E-11*T**3-56188350*T**(-1); 20000 N ! FUNCTION GLIQCA 298.15 +5844.846+62.4838*T-16.3138*T*LN(T) -.01110455*T**2-133574*T**(-1); 500 Y +7838.856+18.2979*T-8.9874787*T*LN(T)-.02266537*T**2+3.338303E-06*T**3 -230193*T**(-1); 1115 Y -2654.938+188.9223*T-35*T*LN(T); 3001 N ! FUNCTION GHSERCA 298.15 -4955.062+72.794266*T-16.3138*T*LN(T) -.01110455*T**2-133574*T**(-1); 1115 Y -107304.428+799.982066*T-114.292247*T*LN(T)+.023733814*T**2 -1.2438E-06*T**3+18245540*T**(-1); 3000 Y -3703.12+192.63995*T-35*T*LN(T); 3001 N ! FUNCTION GBCCCA 298.15 -7020.852+142.970155*T-28.2541*T*LN(T) +.0072326*T**2-4.500217E-06*T**3+60578*T**(-1); 716 Y +1640.475+1.999694*T-6.276*T*LN(T)-.0161921*T**2-523000*T**(-1); 1115 Y -142331.096+1023.54905*T-143.872698*T*LN(T)+.032543127*T**2 -1.704079E-06*T**3+25353771*T**(-1); 3000 Y +321.63+189.433057*T-35*T*LN(T); 3001 N ! FUNCTION GHCPCA 298.15 +GHSERCA#+500+.7*T; 3001 N ! FUNCTION GLIQCD 298.15 -955.025+89.209282*T-22.0442408*T*LN(T) -.006273908*T**2-6966*T**(-1); 400 Y +21716.884-371.046869*T+53.1313898*T*LN(T)-.115159917*T**2 +2.8899781E-05*T**3-1271815*T**(-1); 594.22 Y -3252.303+138.251107*T-29.7064*T*LN(T); 1600 N ! FUNCTION GFCCCD 298.15 +GHSERCD#+892.3-.92*T; 1600 N ! FUNCTION GBCCCD 298.15 +GHSERCD#+1000; 1600 N ! FUNCTION GHSERCD 298.15 -7083.469+99.506198*T-22.0442408*T*LN(T) -.006273908*T**2-6966*T**(-1); 594.22 Y -20064.971+256.812233*T-45.1611543*T*LN(T)+.008832011*T**2 -8.99604E-07*T**3+1241290*T**(-1); 1500 Y -9027.489+148.20548*T-29.7064*T*LN(T); 1600 N ! FUNCTION GLIQCE 298.15 +4117.865-11.423898*T-7.5383948*T*LN(T) -.02936407*T**2+4.827734E-06*T**3-198834*T**(-1); 1000 Y -6730.605+183.023193*T-37.6978*T*LN(T); 4000 N ! FUNCTION GHSERCE 298.15 -7160.519+84.23022*T-22.3664*T*LN(T) -.0067103*T**2-3.20773E-07*T**3-18117*T**(-1); 1000 Y -79678.506+659.4604*T-101.32248*T*LN(T)+.026046487*T**2 -1.930297E-06*T**3+11531707*T**(-1); 2000 Y -14198.639+190.370192*T-37.6978*T*LN(T); 4000 N ! FUNCTION GBCCCE 298.15 -1354.69-5.21501*T-7.7305867*T*LN(T) -.029098402*T**2+4.784299E-06*T**3-196303*T**(-1); 1000 Y -12101.106+187.449688*T-37.6142*T*LN(T); 1072 Y -11950.375+186.333811*T-37.4627992*T*LN(T)-5.7145E-05*T**2 +2.348E-09*T**3-25897*T**(-1); 4000 N ! FUNCTION GHCPCE 298.15 +GHSERCE#+300; 4000 N ! FUNCTION GHSERCF 298.15 -8469.90215+104.280719*T-27.49949*T*LN(T) +7.74221E-04*T**2-3.00430667E-06*T**3+26908.455*T**(-1); 700 Y -8395.62854+100.938938*T-26.83568*T*LN(T)-.0012952475*T**2 -2.20727333E-06*T**3; 1000 Y +38885.0956-780.991201*T+110.0211*T*LN(T)-.13316665*T**2 +1.89404E-05*T**3; 1173 N ! FUNCTION GHSERCL 298.15 +.5*GGASCL2#; 6000 N ! FUNCTION GHSERCM 298.15 -7869.70506+98.7537088*T-25.104*T*LN(T) -.00433044*T**2; 1550 Y -10436.223+155.168758*T-33.472*T*LN(T); 1618 Y -21267.7622+211.327719*T-40.1664*T*LN(T); 4000 N ! FUNCTION GGASCM1 298.15 +377291.101+12.0602152*T-31.00442*T*LN(T) -.001280547*T**2+1.43695533E-06*T**3+129049.4*T**(-1); 700 Y +380454.248-.173822933*T-30.03214*T*LN(T)+.0034346335*T**2 -4.32347E-07*T**3-380009.4*T**(-1); 1700 Y +380329.187-11.3576458*T-28.24452*T*LN(T)+.0018205105*T**2 -2.34110667E-07*T**3; 4200 Y +837692.339-1379.89321*T+135.9805*T*LN(T)-.02460472*T**2 +5.694885E-07*T**3-2.4083855E+08*T**(-1); 6000 N ! FUNCTION GLIQCO 298.15 +GHSERCO#+15085.037-8.931932*T-2.19801E-21*T**7; 1768 Y -846.61+243.599944*T-40.5*T*LN(T); 6000 N ! FUNCTION GFCCCO 298.15 +GHSERCO#+427.591-.615248*T; 6000 N ! FUNCTION GBCCCO 298.15 +GHSERCO#+2938-.7138*T; 6000 N ! FUNCTION GHSERCO 298.15 +310.241+133.36601*T-25.0861*T*LN(T) -.002654739*T**2-1.7348E-07*T**3+72527*T**(-1); 1768 Y -17197.666+253.28374*T-40.5*T*LN(T)+9.3488E+30*T**(-9); 6000 N ! FUNCTION GLIQCR 298.15 +GHSERCR#+24339.955-11.420225*T+2.37615E-21*T**7; 2180 Y -16459.984+335.616316*T-50*T*LN(T); 6000 N ! FUNCTION GFCCCR 298.15 +GHSERCR#+7284+.163*T; 6000 N ! FUNCTION GHSERCR 298.15 -8856.94+157.48*T-26.908*T*LN(T)+.00189435*T**2 -1.47721E-06*T**3+139250*T**(-1); 2180 Y -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6000 N ! FUNCTION GHCPCR 298.15 +GHSERCR#+4438; 6000 N ! FUNCTION GLIQCS 200 +GHSERCS#+2091.141-6.931035*T-3.56867E-18*T**7; 301.59 Y -11454.038+211.728844*T-46.7273304*T*LN(T)+.02043269*T**2 -4.074846E-06*T**3+181528*T**(-1); 2000 N ! FUNCTION GFCCCS 200 +GHSERCS#+500+1.3*T; 2000 N ! FUNCTION GHSERCS 200 -17373.82+436.899787*T-90.5212584*T*LN(T) +.2029422*T**2-1.27907669E-04*T**3+245245*T**(-1); 301.59 Y -13553.817+218.689955*T-46.7273304*T*LN(T)+.02043269*T**2 -4.074846E-06*T**3+181528*T**(-1)+7.8016E+21*T**(-9); 2000 N ! FUNCTION GHCPCS 200 +GHSERCS#+500+2*T; 2000 N ! FUNCTION GLIQCU 298.15 +GHSERCU#+12964.735-9.511904*T-5.8489E-21*T**7; 1357.77 Y -46.545+173.881484*T-31.38*T*LN(T); 3200 N ! FUNCTION GHSERCU 298.15 -7770.458+130.485235*T-24.112392*T*LN(T) -.00265684*T**2+1.29223E-07*T**3+52478*T**(-1); 1357.77 Y -13542.026+183.803828*T-31.38*T*LN(T)+3.64167E+29*T**(-9); 3200 N ! FUNCTION GBCCCU 298.15 +GHSERCU#+4017-1.255*T; 3200 N ! FUNCTION GHCPCU 298.15 +GHSERCU#+600+.2*T; 3200 N ! FUNCTION GHSERD1 298.15 +215521.121+15.8679816*T-20.78611*T*LN(T); 6000 N ! FUNCTION GHSERD2 298.15 -8456.47704+47.5447764*T-28.79321*T*LN(T) +5.47726E-04*T**2-6.60612667E-07*T**3-17075.99*T**(-1); 900 Y -9253.29324+36.5549968*T-26.69957*T*LN(T)-.003286203*T**2 +1.54000683E-07*T**3+326416.2*T**(-1); 2700 Y -486.276998+31.4394622*T-26.65651*T*LN(T)-.002130387*T**2 +4.763655E-08*T**3-5629765*T**(-1); 6200 Y -229545.933+430.175622*T-71.05596*T*LN(T)+.0014570765*T**2 -7.21575833E-10*T**3+2.0713865E+08*T**(-1); 10000 Y -111522.548+359.343028*T-64.5573*T*LN(T)+.0017405465*T**2 -1.28457033E-08*T**3-37551550*T**(-1); 19000 Y +667049.587-289.343336*T+1.813887*T*LN(T)-7.82167E-04*T**2 +5.17027667E-09*T**3-1.757773E+09*T**(-1); 20000 N ! FUNCTION GLIQDY 100 +5259.45264+94.7630477*T-26.3917167*T*LN(T) -7.61683657E-04*T**2-5.86914125E-07*T**3+4010.90565*T**(-1); 1000 Y +300126.971-2519.78614*T+341.302578*T*LN(T)-.196153225*T**2 +1.76197799E-05*T**3-43071677.5*T**(-1); 1685.15 Y -21864.7344+282.205014*T-49.9151*T*LN(T); 3000 N ! FUNCTION GBCCDY 100 -6428.98566+101.740796*T-26.3917167*T*LN(T) -7.61683657E-04*T**2-5.86914125E-07*T**3+4010.90565*T**(-1); 1000 Y +327500.062-2868.04585*T+391.515418*T*LN(T)-.224042148*T**2 +2.04076075E-05*T**3-48652656.5*T**(-1); 1654.15 Y -33708.7949+291.409631*T-50.208*T*LN(T); 1685.15 Y -40775.4966+330.318068*T-55.2811171*T*LN(T)+.0015254673*T**2 -7.7437116E-08*T**3+1776589.32*T**(-1); 3000 N ! FUNCTION GHSERDY 100 -7937.16586+102.307412*T-26.3917167*T*LN(T) -7.61683657E-04*T**2-5.86914125E-07*T**3+4010.90565*T**(-1); 1000 Y -13733.328+214.012934*T-43.8283359*T*LN(T)+.0166909801*T**2 -3.49702836E-06*T**3+.0173619874*T**(-1); 1654.15 Y -404681.371+2032.1415*T-272.123952*T*LN(T)+.0578301681*T**2 -2.76169148E-06*T**3+1.09616238E+08*T**(-1); 3000 N ! FUNCTION GLIQER 298.15 +10892.966+106.457118*T-28.3846744*T*LN(T) +9.95792E-04*T**2-9.52557E-07*T**3+9581*T**(-1); 500 Y +17912.678+.355564*T-12.0761776*T*LN(T)-.014414687*T**2 +1.316517E-06*T**3-528122*T**(-1); 1802 Y +747.131+187.623024*T-38.702*T*LN(T); 3200 N ! FUNCTION GBCCER 298.15 +GHSERER#+4600-2.494353*T; 3200 N ! FUNCTION GHSERER 298.15 -8489.136+116.698964*T-28.3846744*T*LN(T) +9.95792E-04*T**2-9.52557E-07*T**3+9581*T**(-1); 1802 Y -445688.206+2233.10212*T-298.135131*T*LN(T)+.065950553*T**2 -3.041405E-06*T**3+1.23973199E+08*T**(-1); 3200 N ! FUNCTION GHSERES 298.15 -9603.70094+106.74523*T-28.99*T*LN(T) -9.010025E-04*T**2-2.21979333E-07*T**3+129467.6*T**(-1); 1133 Y -16595.0333+167.712355*T-36.95309*T*LN(T); 1500 N ! FUNCTION GGASES1 298.15 +126680.446-61.4481604*T-20.83157*T*LN(T) +1.038889E-04*T**2-3.12514333E-08*T**3; 1300 N ! FUNCTION GLIQEU 298.15 -1482.46+128.661522*T-32.8418896*T*LN(T) +.00931735*T**2-4.006564E-06*T**3+102717*T**(-1); 400 Y +10972.726-103.688201*T+4.3501554*T*LN(T)-.036811218*T**2 +5.452934E-06*T**3-646908*T**(-1); 1095 Y -6890.641+175.517247*T-38.11624*T*LN(T); 1901 N ! FUNCTION GHSEREU 298.15 -9864.965+135.836737*T-32.8418896*T*LN(T) +.00931735*T**2-4.006564E-06*T**3+102717*T**(-1); 1095 Y -287423.476+2174.73304*T-309.357101*T*LN(T)+.114530917*T**2 -8.809866E-06*T**3+48455305*T**(-1); 1900 Y -13663.125+182.113799*T-38.11624*T*LN(T); 1901 N ! FUNCTION GHSERFF 298.15 +.5*GGASF2#; 6000 N ! FUNCTION GLIQFE 298.15 +GHSERFE#+12040.17-6.55843*T-3.67516E-21*T**7; 1811 Y -10838.83+291.302*T-46*T*LN(T); 6000 N ! FUNCTION GFCCFE 298.15 -236.7+132.416*T-24.6643*T*LN(T)-.00375752*T**2 -5.8927E-08*T**3+77359*T**(-1); 1811 Y -27097.3963+300.252559*T-46*T*LN(T)+2.78854E+31*T**(-9); 6000 N ! FUNCTION GHSERFE 298.15 +1225.7+124.134*T-23.5143*T*LN(T)-.00439752*T**2 -5.8927E-08*T**3+77359*T**(-1); 1811 Y -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6000 N ! FUNCTION GHCPFE 298.15 -2480.08+136.725*T-24.6643*T*LN(T)-.00375752*T**2 -5.8927E-08*T**3+77359*T**(-1); 1811 Y -29340.776+304.561559*T-46*T*LN(T)+2.78854E+31*T**(-9); 6000 N ! FUNCTION GHSERFM 298.15 -7435.38424+71.2921434*T-23.12029*T*LN(T) -.006376645*T**2+4.673305E-07*T**3; 1000 N ! FUNCTION GGASFM1 298.15 +136850.723-58.060785*T-21.16418*T*LN(T) +.0010578665*T**2-4.90770333E-07*T**3; 1000 N ! FUNCTION GHSERFR 298.15 -2896.15699+22.135833*T-18.686*T*LN(T) -.00552445*T**2+5.66666667E-11*T**3-471995*T**(-1); 2000 N ! FUNCTION GGASFR1 298.15 +66719.3128-41.3859151*T-21.013*T*LN(T) +2.238E-04*T**2-3.54933333E-08*T**3+5020*T**(-1); 1900 Y +59158.2746+20.6311478*T-29.573*T*LN(T)+.0041483005*T**2 -3.5509E-07*T**3+1031265*T**(-1); 3800 Y +447653.276-1219.99948*T+120.623*T*LN(T)-.0218429*T**2 +4.94483333E-07*T**3-1.886411E+08*T**(-1); 6000 N ! FUNCTION GGASFR2 298.15 +98312.5778-122.431698*T-24.748*T*LN(T) -.0260224*T**2+7.70755833E-06*T**3-121475*T**(-1); 600 Y +72099.8189+267.174378*T-84.831*T*LN(T)+.0351034*T**2-3.9412E-06*T**3 +2019320*T**(-1); 1400 Y +198967.692-664.832058*T+42.754*T*LN(T)-.02224225*T**2 +9.24891667E-07*T**3-21739545*T**(-1); 2300 Y +105542.311-327.058899*T+1.646*T*LN(T)-.0159264*T**2+8.78035E-07*T**3 +14080215*T**(-1); 3500 Y -169012.039+764.904246*T-134.43*T*LN(T)+.0135291*T**2 -3.01303333E-07*T**3+1.1556265E+08*T**(-1); 6000 N ! FUNCTION GLIQGA 200 +GHSERGA#+5491.298-18.073995*T-7.0171E-17*T**7; 302.91 Y -1389.188+114.049043*T-26.0692906*T*LN(T)+1.506E-04*T**2 -4.0173E-08*T**3-118332*T**(-1); 4000 N ! FUNCTION GFCCGA 200 +GHSERGA#+3800-10.2*T; 4000 N ! FUNCTION GBCCGA 200 +GHSERGA#+4500-11.7*T; 4000 N ! FUNCTION GHCPGA 200 +GHSERGA#+4500-9.5*T; 4000 N ! FUNCTION GHSERGA 200 -21312.331+585.263691*T-108.228783*T*LN(T) +.227155636*T**2-1.18575257E-04*T**3+439954*T**(-1); 302.91 Y -7055.643+132.73019*T-26.0692906*T*LN(T)+1.506E-04*T**2 -4.0173E-08*T**3-118332*T**(-1)+1.64547E+23*T**(-9); 4000 N ! FUNCTION GLIQGD 100 +6225.4407+88.8092103*T-24.7214131*T*LN(T) -.00285240521*T**2-3.14674076E-07*T**3-8665.73348*T**(-1); 1000 Y +146262.037-1208.70685*T+159.352082*T*LN(T)-.108247135*T**2 +1.06945505E-05*T**3-19678357*T**(-1); 1508.15 Y -5397.314+192.336215*T-38.5075*T*LN(T); 3600 N ! FUNCTION GFCCGD 200 +GHSERGD#+500; 3600 N ! FUNCTION GBCCGD 100 -3600.77684+95.0191641*T-24.721413*T*LN(T) -.00285240521*T**2-3.14674076E-07*T**3-8665.73348*T**(-1); 1000 Y +152792.743-1349.58873*T+180.097094*T*LN(T)-.119550229*T**2 +1.17915728E-05*T**3-22038836*T**(-1); 1508.15 Y -15783.7618+202.222183*T-38.960425*T*LN(T); 1586.15 Y -19850.5562+224.818035*T-41.904333*T*LN(T)+8.58222759E-04*T**2 -3.77570269E-08*T**3+995428.573*T**(-1); 3600 N ! FUNCTION GHSERGD 200 -6834.5855+97.13101*T-24.7214131*T*LN(T) -.00285240521*T**2-3.14674076E-07*T**3-8665.73348*T**(-1); 1000 Y -6483.25362+95.6919924*T-24.6598297*T*LN(T)-.00185225011*T**2 -6.61211607E-07*T**3; 1508.15 Y -123124.992+699.125537*T-101.800197*T*LN(T)+.0150644246*T**2 -6.39165948E-07*T**3+29356890.3*T**(-1); 3600 N ! FUNCTION GLIQGE 298.15 +GHSERGE#+37141.489-30.687043*T+8.56632E-21*T**7; 1211.40 Y +27243.473+126.324186*T-27.6144*T*LN(T); 3200 N ! FUNCTION GFCCGE 298.15 +GHSERGE#+36000-22.3*T; 3200 N ! FUNCTION GBCCGE 298.15 +GHSERGE#+34100-23.5*T; 3200 N ! FUNCTION GHCPGE 298.15 +GHSERGE#+35000-21.5*T; 3200 N ! FUNCTION GHSERGE 298.15 -9486.153+165.635573*T-29.5337682*T*LN(T) +.005568297*T**2-1.513694E-06*T**3+163298*T**(-1); 900 Y -5689.239+102.86087*T-19.8536239*T*LN(T)-.003672527*T**2; 1211.40 Y -9548.204+156.708024*T-27.6144*T*LN(T)-8.59809E+28*T**(-9); 3200 N ! FUNCTION GHSERHH 298.15 +.5*GGASH2#; 6000 N ! FUNCTION GHSERHE 298.15 -6197.37857+13.0649816*T-20.78611*T*LN(T); 6000 N ! FUNCTION GLIQHF 298.15 +20414.959+99.790933*T-22.7075*T*LN(T) -.004146145*T**2-4.77E-10*T**3-22590*T**(-1); 1000 Y +49731.499-149.91739*T+12.116812*T*LN(T)-.021262021*T**2 +1.376466E-06*T**3-4449699*T**(-1); 2506 Y -4247.217+265.470523*T-44*T*LN(T); 3001 N ! FUNCTION GFCCHF 298.15 +GHSERHF#+10000-2.2*T; 3001 N ! FUNCTION GBCCHF 298.15 +5370.703+103.836026*T-22.8995*T*LN(T) -.004206605*T**2+8.71923E-07*T**3-22590*T**(-1)-1.446E-10*T**4; 2506 Y +1912456.77-8624.20573*T+1087.61412*T*LN(T)-.286857065*T**2 +1.3427829E-05*T**3-6.10085091E+08*T**(-1); 3000 Y -32498.178+276.723247*T-44*T*LN(T); 3001 N ! FUNCTION GHSERHF 298.15 -6987.297+110.744026*T-22.7075*T*LN(T) -.004146145*T**2-4.77E-10*T**3-22590*T**(-1); 2506 Y -1446776.33+6193.60999*T-787.536383*T*LN(T)+.1735215*T**2 -7.575759E-06*T**3+5.01742495E+08*T**(-1); 3000 Y -34274.698+277.882368*T-44*T*LN(T); 3001 N ! FUNCTION GHSERHG 200 +82356.855-3348.19466*T+618.193308*T*LN(T) -2.0282337*T**2+.00118398213*T**3-2366612*T**(-1); 234.32 Y -8961.207+135.232291*T-32.257*T*LN(T)+.0097977*T**2-3.20695E-06*T**3 +6670*T**(-1); 400 Y -7970.627+112.33345*T-28.414*T*LN(T)+.00318535*T**2-1.077802E-06*T**3 -41095*T**(-1); 700 Y -7161.338+90.797305*T-24.87*T*LN(T)-.00166775*T**2+8.737E-09*T**3 -27495*T**(-1); 2000 N ! FUNCTION GFCCHG 298.15 +GHSERHG#+5+8.368*T; 2000 N ! FUNCTION GHCPHG 200 -10468.401+123.974598*T-28.847*T*LN(T) +.01699705*T**2-2.4555667E-05*T**3+13330*T**(-1); 234.32 Y -11225.394+136.628158*T-30.2091*T*LN(T)+.00107555*T**2 -2.28298E-07*T**3+35545*T**(-1); 2000 N ! FUNCTION GRHOMBHG 200 -10668.401+123.274598*T-28.847*T*LN(T) +.01699705*T**2-2.4555667E-05*T**3+13330*T**(-1); 234.32 Y -11425.394+135.928158*T-30.2091*T*LN(T)+.00107555*T**2 -2.28298E-07*T**3+35545*T**(-1); 2000 N ! FUNCTION GLIQHO 298.15 +9770.9926+76.600977*T-23.4879*T*LN(T) -.00827315*T**2+2.375467E-06*T**3; 600 Y +6465.7336+172.483497*T-39.6932*T*LN(T)+.01820065*T**2 -4.829733E-06*T**3; 900 Y +64029.2496-431.466667*T+48.0595*T*LN(T)-.0424634*T**2 +3.233133E-06*T**3-7185900*T**(-1); 1000 Y +124827.533-994.683024*T+127.957778*T*LN(T)-.088196514*T**2 +8.008222E-06*T**3-15727191*T**(-1); 1703 Y -9688.5314+230.793918*T-43.932*T*LN(T); 3001 N ! FUNCTION GBCCHO 298.15 -3773.06+84.546902*T-23.4879*T*LN(T) -.00827315*T**2+2.375467E-06*T**3; 600 Y -7078.318+180.429422*T-39.6932*T*LN(T)+.01820065*T**2 -4.829733E-06*T**3; 900 Y +50485.557-423.520743*T+48.0595*T*LN(T)-.0424634*T**2 +3.233133E-06*T**3-7185900*T**(-1); 1000 Y +185620.196-1635.72662*T+218.937249*T*LN(T)-.13516576*T**2 +1.2168911E-05*T**3-26729747*T**(-1); 1703 Y -28759.761+272.961035*T-48.116*T*LN(T); 1745 Y -152646.008+939.778244*T-134.793064*T*LN(T)+.025544089*T**2 -1.287517E-06*T**3+32050889*T**(-1); 3000 Y -19066.44+236.390471*T-43.932*T*LN(T); 3001 N ! FUNCTION GHSERHO 298.15 -7612.429+86.593171*T-23.4879*T*LN(T) -.00827315*T**2+2.375467E-06*T**3; 600 Y -10917.688+182.475691*T-39.6932*T*LN(T)+.01820065*T**2 -4.829733E-06*T**3; 900 Y +46646.188-421.474473*T+48.0595*T*LN(T)-.0424634*T**2 +3.233133E-06*T**3-7185900*T**(-1); 1200 Y +27786.061-156.162846*T+8.28608*T*LN(T)-.01082725*T**2 -1.112352E-06*T**3-6183850*T**(-1); 1703 Y -825364.662+4248.37906*T-558.950682*T*LN(T)+.139111904*T**2 -6.824652E-06*T**3+2.19952973E+08*T**(-1); 3000 Y -17149.229+235.898104*T-43.932*T*LN(T); 3001 N ! FUNCTION GHSERII 298.15 +.5*GSOLI2#; 1000 N ! FUNCTION GGASI2 298.15 +50783.8025-4.98552933*T-38.14594*T*LN(T) +5.89305E-04*T**2-1.96143167E-07*T**3+45464.01*T**(-1); 2000 Y +31804.6912+32.349576*T-41.67339*T*LN(T)-.001681544*T**2 +1.53575317E-07*T**3+8481775*T**(-1); 4000 Y -34016.1051+280.938545*T-72.42007*T*LN(T)+.004574158*T**2 -8.10419167E-08*T**3+34270380*T**(-1); 6000 N ! FUNCTION GLIQIN 298.15 +GHSERIN#+3282.091-7.636885*T-5.59405E-20*T**7; 429.74 Y -3749.808+116.835756*T-27.4562*T*LN(T)+5.4607E-04*T**2-8.367E-08*T**3 -211708*T**(-1); 3800 N ! FUNCTION GFCCIN 298.15 +GHSERIN#+162.061; 3800 N ! FUNCTION GBCCIN 298.15 +GHSERIN#+800-.8*T; 3800 N ! FUNCTION GHCPIN 298.15 +GHSERIN#+533-.6868*T; 3800 N ! FUNCTION GHSERIN 298.15 -6978.89+92.338115*T-21.8386*T*LN(T) -.00572566*T**2-2.120321E-06*T**3-22906*T**(-1); 429.75 Y -7033.514+124.476588*T-27.4562*T*LN(T)+5.4607E-04*T**2-8.367E-08*T**3 -211708*T**(-1)+3.53332E+22*T**(-9); 3800 N ! FUNCTION GLIQIR 298.15 +16518.956+112.46806*T-22.7944*T*LN(T) -.003091976*T**2-20083*T**(-1); 1000 Y +102217.789-587.632815*T+73.9517579*T*LN(T)-.04638802*T**2 +2.761831E-06*T**3-13382612*T**(-1); 2719 Y -38347.217+411.234043*T-59.418*T*LN(T); 4000 N ! FUNCTION GHSERIR 298.15 -6936.288+118.780119*T-22.7944*T*LN(T) -.003091976*T**2-20083*T**(-1); 1215 Y -8123.73+140.066697*T-26.085*T*LN(T)-4.7969E-07*T**3; 2719 Y +290529.037-1258.35297*T+152.498874*T*LN(T)-.047176402*T**2 +1.844977E-06*T**3-92987250*T**(-1); 4000 N ! FUNCTION GBCCIR 298.15 +GHSERIR#+32000-6.9*T; 4000 N ! FUNCTION GHCPIR 298.15 +GHSERIR#+4000-.6*T; 4000 N ! FUNCTION GLIQKK 200 +GHSERKK#+2318.096-6.886859*T-9.44E-19*T**7; 336.53 Y -8799.422+185.684327*T-39.2885968*T*LN(T)+.012167386*T**2 -2.64387E-06*T**3+43251*T**(-1); 2200 N ! FUNCTION GHSERKK 200 -16112.929+389.624197*T-77.0571464*T*LN(T) +.146211135*T**2-8.4949147E-05*T**3+243385*T**(-1); 336.53 Y -11122.441+192.586544*T-39.2885968*T*LN(T)+.012167386*T**2 -2.64387E-06*T**3+43251*T**(-1)+1.19223E+22*T**(-9); 2200 N ! FUNCTION GFCCKK 200 +GHSERKK#+50+1.3*T; 2200 N ! FUNCTION GHCPKK 200 +GHSERKK#+50+2*T; 2200 N ! FUNCTION GHSERKR 298.15 -6197.37857-24.8680184*T-20.78611*T*LN(T); 6000 N ! FUNCTION GLIQLA 298.15 +5332.653+18.23012*T-11.0188191*T*LN(T) -.020171603*T**2+2.93775E-06*T**3-133541*T**(-1); 1134 Y -3942.004+171.018431*T-34.3088*T*LN(T); 4000 N ! FUNCTION GFCCLA 298.15 -6109.797+89.878761*T-21.7919*T*LN(T) -.004045175*T**2-5.25865E-07*T**3; 1134 Y -124598.976+955.878375*T-139.346741*T*LN(T)+.042032405*T**2 -3.066199E-06*T**3+20994153*T**(-1); 2000 Y -12599.386+178.54399*T-34.3088*T*LN(T); 4000 N ! FUNCTION GBCCLA 298.15 -3952.161+88.072353*T-21.7919*T*LN(T) -.004045175*T**2-5.25865E-07*T**3; 800 Y +321682.673-3565.08252*T+513.440708*T*LN(T)-.387295093*T**2 +4.9547989E-05*T**3-36581228*T**(-1); 1134 Y -16377.894+218.492988*T-39.5388*T*LN(T); 1193 Y -136609.91+1123.34397*T-163.413074*T*LN(T)+.053968535*T**2 -4.056395E-06*T**3+21167204*T**(-1); 2000 Y -8205.988+174.836315*T-34.3088*T*LN(T); 4000 N ! FUNCTION GHSERLA 298.15 -7968.403+120.284604*T-26.34*T*LN(T) -.001295165*T**2; 550 Y -3381.413+59.06113*T-17.1659411*T*LN(T)-.008371705*T**2 +6.8932E-07*T**3-399448*T**(-1); 2000 Y -15608.882+181.390071*T-34.3088*T*LN(T); 4000 N ! FUNCTION GLIQLI 200 -7883.612+211.841861*T-38.940488*T*LN(T) +.035466931*T**2-1.9869816E-05*T**3+159994*T**(-1); 250 Y +12015.027-362.187078*T+61.6104424*T*LN(T)-.182426463*T**2 +6.3955671E-05*T**3-559968*T**(-1); 453.60 Y -6057.31+172.652183*T-31.2283718*T*LN(T)+.002633221*T**2 -4.38058E-07*T**3-102387*T**(-1); 3000 N ! FUNCTION GFCCLI 200 +GHSERLI#-108+1.3*T; 3000 N ! FUNCTION GHSERLI 200 -10583.817+217.637482*T-38.940488*T*LN(T) +.035466931*T**2-1.9869816E-05*T**3+159994*T**(-1); 453.60 Y -559579.123+10547.8799*T-1702.88865*T*LN(T)+2.25832944*T**2 -5.71066077E-04*T**3+33885874*T**(-1); 500 Y -9062.994+179.278285*T-31.2283718*T*LN(T)+.002633221*T**2 -4.38058E-07*T**3-102387*T**(-1); 3000 N ! FUNCTION GHCPLI 200 +GHSERLI#-154+2*T; 3000 N ! FUNCTION GLIQLU 298.15 +3983.791+141.5374*T-29.812*T*LN(T) +.00519165*T**2-1.790717E-06*T**3+39723*T**(-1); 600 Y +30389.863-198.378793*T+20.9392663*T*LN(T)-.034238743*T**2 +2.890636E-06*T**3-2398650*T**(-1); 1936 Y -18994.687+292.091104*T-47.9068*T*LN(T); 3700 N ! FUNCTION GHSERLU 298.15 -8788.329+146.536283*T-29.812*T*LN(T) +.00519165*T**2-1.790717E-06*T**3+39723*T**(-1); 700 Y -9043.057+142.327643*T-29.0095*T*LN(T)+.00371416*T**2-1.50147E-06*T**3 +141549*T**(-1); 1700 Y +6940.092-46.91844*T-1.83986*T*LN(T)-.0119001*T**2; 1936 Y -404023.691+1829.37943*T-239.019502*T*LN(T)+.041800748*T**2 -1.661174E-06*T**3+1.24825465E+08*T**(-1); 3700 N ! FUNCTION GLIQMG 298.15 +GHSERMG#+8202.243-8.83693*T-8.0176E-20*T**7; 923 Y -5439.869+195.324057*T-34.3088*T*LN(T); 3000 N ! FUNCTION GFCCMG 298.15 +GHSERMG#+2600-.9*T; 3000 N ! FUNCTION GBCCMG 298.15 +GHSERMG#+3100-2.1*T; 3000 N ! FUNCTION GHSERMG 298.15 -8367.34+143.675547*T-26.1849782*T*LN(T) +4.858E-04*T**2-1.393669E-06*T**3+78950*T**(-1); 923 Y -14130.185+204.716215*T-34.3088*T*LN(T)+1.038192E+28*T**(-9); 3000 N ! FUNCTION GLIQMN 298.15 +GHSERMN#+17859.91-12.6208*T-4.41929E-21*T**7; 1519 Y -9993.9+299.036*T-48*T*LN(T); 2000 N ! FUNCTION GFCCMN 298.15 -3439.3+131.884*T-24.5177*T*LN(T)-.006*T**2 +69600*T**(-1); 1519 Y -26070.1+309.6664*T-48*T*LN(T)+3.86196E+30*T**(-9); 2000 N ! FUNCTION GBCCMN 298.15 -3235.3+127.85*T-23.7*T*LN(T)-.00744271*T**2 +60000*T**(-1); 1519 Y -23188.83+307.7043*T-48*T*LN(T)+1.265152E+30*T**(-9); 2000 N ! FUNCTION GHCPMN 298.15 -4439.3+133.007*T-24.5177*T*LN(T)-.006*T**2 +69600*T**(-1); 1519 Y -27070.1+310.7894*T-48*T*LN(T)+3.86196E+30*T**(-9); 2000 N ! FUNCTION GHSERMN 298.15 -8115.28+130.059*T-23.4582*T*LN(T)-.00734768*T**2 +69827*T**(-1); 1519 Y -28733.41+312.2648*T-48*T*LN(T)+1.656847E+30*T**(-9); 2000 N ! FUNCTION GLIQMO 298.15 +GHSERMO#+41831.347-14.694912*T+4.24519E-22*T**7; 2896 Y +3538.963+271.6697*T-42.63829*T*LN(T); 5000 N ! FUNCTION GFCCMO 298.15 +GHSERMO#+15200+.63*T; 5000 N ! FUNCTION GHSERMO 298.15 -7746.302+131.9197*T-23.56414*T*LN(T) -.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)-1.30927E-10*T**4; 2896 Y -30556.41+283.559746*T-42.63829*T*LN(T)-4.849315E+33*T**(-9); 5000 N ! FUNCTION GHCPMO 298.15 +GHSERMO#+11550; 5000 N ! FUNCTION GHSERNN 298.15 -3750.675-9.45425*T-12.7819*T*LN(T) -.00176686*T**2+2.681E-09*T**3-32374*T**(-1); 950 Y -7358.85+17.2003*T-16.3699*T*LN(T)-6.5107E-04*T**2+3.0097E-08*T**3 +563070*T**(-1); 3350 Y -16392.8+50.26*T-20.4695*T*LN(T)+2.39754E-04*T**2-8.333E-09*T**3 +4596375*T**(-1); 6000 N ! FUNCTION GLIQNN 298.15 +GHSERNN#+29950+59.02*T; 6000 N ! FUNCTION GLIQNA 200 +GHSERNA#+2581.02-6.95218*T-2.76132E-18*T**7; 370.87 Y -8400.44+192.587343*T-38.1198801*T*LN(T)+.009745854*T**2 -1.70664E-06*T**3+34342*T**(-1); 2300 N ! FUNCTION GFCCNA 200 +GHSERNA#-50+1.3*T; 2300 N ! FUNCTION GHSERNA 200 -11989.434+260.548732*T-51.0393608*T*LN(T) +.072306633*T**2-4.3638283E-05*T**3+132154*T**(-1); 370.87 Y -11009.884+199.619999*T-38.1198801*T*LN(T)+.009745854*T**2 -1.70664E-06*T**3+34342*T**(-1)+1.65071E+23*T**(-9); 2300 N ! FUNCTION GHCPNA 200 +GHSERNA#+104+2*T; 2300 N ! FUNCTION GLIQNB 298.15 +GHSERNB#+29781.555-10.816418*T-3.06098E-23*T**7; 2750 Y -7499.398+260.756148*T-41.77*T*LN(T); 6000 N ! FUNCTION GFCCNB 298.15 +GHSERNB#+13500+1.7*T; 6000 N ! FUNCTION GHSERNB 298.15 -8519.353+142.045475*T-26.4711*T*LN(T) +2.03475E-04*T**2-3.5012E-07*T**3+93399*T**(-1); 2750 Y -37669.3+271.720843*T-41.77*T*LN(T)+1.528238E+32*T**(-9); 6000 N ! FUNCTION GHCPNB 298.15 +GHSERNB#+10000+2.4*T; 6000 N ! FUNCTION GLIQND 298.15 -3351.187+109.517314*T-27.0858*T*LN(T) +5.56125E-04*T**2-2.6923E-06*T**3+34887*T**(-1); 300 Y +5350.01-86.593963*T+5.357301*T*LN(T)-.046955463*T**2 +6.860782E-06*T**3-374380*T**(-1); 1128 Y -16335.232+268.625903*T-48.7854*T*LN(T); 1800 N ! FUNCTION GFCCND 298.15 +GHSERND#+500; 1800 N ! FUNCTION GBCCND 298.15 -6965.635+110.556109*T-27.0858*T*LN(T) +5.56125E-04*T**2-2.6923E-06*T**3+34887*T**(-1); 400 Y +7312.2-153.033976*T+14.9956777*T*LN(T)-.050479*T**2+7.287217E-06*T**3 -831810*T**(-1); 1128 Y -18030.266+239.677322*T-44.5596*T*LN(T); 1289 Y +334513.017-2363.9199*T+311.409193*T*LN(T)-.156030778*T**2 +1.2408421E-05*T**3-64319604*T**(-1); 1799 Y -24495.579+274.879155*T-48.7854*T*LN(T); 1800 N ! FUNCTION GHCPND 298.15 +GHSERND#+1500-.415725*T; 1800 N ! FUNCTION GHSERND 298.15 -8402.93+111.10239*T-27.0858*T*LN(T) +5.56125E-04*T**2-2.6923E-06*T**3+34887*T**(-1); 900 Y -6984.083+83.662617*T-22.7536*T*LN(T)-.00420402*T**2-1.802E-06*T**3; 1128 Y -225610.846+1673.04075*T-238.182873*T*LN(T)+.078615997*T**2 -6.048207E-06*T**3+38810350*T**(-1); 1799 Y -25742.331+276.257088*T-48.7854*T*LN(T); 1800 N ! FUNCTION GHSERNE 298.15 -6197.37857-7.11101836*T-20.78611*T*LN(T); 6000 N ! FUNCTION GLIQNI 298.15 +GHSERNI#+16414.686-9.397*T-3.82318E-21*T**7; 1728 Y -9549.817+268.597977*T-43.1*T*LN(T); 3000 N ! FUNCTION GHSERNI 298.15 -5179.159+117.854*T-22.096*T*LN(T)-.0048407*T**2; 1728 Y -27840.62+279.134977*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 3000 N ! FUNCTION GBCCNI 298.15 +GHSERNI#+8715.084-3.556*T; 3000 N ! FUNCTION GHCPNI 298.15 +GHSERNI#+1046+1.2552*T; 3000 N ! FUNCTION GLIQNP 298.15 -4627.18+160.024959*T-31.229*T*LN(T) -.0163885*T**2+2.941883E-06*T**3+439915*T**(-1); 917 Y -7415.255+247.671446*T-45.3964*T*LN(T); 4000 N ! FUNCTION GBCCNP 298.15 -3224.664+174.911817*T-35.177*T*LN(T) -.00251865*T**2+5.14743E-07*T**3+302225*T**(-1); 856 Y -2366.486+180.807719*T-36.401*T*LN(T); 917 Y +50882.281-297.324358*T+30.7734*T*LN(T)-.0343483*T**2 +2.707217E-06*T**3-7500100*T**(-1); 1999 Y -14879.686+254.773087*T-45.3964*T*LN(T); 4000 N ! FUNCTION GHSERNP 298.15 +241.888-57.531347*T+4.0543*T*LN(T) -.04127725*T**2-402857*T**(-1); 553 Y -57015.112+664.27337*T-102.523*T*LN(T)+.0284592*T**2-2.483917E-06*T**3 +4796910*T**(-1); 1799 Y -12092.736+255.780866*T-45.3964*T*LN(T); 4000 N ! FUNCTION GHSEROO 298.15 -3480.87-25.503038*T-11.1355*T*LN(T) -.005098875*T**2+6.61845833E-07*T**3-38365*T**(-1); 1000 Y -6568.763+12.659879*T-16.8138*T*LN(T)-5.957975E-04*T**2+6.781E-09*T**3 +262905*T**(-1); 3300 Y -13986.728+31.259624*T-18.9536*T*LN(T)-4.25243E-04*T**2 +1.0721E-08*T**3+4383200*T**(-1); 6000 N ! FUNCTION GLIQOO 298.15 +GHSEROO#-2648.9+31.44*T; 6000 N ! FUNCTION GFCCOO 298.15 +GHSEROO#+30000; 6000 N ! FUNCTION GBCCOO 298.15 +GHSEROO#+30000; 6000 N ! FUNCTION GLIQOS 298.15 +29263.192+117.895788*T-23.5710242*T*LN(T) -.00190427*T**2; 1000 Y +68715.318-198.324341*T+19.9382156*T*LN(T)-.020464464*T**2 +1.014279E-06*T**3-6237261*T**(-1); 3306 Y -15903.192+336.874526*T-50*T*LN(T); 5500 N ! FUNCTION GFCCOS 298.15 +GHSEROS#+13000-2.5*T; 5500 N ! FUNCTION GBCCOS 298.15 +GHSEROS#+27500-4.4*T; 5500 N ! FUNCTION GHSEROS 298.15 -7196.978+126.369531*T-23.5710242*T*LN(T) -.00190427*T**2; 3306 Y +644910.07-1935.2137*T+224.998034*T*LN(T)-.042489827*T**2 +1.173861E-06*T**3-3.12569031E+08*T**(-1); 5500 N ! FUNCTION GLIQPP 250 -26316.111+434.930931*T-70.7440584*T*LN(T) -.002898936*T**2+3.9049371E-05*T**3+1141147*T**(-1); 317.30 Y -7232.449+133.291873*T-26.326*T*LN(T); 3000 N ! FUNCTION GFCCPP 250 +10842.441+135.534002*T-25.55*T*LN(T)+.0034121*T**2 -2.418867E-06*T**3+160095*T**(-1); 500 Y +15095.279+64.533737*T-14.368*T*LN(T)-.00957685*T**2+3.93917E-07*T**3 -141375*T**(-1); 852.35 Y -82589.413+1012.89162*T-149.449556*T*LN(T)+.067272364*T**2 -6.651929E-06*T**3+12495943*T**(-1); 1500 Y +12294.881+140.701181*T-26.326*T*LN(T); 3000 N ! FUNCTION GBCCPP 250 +18792.241+135.412002*T-25.55*T*LN(T)+.0034121*T**2 -2.418867E-06*T**3+160095*T**(-1); 500 Y +23045.079+64.411737*T-14.368*T*LN(T)-.00957685*T**2+3.93917E-07*T**3 -141375*T**(-1); 852.35 Y -74639.613+1012.76962*T-149.449556*T*LN(T)+.067272364*T**2 -6.651929E-06*T**3+12495943*T**(-1); 1500 Y +20244.681+140.579181*T-26.326*T*LN(T); 3000 N ! FUNCTION GHSERPP 250 -43821.799+1026.69389*T-178.426*T*LN(T)+.290708*T**2 -1.04022667E-04*T**3+1632695*T**(-1); 317.30 Y -9587.448+152.341487*T-28.7335301*T*LN(T)+.001715669*T**2 -2.2829E-07*T**3+172966*T**(-1); 1000 Y -8093.075+135.876831*T-26.326*T*LN(T); 3000 N ! FUNCTION GREDPP 250 -25976.559+148.672002*T-25.55*T*LN(T)+.0034121*T**2 -2.418867E-06*T**3+160095*T**(-1); 500 Y -21723.721+77.671737*T-14.368*T*LN(T)-.00957685*T**2+3.93917E-07*T**3 -141375*T**(-1); 852.35 Y -119408.413+1026.02962*T-149.449556*T*LN(T)+.067272364*T**2 -6.651929E-06*T**3+12495943*T**(-1); 1500 Y -24524.119+153.839181*T-26.326*T*LN(T); 3000 N ! FUNCTION GLIQPA 298.15 +8499.539+102.429215*T-23.9116*T*LN(T) -.00621325*T**2; 1088 Y +48013.96-278.789916*T+30.336*T*LN(T)-.0372478*T**2+3.075017E-06*T**3 -5064250*T**(-1); 1845 Y -12508.174+277.955437*T-47.2792*T*LN(T); 4000 N ! FUNCTION GBCCPA 298.15 +781.847+71.957409*T-18.203*T*LN(T) -.01322095*T**2+1.337387E-06*T**3-101600*T**(-1); 1443 Y -10955.948+220.478519*T-39.748*T*LN(T); 1845 Y +284495.194-1397.15052*T+171.108*T*LN(T)-.0637105*T**2 +3.343867E-06*T**3-74992000*T**(-1); 2710 Y -27885.171+286.096187*T-47.2792*T*LN(T); 4000 N ! FUNCTION GHSERPA 298.15 -7681.561+111.973215*T-23.9116*T*LN(T) -.00621325*T**2; 1443 Y +27955.763-177.320253*T+16.305*T*LN(T)-.0263416*T**2+1.884933E-06*T**3 -5908900*T**(-1); 2176 Y -29949.683+288.308639*T-47.2792*T*LN(T); 4000 N ! FUNCTION GLIQPB 298.15 +GHSERPB#+4672.124-7.750683*T-6.019E-19*T**7; 600.61 Y -5677.958+146.176046*T-32.4913959*T*LN(T)+.00154613*T**2; 1200 Y +9010.753+45.071937*T-18.9640637*T*LN(T)-.002882943*T**2 +9.8144E-08*T**3-2696755*T**(-1); 2100 N ! FUNCTION GHSERPB 298.15 -7650.085+101.700244*T-24.5242231*T*LN(T) -.00365895*T**2-2.4395E-07*T**3; 600.61 Y -10531.095+154.243182*T-32.4913959*T*LN(T)+.00154613*T**2 +8.05448E+25*T**(-9); 1200 Y +4157.616+53.139072*T-18.9640637*T*LN(T)-.002882943*T**2 +9.8144E-08*T**3-2696755*T**(-1)+8.05448E+25*T**(-9); 2100 N ! FUNCTION GBCCPB 298.15 +GHSERPB#+2400-1.1*T; 2100 N ! FUNCTION GHCPPB 298.15 +GHSERPB#+300+T; 2100 N ! FUNCTION GLIQPD 298.15 +1302.731+170.964153*T-32.211*T*LN(T) +.007120975*T**2-1.919875E-06*T**3+168687*T**(-1); 600 Y +23405.778-116.918419*T+10.8922031*T*LN(T)-.027266568*T**2 +2.430675E-06*T**3-1853674*T**(-1); 1828 Y -12373.637+251.416903*T-41.17*T*LN(T); 4000 N ! FUNCTION GHSERPD 298.15 -10204.027+176.076315*T-32.211*T*LN(T) +.007120975*T**2-1.919875E-06*T**3+168687*T**(-1); 900 Y +917.062+49.659892*T-13.5708*T*LN(T)-.00717522*T**2+1.91115E-07*T**3 -1112465*T**(-1); 1828 Y -67161.018+370.102147*T-54.2067086*T*LN(T)+.002091396*T**2 -6.2811E-08*T**3+18683526*T**(-1); 4000 N ! FUNCTION GBCCPD 298.15 +GHSERPD#+10500-1.8*T; 4000 N ! FUNCTION GHCPPD 298.15 +GHSERPD#+2000+.1*T; 4000 N ! FUNCTION GHSERPM 298.15 -7422.35903+80.1647685*T-21.79273*T*LN(T) -.01040851*T**2+4.84191667E-10*T**3-54.5102*T**(-1); 1163 Y -20335.8031+242.978356*T-45*T*LN(T)-4.665112E-15*T**2 +4.62986667E-19*T**3-1.1469315E-06*T**(-1); 1315 Y -19020.8031+234.796764*T-44*T*LN(T)+5.82907E-18*T**2 -1.53614333E-22*T**3+2.491165E-08*T**(-1); 5000 N ! FUNCTION GGASPM1 298.15 +250509.452-16.8531368*T-24.78283*T*LN(T) -.0047051555*T**2+7.05661167E-07*T**3+131736.9*T**(-1); 800 Y +249850.849-5.81954382*T-26.5177*T*LN(T)-.002737541*T**2 +3.00398167E-07*T**3+177733*T**(-1); 2100 Y +193298.956+304.296847*T-67.1114*T*LN(T)+.01034818*T**2 -4.98411167E-07*T**3+15106220*T**(-1); 4400 Y +916726.64-1758.41221*T+178.7423*T*LN(T)-.026972315*T**2 +5.691155E-07*T**3-3.8600615E+08*T**(-1); 7000 Y -1055624.33+1947.2619*T-239.3529*T*LN(T)+.012517975*T**2 -1.3208175E-07*T**3+1.3629E+09*T**(-1); 10000 N ! FUNCTION GHSERPO 298.15 -6775.95532+74.9200503*T-19.469*T*LN(T) -.01094955*T**2+6.77833333E-09*T**3-255*T**(-1); 527 Y -9814.73668+147.18388*T-31*T*LN(T); 2000 N ! FUNCTION GGASPO1 298.15 +175819.473-49.5734348*T-20.812*T*LN(T) +7.33E-05*T**2-2.05916667E-08*T**3-320*T**(-1); 3700 Y +190794.983-95.2137296*T-15.324*T*LN(T)-8.2235E-04*T**2+6.93E-09*T**3 -7665330*T**(-1); 6000 N ! FUNCTION GLIQPR 298.15 +3848.961-29.099465*T-4.7344931*T*LN(T) -.035119723*T**2+5.427467E-06*T**3-207406*T**(-1); 1068 Y -10539.574+219.508805*T-42.9697*T*LN(T); 3800 N ! FUNCTION GBCCPR 298.15 -2863.651+28.274853*T-13.7470527*T*LN(T) -.02284377*T**2+3.542468E-06*T**3-87486*T**(-1); 1068 Y -11985.919+188.657121*T-38.451*T*LN(T); 1204 Y +953.224+100.826281*T-26.6824313*T*LN(T)-.004106833*T**2 +1.76214E-07*T**3-2473024*T**(-1); 3800 N ! FUNCTION GHSERPR 298.15 -18803.379+356.587384*T-68.9176*T*LN(T) +.072929*T**2-2.5184333E-05*T**3+507385*T**(-1); 500 Y -7246.848+82.427384*T-22.8909*T*LN(T)-.00497126*T**2-1.22951E-06*T**3; 800 Y +95411.023-1073.55111*T+146.764*T*LN(T)-.1288205*T**2 +1.5592233E-05*T**3-11588800*T**(-1); 1068 Y -481663.131+4234.33311*T-606.120311*T*LN(T)+.305181506*T**2 -3.0994702E-05*T**3+70926840*T**(-1); 1204 Y -20014.678+227.685155*T-42.9697*T*LN(T); 3800 N ! FUNCTION GSOLAT2 298.15 -14787.3759+257.374867*T-45.171*T*LN(T) -.0148062*T**2-1.67183333E-08*T**3+385*T**(-1); 500 Y -28494.6063+493.832173*T-80*T*LN(T); 1000 N ! FUNCTION GLIQBR2 298.15 -35828.8251+797.10304*T-155.5776*T*LN(T) +.2064111*T**2-9.74919667E-05*T**3+391199.95*T**(-1); 501 Y -29842.4162+472.126731*T-92.275*T*LN(T); 1000 N ! FUNCTION GGASCL2 298.15 -11735.2388+21.6544571*T-36.24619*T*LN(T) -9.56635E-04*T**2+7.72473833E-08*T**3+126340.1*T**(-1); 1500 Y -14830.9341+52.8425138*T-40.69302*T*LN(T)+.0016038575*T**2 -1.834645E-07*T**3+446405.05*T**(-1); 3300 Y +12605.9761-161.881179*T-12.22677*T*LN(T)-.00734027*T**2 +2.74869167E-07*T**3+3816431.5*T**(-1); 5600 Y -277134.238+658.109036*T-109.5523*T*LN(T)+.00665615*T**2 -9.27583833E-08*T**3+1.564792E+08*T**(-1); 10000 N ! FUNCTION GGASF2 298.15 -9757.53536-3.03641497*T-29.08493*T*LN(T) -.007466065*T**2+1.16183617E-06*T**3+72117.3*T**(-1); 800 Y -10225.5134+17.0719031*T-32.43806*T*LN(T)-.0028914815*T**2 +2.13090167E-07*T**3-31206.07*T**(-1); 2500 Y -75010.7092+286.369351*T-66.19232*T*LN(T)+.004699418*T**2 -9.36513E-08*T**3+22790040*T**(-1); 6800 Y +79866.236-46.25962*T-28.00029*T*LN(T)+4.8653845E-04*T**2 -6.238305E-09*T**3-96222900*T**(-1); 10000 N ! FUNCTION GGASH2 298.15 -9522.97393+78.5273873*T-31.35707*T*LN(T) +.0027589925*T**2-7.46390667E-07*T**3+56582.3*T**(-1); 1000 Y +180.10884-15.6128262*T-17.84857*T*LN(T)-.00584168*T**2 +3.14618667E-07*T**3-1280036*T**(-1); 2100 Y -18840.1661+92.3120249*T-32.05082*T*LN(T)-.0010728235*T**2 +1.14281783E-08*T**3+3561002.5*T**(-1); 6000 N ! FUNCTION GSOLI2 298.15 +13508.6791-397.468312*T+50.64648*T*LN(T) -.1234531*T**2-1398711*T**(-1); 386.70 Y -26045.3569+430.072509*T-80.6717*T*LN(T); 1000 N ! $--------------------------- FUNCTION GLIQPT 298.15 +12518.385+115.113092*T-24.5526*T*LN(T) -.00248297*T**2-2.0138E-08*T**3+7974*T**(-1); 600 Y +19023.491+32.94182*T-12.3403769*T*LN(T)-.011551507*T**2 +9.31516E-07*T**3-601426*T**(-1); 2041.50 Y +1404.468+205.858962*T-36.5*T*LN(T); 4000 N ! FUNCTION GHSERPT 298.15 -7595.631+124.388275*T-24.5526*T*LN(T) -.00248297*T**2-2.0138E-08*T**3+7974*T**(-1); 1300 Y -9253.174+161.529615*T-30.2527*T*LN(T)+.002321665*T**2 -6.56946E-07*T**3-272106*T**(-1); 2041.50 Y -222048.216+1019.35892*T-136.192996*T*LN(T)+.020454938*T**2 -7.59259E-07*T**3+71539020*T**(-1); 4000 N ! FUNCTION GBCCPT 298.15 +GHSERPT#+15000-2.4*T; 4000 N ! FUNCTION GHCPPT 298.15 +GHSERPT#+2500+.1*T; 4000 N ! FUNCTION GLIQPU 298.15 +GHSERPU#+6608.1-12.5133*T; 3000 N ! FUNCTION GFCCPU 298.15 -3920.781+127.586536*T-28.4781*T*LN(T) -.0054035*T**2; 990 Y +3528.208+41.52572*T-15.7351*T*LN(T)-.0154772*T**2+1.524942E-06*T**3 -864940*T**(-1); 1464 Y -12865.948+226.18075*T-42.248*T*LN(T); 3000 N ! FUNCTION GBCCPU 298.15 -1358.984+116.603882*T-27.094*T*LN(T) -.009105*T**2+2.061667E-06*T**3+20863*T**(-1); 745 Y -2890.817+156.878957*T-33.72*T*LN(T); 956 Y +29313.619-132.788248*T+6.921*T*LN(T)-.02023305*T**2+1.426922E-06*T**3 -4469245*T**(-1); 2071 Y -15400.585+227.421855*T-42.248*T*LN(T); 3000 N ! FUNCTION GHSERPU 298.15 -7396.309+80.301382*T-18.1258*T*LN(T)-.02241*T**2; 400 Y -16605.962+236.786603*T-42.4187*T*LN(T)-.00134493*T**2 +2.63443E-07*T**3+579325*T**(-1); 944 Y -14462.156+232.961553*T-42.248*T*LN(T); 3000 N ! FUNCTION GHSERRA 298.15 -7586.80726+84.7267364*T-21.891*T*LN(T) -.01192215*T**2-7.05E-10*T**3+25*T**(-1); 969 Y -16207.5678+236.497235*T-44.69*T*LN(T)+.0024207*T**2 +3.08333333E-10*T**3-1065*T**(-1); 1900 Y +663665.969-3406.90923*T+429.821*T*LN(T)-.14307925*T**2 +8.24672667E-06*T**3-1.809125E+08*T**(-1); 2200 Y -6524.86128+162.845411*T-35*T*LN(T); 4000 N ! FUNCTION GGASRA1 298.15 +153759.624-36.4634424*T-20.909*T*LN(T) +1.327E-04*T**2-2.35816667E-08*T**3+2520*T**(-1); 1500 Y +113415.461+243.449819*T-58.888*T*LN(T)+.0161394*T**2 -1.29957833E-06*T**3+8085840*T**(-1); 2900 Y +740503.588-2269.74719*T+255.137*T*LN(T)-.05399135*T**2 +1.64816167E-06*T**3-2.274382E+08*T**(-1); 4300 Y -464468.83+1071.43441*T-141.421*T*LN(T)+.0039122*T**2 +6.57833333E-08*T**3+4.579589E+08*T**(-1); 5800 Y -1450458.29+3377.99292*T-409.101*T*LN(T)+.0362229*T**2 -6.65655E-07*T**3+1.1393215E+09*T**(-1); 6000 N ! FUNCTION GLIQRB 200 +GHSERRB#+2217.552-7.110486*T+1.44078E-17*T**7; 312.46 Y -5650.532+110.090262*T-29.1775424*T*LN(T)+4.12369E-04*T**2 -4.6822E-07*T**3-126310*T**(-1); 900 Y -37315.276+444.013833*T-77.7006456*T*LN(T)+.033795632*T**2 -4.829082E-06*T**3+3778006*T**(-1); 1600 Y -157569.646+1280.82915*T-191.262774*T*LN(T)+.08161687*T**2 -8.61653E-06*T**3+27738456*T**(-1); 2100 N ! FUNCTION GFCCRB 200 +GHSERRB#+200+1.3*T; 2100 N ! FUNCTION GHSERRB 200 -21669.733+583.580988*T-115.282589*T*LN(T) +.26277612*T**2-1.52236932E-04*T**3+385754*T**(-1); 312.46 Y -7823.397+117.050578*T-29.1775424*T*LN(T)+4.12369E-04*T**2 -4.6822E-07*T**3-126310*T**(-1)-5.55029E+22*T**(-9); 900 Y -39488.142+450.974149*T-77.7006456*T*LN(T)+.033795632*T**2 -4.829082E-06*T**3+3778006*T**(-1)-5.55029E+22*T**(-9); 1600 Y -159742.511+1287.78947*T-191.262774*T*LN(T)+.08161687*T**2 -8.61653E-06*T**3+27738456*T**(-1)-5.55029E+22*T**(-9); 2100 N ! FUNCTION GHCPRB 200 +GHSERRB#+200+2*T; 2100 N ! FUNCTION GLIQRE 298.15 +16125.604+122.076209*T-24.348*T*LN(T) -.00253505*T**2+1.92818E-07*T**3+32915*T**(-1); 1200 Y +8044.885+188.322047*T-33.586*T*LN(T)+.00224565*T**2-2.81835E-07*T**3 +1376270*T**(-1); 2000 Y +568842.665-2527.83846*T+314.178898*T*LN(T)-.08939817*T**2 +3.92854E-06*T**3-1.63100987E+08*T**(-1); 3458 Y -39044.888+335.723691*T-49.519*T*LN(T); 6000 N ! FUNCTION GFCCRE 298.15 +GHSERRE#+11000-1.5*T; 6000 N ! FUNCTION GBCCRE 298.15 +GHSERRE#+17000-3.7*T; 6000 N ! FUNCTION GHSERRE 298.15 -7695.279+128.421589*T-24.348*T*LN(T) -.00253505*T**2+1.92818E-07*T**3+32915*T**(-1); 1200 Y -15775.998+194.667426*T-33.586*T*LN(T)+.00224565*T**2-2.81835E-07*T**3 +1376270*T**(-1); 2400 Y -70882.739+462.110749*T-67.956*T*LN(T)+.01184945*T**2-7.88955E-07*T**3 +18075200*T**(-1); 3458 Y +346325.888-1211.37186*T+140.831655*T*LN(T)-.033764567*T**2 +1.053726E-06*T**3-1.34548866E+08*T**(-1); 5000 Y -78564.296+346.997842*T-49.519*T*LN(T); 6000 N ! FUNCTION GLIQRH 298.15 +11244.082+125.099593*T-24.0178336*T*LN(T) -.003424186*T**2-1.68032E-07*T**3+55846*T**(-1); 700 Y +35898.508-147.926418*T+15.6492377*T*LN(T)-.028665357*T**2 +2.100572E-06*T**3-2638940*T**(-1); 2237 Y -18208.54+332.974832*T-50.58456*T*LN(T); 2500 N ! FUNCTION GHSERRH 298.15 -7848.828+132.020923*T-24.0178336*T*LN(T) -.003424186*T**2-1.68032E-07*T**3+55846*T**(-1); 1200 Y -28367.852+305.771019*T-48.3766632*T*LN(T)+.00966345*T**2 -1.512774E-06*T**3+3348162*T**(-1); 2237 Y -6237470.48+30151.6342*T-3874.21058*T*LN(T)+1.04921361*T**2 -5.3978814E-05*T**3+1.88036218E+09*T**(-1); 2450 Y -44863.489+344.889895*T-50.58456*T*LN(T); 2500 N ! FUNCTION GBCCRH 298.15 +GHSERRH#+19000-4.7*T; 2500 N ! FUNCTION GHCPRH 298.15 +GHSERRH#+3000-.5*T; 2500 N ! FUNCTION GHSERRN 298.15 -6223.28228-36.6929111*T-20.83273*T*LN(T) +1.887983E-05*T**2-1.00153433E-09*T**3+2031.768*T**(-1); 7200 Y -582791.297+1000.48119*T-137.2327*T*LN(T)+.010524605*T**2 -1.79927333E-07*T**3+5.383375E+08*T**(-1); 9800 Y -804769.059+1450.77695*T-188.0433*T*LN(T)+.01510267*T**2 -2.52325333E-07*T**3+6.727465E+08*T**(-1); 12500 Y +9671336.36-10142.4734*T+1037.633*T*LN(T)-.04865342*T**2 +3.69745167E-07*T**3-1.612149E+10*T**(-1); 14500 Y +17110816.5-17603.9629*T+1817.362*T*LN(T)-.08493845*T**2 +6.860405E-07*T**3-2.941658E+10*T**(-1); 17000 Y -10550925.5+5698.86365*T-569.4259*T*LN(T)+.00660433*T**2 +2.76204667E-08*T**3+3.0700315E+10*T**(-1); 20000 N ! FUNCTION GLIQRU 298.15 +19918.743+119.467485*T-22.9143287*T*LN(T) -.004062566*T**2+1.7641E-07*T**3+56377*T**(-1); 800 Y +50827.232-179.818561*T+19.539341*T*LN(T)-.026524167*T**2 +1.667839E-06*T**3-3861125*T**(-1); 2607 Y -17161.807+349.673561*T-51.8816*T*LN(T); 4500 N ! FUNCTION GFCCRU 298.15 +GHSERRU#+12500-2.4*T; 4500 N ! FUNCTION GBCCRU 298.15 +GHSERRU#+21500-5.05*T; 4500 N ! FUNCTION GHSERRU 298.15 -7561.873+127.866233*T-22.9143287*T*LN(T) -.004062566*T**2+1.7641E-07*T**3+56377*T**(-1); 1500 Y -59448.103+489.516214*T-72.3241219*T*LN(T)+.018726245*T**2 -1.952433E-06*T**3+11063885*T**(-1); 2607 Y -38588773+168610.517*T-21329.705*T*LN(T)+5.221639*T**2 -2.40245985E-04*T**3+1.30829926E+10*T**(-1); 2740 Y -55768.304+364.482314*T-51.8816*T*LN(T); 4500 N ! FUNCTION GLIQSS 298.15 -4196.575+85.63027*T-17.413*T*LN(T) -.00993935*T**2-7.0062E-08*T**3+1250*T**(-1); 335 Y +1790361.98-44195.4514*T+7511.61943*T*LN(T)-13.9855175*T**2 +.0048387386*T**3-79880891*T**(-1); 388.36 Y -876313.954+23366.873*T-4028.756*T*LN(T)+7.954595*T**2 -.00290851333*T**3+33980035*T**(-1); 432.25 Y +454088.687-7814.67023*T+1237.001*T*LN(T)-1.5607295*T**2 +3.59883667E-04*T**3-31765395*T**(-1); 500 Y +18554.561-144.895285*T+16.535*T*LN(T)-.0454119*T**2+8.327402E-06*T**3 -2705030*T**(-1); 700 Y +21243.126-113.298877*T+9.944*T*LN(T)-.0288384*T**2+3.791365E-06*T**3 -3507570*T**(-1); 900 Y +16117.849-32.79523*T-2.425*T*LN(T)-.01712545*T**2+1.84974E-06*T**3 -3215170*T**(-1); 1300 Y -6461.814+175.590536*T-32*T*LN(T); 1301 N ! FUNCTION GFCCSS 298.15 +GHSERSS#+105000; 1301 N ! FUNCTION GBCCSS 298.15 +GHSERSS#+105000; 1301 N ! FUNCTION GHSERSS 298.15 -5198.294+53.913855*T-10.726*T*LN(T) -.0273801*T**2+8.179537E-06*T**3; 368.30 Y -6475.706+94.182332*T-17.8693298*T*LN(T)-.010936877*T**2 +1.406467E-06*T**3+36871*T**(-1); 1300 Y -12485.546+188.304687*T-32*T*LN(T); 1301 N ! FUNCTION GGASS2 298.15 +117374.548+2.98629558*T-34.09678*T*LN(T) -.002325464*T**2+1.85480167E-07*T**3+128593.6*T**(-1); 1000 Y +117352.438+2.50383258*T-34.04744*T*LN(T)-.0021150245*T**2 +9.16602333E-08*T**3+175718.45*T**(-1); 3400 Y +124361.091+14.5182895*T-36.1923*T*LN(T)-5.930925E-04*T**2 -7.54259333E-09*T**3-7484105*T**(-1); 6000 N ! FUNCTION GLIQSB 298.15 +GHSERSB#+19822.328-21.923164*T-1.74847E-20*T**7; 903.78 Y +8175.359+147.455986*T-31.38*T*LN(T); 2000 N ! FUNCTION GFCCSB 298.15 +GHSERSB#+19874-13.7*T; 2000 N ! FUNCTION GBCCSB 298.15 +GHSERSB#+19874-15.1*T; 2000 N ! FUNCTION GHCPSB 298.15 +GHSERSB#+19874-13*T; 2000 N ! FUNCTION GHSERSB 298.15 -9242.858+156.154689*T-30.5130752*T*LN(T) +.007748768*T**2-3.003415E-06*T**3+100625*T**(-1); 903.78 Y -11738.83+169.485872*T-31.38*T*LN(T)+1.616849E+27*T**(-9); 2000 N ! FUNCTION GLIQSC 298.15 +6478.66+45.427539*T-10.7967803*T*LN(T) -.020636524*T**2+2.13106E-06*T**3-158106*T**(-1); 1608 Y -11832.111+275.871695*T-44.2249*T*LN(T); 3200 N ! FUNCTION GFCCSC 298.15 +GHSERSC#+5000; 3200 N ! FUNCTION GBCCSC 298.15 -6709.819+152.456835*T-28.1882*T*LN(T) +.00321892*T**2-1.64531E-06*T**3+72177*T**(-1); 800 Y -5531.567+131.735447*T-24.9132*T*LN(T)-5.73295E-04*T**2 -8.59345E-07*T**3; 1000 Y +230161.408-2004.05469*T+276.76664*T*LN(T)-.167120107*T**2 +1.5637371E-05*T**3-33783257*T**(-1); 1608 Y -25928.011+283.642312*T-44.2249*T*LN(T); 3200 N ! FUNCTION GHSERSC 298.15 -8689.547+153.48097*T-28.1882*T*LN(T) +.00321892*T**2-1.64531E-06*T**3+72177*T**(-1); 800 Y -7511.295+132.759582*T-24.9132*T*LN(T)-5.73295E-04*T**2 -8.59345E-07*T**3; 1608 Y +261143.04-1817.92245*T+241.441051*T*LN(T)-.117529396*T**2 +8.7398E-06*T**3-50607159*T**(-1); 2000 Y -30515.246+286.474338*T-44.2249*T*LN(T); 3200 N ! FUNCTION GLIQSE 298.15 +50533.347-1178.28824*T+194.107439*T*LN(T) -.390268991*T**2+1.19219297E-04*T**3-2224398*T**(-1); 494 Y -5228.304+183.72559*T-35.1456*T*LN(T); 1000 N ! FUNCTION GHSERSE 298.15 -9376.371+174.205877*T-33.6527*T*LN(T) +.02424314*T**2-1.5318461E-05*T**3+102249*T**(-1); 494 Y -37546.134+507.111538*T-81.2006585*T*LN(T)+.037144892*T**2 -5.611026E-06*T**3+2614263*T**(-1); 800 Y -12193.47+197.770166*T-35.1456*T*LN(T); 1000 N ! FUNCTION GLIQSI 298.15 +GHSERSI#+50696.36-30.099439*T+2.09307E-21*T**7; 1687 Y +40370.523+137.722298*T-27.196*T*LN(T); 3600 N ! FUNCTION GFCCSI 298.15 +GHSERSI#+51000-21.8*T; 3600 N ! FUNCTION GBCCSI 298.15 +GHSERSI#+47000-22.5*T; 3600 N ! FUNCTION GHCPSI 298.15 +GHSERSI#+49200-20.8*T; 3600 N ! FUNCTION GHSERSI 298.15 -8162.609+137.236859*T-22.8317533*T*LN(T) -.001912904*T**2-3.552E-09*T**3+176667*T**(-1); 1687 Y -9457.642+167.281367*T-27.196*T*LN(T)-4.20369E+30*T**(-9); 3600 N ! FUNCTION GLIQSM 298.15 +3468.783+20.117456*T-11.6968284*T*LN(T) -.032418177*T**2+4.544272E-06*T**3+23528*T**(-1); 1190 Y -11728.229+273.487076*T-50.208*T*LN(T); 2100 N ! FUNCTION GBCCSM 298.15 -4368.72+55.972523*T-16.9298494*T*LN(T) -.025446016*T**2+3.579527E-06*T**3+94209*T**(-1); 1190 Y -15957.862+253.121044*T-46.9445*T*LN(T); 1345 Y +111191.653-624.680805*T+71.6856914*T*LN(T)-.047314968*T**2 +3.329865E-06*T**3-24870276*T**(-1); 2100 N ! FUNCTION GHCPSM 298.15 +GHSERSM#+69.977-.069491*T; 2100 N ! FUNCTION GHSERSM 298.15 -3872.013-32.10748*T-1.6485*T*LN(T)-.050254*T**2 +1.010345E-05*T**3-82168*T**(-1); 700 Y -50078.215+627.869894*T-102.665*T*LN(T)+.0474522*T**2 -7.538383E-06*T**3+3861770*T**(-1); 1190 Y +289719.819-2744.50976*T+381.41982*T*LN(T)-.254986338*T**2 +2.7512152E-05*T**3-40102102*T**(-1); 1345 Y -23056.079+282.194375*T-50.208*T*LN(T); 2100 N ! FUNCTION GLIQSN 100 +GHSERSN#+7103.092-14.087767*T+1.47031E-18*T**7; 505.08 Y +9496.31-9.809114*T-8.2590486*T*LN(T)-.016814429*T**2 +2.623131E-06*T**3-1081244*T**(-1); 800 Y -1285.372+125.182498*T-28.4512*T*LN(T); 3000 N ! FUNCTION GFCCSN 100 +GHSERSN#+5510-8.46*T; 3000 N ! FUNCTION GBCCSN 100 +GHSERSN#+4400-6*T; 3000 N ! FUNCTION GHCPSN 100 +GHSERSN#+3900-7.646*T; 3000 N ! FUNCTION GHSERSN 100 -7958.517+122.765451*T-25.858*T*LN(T) +5.1185E-04*T**2-3.192767E-06*T**3+18440*T**(-1); 250 Y -5855.135+65.443315*T-15.961*T*LN(T)-.0188702*T**2+3.121167E-06*T**3 -61960*T**(-1); 505.08 Y +2524.724+4.005269*T-8.2590486*T*LN(T)-.016814429*T**2 +2.623131E-06*T**3-1081244*T**(-1)-1.2307E+25*T**(-9); 800 Y -8256.959+138.99688*T-28.4512*T*LN(T)-1.2307E+25*T**(-9); 3000 N ! FUNCTION GLIQSR 298.15 +2194.997-10.118994*T-5.0668978*T*LN(T) -.031840595*T**2+4.981237E-06*T**3-265559*T**(-1); 1050 Y -10855.29+213.406219*T-39.463*T*LN(T); 3000 N ! FUNCTION GHSERSR 298.15 -7532.367+107.183879*T-23.905*T*LN(T) -.00461225*T**2-1.67477E-07*T**3-2055*T**(-1); 820 Y -13380.102+153.196104*T-30.0905432*T*LN(T)-.003251266*T**2 +1.84189E-07*T**3+850134*T**(-1); 3000 N ! FUNCTION GBCCSR 298.15 -6779.234+116.583654*T-25.6708365*T*LN(T) -.003126762*T**2+2.2965E-07*T**3+27649*T**(-1); 820 Y -6970.594+122.067301*T-26.57*T*LN(T)-.0019493*T**2-1.7895E-08*T**3 +16495*T**(-1); 1050 Y +8168.357+.423037*T-9.7788593*T*LN(T)-.009539908*T**2+5.20221E-07*T**3 -2414794*T**(-1); 3000 N ! FUNCTION GHCPSR 298.15 +GHSERSR#+250+.7*T; 3000 N ! FUNCTION GHSERT1 298.15 +217173.654+10.8312449*T-20.786*T*LN(T); 6000 N ! FUNCTION GHSERT2 298.15 -7866.66628+27.0791947*T-26.83661*T*LN(T) -.0018402735*T**2-3.83766667E-07*T**3-47495.205*T**(-1); 800 Y -10075.8547+36.1414244*T-27.73559*T*LN(T)-.003476423*T**2 +1.94916667E-07*T**3+366681*T**(-1); 2300 Y -11704.7696+66.9358*T-32.14505*T*LN(T)-.0012333515*T**2 +2.081645E-08*T**3-649401*T**(-1); 5800 Y -154096.368+295.516281*T-57.15841*T*LN(T)+2.810452E-04*T**2 +1.757905E-08*T**3+1.356364E+08*T**(-1); 9800 Y -142455.129+386.293696*T-68.45016*T*LN(T)+.001927947*T**2 -1.4502375E-08*T**3+15481045*T**(-1); 18500 Y +484422.833-154.39806*T-12.90783*T*LN(T)-2.6700035E-04*T**2 +1.79437333E-09*T**3-1.31833E+09*T**(-1); 20000 N ! FUNCTION GLIQTA 298.15 +21875.086+111.561128*T-23.7592624*T*LN(T) -.002623033*T**2+1.70109E-07*T**3-3293*T**(-1); 1000 Y +43884.339-61.981795*T+.0279523*T*LN(T)-.012330066*T**2 +6.14599E-07*T**3-3523338*T**(-1); 3290 Y -6314.543+258.110873*T-41.84*T*LN(T); 6000 N ! FUNCTION GFCCTA 298.15 +GHSERTA#+16000+1.7*T; 6000 N ! FUNCTION GHSERTA 298.15 -7285.889+119.139857*T-23.7592624*T*LN(T) -.002623033*T**2+1.70109E-07*T**3-3293*T**(-1); 1300 Y -22389.955+243.88676*T-41.137088*T*LN(T)+.006167572*T**2 -6.55136E-07*T**3+2429586*T**(-1); 2500 Y +229382.886-722.59722*T+78.5244752*T*LN(T)-.017983376*T**2 +1.95033E-07*T**3-93813648*T**(-1); 3290 Y -1042384.01+2985.49125*T-362.159132*T*LN(T)+.043117795*T**2 -1.055148E-06*T**3+5.54714342E+08*T**(-1); 6000 N ! FUNCTION GHCPTA 298.15 +GHSERTA#+12000+2.4*T; 6000 N ! FUNCTION GLIQTB 298.15 +3945.831+29.867521*T-14.252646*T*LN(T) -.020466105*T**2+2.17475E-06*T**3-160724*T**(-1); 1562 Y -13247.649+251.16889*T-46.4842*T*LN(T); 3000 N ! FUNCTION GBCCTB 298.15 -16674.323+406.656848*T-77.5006*T*LN(T) +.0832265*T**2-2.5672833E-05*T**3+562430*T**(-1); 600 Y -4604.771+99.958913*T-25.8659*T*LN(T)-.002757005*T**2-8.05838E-07*T**3 +172355*T**(-1); 1200 Y +633060.245-5157.77779*T+706.580596*T*LN(T)-.373763517*T**2 +3.4100235E-05*T**3-1.03233571E+08*T**(-1); 1562 Y -23398.029+257.388486*T-46.4842*T*LN(T); 3000 N ! FUNCTION GHSERTB 298.15 -20842.158+409.309555*T-77.5006*T*LN(T) +.0832265*T**2-2.5672833E-05*T**3+562430*T**(-1); 600 Y -8772.606+102.61162*T-25.8659*T*LN(T)-.002757005*T**2-8.05838E-07*T**3 +172355*T**(-1); 1200 Y -7944.942+101.7776*T-25.9584*T*LN(T)-.001676335*T**2-1.067632E-06*T**3; 1562 Y -265240.309+1456.04268*T-200.215695*T*LN(T)+.041615159*T**2 -2.044697E-06*T**3+65043790*T**(-1); 3000 N ! FUNCTION GLIQTC 298.15 +GHSERTC#+30402.134-12.313*T-9.62385E-22*T**7; 2430 Y -12221.9+303.7538*T-47*T*LN(T); 4000 N ! FUNCTION GFCCTC 298.15 +GHSERTC#+10000-1.5*T; 4000 N ! FUNCTION GBCCTC 298.15 +GHSERTC#+18000-4.5*T; 4000 N ! FUNCTION GHSERTC 298.15 -7947.794+132.5101*T-24.3394*T*LN(T) -.002954747*T**2+63855*T**(-1); 2430 Y -47759.99+318.286*T-47*T*LN(T)+6.63829E+32*T**(-9); 4000 N ! FUNCTION GLIQTE 298.15 -17554.731+685.877639*T-126.318*T*LN(T) +.2219435*T**2-9.42075E-05*T**3+827930*T**(-1); 626.49 Y -3165763.48+46756.357*T-7196.41*T*LN(T)+7.09775*T**2-.00130692833*T**3 +2.58051E+08*T**(-1); 722.66 Y +180326.959-1500.57909*T+202.743*T*LN(T)-.142016*T**2 +1.6129733E-05*T**3-24238450*T**(-1); 1150 Y +6328.687+148.708299*T-32.5596*T*LN(T); 1600 N ! FUNCTION GHSERTE 298.15 -10544.679+183.372894*T-35.6687*T*LN(T) +.01583435*T**2-5.240417E-06*T**3+155015*T**(-1); 722.66 Y +9160.595-129.265373*T+13.004*T*LN(T)-.0362361*T**2+5.006367E-06*T**3 -1286810*T**(-1); 1150 Y -12781.349+174.901226*T-32.5596*T*LN(T); 1600 N ! FUNCTION GLIQTH 298.15 +5031.109+110.886346*T-24.987*T*LN(T) -.00168345*T**2-9.09067E-07*T**3+10865*T**(-1); 1499.80 Y -15602.847+127.657716*T-24.03*T*LN(T)-.0136421*T**2+1.210117E-06*T**3 +7111100*T**(-1); 2014.50 Y -17273.382+275.001274*T-46.024*T*LN(T); 4000 N ! FUNCTION GHSERTH 298.15 -7732.08+116.273975*T-24.841*T*LN(T) -.00236725*T**2-5.2883E-07*T**3+13010*T**(-1); 1633 Y -37352.871+236.906118*T-39.107*T*LN(T)-.00358025*T**2+2.36893E-07*T**3 +7981000*T**(-1); 2900 Y -33353.313+283.231045*T-46.024*T*LN(T); 4000 N ! FUNCTION GBCCTH 298.15 -2321.06+133.531195*T-28.244*T*LN(T) +4.3775E-04*T**2-5.3048E-07*T**3+91190*T**(-1); 1633 Y -115978.348+800.909049*T-116.453*T*LN(T)+.03098*T**2-2.536883E-06*T**3 +27512600*T**(-1); 2023 Y -33602.796+208.774709*T-35.813*T*LN(T)-.00346655*T**2+1.66067E-07*T**3 +11876950*T**(-1); 3600 Y -34333.615+283.181494*T-46.024*T*LN(T); 4000 N ! FUNCTION GLIQTI 298.15 +4134.494+126.63427*T-23.9933*T*LN(T) -.004777975*T**2+1.06716E-07*T**3+72636*T**(-1); 900 Y +4382.601+126.00713*T-23.9887*T*LN(T)-.0042033*T**2-9.0876E-08*T**3 +42680*T**(-1); 1155 Y +13103.253+59.9956*T-14.9466*T*LN(T)-.0081465*T**2+2.02715E-07*T**3 -1477660*T**(-1); 1300 Y +369519.198-2554.0225*T+342.059267*T*LN(T)-.163409355*T**2 +1.2457117E-05*T**3-67034516*T**(-1); 1941 Y -19887.066+298.7367*T-46.29*T*LN(T); 4000 N ! FUNCTION GFCCTI 298.15 +GHSERTI#+6000-.1*T; 4000 N ! FUNCTION GBCCTI 298.15 -1272.064+134.71418*T-25.5768*T*LN(T) -6.63845E-04*T**2-2.78803E-07*T**3+7208*T**(-1); 1155 Y +6667.385+105.366379*T-22.3771*T*LN(T)+.00121707*T**2-8.4534E-07*T**3 -2002750*T**(-1); 1941 Y +26483.26-182.426471*T+19.0900905*T*LN(T)-.02200832*T**2 +1.228863E-06*T**3+1400501*T**(-1); 4000 N ! FUNCTION GHSERTI 298.15 -8059.921+133.615208*T-23.9933*T*LN(T) -.004777975*T**2+1.06716E-07*T**3+72636*T**(-1); 900 Y -7811.815+132.988068*T-23.9887*T*LN(T)-.0042033*T**2-9.0876E-08*T**3 +42680*T**(-1); 1155 Y +908.837+66.976538*T-14.9466*T*LN(T)-.0081465*T**2+2.02715E-07*T**3 -1477660*T**(-1); 1941 Y -124526.786+638.806871*T-87.2182461*T*LN(T)+.008204849*T**2 -3.04747E-07*T**3+36699805*T**(-1); 4000 N ! FUNCTION GLIQTL 200 -946.623+.755649*T-7.44455*T*LN(T)-.044350292*T**2 +1.4248046E-05*T**3-54228*T**(-1); 577 Y -614.74+98.472609*T-25.8437*T*LN(T)-8.3662E-04*T**2+9E-12*T**3 -612570*T**(-1); 1801 N ! FUNCTION GFCCTL 200 +GHSERTL#+310; 1801 N ! FUNCTION GBCCTL 200 -9194.493+150.019517*T-33.0508*T*LN(T)+.0172318*T**2 -1.0115933E-05*T**3+82153*T**(-1); 577 Y -41836.403+482.633817*T-79.2926704*T*LN(T)+.026042993*T**2 -2.359101E-06*T**3+3507810*T**(-1); 1800 Y -623.343+101.120182*T-25.8437*T*LN(T)-8.3662E-04*T**2+9E-12*T**3 -612570*T**(-1); 1801 N ! FUNCTION GHSERTL 200 -8104.038+107.140405*T-25.2274*T*LN(T)-.0033063*T**2 -1.21807E-07*T**3+42058*T**(-1); 577 Y -15406.859+196.771926*T-38.4130658*T*LN(T)+.005228106*T**2 -5.19136E-07*T**3+729665*T**(-1); 1800 Y -4885.034+106.361006*T-25.8437*T*LN(T)-8.3662E-04*T**2+9E-12*T**3 -612570*T**(-1); 1801 N ! FUNCTION GLIQTM 298.15 +3182.534+144.479977*T-34.3664974*T*LN(T) +.012110965*T**2-3.831156E-06*T**3+95982*T**(-1); 600 Y +22640.028-126.738485*T+6.8744933*T*LN(T)-.025487085*T**2 +2.288172E-06*T**3-1585412*T**(-1); 1818 Y -10090.305+214.184413*T-41.37976*T*LN(T); 2300 N ! FUNCTION GHSERTM 298.15 -10016.715+151.037648*T-34.3664974*T*LN(T) +.012110965*T**2-3.831156E-06*T**3+95982*T**(-1); 700 Y -14701.965+147.957496*T-32.1951269*T*LN(T)+4.44753E-04*T**2 -3.96694E-07*T**3+1091664*T**(-1); 1600 Y -8669.227+97.98144*T-25.1816969*T*LN(T)-.003384563*T**2; 1818 Y +727125.608-4147.40063*T+534.082763*T*LN(T)-.19093039*T**2 +1.1689185E-05*T**3-1.8038222E+08*T**(-1); 2300 N ! FUNCTION GLIQUU 298.15 +GHSERUU#+12355.5-10.3239*T; 3000 N ! FUNCTION GFCCUU 298.15 +GHSERUU#+5000; 3000 N ! FUNCTION GBCCUU 298.15 -752.767+131.5381*T-27.5152*T*LN(T) -.00835595*T**2+9.67907E-07*T**3+204611*T**(-1); 1049 Y -4698.365+202.685635*T-38.2836*T*LN(T); 3000 N ! FUNCTION GHCPUU 298.15 +4247.233+131.5301*T-27.5152*T*LN(T) -.00835595*T**2+9.67907E-07*T**3+204611*T**(-1); 1049 Y +301.635+202.677635*T-38.2836*T*LN(T); 2500 N ! FUNCTION GHSERUU 298.15 -8407.734+130.955151*T-26.9182*T*LN(T) +.00125156*T**2-4.42605E-06*T**3+38568*T**(-1); 955 Y -22521.8+292.121093*T-48.66*T*LN(T); 3000 N ! FUNCTION GLIQVV 298.15 +GHSERVV#+20764.117-9.455552*T-5.19136E-22*T**7; 2183 Y -19617.51+311.055983*T-47.43*T*LN(T); 4000 N ! FUNCTION GFCCVV 298.15 +GHSERVV#+7500+1.7*T; 4000 N ! FUNCTION GHSERVV 298.15 -7930.43+133.346053*T-24.134*T*LN(T)-.003098*T**2 +1.2175E-07*T**3+69460*T**(-1); 790 Y -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; 2183 Y -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); 4000 N ! FUNCTION GHCPVV 298.15 +GHSERVV#+4000+2.4*T; 4000 N ! FUNCTION GLIQWW 298.15 +GHSERWW#+52160.584-14.10999*T-2.713468E-24*T**7; 3695 Y -30436.051+375.175*T-54*T*LN(T); 6000 N ! FUNCTION GFCCWW 298.15 +GHSERWW#+19300+.63*T; 6000 N ! FUNCTION GHSERWW 298.15 -7646.311+130.4*T-24.1*T*LN(T)-.001936*T**2 +2.07E-07*T**3+44500*T**(-1)-5.33E-11*T**4; 3695 Y -82868.801+389.362335*T-54*T*LN(T)+1.528621E+33*T**(-9); 6000 N ! FUNCTION GHCPWW 298.15 +GHSERWW#+14750; 6000 N ! FUNCTION GHSERXE 298.15 -6218.7749-30.2044649*T-20.82368*T*LN(T) +1.4072105E-05*T**2-6.82734E-10*T**3+1700.88*T**(-1); 8200 Y -704701.42+1081.53707*T-143.6918*T*LN(T)+.00967559*T**2 -1.44048483E-07*T**3+7.482925E+08*T**(-1); 11000 Y -1276720.23+1886.04885*T-231.1446*T*LN(T)+.01552948*T**2 -2.16645667E-07*T**3+1.43637E+09*T**(-1); 14000 Y +9750984.27-9088.96014*T+914.806*T*LN(T)-.037416845*T**2 +2.42242833E-07*T**3-1.84681E+10*T**(-1); 16500 Y +20031412.8-18268.3895*T+1861.258*T*LN(T)-.0761213*T**2 +5.38855667E-07*T**3-3.939352E+10*T**(-1); 20000 N ! FUNCTION GGASXE2 298.15 -12203.7597-137.981553*T-20.77691*T*LN(T) -4.6678605E-06*T**2+4.43969167E-10*T**3-45209.57*T**(-1); 2000 N ! FUNCTION GLIQYY 100 +2098.50738+119.41873*T-24.6467508*T*LN(T) -.00347023463*T**2-8.12981167E-07*T**3+23713.7332*T**(-1); 1000 Y +7386.44846+19.4520171*T-9.0681627*T*LN(T)-.0189533369*T**2 +1.7595327E-06*T**3; 1795.15 Y -12976.5957+257.400783*T-43.0952*T*LN(T); 3700 N ! FUNCTION GFCCYY 100 +GHSERYY#+6000; 3700 N ! FUNCTION GBCCYY 100 -833.658863+123.667346*T-25.5832578*T*LN(T) -.00237175965*T**2+9.10372497E-09*T**3+27340.0687*T**(-1); 1000 Y -1297.79829+134.528352*T-27.3038477*T*LN(T)-5.41757644E-04*T**2 -3.05012175E-07*T**3; 1795.15 Y +15389.4975+.981325399*T-8.88296647*T*LN(T)-.00904576576*T**2 +4.02944768E-07*T**3-2542575.96*T**(-1); 3700 N ! FUNCTION GHSERYY 100 -8011.09379+128.572856*T-25.6656992*T*LN(T) -.00175716414*T**2-4.17561786E-07*T**3+26911.509*T**(-1); 1000 Y -7179.74574+114.497104*T-23.4941827*T*LN(T)-.0038211802*T**2 -8.2534534E-08*T**3; 1795.15 Y -67480.7761+382.124727*T-56.9527111*T*LN(T)+.00231774379*T**2 -7.22513088E-08*T**3+18077162.6*T**(-1); 3700 N ! FUNCTION GLIQYB 298.15 +7030.788-40.615571*T-1.8061816*T*LN(T) -.03250938*T**2+5.136665E-06*T**3-370554*T**(-1); 1033 Y -6445.835+186.690398*T-36.7774*T*LN(T); 2000 N ! FUNCTION GHSERYB 298.15 -9370.941+189.327664*T-40.0791*T*LN(T) +.04227115*T**2-2.2242E-05*T**3; 553 Y -8192.154+121.065655*T-26.7591*T*LN(T)-.00256065*T**2; 1033 Y +16034.89-89.478241*T+2.7623966*T*LN(T)-.017961331*T**2 +1.421719E-06*T**3-3631462*T**(-1); 2000 N ! FUNCTION GBCCYB 298.15 -965.99-21.293677*T-3.8534432*T*LN(T) -.030009694*T**2+4.743871E-06*T**3-334650*T**(-1); 1033 Y -13368.113+188.313864*T-36.1079*T*LN(T); 1097 Y -3911.847+113.174165*T-25.7402233*T*LN(T)-.004743348*T**2 +3.63044E-07*T**3-1553668*T**(-1); 2000 N ! FUNCTION GHCPYB 298.15 +GHSERYB#+5000; 2000 N ! FUNCTION GLIQZN 298.15 +GHSERZN#+7157.222-10.29305*T-3.58949E-19*T**7; 692.67 Y -3620.385+161.60854*T-31.38*T*LN(T); 1700 N ! FUNCTION GFCCZN 298.15 +GHSERZN#+2969.82-1.56968*T; 1700 N ! FUNCTION GBCCZN 298.15 +GHSERZN#+2886.96-2.5104*T; 1700 N ! FUNCTION GHCPZN 298.15 +GHSERZN#+2969.82-1.56968*T; 1700 N ! FUNCTION GHSERZN 298.15 -7285.787+118.470069*T-23.701314*T*LN(T) -.001712034*T**2-1.264963E-06*T**3; 692.67 Y -11070.546+172.345644*T-31.38*T*LN(T)+4.7047E+26*T**(-9); 1700 N ! FUNCTION GLIQZR 298.15 +GHSERZR#+18147.69-9.080812*T+1.6275E-22*T**7; 2128 Y -8281.26+253.812609*T-42.144*T*LN(T); 6000 N ! FUNCTION GFCCZR 298.15 +GHSERZR#+7600-.9*T; 6000 N ! FUNCTION GBCCZR 298.15 -525.539+124.9457*T-25.607406*T*LN(T) -3.40084E-04*T**2-9.729E-09*T**3+25233*T**(-1)-7.6143E-11*T**4; 2128 Y -30705.955+264.284163*T-42.144*T*LN(T)+1.276058E+32*T**(-9); 6000 N ! FUNCTION GHSERZR 130 -7827.595+125.64905*T-24.1618*T*LN(T)-.00437791*T**2 +34971*T**(-1); 2128 Y -26085.921+262.724183*T-42.144*T*LN(T)-1.342896E+31*T**(-9); 6000 N ! FUNCTION UN_ASS 298.15 +0; 300 N ! TYPE_DEFINITION % SEQ *! DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! PHASE GAS:G % 1 1.0 ! CONSTITUENT GAS:G :AC,AR,AT,AT2,BR2,C,CL2,CM,D,D2,ES,F2,FM,FR,FR2,H2,HE, I2,KR,N2,NE,O2,PM,PO,RA,RN,S2,T,T2,T3,XE,XE2 : ! PARAMETER G(GAS,AC;0) 298.15 +GGASAC1#+RTLNP#; 6000 N REF3 ! PARAMETER G(GAS,AR;0) 298.15 +GHSERAR#+RTLNP#; 6000 N REF2 ! PARAMETER G(GAS,AT;0) 298.15 +GGASAT1#+RTLNP#; 6000 N REF3 ! PARAMETER G(GAS,AT2;0) 298.15 +GGASAT2#+RTLNP#; 6000 N REF3 ! PARAMETER G(GAS,BR2;0) 298.15 +GGASBR2#+RTLNP#; 6000 N REF3 ! PARAMETER G(GAS,C;0) 298.15 +GGASC1#+RTLNP#; 6000 N REF2 ! PARAMETER G(GAS,CL2;0) 298.15 +2*GHSERCL#+RTLNP#; 6000 N REF3 ! PARAMETER G(GAS,CM;0) 298.15 +GGASCM1#+RTLNP#; 6000 N REF3 ! PARAMETER G(GAS,D;0) 298.15 +GHSERD1#+RTLNP#; 6000 N REF2 ! PARAMETER G(GAS,D2;0) 298.15 +GHSERD2#+RTLNP#; 6000 N REF2 ! PARAMETER G(GAS,ES;0) 298.15 +GGASES1#+RTLNP#; 6000 N REF3 ! PARAMETER G(GAS,F2;0) 298.15 +2*GHSERFF#+RTLNP#; 6000 N REF3 ! PARAMETER G(GAS,FM;0) 298.15 +GGASFM1#+RTLNP#; 6000 N REF3 ! PARAMETER G(GAS,FR;0) 298.15 +GGASFR1#+RTLNP#; 6000 N REF3 ! PARAMETER G(GAS,FR2;0) 298.15 +GGASFR2#+RTLNP#; 6000 N REF3 ! PARAMETER G(GAS,H2;0) 298.15 +2*GHSERHH#+RTLNP#; 6000 N REF3 ! PARAMETER G(GAS,HE;0) 298.15 +GHSERHE#+RTLNP#; 6000 N REF3 ! PARAMETER G(GAS,I2;0) 298.15 +GGASI2#+RTLNP#; 6000 N REF3 ! PARAMETER G(GAS,KR;0) 298.15 +GHSERKR#+RTLNP#; 6000 N REF3 ! PARAMETER G(GAS,N2;0) 298.15 +2*GHSERNN#; 6000 N REF2 ! PARAMETER G(GAS,NE;0) 298.15 +GHSERNE#+RTLNP#; 6000 N REF3 ! PARAMETER G(GAS,O2;0) 298.15 +2*GHSEROO#; 6000 N REF2 ! PARAMETER G(GAS,PM;0) 298.15 +GGASPM1#+RTLNP#; 6000 N REF3 ! PARAMETER G(GAS,PO;0) 298.15 +GGASPO1#+RTLNP#; 6000 N REF3 ! PHASE LIQUID % 1 1.0 ! CONSTITUENT LIQUID :AC,AG,AL,AM,AS,AT2,AU,B,BA,BE,BI,BR2,C,CA,CD,CE,CM, CO,CR,CS,CU,DY,ER,ES,EU,FE,GA,GD,GE,HF,HG,HO,I2,IN,IR,K,LA,LI,LU,MG,MN, MO,N,NA,NB,ND,NI,NP,O,OS,P,PA,PB,PD,PM,PO,PR, PT,PU,RA,RB,RE,RH,RU,S,SB,SC,SE,SI,SM,SN,SR,TA,TB, TC,TE,TH,TI,TL,TM,U,V,W,Y,YB,ZN,ZR : ! PARAMETER G(LIQUID,AC;0) 298.15 +GHSERAC#+12000 -9.07029478*T; 5000 N REF3 ! PARAMETER G(LIQUID,AG;0) 298.15 +GLIQAG#; 3000 N REF2 ! PARAMETER G(LIQUID,AL;0) 298.15 +GLIQAL#; 2900 N REF2 ! PARAMETER G(LIQUID,AM;0) 298.15 +GLIQAM#; 3000 N REF3 ! PARAMETER G(LIQUID,AS;0) 298.15 +GLIQAS#; 1200 N REF2 ! PARAMETER G(LIQUID,AT2;0) 298.15 +2*GHSERAT#+20000-40*T; 6000 N REF3 ! PARAMETER G(LIQUID,AU;0) 298.15 +GLIQAU#; 3200 N REF2 ! PARAMETER G(LIQUID,B;0) 298.15 +GLIQBB#; 6000 N REF4 ! PARAMETER G(LIQUID,BA;0) 298.15 +GLIQBA#; 4000 N REF2 ! PARAMETER G(LIQUID,BE;0) 298.15 +GLIQBE#; 3000 N REF2 ! PARAMETER G(LIQUID,BI;0) 298.15 +GLIQBI#; 3000 N REF2 ! PARAMETER G(LIQUID,BR2;0) 298.15 +2*GHSERBR#; 6000 N REF3 ! PARAMETER G(LIQUID,C;0) 298.15 +GLIQCC#; 6000 N REF2 ! PARAMETER G(LIQUID,CA;0) 298.15 +GLIQCA#; 3001 N REF4 ! PARAMETER G(LIQUID,CD;0) 298.15 +GLIQCD#; 1600 N REF2 ! PARAMETER G(LIQUID,CE;0) 298.15 +GLIQCE#; 4000 N REF2 ! PARAMETER G(LIQUID,CM;0) 298.15 +GHSERCM#+17886.6 -11.1426799*T; 6000 N REF3 ! PARAMETER G(LIQUID,CO;0) 298.15 +GLIQCO#; 6000 N REF2 ! PARAMETER G(LIQUID,CR;0) 298.15 +GLIQCR#; 6000 N REF2 ! PARAMETER G(LIQUID,CS;0) 200 +GLIQCS#; 2000 N REF2 ! PARAMETER G(LIQUID,CU;0) 298.15 +GLIQCU#; 3200 N REF2 ! PARAMETER G(LIQUID,DY;0) 100 +GLIQDY#; 3000 N REF2 ! PARAMETER G(LIQUID,ER;0) 298.15 +GLIQER#; 3200 N REF2 ! PARAMETER G(LIQUID,ES;0) 298.15 +GHSERES#+9405.6 -8.30150044*T; 6000 N REF3 ! PARAMETER G(LIQUID,EU;0) 298.15 +GLIQEU#; 1901 N REF2 ! PARAMETER G(LIQUID,FE;0) 298.15 +GLIQFE#; 6000 N REF2 ! PARAMETER G(LIQUID,GA;0) 200 +GLIQGA#; 4000 N REF3 ! PARAMETER G(LIQUID,GD;0) 100 +GLIQGD#; 3600 N REF2 ! PARAMETER G(LIQUID,GE;0) 298.15 +GLIQGE#; 3200 N REF2 ! PARAMETER G(LIQUID,HF;0) 298.15 +GLIQHF#; 3001 N REF3 ! PARAMETER G(LIQUID,HG;0) 200 +GHSERHG#; 2000 N REF1 ! PARAMETER G(LIQUID,HO;0) 298.15 +GLIQHO#; 3001 N REF3 ! PARAMETER G(LIQUID,I2;0) 298.15 +2*GHSERII#+15517.2 -40.1272304*T; 1000 N REF3 ! PARAMETER G(LIQUID,IN;0) 298.15 +GLIQIN#; 3800 N REF3 ! PARAMETER G(LIQUID,IR;0) 298.15 +GLIQIR#; 4000 N REF2 ! PARAMETER G(LIQUID,K;0) 200 +GLIQKK#; 2200 N REF3 ! PARAMETER G(LIQUID,LA;0) 298.15 +GLIQLA#; 4000 N REF2 ! PARAMETER G(LIQUID,LI;0) 200 +GLIQLI#; 3000 N REF4 ! PARAMETER G(LIQUID,LU;0) 298.15 +GLIQLU#; 3700 N REF2 ! PARAMETER G(LIQUID,MG;0) 298.15 +GLIQMG#; 3000 N REF2 ! PARAMETER G(LIQUID,MN;0) 298.15 +GLIQMN#; 2000 N REF3 ! PARAMETER G(LIQUID,MO;0) 298.15 +GLIQMO#; 5000 N REF2 ! PARAMETER G(LIQUID,N;0) 298.15 +GLIQNN#; 6000 N REF2 ! PARAMETER G(LIQUID,NA;0) 200 +GLIQNA#; 2300 N REF2 ! PARAMETER G(LIQUID,NB;0) 298.15 +GLIQNB#; 6000 N REF2 ! PARAMETER G(LIQUID,ND;0) 298.15 +GLIQND#; 1800 N REF2 ! PARAMETER G(LIQUID,NI;0) 298.15 +GLIQNI#; 3000 N REF4 ! PARAMETER G(LIQUID,NP;0) 298.15 +GLIQNP#; 4000 N REF2 ! PARAMETER G(LIQUID,O;0) 298.15 +GLIQOO#; 6000 N REF2 ! PARAMETER G(LIQUID,OS;0) 298.15 +GLIQOS#; 5500 N REF2 ! PARAMETER G(LIQUID,P;0) 250 +GLIQPP#; 3000 N REF2 ! PARAMETER G(LIQUID,PA;0) 298.15 +GLIQPA#; 4000 N REF2 ! PARAMETER G(LIQUID,PB;0) 298.15 +GLIQPB#; 2100 N REF2 ! PARAMETER G(LIQUID,PD;0) 298.15 +GLIQPD#; 4000 N REF2 ! PARAMETER G(LIQUID,PM;0) 298.15 +GHSERPM#+10900 -8.60701804*T; 6000 N REF3 ! PARAMETER G(LIQUID,PO;0) 298.15 +GHSERPO#+10000 -18.9753321*T; 6000 N REF3 ! PARAMETER G(LIQUID,PR;0) 298.15 +GLIQPR#; 3800 N REF2 ! PARAMETER G(LIQUID,PT;0) 298.15 +GLIQPT#; 4000 N REF3 ! PARAMETER G(LIQUID,PU;0) 298.15 +GLIQPU#; 3000 N REF2 ! PARAMETER G(LIQUID,RA;0) 298.15 +GHSERRA#+7700-7.94633643*T; 6000 N REF3 ! PARAMETER G(LIQUID,RB;0) 200 +GLIQRB#; 2100 N REF2 ! PARAMETER G(LIQUID,RE;0) 298.15 +GLIQRE#; 6000 N REF2 ! PARAMETER G(LIQUID,RH;0) 298.15 +GLIQRH#; 2500 N REF2 ! PARAMETER G(LIQUID,RU;0) 298.15 +GLIQRU#; 4500 N REF2 ! PARAMETER G(LIQUID,S;0) 298.15 +GLIQSS#; 1301 N REF3 ! PARAMETER G(LIQUID,SB;0) 298.15 +GLIQSB#; 2000 N REF2 ! PARAMETER G(LIQUID,SC;0) 298.15 +GLIQSC#; 3200 N REF3 ! PARAMETER G(LIQUID,SE;0) 298.15 +GLIQSE#; 1000 N REF3 ! PARAMETER G(LIQUID,SI;0) 298.15 +GLIQSI#; 3600 N REF2 ! PARAMETER G(LIQUID,SM;0) 298.15 +GLIQSM#; 2100 N REF2 ! PARAMETER G(LIQUID,SN;0) 100 +GLIQSN#; 3000 N REF2 ! PARAMETER G(LIQUID,SR;0) 298.15 +GLIQSR#; 3000 N REF2 ! PARAMETER G(LIQUID,TA;0) 298.15 +GLIQTA#; 6000 N REF2 ! PARAMETER G(LIQUID,TB;0) 298.15 +GLIQTB#; 3000 N REF2 ! PARAMETER G(LIQUID,TC;0) 298.15 +GLIQTC#; 4000 N REF2 ! PARAMETER G(LIQUID,TE;0) 298.15 +GLIQTE#; 1600 N REF2 ! PARAMETER G(LIQUID,TH;0) 298.15 +GLIQTH#; 4000 N REF3 ! PARAMETER G(LIQUID,TI;0) 298.15 +GLIQTI#; 4000 N REF3 ! PARAMETER G(LIQUID,TL;0) 200 +GLIQTL#; 1801 N REF2 ! PARAMETER G(LIQUID,TM;0) 298.15 +GLIQTM#; 2300 N REF2 ! PARAMETER G(LIQUID,U;0) 298.15 +GLIQUU#; 3000 N REF2 ! PARAMETER G(LIQUID,V;0) 298.15 +GLIQVV#; 4000 N REF2 ! PARAMETER G(LIQUID,W;0) 298.15 +GLIQWW#; 6000 N REF2 ! PARAMETER G(LIQUID,Y;0) 100 +GLIQYY#; 3700 N REF2 ! PARAMETER G(LIQUID,YB;0) 298.15 +GLIQYB#; 2000 N REF2 ! PARAMETER G(LIQUID,ZN;0) 298.15 +GLIQZN#; 1700 N REF2 ! PARAMETER G(LIQUID,ZR;0) 298.15 +GLIQZR#; 6000 N REF2 ! PHASE AC_S % 1 1.0 ! CONSTITUENT AC_S :AC : ! PARAMETER G(AC_S,AC;0) 298.15 +GHSERAC#; 5000 N REF3 ! PHASE ALPHA_RHOMBO_B % 1 1.0 ! CONSTITUENT ALPHA_RHOMBO_B :B : ! PARAMETER G(ALPHA_RHOMBO_B,B;0) 298.15 -6076.24+86.648762*T -12.942464*T*LN(T)-.007089468*T**2+6.59896E-07*T**3-45*T**(-1); 1400 Y +28477.506-106.789208*T+12.1072478*T*LN(T)-.013316875*T**2 +7.06895E-07*T**3-8002403*T**(-1); 3000 Y -25699.64+225.127135*T-31.4*T*LN(T); 6000 N REF4 ! PHASE ALPHA_PU % 1 1.0 ! CONSTITUENT ALPHA_PU :PU : ! PARAMETER G(ALPHA_PU,PU;0) 298.15 +GHSERPU#; 3000 N REF1 ! PHASE AT2_S % 1 1.0 ! CONSTITUENT AT2_S :AT2 : ! PARAMETER G(AT2_S,AT2;0) 298.15 +2*GHSERAT#; 6000 N REF3 ! TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! PHASE BCC_A2 %& 2 1 3 ! CONSTITUENT BCC_A2 :AG,AL,AM,AS,AU,B,BA,BE,BI,CA,CD,CE,CO,CR,CS,CU,DY, ER,EU,FE,GA,GD,GE,HF,HO,IN,IR,K,LA,LI,MG,MN,MO,NA,NB,ND,NI,NP,O,OS,P,PA, PB,PD,PR,PT,PU,RB,RE,RH,RU,S,SB,SC,SI,SM,SN,SR,TA,TB,TC,TH, TI,TL,U,V,W,Y,YB,ZN,ZR : VA : ! PARAMETER G(BCC_A2,AG:VA;0) 298.15 +GBCCAG#; 3000 N REF2 ! PARAMETER G(BCC_A2,AL:VA;0) 298.15 +GBCCAL#; 2900 N REF2 ! PARAMETER G(BCC_A2,AM:VA;0) 298.15 +GBCCAM#; 3000 N REF3 ! PARAMETER G(BCC_A2,AS:VA;0) 298.15 +GBCCAS#; 1200 N REF2 ! PARAMETER G(BCC_A2,AU:VA;0) 298.15 +GBCCAU#; 3200 N REF2 ! PARAMETER G(BCC_A2,B:VA;0) 298.15 +GBCCBB#; 6000 N REF2 ! PARAMETER G(BCC_A2,BA:VA;0) 298.15 +GHSERBA#; 4000 N REF1 ! PARAMETER G(BCC_A2,BE:VA;0) 298.15 +GBCCBE#; 3000 N REF2 ! PARAMETER G(BCC_A2,BI:VA;0) 298.15 +GBCCBI#; 3000 N REF2 ! PARAMETER G(BCC_A2,CA:VA;0) 298.15 +GBCCCA#; 3001 N REF4 ! PARAMETER G(BCC_A2,CD:VA;0) 298.15 +GBCCCD#; 1600 N REF4 ! PARAMETER G(BCC_A2,CE:VA;0) 298.15 +GBCCCE#; 4000 N REF2 ! PARAMETER G(BCC_A2,CO:VA;0) 298.15 +GBCCCO#; 6000 N REF2 ! PARAMETER TC(BCC_A2,CO:VA;0) 298.15 +1450; 6000 N REF2 ! PARAMETER BMAGN(BCC_A2,CO:VA;0) 298.15 +1.35; 6000 N REF2 ! PARAMETER G(BCC_A2,CR:VA;0) 298.15 +GHSERCR#; 6000 N REF1 ! PARAMETER TC(BCC_A2,CR:VA;0) 298.15 -311.5; 6000 N REF2 ! PARAMETER BMAGN(BCC_A2,CR:VA;0) 298.15 -.008; 6000 N REF2 ! PARAMETER G(BCC_A2,CS:VA;0) 200 +GHSERCS#; 2000 N REF1 ! PARAMETER G(BCC_A2,CU:VA;0) 298.15 +GBCCCU#; 3200 N REF2 ! PARAMETER G(BCC_A2,DY:VA;0) 100 +GBCCDY#; 3000 N REF2 ! PARAMETER G(BCC_A2,ER:VA;0) 298.15 +GBCCER#; 3200 N REF3 ! PARAMETER G(BCC_A2,EU:VA;0) 298.15 +GHSEREU#; 1901 N REF4 ! PARAMETER G(BCC_A2,FE:VA;0) 298.15 +GHSERFE#; 6000 N REF1 ! PARAMETER TC(BCC_A2,FE:VA;0) 298.15 +1043; 6000 N REF2 ! PARAMETER BMAGN(BCC_A2,FE:VA;0) 298.15 +2.22; 6000 N REF2 ! PARAMETER G(BCC_A2,GA:VA;0) 200 +GBCCGA#; 4000 N REF3 ! PARAMETER G(BCC_A2,GD:VA;0) 100 +GBCCGD#; 3600 N REF4 ! PARAMETER G(BCC_A2,GE:VA;0) 298.15 +GBCCGE#; 3200 N REF2 ! PARAMETER G(BCC_A2,HF:VA;0) 298.15 +GBCCHF#; 3001 N REF3 ! PARAMETER G(BCC_A2,HO:VA;0) 298.15 +GBCCHO#; 3001 N REF3 ! PARAMETER G(BCC_A2,IN:VA;0) 298.15 +GBCCIN#; 3800 N REF2 ! PARAMETER G(BCC_A2,IR:VA;0) 298.15 +GBCCIR#; 4000 N REF2 ! PARAMETER G(BCC_A2,K:VA;0) 200 +GHSERKK#; 2200 N REF1 ! PARAMETER G(BCC_A2,LA:VA;0) 298.15 +GBCCLA#; 4000 N REF2 ! PARAMETER G(BCC_A2,LI:VA;0) 200 +GHSERLI#; 3000 N REF4 ! PARAMETER G(BCC_A2,MG:VA;0) 298.15 +GBCCMG#; 3000 N REF2 ! PARAMETER G(BCC_A2,MN:VA;0) 298.15 +GBCCMN#; 2000 N REF3 ! PARAMETER TC(BCC_A2,MN:VA;0) 298.15 -580; 2000 N REF2 ! PARAMETER BMAGN(BCC_A2,MN:VA;0) 298.15 -.27; 2000 N REF2 ! PARAMETER G(BCC_A2,MO:VA;0) 298.15 +GHSERMO#; 5000 N REF1 ! PARAMETER G(BCC_A2,NA:VA;0) 200 +GHSERNA#; 2300 N REF1 ! PARAMETER G(BCC_A2,NB:VA;0) 298.15 +GHSERNB#; 6000 N REF1 ! PARAMETER G(BCC_A2,ND:VA;0) 298.15 +GBCCND#; 1800 N REF2 ! PARAMETER G(BCC_A2,NI:VA;0) 298.15 +GBCCNI#; 3000 N REF4 ! PARAMETER TC(BCC_A2,NI:VA;0) 298.15 +575; 3000 N REF2 ! PARAMETER BMAGN(BCC_A2,NI:VA;0) 298.15 +.85; 3000 N REF2 ! PARAMETER G(BCC_A2,NP:VA;0) 298.15 +GBCCNP#; 4000 N REF2 ! PARAMETER G(BCC_A2,O:VA;0) 298.15 +GBCCOO#; 6000 N REF2 ! PARAMETER G(BCC_A2,OS:VA;0) 298.15 +GBCCOS#; 5500 N REF3 ! PARAMETER G(BCC_A2,P:VA;0) 250 +GBCCPP#; 3000 N REF2 ! PARAMETER G(BCC_A2,PA:VA;0) 298.15 +GBCCPA#; 4000 N REF2 ! PARAMETER G(BCC_A2,PB:VA;0) 298.15 +GBCCPB#; 2100 N REF2 ! PARAMETER G(BCC_A2,PD:VA;0) 298.15 +GBCCPD#; 4000 N REF2 ! PARAMETER G(BCC_A2,PR:VA;0) 298.15 +GBCCPR#; 3800 N REF2 ! PARAMETER G(BCC_A2,PT:VA;0) 298.15 +GBCCPT#; 4000 N REF3 ! PARAMETER G(BCC_A2,PU:VA;0) 298.15 +GBCCPU#; 3000 N REF2 ! PARAMETER G(BCC_A2,RB:VA;0) 200 +GHSERRB#; 2100 N REF1 ! PARAMETER G(BCC_A2,RE:VA;0) 298.15 +GBCCRE#; 6000 N REF3 ! PARAMETER G(BCC_A2,RH:VA;0) 298.15 +GBCCRH#; 2500 N REF2 ! PARAMETER G(BCC_A2,RU:VA;0) 298.15 +GBCCRU#; 4500 N REF3 ! PARAMETER G(BCC_A2,S:VA;0) 298.15 +GBCCSS#; 1301 N REF3 ! PARAMETER G(BCC_A2,SB:VA;0) 298.15 +GBCCSB#; 2000 N REF2 ! PARAMETER G(BCC_A2,SC:VA;0) 298.15 +GBCCSC#; 3200 N REF3 ! PARAMETER G(BCC_A2,SI:VA;0) 298.15 +GBCCSI#; 3600 N REF2 ! PARAMETER G(BCC_A2,SM:VA;0) 298.15 +GBCCSM#; 2100 N REF2 ! PARAMETER G(BCC_A2,SN:VA;0) 100 +GBCCSN#; 3000 N REF2 ! PARAMETER G(BCC_A2,SR:VA;0) 298.15 +GBCCSR#; 3000 N REF2 ! PARAMETER G(BCC_A2,TA:VA;0) 298.15 +GHSERTA#; 6000 N REF1 ! PARAMETER G(BCC_A2,TB:VA;0) 298.15 +GBCCTB#; 3000 N REF2 ! PARAMETER G(BCC_A2,TC:VA;0) 298.15 +GBCCTC#; 4000 N REF2 ! PARAMETER G(BCC_A2,TH:VA;0) 298.15 +GBCCTH#; 4000 N REF3 ! PARAMETER G(BCC_A2,TI:VA;0) 298.15 +GBCCTI#; 4000 N REF2 ! PARAMETER G(BCC_A2,TL:VA;0) 200 +GBCCTL#; 1801 N REF2 ! PARAMETER G(BCC_A2,U:VA;0) 298.15 +GBCCUU#; 3000 N REF2 ! PARAMETER G(BCC_A2,V:VA;0) 298.15 +GHSERVV#; 4000 N REF1 ! PARAMETER G(BCC_A2,W:VA;0) 298.15 +GHSERWW#; 6000 N REF1 ! PARAMETER G(BCC_A2,Y:VA;0) 100 +GBCCYY#; 3700 N REF2 ! PARAMETER G(BCC_A2,YB:VA;0) 298.15 +GBCCYB#; 2000 N REF2 ! PARAMETER G(BCC_A2,ZN:VA;0) 298.15 +GBCCZN#; 1700 N REF2 ! PARAMETER G(BCC_A2,ZR:VA;0) 298.15 +GBCCZR#; 6000 N REF2 ! PHASE BCT_A5 % 1 1.0 ! CONSTITUENT BCT_A5 :AG,AL,BI,CD,GA,GE,IN,NI,PB,SB,SN,TI,ZN : ! PARAMETER G(BCT_A5,AG;0) 298.15 +GHSERAG#+4184.1; 3000 N REF4 ! PARAMETER G(BCT_A5,AL;0) 298.15 +GHSERAL#+10083-4.813*T; 2900 N REF2 ! PARAMETER G(BCT_A5,BI;0) 298.15 +GHSERBI#+4184.07; 3000 N REF2 ! PARAMETER G(BCT_A5,CD;0) 298.15 +GHSERCD#+5000; 1600 N REF3 ! PARAMETER G(BCT_A5,GA;0) 200 +GHSERGA#+3846-9.8*T; 4000 N REF2 ! PARAMETER G(BCT_A5,GE;0) 298.15 +GHSERGE#+28800-16.5*T; 3000 N REF3 ! PARAMETER G(BCT_A5,IN;0) 298.15 +GHSERIN#+5040.87-3.33969*T; 3800 N REF3 ! PARAMETER G(BCT_A5,NI;0) 298.15 +GHSERNI#+10023-4.556*T; 3000 N REF4 ! PARAMETER G(BCT_A5,PB;0) 298.15 +GHSERPB#+489+3.52*T; 2100 N REF2 ! PARAMETER G(BCT_A5,SB;0) 298.15 +GHSERSB#+13000-8*T; 2000 N REF2 ! PARAMETER G(BCT_A5,SN;0) 100 +GHSERSN#; 3000 N REF1 ! PARAMETER G(BCT_A5,TI;0) 298.15 +GHSERTI#+4602.2; 3000 N REF2 ! PARAMETER G(BCT_A5,ZN;0) 298.15 +GHSERZN#+2886.96-2.5104*T; 1700 N REF2 ! PHASE BCT_AA % 1 1.0 ! CONSTITUENT BCT_AA :PA : ! PARAMETER G(BCT_AA,PA;0) 298.15 +GHSERPA#; 4000 N REF1 ! PHASE BETA_RHOMBO_B % 1 1.0 ! CONSTITUENT BETA_RHOMBO_B :B : ! PARAMETER G(BETA_RHOMBO_B,B;0) 298.15 +GHSERBB#; 6000 N REF2 ! PHASE BETA_PU % 1 1.0 ! CONSTITUENT BETA_PU :PU : ! PARAMETER G(BETA_PU,PU;0) 298.15 -4873.654+123.249151*T -27.416*T*LN(T)-.00653*T**2; 679.50 Y +2435.094+43.566585*T-15.7351*T*LN(T)-.0154772*T**2+1.524942E-06*T**3 -864940*T**(-1); 1464 Y -13959.062+228.221615*T-42.248*T*LN(T); 3000 N REF2 ! TYPE_DEFINITION ' GES A_P_D CBCC_A12 MAGNETIC -3.0 2.80000E-01 ! PHASE CBCC_A12 %' 2 1 1 ! CONSTITUENT CBCC_A12 :AL,CO,CR,FE,MG,MN,NI,SI,SN,TI,V,ZN,ZR : VA : ! PARAMETER G(CBCC_A12,AL:VA;0) 298.15 +GHSERAL#+10083.4-4.813*T; 2900 N REF2 ! PARAMETER G(CBCC_A12,CO:VA;0) 298.15 +GHSERCO#+4155; 6000 N REF2 ! PARAMETER G(CBCC_A12,CR:VA;0) 298.15 +GHSERCR#+11087+2.7196*T; 6000 N REF2 ! PARAMETER G(CBCC_A12,FE:VA;0) 298.15 +GHSERFE#+4745; 6000 N REF2 ! PARAMETER G(CBCC_A12,MG:VA;0) 298.15 +GHSERMG#+4602.4-3.011*T; 3000 N REF2 ! PARAMETER G(CBCC_A12,MN:VA;0) 298.15 +GHSERMN#; 2000 N REF3 ! PARAMETER TC(CBCC_A12,MN:VA;0) 298.15 -285; 2000 N REF2 ! PARAMETER BMAGN(CBCC_A12,MN:VA;0) 298.15 -.66; 2000 N REF2 ! PARAMETER G(CBCC_A12,NI:VA;0) 298.15 +GHSERNI#+3556; 3000 N REF4 ! PARAMETER G(CBCC_A12,SI:VA;0) 298.15 +GHSERSI#+50208-20.377*T; 3600 N REF2 ! PARAMETER G(CBCC_A12,SN:VA;0) 100 +GHSERSN#+2000; 3000 N REF3 ! PARAMETER G(CBCC_A12,TI:VA;0) 298.15 +GHSERTI#+4602.2; 4000 N REF2 ! PARAMETER G(CBCC_A12,V:VA;0) 298.15 +GHSERVV#+9000; 4000 N REF2 ! PARAMETER G(CBCC_A12,ZN:VA;0) 298.15 +GHSERZN#+2000; 1700 N REF3 ! PARAMETER G(CBCC_A12,ZR:VA;0) 298.15 +GHSERZR#+4602.2; 6000 N REF3 ! PHASE CF_S % 1 1.0 ! CONSTITUENT CF_S :CF : ! PARAMETER G(CF_S,CF;0) 298.15 +GHSERCF#; 6000 N REF3 ! PHASE CM_S % 1 1.0 ! CONSTITUENT CM_S :CM : ! PARAMETER G(CM_S,CM;0) 298.15 +GHSERCM#; 6000 N REF3 ! PHASE CM_S2 % 1 1.0 ! CONSTITUENT CM_S2 :CM : ! PARAMETER G(CM_S2,CM;0) 298.15 +GHSERCM#+3242.6-2.092*T; 6000 N REF3 ! PHASE CUB_A13 % 2 1 1 ! CONSTITUENT CUB_A13 :AG,AL,CO,CR,FE,MG,MN,NI,SI,SN,TI,V,ZN,ZR : VA : ! PARAMETER G(CUB_A13,AG:VA;0) 298.15 +GHSERAG#+3400-1.05*T; 3000 N REF4 ! PARAMETER G(CUB_A13,AL:VA;0) 298.15 +GHSERAL#+10920.44-4.8116*T; 2900 N REF2 ! PARAMETER G(CUB_A13,CO:VA;0) 298.15 +GHSERCO#+3155; 6000 N REF2 ! PARAMETER G(CUB_A13,CR:VA;0) 298.15 +GHSERCR#+15899+.6276*T; 6000 N REF2 ! PARAMETER G(CUB_A13,FE:VA;0) 298.15 +GHSERFE#+3745; 6000 N REF2 ! PARAMETER G(CUB_A13,MG:VA;0) 298.15 +GHSERMG#+5000-3*T; 3000 N REF2 ! PARAMETER G(CUB_A13,MN:VA;0) 298.15 -5800.4+135.995*T -24.8785*T*LN(T)-.00583359*T**2+70269*T**(-1); 1519 Y -28290.76+311.2933*T-48*T*LN(T)+3.96757E+30*T**(-9); 2000 N REF3 ! PARAMETER G(CUB_A13,NI:VA;0) 298.15 +GHSERNI#+2092; 3000 N REF4 ! PARAMETER G(CUB_A13,SI:VA;0) 298.15 +GHSERSI#+47279-20.377*T; 3600 N REF2 ! PARAMETER G(CUB_A13,SN:VA;0) 100 +GHSERSN#+2000; 3000 N REF3 ! PARAMETER G(CUB_A13,TI:VA;0) 298.15 +GHSERTI#+7531.2; 4000 N REF2 ! PARAMETER G(CUB_A13,V:VA;0) 298.15 +GHSERVV#+10000; 4000 N REF2 ! PARAMETER G(CUB_A13,ZN:VA;0) 298.15 +GHSERZN#+2000; 1700 N REF3 ! PARAMETER G(CUB_A13,ZR:VA;0) 298.15 +GHSERZR#+7531.2; 6000 N REF3 ! PHASE DHCP % 1 1.0 ! CONSTITUENT DHCP :AM,AU,CE,IN,LA,ND,PR,SC,SN : ! PARAMETER G(DHCP,AM;0) 298.15 +GHSERAM#; 3000 N REF1 ! PARAMETER G(DHCP,AU;0) 298.15 +GHSERAU#+5000; 3200 N REF4 ! PARAMETER G(DHCP,CE;0) 298.15 +GHSERCE#-122.539+.433*T; 4000 N REF4 ! PARAMETER G(DHCP,IN;0) 298.15 +GHSERIN#+520-.384*T; 3800 N REF4 ! PARAMETER G(DHCP,LA;0) 298.15 +GHSERLA#; 4000 N REF1 ! PARAMETER G(DHCP,ND;0) 298.15 +GHSERND#; 1800 N REF1 ! PARAMETER G(DHCP,PR;0) 298.15 +GHSERPR#; 3800 N REF1 ! PARAMETER G(DHCP,SC;0) 298.15 +GHSERSC#+1200+.415725*T; 3200 N REF3 ! PARAMETER G(DHCP,SN;0) 100 +GHSERSN#+3803.52-3.46*T; 3000 N REF4 ! PHASE DIAMOND_A4 % 1 1.0 ! CONSTITUENT DIAMOND_A4 :AL,B,BI,C,CO,GA,GE,SI,SN,TI,ZN : ! PARAMETER G(DIAMOND_A4,AL;0) 298.15 +GHSERAL#+30*T; 2900 N REF2 ! PARAMETER G(DIAMOND_A4,B;0) 298.15 +GHSERBB#+10; 6000 N REF4 ! PARAMETER G(DIAMOND_A4,BI;0) 298.15 +GHSERBI#+11296.8 +9.253655*T; 3000 N REF4 ! PARAMETER G(DIAMOND_A4,C;0) 298.15 +GDIACC#; 6000 N REF2 ! PARA G(DIAMOND_A4,CO;0) 298.15 +0; 6000 N! PARAMETER G(DIAMOND_A4,GA;0) 200 +GHSERGA#+20900-2*T; 4000 N REF4 ! PARAMETER G(DIAMOND_A4,GE;0) 298.15 +GHSERGE#; 3200 N REF1 ! PARAMETER G(DIAMOND_A4,SI;0) 298.15 +GHSERSI#; 3600 N REF1 ! PARAMETER G(DIAMOND_A4,SN;0) 100 -9579.608+114.007785*T -22.972*T*LN(T)-.00813975*T**2+2.7288E-06*T**3+25615*T**(-1); 298.15 Y -9063.001+104.84654*T-21.5750771*T*LN(T)-.008575282*T**2 +1.784447E-06*T**3-2544*T**(-1); 800 Y -10909.353+147.396537*T-28.4512*T*LN(T); 3000 N REF2 ! PARAMETER G(DIAMOND_A4,TI;0) 298.15 +GHSERTI#+25000; 4000 N REF2 ! PARAMETER G(DIAMOND_A4,ZN;0) 298.15 +GHSERZN#+30*T; 1700 N REF2 ! PHASE ES_S % 1 1.0 ! CONSTITUENT ES_S :ES : ! PARAMETER G(ES_S,ES;0) 298.15 +GHSERES#; 6000 N REF3 ! TYPE_DEFINITION ( GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! PHASE FCC_A1 %( 2 1 1 ! CONSTITUENT FCC_A1 :AG,AL,AM,AS,AU,B,BA,BE,BI,CA,CD,CE,CO,CR,CS,CU,FE, GA,GD,GE,HF,HG,IN,IR,K,LA,LI,MG,MN,MO,NA,NB,ND,NI,O,OS,P,PB,PD, PT,PU,RB,RE,RH,RU,S,SB,SC,SI,SN,SR,TA,TC,TH,TI,TL,U, V,W,Y,YB,ZN,ZR : VA : ! PARAMETER G(FCC_A1,AG:VA;0) 298.15 +GHSERAG#; 3000 N REF1 ! PARAMETER G(FCC_A1,AL:VA;0) 298.15 +GHSERAL#; 2900 N REF1 ! PARAMETER G(FCC_A1,AM:VA;0) 298.15 +GFCCAM#; 3000 N REF3 ! PARAMETER G(FCC_A1,AS:VA;0) 298.15 +GFCCAS#; 1200 N REF2 ! PARAMETER G(FCC_A1,AU:VA;0) 298.15 +GHSERAU#; 3200 N REF1 ! PARAMETER G(FCC_A1,B:VA;0) 298.15 +GFCCBB#; 6000 N REF2 ! PARAMETER G(FCC_A1,BA:VA;0) 298.15 +GFCCBA#; 4000 N REF2 ! PARAMETER G(FCC_A1,BE:VA;0) 298.15 +GFCCBE#; 3000 N REF2 ! PARAMETER G(FCC_A1,BI:VA;0) 298.15 +GFCCBI#; 3000 N REF2 ! PARAMETER G(FCC_A1,CA:VA;0) 298.15 +GHSERCA#; 3001 N REF1 ! PARAMETER G(FCC_A1,CD:VA;0) 298.15 +GFCCCD#; 1600 N REF2 ! PARAMETER G(FCC_A1,CE:VA;0) 298.15 +GHSERCE#; 4000 N REF1 ! PARAMETER G(FCC_A1,CO:VA;0) 298.15 +GFCCCO#; 6000 N REF4 ! PARAMETER TC(FCC_A1,CO:VA;0) 298.15 +1396; 6000 N REF2 ! PARAMETER BMAGN(FCC_A1,CO:VA;0) 298.15 +1.35; 6000 N REF2 ! PARAMETER G(FCC_A1,CR:VA;0) 298.15 +GFCCCR#; 6000 N REF2 ! PARAMETER TC(FCC_A1,CR:VA;0) 298.15 -1109; 6000 N REF2 ! PARAMETER BMAGN(FCC_A1,CR:VA;0) 298.15 -2.46; 6000 N REF2 ! PARAMETER G(FCC_A1,CS:VA;0) 200 +GFCCCS#; 2000 N REF2 ! PARAMETER G(FCC_A1,CU:VA;0) 298.15 +GHSERCU#; 3200 N REF1 ! PARAMETER G(FCC_A1,FE:VA;0) 298.15 +GFCCFE#; 6000 N REF3 ! PARAMETER TC(FCC_A1,FE:VA;0) 298.15 -201; 6000 N REF2 ! PARAMETER BMAGN(FCC_A1,FE:VA;0) 298.15 -2.1; 6000 N REF2 ! PARAMETER G(FCC_A1,GA:VA;0) 200 +GFCCGA#; 4000 N REF3 ! PARAMETER G(FCC_A1,GD:VA;0) 200 +GFCCGD#; 3600 N REF3 ! PARAMETER G(FCC_A1,GE:VA;0) 298.15 +GFCCGE#; 3200 N REF2 ! PARAMETER G(FCC_A1,HF:VA;0) 298.15 +GFCCHF#; 3001 N REF3 ! PARAMETER G(FCC_A1,HG:VA;0) 200 +GFCCHG#; 2000 N REF4 ! PARAMETER G(FCC_A1,IN:VA;0) 298.15 +GFCCIN#; 3800 N REF3 ! PARAMETER G(FCC_A1,IR:VA;0) 298.15 +GHSERIR#; 4000 N REF1 ! PARAMETER G(FCC_A1,K:VA;0) 200 +GFCCKK#; 2200 N REF2 ! PARAMETER G(FCC_A1,LA:VA;0) 298.15 +GFCCLA#; 4000 N REF2 ! PARAMETER G(FCC_A1,LI:VA;0) 200 +GFCCLI#; 3000 N REF4 ! PARAMETER G(FCC_A1,MG:VA;0) 298.15 +GFCCMG#; 3000 N REF2 ! PARAMETER G(FCC_A1,MN:VA;0) 298.15 +GFCCMN#; 2000 N REF3 ! PARAMETER TC(FCC_A1,MN:VA;0) 298.15 -1620; 2000 N REF2 ! PARAMETER BMAGN(FCC_A1,MN:VA;0) 298.15 -1.86; 2000 N REF2 ! PARAMETER G(FCC_A1,MO:VA;0) 298.15 +GFCCMO#; 5000 N REF2 ! PARAMETER G(FCC_A1,NA:VA;0) 200 +GFCCNA#; 2300 N REF2 ! PARAMETER G(FCC_A1,NB:VA;0) 298.15 +GFCCNB#; 6000 N REF2 ! PARAMETER G(FCC_A1,ND:VA;0) 298.15 +GFCCND#; 1800 N REF3 ! PARAMETER G(FCC_A1,NI:VA;0) 298.15 +GHSERNI#; 3000 N REF4 ! PARAMETER TC(FCC_A1,NI:VA;0) 298.15 +633; 3000 N REF2 ! PARAMETER BMAGN(FCC_A1,NI:VA;0) 298.15 +.52; 3000 N REF2 ! PARAMETER G(FCC_A1,O:VA;0) 298.15 +GFCCOO#; 6000 N REF2 ! PARAMETER G(FCC_A1,OS:VA;0) 298.15 +GFCCOS#; 5500 N REF2 ! PARAMETER G(FCC_A1,P:VA;0) 250 +GFCCPP#; 3000 N REF2 ! PARAMETER G(FCC_A1,PB:VA;0) 298.15 +GHSERPB#; 2100 N REF1 ! PARAMETER G(FCC_A1,PD:VA;0) 298.15 +GHSERPD#; 4000 N REF1 ! PARAMETER G(FCC_A1,PT:VA;0) 298.15 +GHSERPT#; 4000 N REF1 ! PARAMETER G(FCC_A1,PU:VA;0) 298.15 +GFCCPU#; 3000 N REF2 ! PARAMETER G(FCC_A1,RB:VA;0) 200 +GFCCRB#; 2100 N REF2 ! PARAMETER G(FCC_A1,RE:VA;0) 298.15 +GFCCRE#; 6000 N REF2 ! PARAMETER G(FCC_A1,RH:VA;0) 298.15 +GHSERRH#; 2500 N REF1 ! PARAMETER G(FCC_A1,RU:VA;0) 298.15 +GFCCRU#; 4500 N REF2 ! PARAMETER G(FCC_A1,S:VA;0) 298.15 +GFCCSS#; 1301 N REF3 ! PARAMETER G(FCC_A1,SB:VA;0) 298.15 +GFCCSB#; 2000 N REF2 ! PARAMETER G(FCC_A1,SC:VA;0) 298.15 +GFCCSC#; 3200 N REF3 ! PARAMETER G(FCC_A1,SI:VA;0) 298.15 +GFCCSI#; 3600 N REF2 ! PARAMETER G(FCC_A1,SN:VA;0) 100 +GFCCSN#; 3000 N REF2 ! PARAMETER G(FCC_A1,SR:VA;0) 298.15 +GHSERSR#; 3000 N REF1 ! PARAMETER G(FCC_A1,TA:VA;0) 298.15 +GFCCTA#; 6000 N REF2 ! PARAMETER G(FCC_A1,TC:VA;0) 298.15 +GFCCTC#; 4000 N REF2 ! PARAMETER G(FCC_A1,TH:VA;0) 298.15 +GHSERTH#; 4000 N REF3 ! PARAMETER G(FCC_A1,TI:VA;0) 298.15 +GFCCTI#; 4000 N REF2 ! PARAMETER G(FCC_A1,TL:VA;0) 200 +GFCCTL#; 1801 N REF2 ! PARAMETER G(FCC_A1,U:VA;0) 298.15 +GFCCUU#; 3000 N REF3 ! PARAMETER G(FCC_A1,V:VA;0) 298.15 +GFCCVV#; 4000 N REF2 ! PARAMETER G(FCC_A1,W:VA;0) 298.15 +GFCCWW#; 6000 N REF2 ! PARAMETER G(FCC_A1,Y:VA;0) 100 +GFCCYY#; 3700 N REF3 ! PARAMETER G(FCC_A1,YB:VA;0) 298.15 +GHSERYB#; 2000 N REF1 ! PARAMETER G(FCC_A1,ZN:VA;0) 298.15 +GFCCZN#; 1700 N REF2 ! PARAMETER G(FCC_A1,ZR:VA;0) 298.15 +GFCCZR#; 6000 N REF2 ! PHASE FM_S % 1 1.0 ! CONSTITUENT FM_S :FM : ! PARAMETER G(FM_S,FM;0) 298.15 +GHSERFM#; 6000 N REF3 ! PHASE FR_S % 1 1.0 ! CONSTITUENT FR_S :FR : ! PARAMETER G(FR_S,FR;0) 298.15 +GHSERFR#; 6000 N REF3 ! PHASE GAMMA_PU % 1 1.0 ! CONSTITUENT GAMMA_PU :PU : ! PARAMETER G(GAMMA_PU,PU;0) 298.15 -16766.303+419.402655*T -77.5802*T*LN(T)+.0816415*T**2-2.8103833E-05*T**3+574825*T**(-1); 487.90 Y -2942.77+88.325069*T-22.0233*T*LN(T)-.0114795*T**2; 593.90 Y -9336.967+160.314641*T-32.3405*T*LN(T)-.0070383*T**2+6.92887E-07*T**3 +630600*T**(-1); 1179 Y -12435.75+226.131617*T-42.248*T*LN(T); 3000 N REF2 ! PHASE GRAPHITE % 1 1.0 ! CONSTITUENT GRAPHITE :B,C : ! PARAMETER G(GRAPHITE,B;0) 298.15 +GHSERBB#+10000-2*T; 6000 N REF4 ! PARAMETER G(GRAPHITE,C;0) 298.15 +GHSERCC#; 6000 N REF1 ! TYPE_DEFINITION ) GES A_P_D HCP_A3 MAGNETIC -3.0 2.80000E-01 ! PHASE HCP_A3 %) 2 1 .5 ! CONSTITUENT HCP_A3 :AG,AL,AS,AU,B,BA,BE,BI,CA,CD,CE,CO,CR,CS,CU,DY,ER, FE,GA,GD,GE,HF,HG,HO,IN,IR,K,LI,LU,MG,MN,MO,NA,NB,ND,NI,OS,PB,PD, PT,RB,RE,RH,RU,SB,SC,SI,SM,SN,SR,TA,TB,TC,TI,TL,TM, U,V,W,Y,YB,ZN,ZR : VA : ! PARAMETER G(HCP_A3,AG:VA;0) 298.15 +GHCPAG#; 3000 N REF2 ! PARAMETER G(HCP_A3,AL:VA;0) 298.15 +GHCPAL#; 2900 N REF2 ! PARAMETER G(HCP_A3,AS:VA;0) 298.15 +GHCPAS#; 1200 N REF2 ! PARAMETER G(HCP_A3,AU:VA;0) 298.15 +GHCPAU#; 3200 N REF2 ! PARAMETER G(HCP_A3,B:VA;0) 298.15 +GHCPBB#; 6000 N REF2 ! PARAMETER G(HCP_A3,BA:VA;0) 298.15 +GHCPBA#; 4000 N REF2 ! PARAMETER G(HCP_A3,BE:VA;0) 298.15 +GHSERBE#; 3000 N REF1 ! PARAMETER G(HCP_A3,BI:VA;0) 298.15 +GHCPBI#; 3000 N REF2 ! PARAMETER G(HCP_A3,CA:VA;0) 298.15 +GHCPCA#; 3001 N REF4 ! PARAMETER G(HCP_A3,CD:VA;0) 298.15 +GHSERCD#; 1600 N REF1 ! PARAMETER G(HCP_A3,CE:VA;0) 298.15 +GHCPCE#; 4000 N REF4 ! PARAMETER G(HCP_A3,CO:VA;0) 298.15 +GHSERCO#; 6000 N REF1 ! PARAMETER TC(HCP_A3,CO:VA;0) 298.15 +1396; 6000 N REF2 ! PARAMETER BMAGN(HCP_A3,CO:VA;0) 298.15 +1.35; 6000 N REF2 ! PARAMETER G(HCP_A3,CR:VA;0) 298.15 +GHCPCR#; 6000 N REF2 ! PARAMETER TC(HCP_A3,CR:VA;0) 298.15 -1109; 6000 N REF2 ! PARAMETER BMAGN(HCP_A3,CR:VA;0) 298.15 -2.46; 6000 N REF2 ! PARAMETER G(HCP_A3,CS:VA;0) 200 +GHCPCS#; 2000 N REF2 ! PARAMETER G(HCP_A3,CU:VA;0) 298.15 +GHCPCU#; 3200 N REF3 ! PARAMETER G(HCP_A3,DY:VA;0) 100 +GHSERDY#; 3000 N REF2 ! PARAMETER TC(HCP_A3,DY:VA;0) 100 +179; 3000 N REF2 ! PARAMETER BMAGN(HCP_A3,DY:VA;0) 100 +3; 3000 N REF2 ! PARAMETER G(HCP_A3,ER:VA;0) 298.15 +GHSERER#; 3200 N REF2 ! PARAMETER G(HCP_A3,FE:VA;0) 298.15 +GHCPFE#; 6000 N REF3 ! PARAMETER G(HCP_A3,GA:VA;0) 200 +GHCPGA#; 4000 N REF3 ! PARAMETER G(HCP_A3,GD:VA;0) 200 +GHSERGD#; 3600 N REF2 ! PARAMETER TC(HCP_A3,GD:VA;0) 200 +293.4; 3600 N REF2 ! PARAMETER BMAGN(HCP_A3,GD:VA;0) 200 +3; 3600 N REF2 ! PARAMETER G(HCP_A3,GE:VA;0) 298.15 +GHCPGE#; 3200 N REF2 ! PARAMETER G(HCP_A3,HF:VA;0) 298.15 +GHSERHF#; 3001 N REF3 ! PARAMETER G(HCP_A3,HG:VA;0) 200 +GHCPHG#; 2000 N REF3 ! PARAMETER G(HCP_A3,HO:VA;0) 298.15 +GHSERHO#; 3001 N REF4 ! PARAMETER G(HCP_A3,IN:VA;0) 298.15 +GHCPIN#; 3800 N REF4 ! PARAMETER G(HCP_A3,IR:VA;0) 298.15 +GHCPIR#; 4000 N REF2 ! PARAMETER G(HCP_A3,K:VA;0) 200 +GHCPKK#; 2200 N REF2 ! PARAMETER G(HCP_A3,LI:VA;0) 200 +GHCPLI#; 3000 N REF4 ! PARAMETER G(HCP_A3,LU:VA;0) 298.15 +GHSERLU#; 3700 N REF1 ! PARAMETER G(HCP_A3,MG:VA;0) 298.15 +GHSERMG#; 3000 N REF1 ! PARAMETER G(HCP_A3,MN:VA;0) 298.15 +GHCPMN#; 2000 N REF3 ! PARAMETER TC(HCP_A3,MN:VA;0) 298.15 -1620; 2000 N REF2 ! PARAMETER BMAGN(HCP_A3,MN:VA;0) 298.15 -1.86; 2000 N REF2 ! PARAMETER G(HCP_A3,MO:VA;0) 298.15 +GHCPMO#; 5000 N REF2 ! PARAMETER G(HCP_A3,NA:VA;0) 200 +GHCPNA#; 2300 N REF2 ! PARAMETER G(HCP_A3,NB:VA;0) 298.15 +GHCPNB#; 6000 N REF2 ! PARAMETER G(HCP_A3,ND:VA;0) 298.15 +GHCPND#; 1800 N REF3 ! PARAMETER G(HCP_A3,NI:VA;0) 298.15 +GHCPNI#; 3000 N REF4 ! PARAMETER TC(HCP_A3,NI:VA;0) 298.15 +633; 3000 N REF2 ! PARAMETER BMAGN(HCP_A3,NI:VA;0) 298.15 +.52; 3000 N REF2 ! PARAMETER G(HCP_A3,OS:VA;0) 298.15 +GHSEROS#; 5500 N REF1 ! PARAMETER G(HCP_A3,PB:VA;0) 298.15 +GHCPPB#; 2100 N REF2 ! PARAMETER G(HCP_A3,PD:VA;0) 298.15 +GHCPPD#; 4000 N REF2 ! PARAMETER G(HCP_A3,PT:VA;0) 298.15 +GHCPPT#; 4000 N REF3 ! PARAMETER G(HCP_A3,RB:VA;0) 200 +GHCPRB#; 2100 N REF2 ! PARAMETER G(HCP_A3,RE:VA;0) 298.15 +GHSERRE#; 6000 N REF2 ! PARAMETER G(HCP_A3,RH:VA;0) 298.15 +GHCPRH#; 2500 N REF2 ! PARAMETER G(HCP_A3,RU:VA;0) 298.15 +GHSERRU#; 4500 N REF1 ! PARAMETER G(HCP_A3,SB:VA;0) 298.15 +GHCPSB#; 2000 N REF2 ! PARAMETER G(HCP_A3,SC:VA;0) 298.15 +GHSERSC#; 3200 N REF1 ! PARAMETER G(HCP_A3,SI:VA;0) 298.15 +GHCPSI#; 3600 N REF2 ! PARAMETER G(HCP_A3,SM:VA;0) 298.15 +GHCPSM#; 2100 N REF3 ! PARAMETER G(HCP_A3,SN:VA;0) 100 +GHCPSN#; 3000 N REF3 ! PARAMETER G(HCP_A3,SR:VA;0) 298.15 +GHCPSR#; 3000 N REF2 ! PARAMETER G(HCP_A3,TA:VA;0) 298.15 +GHCPTA#; 6000 N REF2 ! PARAMETER G(HCP_A3,TB:VA;0) 298.15 +GHSERTB#; 3000 N REF2 ! PARAMETER G(HCP_A3,TC:VA;0) 298.15 +GHSERTC#; 4000 N REF1 ! PARAMETER G(HCP_A3,TI:VA;0) 298.15 +GHSERTI#; 4000 N REF1 ! PARAMETER G(HCP_A3,TL:VA;0) 200 +GHSERTL#; 1801 N REF1 ! PARAMETER G(HCP_A3,TM:VA;0) 298.15 +GHSERTM#; 2300 N REF1 ! PARAMETER G(HCP_A3,U:VA;0) 298.15 +GHCPUU#; 2500 N REF3 ! PARAMETER G(HCP_A3,V:VA;0) 298.15 +GHCPVV#; 4000 N REF2 ! PARAMETER G(HCP_A3,W:VA;0) 298.15 +GHCPWW#; 6000 N REF2 ! PARAMETER G(HCP_A3,Y:VA;0) 100 +GHSERYY#; 3700 N REF2 ! PARAMETER G(HCP_A3,YB:VA;0) 298.15 +GHCPYB#; 2000 N REF4 ! PARAMETER G(HCP_A3,ZN:VA;0) 298.15 +GHCPZN#; 1700 N REF2 ! PARAMETER G(HCP_A3,ZR:VA;0) 298.15 +GHSERZR#; 6000 N REF1 ! PHASE HCP_ZN % 2 1 .5 ! CONSTITUENT HCP_ZN :AG,AL,CR,CU,GA,IN,MG,SI,SN,ZN : VA : ! PARAMETER G(HCP_ZN,AG:VA;0) 298.15 +GHSERAG#+400+.3*T; 3000 N REF4 ! PARAMETER G(HCP_ZN,AL:VA;0) 298.15 +GHSERAL#+5481-1.8*T; 2900 N REF4 ! PARAMETER G(HCP_ZN,CR:VA;0) 298.15 +GHSERCR#+4439; 6000 N REF3 ! PARAMETER G(HCP_ZN,CU:VA;0) 298.15 +GHSERCU#+600+.2*T; 3200 N REF3 ! PARAMETER G(HCP_ZN,GA:VA;0) 200 +GHSERGA#+4501-9.5*T; 4000 N REF4 ! PARAMETER G(HCP_ZN,IN:VA;0) 298.15 +GHSERIN#+533-.6868*T; 3800 N REF3 ! PARAMETER G(HCP_ZN,MG:VA;0) 298.15 +GHSERMG#+100; 3000 N REF3 ! PARAMETER G(HCP_ZN,SI:VA;0) 298.15 +GHSERSI#+49201-20.8*T; 3600 N REF3 ! PARAMETER G(HCP_ZN,SN:VA;0) 100 +GHSERSN#+3905-7.646*T; 3000 N REF3 ! PARAMETER G(HCP_ZN,ZN:VA;0) 298.15 +GHSERZN#; 1700 N REF3 ! PHASE HEXAGONAL_A8 % 1 1.0 ! CONSTITUENT HEXAGONAL_A8 :SE,TE : ! PARAMETER G(HEXAGONAL_A8,SE;0) 298.15 +GHSERSE#; 1000 N REF1 ! PARAMETER G(HEXAGONAL_A8,TE;0) 298.15 +GHSERTE#; 1600 N REF2 ! PHASE I2_S % 1 1.0 ! CONSTITUENT I2_S :I2 : ! PARAMETER G(I2_S,I2;0) 298.15 +2*GHSERII#; 1000 N REF3 ! PHASE LAVES_C14 % 2 2 1 ! CONSTITUENT LAVES_C14 :MN,TI : MN,TI : ! PARAMETER G(LAVES_C14,MN:MN;0) 298.15 -21345.84+390.177*T -70.3746*T*LN(T)-.02204304*T**2+209481*T**(-1); 1519 Y -83200.23+936.7944*T-144*T*LN(T)+4.97054E+30*T**(-9); 2000 N REF3 ! PARAMETER G(LAVES_C14,TI:TI;0) 298.15 -9179.763+400.845624*T -71.9799*T*LN(T)-.014333925*T**2+3.20148E-07*T**3+217908*T**(-1); 900 Y -8435.445+398.964204*T-71.9661*T*LN(T)-.0126099*T**2-2.72628E-07*T**3 +128040*T**(-1); 1155 Y +17726.511+200.929614*T-44.8398*T*LN(T)-.0244395*T**2+6.08145E-07*T**3 -4432980*T**(-1); 1941 Y -358580.358+1916.42061*T-261.654738*T*LN(T)+.024614547*T**2 -9.14241E-07*T**3+1.10099415E+08*T**(-1); 4000 N REF2 ! PHASE LAVES_C15 % 2 2 1 ! CONSTITUENT LAVES_C15 :CR,CU,MG,TI,ZR : CR,CU,MG,TI,ZR : ! PARAMETER G(LAVES_C15,CR:CR;0) 298.15 -11570.82+472.44*T -80.724*T*LN(T)+.00568305*T**2-4.43163E-06*T**3+417750*T**(-1); 2180 Y -89608.032+1032.54*T-150*T*LN(T)-8.65578E+32*T**(-9); 6000 N REF2 ! PARA G(LAVES_C15,CU:CR;0) 298.15 +0; 6000 N! PARA G(LAVES_C15,MG:CR;0) 298.15 +0; 6000 N! PARA G(LAVES_C15,CR:CU;0) 298.15 +0; 6000 N! PARAMETER G(LAVES_C15,CU:CU;0) 298.15 -8311.374+391.455705*T -72.337176*T*LN(T)-.00797052*T**2+3.87669E-07*T**3+157434*T**(-1); 1357.77 Y -25626.078+551.411484*T-94.14*T*LN(T)+1.092501E+30*T**(-9); 3200 N REF2 ! PARA G(LAVES_C15,MG:CU;0) 298.15 +0; 6000 N! PARA G(LAVES_C15,CR:MG;0) 298.15 +0; 6000 N! PARA G(LAVES_C15,CU:MG;0) 298.15 +0; 6000 N! PARAMETER G(LAVES_C15,MG:MG;0) 298.15 -10102.02+431.026641*T -78.5549346*T*LN(T)+.0014574*T**2-4.181007E-06*T**3+236850*T**(-1); 923 Y -27390.555+614.148645*T-102.9264*T*LN(T)+3.11458E+28*T**(-9); 3000 N REF3 ! PARAMETER G(LAVES_C15,TI:TI;0) 298.15 -9179.763+400.845624*T -71.9799*T*LN(T)-.014333925*T**2+3.20148E-07*T**3+217908*T**(-1); 900 Y -8435.445+398.964204*T-71.9661*T*LN(T)-.0126099*T**2-2.72628E-07*T**3 +128040*T**(-1); 1155 Y +17726.511+200.929614*T-44.8398*T*LN(T)-.0244395*T**2+6.08145E-07*T**3 -4432980*T**(-1); 1941 Y -358580.358+1916.42061*T-261.654738*T*LN(T)+.024614547*T**2 -9.14241E-07*T**3+1.10099415E+08*T**(-1); 4000 N REF2 ! PHASE MONOCLINIC % 1 1.0 ! CONSTITUENT MONOCLINIC :S : ! PARAMETER G(MONOCLINIC,S;0) 298.15 -5725.422+89.544275*T -17.413*T*LN(T)-.00993935*T**2-7.0062E-08*T**3+1250*T**(-1); 388.36 Y -7455.008+114.782945*T-21.1531404*T*LN(T)-.008566163*T**2 +1.112484E-06*T**3+122167*T**(-1); 1300 Y -11779.415+186.699065*T-32*T*LN(T); 1301 N REF3 ! PHASE OMEGA % 1 1.0 ! CONSTITUENT OMEGA :ZR : ! PARAMETER G(OMEGA,ZR;0) 298.15 -8878.082+144.432234*T -26.8556*T*LN(T)-.002799446*T**2+38376*T**(-1); 2128 Y -29500.524+265.290858*T-42.144*T*LN(T)+7.17445E+31*T**(-9); 6000 N REF2 ! PHASE ORTHORHOMBIC_A20 % 1 1.0 ! CONSTITUENT ORTHORHOMBIC_A20 :FE,U,ZR : ! PARAMETER G(ORTHORHOMBIC_A20,FE;0) 298.15 +GHSERFE#+5000; 6000 N REF3 ! PARAMETER G(ORTHORHOMBIC_A20,U;0) 298.15 +GHSERUU#; 3000 N REF1 ! PARAMETER G(ORTHORHOMBIC_A20,ZR;0) 298.15 +4474.461+124.9457*T -25.607406*T*LN(T)-3.40084E-04*T**2-9.729E-09*T**3+25233*T**(-1) -7.6143E-11*T**4; 2128 Y -25705.955+264.284163*T-42.144*T*LN(T)+1.276058E+32*T**(-9); 6000 N REF3 ! PHASE ORTHORHOMBIC_AC % 1 1.0 ! CONSTITUENT ORTHORHOMBIC_AC :NP : ! PARAMETER G(ORTHORHOMBIC_AC,NP;0) 298.15 +GHSERNP#; 4000 N REF1 ! PHASE ORTHORHOMBIC_GA % 1 1.0 ! CONSTITUENT ORTHORHOMBIC_GA :GA : ! PARAMETER G(ORTHORHOMBIC_GA,GA;0) 200 +GHSERGA#; 4000 N REF2 ! PHASE ORTHORHOMBIC_S % 1 1.0 ! CONSTITUENT ORTHORHOMBIC_S :S : ! PARAMETER G(ORTHORHOMBIC_S,S;0) 298.15 +GHSERSS#; 1301 N REF3 ! PHASE PM_S % 1 1.0 ! CONSTITUENT PM_S :PM : ! PARAMETER G(PM_S,PM;0) 298.15 +GHSERPM#; 6000 N REF3 ! PHASE PM_S2 % 1 1.0 ! CONSTITUENT PM_S2 :PM : ! PARAMETER G(PM_S2,PM;0) 298.15 +GHSERPM#+3200-2.75150473*T; 6000 N REF3 ! PHASE PO_S % 1 1.0 ! CONSTITUENT PO_S :PO : ! PARAMETER G(PO_S,PO;0) 298.15 +GHSERPO#; 6000 N REF3 ! PHASE RA_S % 1 1.0 ! CONSTITUENT RA_S :RA : ! PARAMETER G(RA_S,RA;0) 298.15 +GHSERRA#; 6000 N REF3 ! PHASE RED_P % 1 1.0 ! CONSTITUENT RED_P :AS,P : ! PARAMETER G(RED_P,AS;0) 298.15 +GHSERAS#+5782-3.85466*T; 1200 N REF3 ! PARAMETER G(RED_P,P;0) 250 +GREDPP#; 3000 N REF2 ! PHASE RHOMBOHEDRAL_A10 % 1 1.0 ! CONSTITUENT RHOMBOHEDRAL_A10 :CD,HG,PB,ZN : ! PARAMETER G(RHOMBOHEDRAL_A10,CD;0) 298.15 +GHSERCD#+800-.62*T; 1600 N REF3 ! PARAMETER G(RHOMBOHEDRAL_A10,HG;0) 200 +GRHOMBHG#; 2000 N REF4 ! PARAMETER G(RHOMBOHEDRAL_A10,PB;0) 298.15 +GHSERPB#+10; 2100 N REF4 ! PARAMETER G(RHOMBOHEDRAL_A10,ZN;0) 200 -2128.565+118.177019*T -23.701314*T*LN(T)-.001712034*T**2-1.264963E-06*T**3-3.589488E-19*T**7; 692.67 Y -5620.385+171.60854*T-31.38*T*LN(T); 1700 N REF2 ! PHASE RHOMBOHEDRAL_A7 % 1 1.0 ! CONSTITUENT RHOMBOHEDRAL_A7 :AS,BI,GE,IN,P,PB,PD,SB,SN,ZN : ! PARAMETER G(RHOMBOHEDRAL_A7,AS;0) 298.15 +GHSERAS#; 1200 N REF1 ! PARAMETER G(RHOMBOHEDRAL_A7,BI;0) 298.15 +GHSERBI#; 3000 N REF1 ! PARAMETER G(RHOMBOHEDRAL_A7,GE;0) 298.15 +GHSERGE#+29800-16.5*T; 3000 N REF3 ! PARAMETER G(RHOMBOHEDRAL_A7,IN;0) 298.15 +GHSERIN#+4184; 3800 N REF3 ! PARAMETER G(RHOMBOHEDRAL_A7,P;0) 250 +GHSERPP#-188+.12527*T; 3000 N REF3 ! PARAMETER G(RHOMBOHEDRAL_A7,PB;0) 298.15 +GHSERPB#+300+T; 2100 N REF3 ! PARAMETER G(RHOMBOHEDRAL_A7,PD;0) 298.15 +GHSERPD#+4000; 4000 N REF4 ! PARAMETER G(RHOMBOHEDRAL_A7,SB;0) 298.15 +GHSERSB#; 2000 N REF2 ! PARAMETER G(RHOMBOHEDRAL_A7,SN;0) 100 +GHSERSN#+2035; 3000 N REF2 ! PARAMETER G(RHOMBOHEDRAL_A7,ZN;0) 298.15 +GHSERZN#+2300+11.5*T; 1700 N REF3 ! PARAMETER G(RHOMBOHEDRAL_A7,SB;0) 298.15 +GHSERSB#; 2000 N REF2 ! PARAMETER G(RHOMBOHEDRAL_A7,SN;0) 100 +GHSERSN#+2035; 3000 N REF2 ! PARAMETER G(RHOMBOHEDRAL_A7,ZN;0) 298.15 +GHSERZN#+2300+11.5*T; 1700 N REF3 ! PHASE RHOMBOHEDRAL_C19 % 1 1.0 ! CONSTITUENT RHOMBOHEDRAL_C19 :SM : ! PARAMETER G(RHOMBOHEDRAL_C19,SM;0) 298.15 +GHSERSM#; 2100 N REF1 ! PHASE TETRAGONAL_A6 % 1 1.0 ! CONSTITUENT TETRAGONAL_A6 :BI,CD,GA,HG,IN,PB,PU,SN,ZN : ! : ! PARAMETER G(TETRAGONAL_A6,BI;0) 298.15 +GHSERBI#+4184.07; 3000 N REF2 ! PARAMETER G(TETRAGONAL_A6,CD;0) 298.15 +GHSERCD#+892.3-.92*T; 1600 N REF2 ! PARAMETER G(TETRAGONAL_A6,GA;0) 200 +GHSERGA#+3500-10*T; 4000 N REF2 ! PARAMETER G(TETRAGONAL_A6,HG;0) 200 -10459.721+125.04019*T -28.847*T*LN(T)+.01699705*T**2-2.4555667E-05*T**3+13330*T**(-1); 234.32 Y -11216.714+137.69375*T-30.2091*T*LN(T)+.00107555*T**2-2.28298E-07*T**3 +35545*T**(-1); 2000 N REF3 ! PARAMETER G(TETRAGONAL_A6,IN;0) 298.15 +GHSERIN#; 3800 N REF1 ! PARAMETER G(TETRAGONAL_A6,PB;0) 298.15 +GHSERPB#+4493.235; 2100 N REF3 ! PARAMETER G(TETRAGONAL_A6,PU;0) 298.15 -496.178+54.586547*T -16.43*T*LN(T)-.024006*T**2+5.166667E-06*T**3-158470*T**(-1); 736 Y -6122.307+173.35008*T-35.56*T*LN(T); 757 Y +3982.078+63.890352*T-19.756*T*LN(T)-.00937295*T**2+6.59882E-07*T**3 -1112565*T**(-1); 2157 Y -15200.539+228.05641*T-42.248*T*LN(T); 3000 N REF2 ! PARAMETER G(TETRAGONAL_A6,SN;0) 100 +GHSERSN#+5387-8.26212*T; 3000 N REF3 ! PARAMETER G(TETRAGONAL_A6,ZN;0) 298.15 +GHSERZN#+4184; 1700 N REF4 ! PHASE TETRAGONAL_AD % 1 1.0 ! CONSTITUENT TETRAGONAL_AD :NP : ! PARAMETER G(TETRAGONAL_AD,NP;0) 298.15 -10157.32+183.829213*T -34.11*T*LN(T)-.0161186*T**2+4.98465E-06*T**3+532825*T**(-1); 555 Y -7873.688+207.01896*T-39.33*T*LN(T); 856 Y +19027.98-46.64846*T-3.4265*T*LN(T)-.01921045*T**2+1.52726E-06*T**3 -3564640*T**(-1); 1999 Y -16070.82+256.707037*T-45.3964*T*LN(T); 4000 N REF2 ! PHASE TETRAGONAL_U % 1 1.0 ! CONSTITUENT TETRAGONAL_U :FE,U,ZR : ! PARAMETER G(TETRAGONAL_U,FE;0) 298.15 +GHSERFE#+5000; 6000 N REF3 ! PARAMETER G(TETRAGONAL_U,U;0) 298.15 -5156.136+106.976316*T -22.841*T*LN(T)-.01084475*T**2+2.7889E-08*T**3+81944*T**(-1); 941.50 Y -14327.309+244.16802*T-42.9278*T*LN(T); 3000 N REF2 ! PARAMETER G(TETRAGONAL_U,ZR;0) 298.15 +4474.461+124.9457*T -25.607406*T*LN(T)-3.40084E-04*T**2-9.729E-09*T**3+25233*T**(-1) -7.6143E-11*T**4; 2128 Y -25705.955+264.284163*T-42.144*T*LN(T)+1.276058E+32*T**(-9); 6000 N REF3 ! PHASE TET_ALPHA1 % 1 1.0 ! CONSTITUENT TET_ALPHA1 :BI,IN,PB,SN : ! PARAMETER G(TET_ALPHA1,BI;0) 298.15 +GHSERBI#+4234; 3000 N REF2 ! PARAMETER G(TET_ALPHA1,IN;0) 298.15 +GHSERIN#+123-.1988*T; 3800 N REF3 ! PARAMETER G(TET_ALPHA1,PB;0) 298.15 +GHSERPB#+1903.3-2.0602*T; 2100 N REF3 ! PARAMETER G(TET_ALPHA1,SN;0) 100 +GHSERSN#+5510-8.46*T; 3000 N REF3 ! PHASE WHITE_P % 1 1.0 ! CONSTITUENT WHITE_P :P : ! PARAMETER G(WHITE_P,P;0) 250 +GHSERPP#; 3000 N REF2 ! LIST_OF_REFERENCES NUMBER SOURCE REF3 'PURE4 - SGTE Pure Elements (Unary) Database (Version 4.6), developed by SGTE (Scientific Group Thermodata Europe), 1991-2008, and provided by TCSAB (Jan. 2008). ' REF2 'PURE3 - SGTE Pure Elements (Unary) Database (Version 3.0), developed by SGTE (Scientific Group Thermodata Europe), 1991-1996, and provided by TCSAB (Aug. 1996). ' REF1 'PURE1 - SGTE Pure Elements (Unary) Database (Version 1.0), developed by SGTE (Scientific Group Thermodata Europe), 1991-1992, and provided by TCSAB (Jan. 1991). Also in: Dinsdale A. (1991): SGTE data for pure elements, Calphad, 15, 317-425.' REF4 'PURE5 - SGTE Pure Elements (Unary) Database (Version 5.1), developed by SGTE (Scientific Group Thermodata Europe), 1991-2010, and provided by TCSAB (Jun. 2010). ' ! ================================================ FILE: examples/macros/agcu.TDB ================================================ $ Database file written 2014- 2-22 $ From database: SSOL2 ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT AG FCC_A1 1.0787E+02 5.7446E+03 4.2551E+01! ELEMENT CU FCC_A1 6.3546E+01 5.0041E+03 3.3150E+01! FUNCTION GHSERAG 298.15 -7209.512+118.200733*T-23.8463314*T*LN(T) -.001790585*T**2-3.98587E-07*T**3-12011*T**(-1); 1.23508E+03 Y -15095.314+190.265169*T-33.472*T*LN(T)+1.412186E+29*T**(-9); 3000 N ! FUNCTION GHSERCU 298.15 -7770.458+130.485403*T-24.112392*T*LN(T) -.00265684*T**2+1.29223E-07*T**3+52478*T**(-1); 1.35802E+03 Y -13542.33+183.804197*T-31.38*T*LN(T)+3.64643E+29*T**(-9); 3200 N ! FUNCTION UN_ASS 298.15 0; 300 N ! TYPE_DEFINITION % SEQ *! DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! PHASE LIQUID:L % 1 1.0 ! CONSTITUENT LIQUID:L :AG,CU : ! PARAMETER G(LIQUID,AG;0) 298.15 +11025.293-8.890146*T -1.0322E-20*T**7+GHSERAG#; 1.23508E+03 Y +11507.972-9.300495*T-1.412186E+29*T**(-9)+GHSERAG#; 3000 N REF283 ! PARAMETER G(LIQUID,CU;0) 298.15 +12964.84-9.510243*T -5.83932E-21*T**7+GHSERCU#; 1.35802E+03 Y +13495.4-9.920463*T-3.64643E+29*T**(-9)+GHSERCU#; 3.20000E+03 N REF283 ! PARAMETER G(LIQUID,AG,CU;0) 298.15 +17534.6-4.45479*T; 6000 N REF137 ! PARAMETER G(LIQUID,AG,CU;1) 298.15 +2251.3-2.6733*T; 6000 N REF137 ! PARAMETER G(LIQUID,AG,CU;2) 298.15 492.7; 6000 N REF137 ! TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! PHASE BCC_A2 %& 2 1 3 ! CONSTITUENT BCC_A2 :AG,CU : VA% : ! PARAMETER G(BCC_A2,AG:VA;0) 298.15 +3400-1.05*T+GHSERAG#; 3000 N REF283 ! PARAMETER G(BCC_A2,CU:VA;0) 298.15 +4017-1.255*T+GHSERCU#; 3200 N REF283 ! PARAMETER G(BCC_A2,AG,CU:VA;0) 298.15 +35000-8*T; 6000 N REF135 ! TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! PHASE FCC_A1 %' 2 1 1 ! CONSTITUENT FCC_A1 :AG%,CU% : VA% : ! PARAMETER G(FCC_A1,AG:VA;0) 298.15 +GHSERAG#; 3.00000E+03 N REF283 ! PARAMETER G(FCC_A1,CU:VA;0) 298.15 +GHSERCU#; 3.20000E+03 N REF283 ! PARAMETER G(FCC_A1,AG,CU:VA;0) 298.15 +33819.1-8.1236*T; 6000 N REF137 ! PARAMETER G(FCC_A1,AG,CU:VA;1) 298.15 -5601.9+1.32997*T; 6000 N REF137 ! TYPE_DEFINITION ( GES A_P_D HCP_A3 MAGNETIC -3.0 2.80000E-01 ! PHASE HCP_A3 %( 2 1 .5 ! CONSTITUENT HCP_A3 :AG,CU : VA% : ! PARAMETER G(HCP_A3,AG:VA;0) 298.15 +300+.3*T+GHSERAG#; 3000 N REF283 ! PARAMETER G(HCP_A3,CU:VA;0) 298.15 +600+.2*T+GHSERCU#; 3200 N REF283 ! PARAMETER G(HCP_A3,AG,CU:VA;0) 298.15 +35000-8*T; 6000 N REF135 ! LIST_OF_REFERENCES NUMBER SOURCE REF283 'Alan Dinsdale, SGTE Data for Pure Elements, Calphad Vol 15(1991) p 317-425, also in NPL Report DMA(A)195 Rev. August 1990' REF137 'F.H. Hayes, H.L. Lukas, G. Effenberg, G. Petzow, Z. fur Metallkde, Vol 77 (1986), No 11, p 749-754; AG-CU-PB' REF135 'Unassessed parameter, inserted to make this phase less stable.' ! ================================================ FILE: examples/macros/all-from-map19.OCM ================================================ @$ @$ running all test macros @$ @$ @$ @$ Before running this use the command SET ADVANCED WORKSPACE @$ to the directory with the "all.OCM" file @$ That should make all files created to reside on that directory @$ set echo Y @&& ********************************************************* @$ Test of NaCl-MgCl2 using the MQMQA model @$ ********************************************************* mac ./map19 @&& ********************************************************* @$ Second test of the MQMQA model @$ ********************************************************* mac ./cslaf-map @&& ********************************************************* @$ Testing the CEF SRO calculations @$ ********************************************************* mac ./sro-cef.OCM @&& ********************************************************* @$ Testing the UNIQUAC model this model no longer supported @$ ********************************************************* @$ mac ./uniquac @&& ********************************************************* @$ Calculation for 20 elements and 191 phases using COST507 @$ ********************************************************* mac ./allcost @&& ********************************************************* @$ Calculating 21 equilibria in parallel @$ First test of parallel calculations @$ ********************************************************* mac ./parallel1 @&& ********************************************************* @$ Enter a table with many equilibria and calculate all @$ Can be used to test parallel calculations @$ ********************************************************* mac ./parallel2 @&& ********************************************************* @$ Assessment using fictitious binary experimental data @$ ********************************************************* @$ mac ./opttest1 @&& ********************************************************* @$ Assessment start of the Cu-Mg case study must be run by itself @$ on the directory with the macro files @$ ********************************************************* @$ @$ mac ./opttest2 @$ @&& ********************************************************* @$ that is all and hopefully enough @$ ********************************************************* set inter ================================================ FILE: examples/macros/all-from-map4.OCM ================================================ @$ @$ running all test macros @$ @$ @$ @$ Before running this use the command SET ADVANCED WORKSPACE @$ to the directory with the "all.OCM" file @$ That should make all files created to reside on that directory @$ set echo Y @&& ********************************************************* @$ Phase diagram for O-U @$ ********************************************************* mac ./map4 @&& ********************************************************* @$ Phase diagram for Fe-Mo @$ ********************************************************* mac ./map5 @&& ********************************************************* @$ The isopleth phase diagram for an 18-8 stainless steel @$ ********************************************************* mac ./map6 @&& ********************************************************* @$ Almost complete isopleth calculation of a HSS @$ ********************************************************* mac ./map7 @&& ********************************************************* @$ Metastable phase diagram for ordered FCC in Fe-Ni @$ ********************************************************* mac ./map8 @&& ********************************************************* @$ Metastable Re-W phase diagram based on First Principles data @$ ********************************************************* mac ./map9 @&& ********************************************************* @$ An isothermal section of Cr-Fe-Ni @$ ********************************************************* mac ./map10 @&& ********************************************************* @$ The Cr-Fe binary phase diagram @$ ********************************************************* mac ./map11 @&& ********************************************************* @$ The Mo-Re binary phase diagram using database in TDBformat @$ ********************************************************* mac ./map12 @&& ********************************************************* @$ The Al-Ni binary phase diagram with 4 sublattice order/disorder models @$ ********************************************************* mac ./map13 @&& ********************************************************* @$ The Cr-Fe-Mo isothermal section at 1400 K @$ ********************************************************* mac ./map14 @&& ********************************************************* @$ The Mo-Ni-Re EBEF model isothermal section at 2500, 1500 and 500 K. @$ ********************************************************* mac ./map15 @&& ********************************************************* @$ The isopleth C-13wCr-Fe with a 4 phase invariant equilinrium @$ ********************************************************* mac ./map16 @&& ********************************************************* @$ The Al-Fe binary with a dashed A2/B2 transition line @$ ********************************************************* mac ./map17 @&& ********************************************************* @$ The Al-Mg-Zn isopleth at x(zn)=0.05 @$ ********************************************************* mac ./map18 @&& ********************************************************* @$ Test of NaCl-MgCl2 using the MQMQA model @$ ********************************************************* mac ./map19 @&& ********************************************************* @$ Second test of the MQMQA model @$ ********************************************************* mac ./cslaf-map @&& ********************************************************* @$ Testing the CEF SRO calculations @$ ********************************************************* mac ./sro-cef.OCM @&& ********************************************************* @$ Testing the UNIQUAC model this model no longer supported @$ ********************************************************* @$ mac ./uniquac @&& ********************************************************* @$ Calculation for 20 elements and 191 phases using COST507 @$ ********************************************************* mac ./allcost @&& ********************************************************* @$ Calculating 21 equilibria in parallel @$ First test of parallel calculations @$ ********************************************************* mac ./parallel1 @&& ********************************************************* @$ Enter a table with many equilibria and calculate all @$ Can be used to test parallel calculations @$ ********************************************************* mac ./parallel2 @&& ********************************************************* @$ Assessment using fictitious binary experimental data @$ ********************************************************* @$ mac ./opttest1 @&& ********************************************************* @$ Assessment start of the Cu-Mg case study must be run by itself @$ on the directory with the macro files @$ ********************************************************* @$ @$ mac ./opttest2 @$ @&& ********************************************************* @$ that is all and hopefully enough @$ ********************************************************* set inter ================================================ FILE: examples/macros/all-from-tzero.OCM ================================================ @$ @$ running all test macros @$ @$ @$ @$ Before running this use the command SET ADVANCED WORKSPACE @$ to the directory with the "all.OCM" file @$ That should make all files created to reside on that directory @$ set echo Y @&& ********************************************************* @$ A T-zero line in a Fe-Cr-Si-C steel @$ ********************************************************* mac ./step-tzero @&& ********************************************************* @$ A isothermal section, paraequilibrum and T-zero line in a Fe-Mn-Si-C steel @$ ********************************************************* mac ./step-epz @&& ********************************************************* @$ A Scheil-Gulliver solidification simulation @$ ********************************************************* mac ./step-scheil @&& ********************************************************* @$ Phase diagram for Ag-Cu with various axis @$ ********************************************************* mac ./map1 @&& ********************************************************* @$ Phase diagram for Cr-Mo @$ ********************************************************* mac ./map2 @&& ********************************************************* @$ Phase diagram for C-Fe @$ ********************************************************* mac ./map3 @&& ********************************************************* @$ Phase diagram for O-U @$ ********************************************************* mac ./map4 @&& ********************************************************* @$ Phase diagram for Fe-Mo @$ ********************************************************* mac ./map5 @&& ********************************************************* @$ The isopleth phase diagram for an 18-8 stainless steel @$ ********************************************************* mac ./map6 @&& ********************************************************* @$ Almost complete isopleth calculation of a HSS @$ ********************************************************* mac ./map7 @&& ********************************************************* @$ Metastable phase diagram for ordered FCC in Fe-Ni @$ ********************************************************* mac ./map8 @&& ********************************************************* @$ Metastable Re-W phase diagram based on First Principles data @$ ********************************************************* mac ./map9 @&& ********************************************************* @$ An isothermal section of Cr-Fe-Ni @$ ********************************************************* mac ./map10 @&& ********************************************************* @$ The Cr-Fe binary phase diagram @$ ********************************************************* mac ./map11 @&& ********************************************************* @$ The Mo-Re binary phase diagram using database in TDBformat @$ ********************************************************* mac ./map12 @&& ********************************************************* @$ The Al-Ni binary phase diagram with 4 sublattice order/disorder models @$ ********************************************************* mac ./map13 @&& ********************************************************* @$ The Cr-Fe-Mo isothermal section at 1400 K @$ ********************************************************* mac ./map14 @&& ********************************************************* @$ The Mo-Ni-Re EBEF model isothermal section at 2500, 1500 and 500 K. @$ ********************************************************* mac ./map15 @&& ********************************************************* @$ The isopleth C-13wCr-Fe with a 4 phase invariant equilinrium @$ ********************************************************* mac ./map16 @&& ********************************************************* @$ The Al-Fe binary with a dashed A2/B2 transition line @$ ********************************************************* mac ./map17 @&& ********************************************************* @$ The Al-Mg-Zn isopleth at x(zn)=0.05 @$ ********************************************************* mac ./map18 @&& ********************************************************* @$ Test of NaCl-MgCl2 using the MQMQA model @$ ********************************************************* mac ./map19 @&& ********************************************************* @$ Second test of the MQMQA model @$ ********************************************************* mac ./cslaf-map @&& ********************************************************* @$ Testing the CEF SRO calculations @$ ********************************************************* mac ./sro-cef.OCM @&& ********************************************************* @$ Testing the UNIQUAC model @$ ********************************************************* @$ mac ./uniquac @&& ********************************************************* @$ Calculation for 20 elements and 191 phases using COST507 @$ ********************************************************* mac ./allcost @&& ********************************************************* @$ Calculating 21 equilibria in parallel @$ First test of parallel calculations @$ ********************************************************* mac ./parallel1 @&& ********************************************************* @$ Enter a table with many equilibria and calculate all @$ Can be used to test parallel calculations @$ ********************************************************* mac ./parallel2 @&& ********************************************************* @$ Assessment using fictitious binary experimental data @$ ********************************************************* @$ mac ./opttest1 @&& ********************************************************* @$ Assessment start of the Cu-Mg case study must be run by itself @$ on the directory with the macro files @$ ********************************************************* @$ @$ mac ./opttest2 @$ @&& ********************************************************* @$ that is all and hopefully enough @$ ********************************************************* set inter ================================================ FILE: examples/macros/all.OCM ================================================ @$ @$ running all test macros @$ @$ @$ @$ Before running this use the command SET ADVANCED WORKSPACE @$ to the directory with the "all.OCM" file @$ That should make all files created to reside on that directory @$ set echo Y @$ @$ ********************************************************* @$ Equilibria in pure Fe @$ ********************************************************* mac ./unary @&& ********************************************************* @$ Test setting various conditions for a C-Cr-Fe system @$ ********************************************************* mac ./testcond1 @&& ********************************************************* @$ Equilibria and melting T of a 6 component high speed steel (HSS) @$ ********************************************************* mac ./melting @&& ********************************************************* @$ Testing a single calculation and save/read it unformatted @$ ********************************************************* mac ./save @&& ********************************************************* @$ Diagrams for phase fractions, compositions, heat content of a HSS @$ ********************************************************* mac ./step1 @&& ********************************************************* @$ Diagrams for Gibbs energy curves for Ag-Cu @$ ********************************************************* mac ./step2 @&& ********************************************************* @$ Diagrams for gas phase speciation, heat content and heat capacity @$ ********************************************************* mac ./step3 @&& ********************************************************* @$ Diagrams for constituion and Gibbs energy curves for ordered FCC in Fe-Ni @$ ********************************************************* mac ./step4 @&& ********************************************************* @$ Diagrams for constitution and heat capacity for ordered FCC in Fe-Ni @$ ********************************************************* mac ./step5 @&& ********************************************************* @$ Diagram for Gibbs energy curves for Fe-Mo @$ ********************************************************* mac ./step6 @&& ********************************************************* @$ Diagram for phase fractions and PRE for a duplex stainless steel @$ ********************************************************* mac ./step7 @&& ********************************************************* @$ Adiabatic flame temperature for C3H8 as funktion of N(O) @$ ********************************************************* mac ./step8 @&& ********************************************************* @$ Second order transition in a B2 phase with tentative T dependent SRO @$ ********************************************************* mac ./step9 @&& ********************************************************* @$ A T-zero line in a Fe-Cr-Si-C steel @$ ********************************************************* mac ./step-tzero @&& ********************************************************* @$ A isothermal section, paraequilibrum and T-zero line in a Fe-Mn-Si-C steel @$ ********************************************************* mac ./step-epz @&& ********************************************************* @$ A Scheil-Gulliver solidification simulation @$ ********************************************************* mac ./step-scheil @&& ********************************************************* @$ Phase diagram for Ag-Cu with various axis @$ ********************************************************* mac ./map1 @&& ********************************************************* @$ Phase diagram for Cr-Mo @$ ************************************* ******************** mac ./map2 @&& ********************************************************* @$ Phase diagram for C-Fe @$ ********************************************************* mac ./map3 @&& ********************************************************* @$ Phase diagram for O-U @$ ********************************************************* mac ./map4 @&& ********************************************************* @$ Phase diagram for Fe-Mo @$ ********************************************************* mac ./map5 @&& ********************************************************* @$ The isopleth phase diagram for an 18-8 stainless steel @$ ********************************************************* mac ./map6 @&& ********************************************************* @$ Almost complete isopleth calculation of a HSS @$ ********************************************************* mac ./map7 @&& ********************************************************* @$ Metastable phase diagram for ordered FCC in Fe-Ni @$ ********************************************************* mac ./map8 @&& ********************************************************* @$ Metastable Re-W phase diagram based on First Principles data @$ ********************************************************* mac ./map9 @&& ********************************************************* @$ An isothermal section of Cr-Fe-Ni @$ ********************************************************* mac ./map10 @&& ********************************************************* @$ The Cr-Fe binary phase diagram @$ ********************************************************* mac ./map11 @&& ********************************************************* @$ The Mo-Re binary phase diagram using database in TDBformat @$ ********************************************************* mac ./map12 @&& ********************************************************* @$ The Al-Ni binary phase diagram with 4 sublattice order/disorder models @$ ********************************************************* mac ./map13 @&& ********************************************************* @$ The Cr-Fe-Mo isothermal section at 1400 K @$ ********************************************************* mac ./map14 @&& ********************************************************* @$ The Mo-Ni-Re EBEF model isothermal section at 2500, 1500 and 500 K. @$ ********************************************************* mac ./map15 @&& ********************************************************* @$ The isopleth C-13wCr-Fe with a 4 phase invariant equilinrium @$ ********************************************************* mac ./map16 @&& ********************************************************* @$ The Al-Fe binary with a dashed A2/B2 transition line @$ ********************************************************* mac ./map17 @&& ********************************************************* @$ The Al-Mg-Zn isopleth at x(zn)=0.05 @$ ********************************************************* mac ./map18 @&& ********************************************************* @$ Test of NaCl-MgCl2 using the MQMQA model @$ ********************************************************* mac ./map19 @&& ********************************************************* @$ Second test of the MQMQA model @$ ********************************************************* mac ./cslaf-map @&& ********************************************************* @$ Testing the CEF SRO calculations @$ ********************************************************* mac ./sro-cef.OCM @&& ********************************************************* @$ New unary descriptions @$ ********************************************************* mac ./AlC-diagrams @&& ********************************************************* @$ Testing the UNIQUAC model Removed as it conflicts with the new MQMQA model @$ ********************************************************* @$ mac ./uniquac @&& ********************************************************* @$ Calculation for 20 elements and 191 phases using COST507 @$ ********************************************************* mac ./allcost @&& ********************************************************* @$ Calculating 21 equilibria in parallel @$ First test of parallel calculations @$ ********************************************************* mac ./parallel1 @&& ********************************************************* @$ Enter a table with many equilibria and calculate all @$ Can be used to test parallel calculations @$ ********************************************************* mac ./parallel2 @&& ********************************************************* @$ Assessment using fictitious binary experimental data @$ ********************************************************* @$ mac ./opttest1 @&& ********************************************************* @$ Assessment start of the Cu-Mg case study must be run by itself @$ on the directory with the macro files @$ ********************************************************* @$ @$ mac ./opttest2 @$ @&& ********************************************************* @$ that is all and hopefully enough @$ ********************************************************* set inter ================================================ FILE: examples/macros/allcost.OCM ================================================ new Y set echo Y @$ ============================================================== @$ @$ @$ @$ @$ @$ This macro calculates some equilibria in a multicomponent system @$ using the largest free databases I have, cost507 for light alloys @$ which has 20 elements and 191 phases @$ @$ This database is from 1997 and NOT VERY HIGH QUALITY @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ allcost.OCM @$ @$ ============================================================== set echo r t ./cost507R @& @$ This should try to enter >9 composition sets set c t=2000 p=1e5 n=1 set c w(b)=.001 w(c)=.004 w(ce)=.002 w(cr)=0.0002 w(cu)=.02 w(fe)=0.0001 set c w(li)=.0006 w(mg)=.03 w(mn)=.0002 w(n)=0.001 w(nd)=.01 w(ni)=.01 set c w(si)=.07 w(sn)=.003 w(ti)=.002 w(v)=.0008 w(y)=.00014 set c w(zn)=.06 w(zr)=.007 l c @$ Set small grid to speed up calculations @$ set adv small DEPRECIATED COMMAND set adv grid 0 @& @$ Just calculate with gridmin, some warnings c g @& @$ A short listing of the 20 phases selected by gridmin l sh p @$ Note several composition set for the liquid @& @$ Then calculate the full equilibrium using this start point c n @& l,,,,, @$ Only the AlN solid stable together with the liquid @$ NOTE THE DATABASE IS NOT RELIABLE FOR THIS SYSTEM debug symbol g -1.4480613E5 @& @$ Then calculte a full equilibrium at 1000 K set c t=1000 c e @$ Sometimes it does not converge here because competing liquids ... try again @& c e debug symbol g -5.2815596E+04 @$ Numerical problems can always occur. @$ If you have a presistant problem please provide database and macro file @$ to the OC team @& l,,,,, @$ NOTE THE DATABASE IS NOT RELIABLE FOR THIS SYSTEM @& l sh p @$ NOTE THE DATABASE IS NOT RELIABLE FOR THIS SYSTEM @& @$ Calculate at a lower T set c t=500 c e l,,,, @$ NOTE THE DATABASE IS NOT RELIABLE FOR THIS SYSTEM @$ Testing result debug symbol g -2.3254708E4 @& l sh p @$ NOTE THE DATABASE IS NOT RELIABLE FOR THIS SYSTEM @& @$ Added test of the command CALCULATE BOSSES_METHOD ...does not work... @$ This may be useful if there are convergence problems @$ c b-m @$ Or try this step by step method @$ First just the grid minimizer c g @$ set all phases except those found by the gridminimizer as suspended @$ and calculate equilibrium without the gridminimizer @$ *U is all unstable phases set st ph *U=S @$ use c n is to calculate without gridminimizer c n @$ it converges but we cannot be sure we have the most stable equilibrium @& @$ Then set all suspended phases as dormant and calculate without gridmin set st ph *S=D c n @$ Thus time the driving force for all dormat phases will be calculated @& l r @$ There are 2 dormant phases listed which want to be stable, add them set st ph bcc_a2 alcu_theta = E 0 @& c n @$ Calculate again without the gridminimizer @& l r @$ When listing no new phases wants to be stable @$ set all dormant phases as entered set st ph *D=E @$ Continue to use "c n" because using "c e" will use the gridminimizer c n @& l r @$ Listing result with all phases as entered, same as before! debug symbol g -2.3254708E4 @$========================================================================== @$ end of allcost macro @$========================================================================== set inter @$ gprof oc5prof.exe gmon.out > output_file.txt ================================================ FILE: examples/macros/alni-4slx.TDB ================================================ $ Database file written 2017- 8- 2 $ From database: USER ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT AL A1 2.6982E+01 4.5773E+03 2.8322E+01! ELEMENT NI A1 5.8690E+01 4.7870E+03 2.9796E+01! FUNCTION GLIQAL 298.15 +11005.553-11.840873*T+7.9401E-20*T**7+GHSERAL#; 933.60 Y +10481.974-11.252014*T+1.234264E+28*T**(-9)+GHSERAL#; 2900 N ! FUNCTION GHSERAL 298.15 -7976.15+137.071542*T-24.3671976*T*LN(T) -.001884662*T**2-8.77664E-07*T**3+74092*T**(-1); 700 Y -11276.24+223.02695*T-38.5844296*T*LN(T)+.018531982*T**2 -5.764227E-06*T**3+74092*T**(-1); 933.60 Y -11277.683+188.661987*T-31.748192*T*LN(T)-1.234264E+28*T**(-9); 2900 N ! FUNCTION GBCCAL 298.15 +10083-4.813*T+GHSERAL#; 6000 N ! FUNCTION B2ALVA 298.15 +10000-T; 6000 N ! FUNCTION LB2ALVA 298.15 +200000; 6000 N ! FUNCTION BALVAB2 298.15 +.5*B2ALVA#-.5*LB2ALVA#; 6000 N ! FUNCTION BUALVA 298.15 +.25*BALVAB2#; 6000 N ! FUNCTION GHCPAL 298.15 +5481-1.799*T+GHSERAL#; 6000 N ! FUNCTION C14AL 298.15 +14000+GHSERAL#; 6000 N ! FUNCTION B2NIVA 298.15 +162397.3-27.40575*T; 6000 N ! FUNCTION LB2NIVA 298.15 -64024.38+26.49419*T; 6000 N ! FUNCTION BNIVAB2 298.15 +.5*B2NIVA#-.5*LB2NIVA#; 6000 N ! FUNCTION BUNIVA 298.15 +.25*BNIVAB2#; 6000 N ! FUNCTION C14NI 298.15 +18900+GHSERNI#; 6000 N ! FUNCTION GDHCNI 298.15 +.5*GHCPNI#+.5*GFCCNI#; 6000 N ! FUNCTION LLIQ0 298.15 -5*LLIQ2#-9*LLIQ4#; 6000 N ! FUNCTION LLIQ1 298.15 -7*UNTIER#*LLIQ3#; 6000 N ! FUNCTION LLIQ2 298.15 +81204.81-31.95713*T; 6000 N ! FUNCTION LLIQ3 298.15 +4365.35-2.51632*T; 6000 N ! FUNCTION LLIQ4 298.15 -22101.64+13.16341*T; 6000 N ! FUNCTION FAL3NI 298.15 -29600; 6000 N ! FUNCTION FAL2NI2 298.15 -66718+11.64*T; 6000 N ! FUNCTION FALNI3 298.15 -43590+6.22*T; 6000 N ! FUNCTION FRALNI 298.15 -34575+13.22*T; 6000 N ! FUNCTION F0ALNI 298.15 +5310-1.46*T; 6000 N ! FUNCTION LB2ALNI 298.15 -62104+19.28*T; 6000 N ! FUNCTION B2ALNI 298.15 -152397.3+26.40575*T; 6000 N ! FUNCTION BALNIB2 298.15 +.5*B2ALNI#-.5*LB2ALNI#; 6000 N ! FUNCTION BAL3NI 298.15 +2*BUALNI#; 6000 N ! FUNCTION BALNI3 298.15 +2*BUALNI#; 6000 N ! FUNCTION BALNIB32 298.15 +2*BUALNI#; 6000 N ! FUNCTION BUALNI 298.15 +.25*BALNIB2#; 6000 N ! FUNCTION HAL3NI 298.15 -29600; 6000 N ! FUNCTION HAL2NI2 298.15 -66718+11.64*T; 6000 N ! FUNCTION HALNI3 298.15 -43590+6.22*T; 6000 N ! FUNCTION HRALNI 298.15 -34575+13.22*T; 6000 N ! FUNCTION H0ALNI 298.15 +5310-1.46*T; 6000 N ! FUNCTION GHSERNI 298.15 -5179.159+117.854*T-22.096*T*LN(T)-.0048407*T**2; 1728 Y -27840.655+279.135*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 6000 N ! FUNCTION GALALNI 298.15 -GALNIVA#+GALALVA#+GALNINI#; 6000 N ! FUNCTION GALNINI 298.15 +5000+FB2ALNI#; 6000 N ! FUNCTION GALALVA 298.15 +5000-.5*T+5*UNSURSIX#*GBCCAL#; 6000 N ! FUNCTION GALNIVA 298.15 -59620.987+11.387*T+3*UNSURSIX#*GBCCAL# +2*UNSURSIX#*GBCCNI#; 6000 N ! FUNCTION L32ALNI 298.15 -32247.363+21.965*T; 6000 N ! FUNCTION L32NIVA 298.15 -3666.95+1.1722*T; 6000 N ! FUNCTION GHCPNI 298.15 +1046+1.255*T+GHSERNI#; 3000 N ! FUNCTION GFCCNI 298.15 +GHSERNI#; 3000 N ! FUNCTION UNTIER 298.15 +TROIS#**(-1); 6000 N ! FUNCTION UNSURSIX 298.15 +SIX#**(-1); 6000 N ! FUNCTION FB2ALNI 298.15 -76198.65+13.202875*T+.5*GBCCAL#+.5*GBCCNI#; 6000 N ! FUNCTION GBCCNI 298.15 +8715.084-3.556*T+GHSERNI#; 3000 N ! FUNCTION TROIS 298.15 +3; 6000 N ! FUNCTION SIX 298.15 +6; 6000 N ! FUNCTION UN_ASS 298.15 +0; 300 N ! TYPE_DEFINITION % SEQ *! DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! TYPE_DEFINITION ) GES AMEND_PHASE_DESCRIPTION BCC4 DIS_PART A2,,,! TYPE_DEFINITION + GES AMEND_PHASE_DESCRIPTION FCC4 DIS_PART A1,,,! TYPE_DEFINITION . GES AMEND_PHASE_DESCRIPTION HCP4 DIS_PART A3,,,! PHASE LIQUID:L % 1 1.0 ! CONSTITUENT LIQUID:L :AL,NI : ! PARAMETER G(LIQUID,AL;0) 298.15 +GLIQAL#; 2900 N REF2 ! PARAMETER G(LIQUID,NI;0) 298.15 +11235.527+108.457*T -22.096*T*LN(T)-.0048407*T**2-3.82318E-21*T**7; 1728 Y -9549.775+268.598*T-43.1*T*LN(T); 3000 N REF2 ! PARAMETER G(LIQUID,AL,NI;0) 298.15 +LLIQ0#; 6000 N REF4 ! PARAMETER G(LIQUID,AL,NI;1) 298.15 +LLIQ1#; 6000 N REF4 ! PARAMETER G(LIQUID,AL,NI;2) 298.15 +LLIQ2#; 6000 N REF4 ! PARAMETER G(LIQUID,AL,NI;3) 298.15 +LLIQ3#; 6000 N REF4 ! PARAMETER G(LIQUID,AL,NI;4) 298.15 +LLIQ4#; 6000 N REF4 ! TYPE_DEFINITION & GES A_P_D A1 MAGNETIC -3.0 2.80000E-01 ! PHASE A1 %& 1 1.0 ! CONSTITUENT A1 :AL,NI : ! PARAMETER G(A1,AL;0) 298.15 +GHSERAL#; 6000 N REF2 ! PARAMETER G(A1,NI;0) 298.15 -5179.159+117.854*T -22.096*T*LN(T)-.0048407*T**2; 1728 Y -27840.655+279.135*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 3000 N REF1 ! PARAMETER TC(A1,NI;0) 298.15 +633; 3000 N REF1 ! PARAMETER BMAGN(A1,NI;0) 298.15 +.52; 3000 N REF2 ! PARAMETER TC(A1,AL,NI;0) 298.15 -1112; 6000 N REF4 ! PARAMETER TC(A1,AL,NI;1) 298.15 +1745; 6000 N REF4 ! PARAMETER G(A1,AL,NI;0) 298.15 +FAL3NI#+1.5*FAL2NI2# +FALNI3#+1.5*FRALNI#+4*F0ALNI#; 6000 N REF11 ! PARAMETER G(A1,AL,NI;1) 298.15 +2*FAL3NI#-2*FALNI3#; 6000 N REF11 ! PARAMETER G(A1,AL,NI;2) 298.15 +FAL3NI#-1.5*FAL2NI2# +FALNI3#-1.5*FRALNI#; 6000 N REF11 ! TYPE_DEFINITION ' GES A_P_D A2 MAGNETIC -1.0 4.00000E-01 ! PHASE A2 %' 1 1.0 ! CONSTITUENT A2 :AL,NI,VA : ! PARAMETER G(A2,AL;0) 298.15 +GBCCAL#; 6000 N REF2 ! PARAMETER TC(A2,NI;0) 298.15 +575; 3000 N REF1 ! PARAMETER BMAGN(A2,NI;0) 298.15 +.85; 3000 N REF1 ! PARAMETER G(A2,NI;0) 298.15 +3535.925+114.298*T -22.096*T*LN(T)-.0048407*T**2; 1728 Y -19125.571+275.579*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 6000 N REF2 ! PARAMETER G(A2,VA;0) 298.15 +30*T; 6000 N REF20 ! PARAMETER G(A2,AL,VA;0) 298.15 +B2ALVA#+LB2ALVA#; 6000 N REF20 ! PARAMETER G(A2,AL,NI;0) 298.15 +B2ALNI#+LB2ALNI#; 6000 N REF8 ! PARAMETER G(A2,NI,VA;0) 298.15 +B2NIVA#+LB2NIVA#; 6000 N REF8 ! TYPE_DEFINITION ( GES A_P_D A3 MAGNETIC -3.0 2.80000E-01 ! PHASE A3 %( 1 1.0 ! CONSTITUENT A3 :AL,NI : ! PARAMETER G(A3,AL;0) 298.15 +GHCPAL#; 6000 N REF0 ! PARAMETER TC(A3,NI;0) 298.15 +633; 6000 N REF1 ! PARAMETER BMAGN(A3,NI;0) 298.15 +.52; 6000 N REF1 ! PARAMETER G(A3,NI;0) 298.15 -4133.159+119.109*T -22.096*T*LN(T)-.0048407*T**2; 1728 Y -26794.655+280.39*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 3000 N REF2 ! PARAMETER G(A3,AL,NI;0) 298.15 +HAL3NI#+1.5*HAL2NI2# +HALNI3#+1.5*HRALNI#+4*H0ALNI#; 6000 N REF20 ! PARAMETER G(A3,AL,NI;1) 298.15 +2*HAL3NI#-2*HALNI3#; 6000 N REF20 ! PARAMETER G(A3,AL,NI;2) 298.15 +HAL3NI#-1.5*HAL2NI2# +HALNI3#-1.5*HRALNI#; 6000 N REF20 ! PHASE AL3NI1 % 2 .75 .25 ! CONSTITUENT AL3NI1 :AL : NI : ! PARAMETER G(AL3NI1,AL:NI;0) 298.15 -48483.73+12.29913*T +.75*GHSERAL#+.25*GHSERNI#; 6000 N REF4 ! PHASE AL3NI2 % 3 3 2 1 ! CONSTITUENT AL3NI2 :AL : AL,NI% : NI,VA% : ! PARAMETER G(AL3NI2,AL:AL:NI;0) 298.15 +6*GALALNI#; 6000 N REF4 ! PARAMETER G(AL3NI2,AL:NI:NI;0) 298.15 +6*GALNINI#; 6000 N REF4 ! PARAMETER G(AL3NI2,AL:AL:VA;0) 298.15 +6*GALALVA#; 6000 N REF4 ! PARAMETER G(AL3NI2,AL:NI:VA;0) 298.15 +6*GALNIVA#; 6000 N REF4 ! PARAMETER G(AL3NI2,AL:AL,NI:*;0) 298.15 +6*L32ALNI#; 6000 N REF4 ! PARAMETER G(AL3NI2,AL:*:NI,VA;0) 298.15 +6*L32NIVA#; 6000 N REF4 ! PHASE AL3NI5 % 2 .375 .625 ! CONSTITUENT AL3NI5 :AL : NI : ! PARAMETER G(AL3NI5,AL:NI;0) 298.15 -66520+18.9*T+.375*GHSERAL# +.625*GHSERNI#; 6000 N REF11 ! PHASE AL3TI % 2 3 1 ! CONSTITUENT AL3TI :AL : AL : ! PARAMETER G(AL3TI,AL:AL;0) 298.15 +4*GHSERAL#+400; 6000 N REF17 ! PHASE AL8FE5_CI52 % 2 8 5 ! CONSTITUENT AL8FE5_CI52 :AL : AL : ! PARAMETER G(AL8FE5_CI52,AL:AL;0) 298.15 +13*GBCCAL#; 6000 N REF14 ! $ THIS PHASE HAS A DISORDERED CONTRIBUTION FROM A2 TYPE_DEFINITION * GES A_P_D BCC4 MAGNETIC -1.0 4.00000E-01 ! PHASE BCC4:B %)* 4 .25 .25 .25 .25 ! CONSTITUENT BCC4:B :AL,NI,VA : AL,NI,VA : AL,NI,VA : AL,NI,VA : ! PARAMETER G(BCC4,AL:AL:AL:AL;0) 298.15 +0.0; 6000 N REF0 ! PARAMETER G(BCC4,AL:AL:AL:NI;0) 298.15 +BAL3NI#; 6000 N REF20 ! PARAMETER G(BCC4,AL:NI:AL:NI;0) 298.15 +BALNIB32#; 6000 N REF20 ! PARAMETER G(BCC4,AL:AL:NI:NI;0) 298.15 +BALNIB2#; 6000 N REF8 ! PARAMETER G(BCC4,AL:NI:NI:NI;0) 298.15 +BALNI3#; 6000 N REF20 ! PARAMETER G(BCC4,NI:NI:NI:NI;0) 298.15 +0.0; 6000 N REF0 ! PARAMETER G(BCC4,AL:VA:NI:NI;0) 298.15 +2*BUALNI#+2*BUNIVA#; 6000 N REF19 ! PARAMETER G(BCC4,AL:AL:AL:VA;0) 298.15 +2*BUALVA#; 6000 N REF20 ! PARAMETER G(BCC4,AL:NI:AL:VA;0) 298.15 +BUALNI#+BUALVA#+BUNIVA#; 6000 N REF0 ! PARAMETER G(BCC4,AL:VA:AL:VA;0) 298.15 +2*BUALVA#; 6000 N REF20 ! PARAMETER G(BCC4,AL:AL:NI:VA;0) 298.15 +2*BUALNI#+2*BUALVA#; 6000 N REF0 ! PARAMETER G(BCC4,AL:NI:NI:VA;0) 298.15 +BUALNI#+BUALVA#+BUNIVA#; 6000 N REF0 ! PARAMETER G(BCC4,NI:NI:NI:VA;0) 298.15 +2*BUNIVA#; 6000 N REF0 ! PARAMETER G(BCC4,AL:VA:NI:VA;0) 298.15 +BUALNI#+BUNIVA#+BUALVA#; 6000 N REF0 ! PARAMETER G(BCC4,NI:VA:NI:VA;0) 298.15 +2*BUNIVA#; 6000 N REF20 ! PARAMETER G(BCC4,AL:AL:VA:VA;0) 298.15 +BALVAB2#; 6000 N REF20 ! PARAMETER G(BCC4,AL:NI:VA:VA;0) 298.15 +2*BUNIVA#+2*BUALVA#; 6000 N REF19 ! PARAMETER G(BCC4,NI:NI:VA:VA;0) 298.15 +BNIVAB2#; 6000 N REF20 ! PARAMETER G(BCC4,AL:VA:VA:VA;0) 298.15 +2*BUALVA#; 6000 N REF20 ! PARAMETER G(BCC4,NI:VA:VA:VA;0) 298.15 +2*BUNIVA#; 6000 N REF20 ! PARAMETER G(BCC4,VA:VA:VA:VA;0) 298.15 +0.0; 6000 N REF0 ! PHASE C14 % 3 1 1.5 .5 ! CONSTITUENT C14 :AL,NI : AL,NI : AL,NI : ! PARAMETER G(C14,AL:AL:AL;0) 298.15 +3*C14AL#; 6000 N REF18 ! PARAMETER G(C14,NI:AL:AL;0) 298.15 +C14NI#+2*C14AL#; 6000 N REF20 ! PARAMETER G(C14,AL:NI:AL;0) 298.15 +1.5*C14AL#+1.5*C14NI#; 6000 N REF20 ! PARAMETER G(C14,NI:NI:AL;0) 298.15 +2.5*C14NI#+.5*C14AL#; 6000 N REF20 ! PARAMETER G(C14,AL:AL:NI;0) 298.15 +2.5*C14AL#+.5*C14NI#; 6000 N REF20 ! PARAMETER G(C14,NI:AL:NI;0) 298.15 +1.5*C14NI#+1.5*C14AL#; 6000 N REF20 ! PARAMETER G(C14,AL:NI:NI;0) 298.15 +C14AL#+2*C14NI#; 6000 N REF20 ! PARAMETER G(C14,NI:NI:NI;0) 298.15 +3*C14NI#; 6000 N REF18 ! $ THIS PHASE HAS A DISORDERED CONTRIBUTION FROM A1 TYPE_DEFINITION - GES A_P_D FCC4 MAGNETIC -3.0 2.80000E-01 ! PHASE FCC4:F %+- 4 .25 .25 .25 .25 ! CONSTITUENT FCC4:F :AL,NI : AL,NI : AL,NI : AL,NI : ! PARAMETER G(FCC4,AL:AL:AL:AL;0) 298.15 +0.0; 6000 N REF0 ! PARAMETER G(FCC4,AL:AL:AL:NI;0) 298.15 +FAL3NI#; 6000 N REF0 ! PARAMETER G(FCC4,AL:AL:NI:NI;0) 298.15 +FAL2NI2#; 6000 N REF0 ! PARAMETER G(FCC4,AL:NI:NI:NI;0) 298.15 +FALNI3#; 6000 N REF0 ! PARAMETER G(FCC4,NI:NI:NI:NI;0) 298.15 +0.0; 6000 N REF0 ! PARAMETER G(FCC4,AL,NI:*:*:*;0) 298.15 +F0ALNI#; 6000 N REF11 ! PARAMETER G(FCC4,AL,NI:AL,NI:*:*;0) 298.15 +FRALNI#; 6000 N REF0 ! $ THIS PHASE HAS A DISORDERED CONTRIBUTION FROM A3 TYPE_DEFINITION / GES A_P_D HCP4 MAGNETIC -3.0 2.80000E-01 ! PHASE HCP4:F %./ 4 .25 .25 .25 .25 ! CONSTITUENT HCP4:F :AL,NI : AL,NI : AL,NI : AL,NI : ! PARAMETER G(HCP4,AL:AL:AL:AL;0) 298.15 +0.0; 6000 N REF0 ! PARAMETER G(HCP4,AL:AL:AL:NI;0) 298.15 +HAL3NI#; 6000 N REF0 ! PARAMETER G(HCP4,AL:AL:NI:NI;0) 298.15 +HAL2NI2#; 6000 N REF0 ! PARAMETER G(HCP4,AL:NI:NI:NI;0) 298.15 +HALNI3#; 6000 N REF0 ! PARA G(HCP4,NI:NI:NI:NI;0) 298.15 +0; 6000 N! PARAMETER G(HCP4,AL,NI:*:*:*;0) 298.15 +H0ALNI#; 6000 N REF20 ! PARAMETER G(HCP4,AL,NI:AL,NI:*:*;0) 298.15 +FRALNI#; 6000 N REF0 ! PHASE NI3TI % 2 3 1 ! CONSTITUENT NI3TI :NI : NI : ! PARAMETER G(NI3TI,NI:NI;0) 298.15 +4*GDHCNI#; 6000 N REF13 ! LIST_OF_REFERENCES NUMBER SOURCE REF20 ' at work' REF2 'Alan Dinsdale, SGTE Data for Pure Elements, Calphad Vol 15(1991) p 317-425, also in NPL Report DMA(A)195 Rev. August 1990' REF18 'M.H.F. Sluiter Calphad 30 (2006) 357-366 and Acta Materialia 55 (207) 3707-3718' REF1 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 September 1989' REF8 'N. Dupin, Z. Metallkd. 90 (1999) 76-85' REF13 'J. De Keyzer, G. Cacciamani, N. Dupin, P. Wollants, CALPHAD 33 (2009) 109–123; Fe-Ni-Ti' REF14 'B. Sundman, I. Ohnuma, N. Dupin, U. Kattner, S.G. Fries, Acta Materialia, 57 (2009) 2896-2908; Al-Fe' REF4 'N. DThesis, INP Grenoble 1995' REF11 'N. Dupin, B. Sundman, XXVII Jeep, Journees d’Etude des Equilibre Entre Phases, 2003. Parameters listed in X.-G. Lu, B. Sundman and J. Agren, Calphad (2009) 450-456' REF19 'Linear combinations on bounds' REF17 'B. Sundman, private communication 15/06/2015; Al-Ti' ! ================================================ FILE: examples/macros/cost507R.TDB ================================================ $ From COST project 507 DATABASE_INFO about the COST 507 database This thermodynamic database is the result of the European COST 507 project. It contains about 70 assessed binary and a few ternary system for 20 elements, Many binaries and ternaries have no data and cannot be calculated. A simple test is to list the data for the liquid phase: "list ph liq data" If there are no EXCESS parameters for a system in the liquid the system has not been assessed. General reference: Luxembourg: Office for Official Publications of the European Communities, 1998 Volume 2: ISBN 92-828-3902-8 Volumes 1 to 3: ISBN 92-828-3900-1 For the each assessed model parameter a bibliographic reference is provided. ! $ ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT AL FCC_A1 2.6982E+01 4.5773E+03 2.8322E+01! ELEMENT B BETA_RHOMBO_B 1.0811E+01 1.2220E+03 5.9000E+00! ELEMENT C GRAPHITE 1.2011E+01 1.0540E+03 5.7400E+00! ELEMENT CE FCC_A1 1.4012E+02 7.2801E+03 6.9454E+00! ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01! ELEMENT CU FCC_A1 6.3546E+01 5.0041E+03 3.3150E+01! ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! ELEMENT LI BCC_A2 6.9410E+00 4.6233E+03 2.9095E+01! ELEMENT MG HCP_A3 2.4305E+01 4.9980E+03 3.2671E+01! ELEMENT MN CBCC_A12 5.4938E+01 4.9960E+03 3.2008E+01! ELEMENT N 1/2_MOLE_N2(G) 1.4007E+01 4.3350E+03 9.5751E+01! ELEMENT ND DHCP 1.4424E+01 7.1337E+03 7.1086E+01! ELEMENT NI FCC_A1 5.8690E+01 4.7870E+03 2.9797E+01! ELEMENT SI DIAMOND_A4 2.8085E+01 3.2175E+03 1.8820E+01! ELEMENT SN BCT_A5 1.1869E+02 6.3220E+03 5.1195E+01! ELEMENT TI HCP_A3 4.7880E+01 4.8240E+03 3.0720E+01! ELEMENT V BCC_A2 5.0942E+01 4.5070E+03 3.0890E+01! ELEMENT Y HCP_A3 8.8906E+01 5.9664E+03 4.4434E+01! ELEMENT ZN HCP_A3 6.5380E+01 5.6567E+03 4.1631E+01! ELEMENT ZR HCP_A3 9.1224E+01 5.5663E+03 3.9181E+01! SPECIES AL2 AL2! SPECIES B1N1 B1N1! SPECIES B2 B2! SPECIES B4 B4! SPECIES BC B1C1! SPECIES BN B1N1! SPECIES C+1 C1/+1! SPECIES C-1 C1/-1! SPECIES C2 C2! SPECIES C2-1 C2/-1! SPECIES C2B B1C2! SPECIES C2SI C2SI1! SPECIES C3 C3! SPECIES C4 C4! SPECIES C5 C5! SPECIES CSI C1SI1! SPECIES CSI2 C1SI2! SPECIES MG2SN MG2SN1! SPECIES N2 N2! SPECIES N3 N3! SPECIES SI+1 SI1/+1! SPECIES SI2 SI2! SPECIES SI3 SI3! FUNCTION GHSERAL 2.98150E+02 -7976.15+137.093038*T-24.3671976*T*LN(T) -.001884662*T**2-8.77664E-07*T**3+74092*T**(-1); 7.00000E+02 Y -11276.24+223.048446*T-38.5844296*T*LN(T)+.018531982*T**2 -5.764227E-06*T**3+74092*T**(-1); 9.33470E+02 Y -11278.378+188.684153*T-31.748192*T*LN(T)-1.230524E+28*T**(-9); 2.90000E+03 N ! FUNCT GLIQAL 298.15 +11005.029-11.841867*T+7.934E-20*T**7+GHSERAL; 933.47 Y +10482.382-11.253974*T+1.231E+28*T**(-9)+GHSERAL; 6000.00 N REF0! FUNCTION GHSERCC 2.98150E+02 -17368.441+170.73*T-24.3*T*LN(T) -4.723E-04*T**2+2562600*T**(-1)-2.643E+08*T**(-2)+1.2E+10*T**(-3); 6.00000E+03 N ! FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T) +.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2.18000E+03 Y -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6.00000E+03 N ! FUNCTION GHSERFE 2.98150E+02 +1225.7+124.134*T-23.5143*T*LN(T) -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6.00000E+03 N ! FUNCTION GHSERMG 2.98150E+02 -8367.34+143.675547*T-26.1849782*T*LN(T) +4.858E-04*T**2-1.393669E-06*T**3+78950*T**(-1); 9.23000E+02 Y -14130.185+204.716215*T-34.3088*T*LN(T)+1.038192E+28*T**(-9); 3.00000E+03 N ! FUNCTION GHSERMN 2.98150E+02 -8115.28+130.059*T-23.4582*T*LN(T) -.00734768*T**2+69827*T**(-1); 1.51900E+03 Y -28733.41+312.2648*T-48*T*LN(T)+1.656847E+30*T**(-9); 6.00000E+03 N ! FUNCTION GHSERNN 2.98150E+02 -3750.675-9.45425*T-12.7819*T*LN(T) -.00176686*T**2+2.681E-09*T**3-32374*T**(-1); 9.50000E+02 Y -7358.85+17.2003*T-16.3699*T*LN(T)-6.5107E-04*T**2+3.0097E-08*T**3 +563070*T**(-1); 3.35000E+03 Y -16392.8+50.26*T-20.4695*T*LN(T)+2.39754E-04*T**2-8.333E-09*T**3 +4596375*T**(-1); 6.00000E+03 N ! FUNCTION GHSERNI 2.98150E+02 -5179.159+117.854*T-22.096*T*LN(T) -.0048407*T**2; 1.72800E+03 N ! FUNCTION GHSERSI 2.98150E+02 -8162.609+137.236859*T-22.8317533*T*LN(T) -.001912904*T**2-3.552E-09*T**3+176667*T**(-1); 1.68700E+03 Y -9457.642+167.281367*T-27.196*T*LN(T)-4.20369E+30*T**(-9); 3.60000E+03 N ! FUNCTION GLIQSN 1.00000E+02 -855.425+108.677684*T-25.858*T*LN(T) +5.1185E-04*T**2-3.192767E-06*T**3+18440*T**(-1)+1.47031E-18*T**7; 2.50000E+02 Y +1247.957+51.355548*T-15.961*T*LN(T)-.0188702*T**2+3.121167E-06*T**3 -61960*T**(-1)+1.47031E-18*T**7; 5.05080E+02 Y +9496.31-9.809114*T-8.2590486*T*LN(T)-.016814429*T**2 +2.623131E-06*T**3-1081244*T**(-1); 8.00000E+02 Y -1285.372+125.182498*T-28.4512*T*LN(T); 3.00000E+03 N ! FUNCTION GLIQTI 2.98150E+02 +12194.415-6.980938*T+GHSERTI#; 1.30000E+03 Y +368610.36-2620.99904*T+357.005867*T*LN(T)-.155262855*T**2 +1.2254402E-05*T**3-65556856*T**(-1)+GHSERTI#; 1.94100E+03 Y +104639.72-340.070171*T+40.9282461*T*LN(T)-.008204849*T**2 +3.04747E-07*T**3-36699805*T**(-1)+GHSERTI#; 6.00000E+03 N ! FUNCTION GHSERV 2.98150E+02 -7930.43+133.346053*T-24.134*T*LN(T) -.003098*T**2+1.2175E-07*T**3+69460*T**(-1); 7.90000E+02 Y -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; 2.18300E+03 Y -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); 6.00000E+03 N ! FUNCTION GHSERZR 1.30000E+02 -7827.595+125.64905*T-24.1618*T*LN(T) -.00437791*T**2+34971*T**(-1); 2.12800E+03 Y -26085.921+262.724183*T-42.144*T*LN(T)-1.342895E+31*T**(-9); 6.00000E+03 N ! FUNCTION GHSERTI 2.98150E+02 -8059.921+133.615208*T-23.9933*T*LN(T) -.004777975*T**2+1.06716E-07*T**3+72636*T**(-1); 9.00000E+02 Y -7811.815+132.988068*T-23.9887*T*LN(T)-.0042033*T**2-9.0876E-08*T**3 +42680*T**(-1); 1.15500E+03 Y +908.837+66.976538*T-14.9466*T*LN(T)-.0081465*T**2+2.02715E-07*T**3 -1477660*T**(-1); 1.94100E+03 Y -124526.786+638.806871*T-87.2182461*T*LN(T)+.008204849*T**2 -3.04747E-07*T**3+36699805*T**(-1); 4.00000E+03 N ! FUNCTION GHSERCE 2.98150E+02 -7160.519+84.23022*T-22.3664*T*LN(T) -.0067103*T**2-3.20773E-07*T**3-18117*T**(-1); 1.00000E+03 Y -79678.506+659.4604*T-101.32248*T*LN(T)+.026046487*T**2 -1.9302976E-06*T**3+11531707*T**(-1); 2.00000E+03 Y -14198.639+190.370192*T-37.6978*T*LN(T); 4.00000E+03 N ! FUNCTION GHSERND 2.98150E+02 -8402.93+111.10239*T-27.0858*T*LN(T) +5.56125E-04*T**2-2.6923E-06*T**3+34887*T**(-1); 9.00000E+02 Y -6984.083+83.662617*T-22.7536*T*LN(T)-.00420402*T**2-1.802E-06*T**3; 1.12800E+03 Y -225610.846+1673.04075*T-238.182873*T*LN(T)+.078615997*T**2 -6.048207E-06*T**3+38810350*T**(-1); 1.80000E+03 N ! FUNCTION GHSERLI 2.00000E+02 -10583.817+217.637482*T-38.940488*T*LN(T) +.035466931*T**2-1.9869816E-05*T**3+159994*T**(-1); 4.53600E+02 Y -559579.123+10547.8799*T-1702.88865*T*LN(T)+2.25832944*T**2 -5.71066077E-04*T**3+33885874*T**(-1); 5.00000E+02 Y -9062.994+179.278285*T-31.2283718*T*LN(T)+.002633221*T**2 -4.38058E-07*T**3-102387*T**(-1); 3.00000E+03 N ! FUNCTION GHSERY 2.98150E+02 -7347.055+117.532124*T-23.8685*T*LN(T) -.003845475*T**2+1.1125E-08*T**3-16486*T**(-1); 1.50000E+03 Y -15802.62+229.831717*T-40.2851*T*LN(T)+.0068095*T**2-1.14182E-06*T**3; 1.79900E+03 Y -72946.216+393.885821*T-58.2078433*T*LN(T)+.002436461*T**2 -7.2627E-08*T**3+20866567*T**(-1); 3.70000E+03 N ! FUNCTION GHSERBB 2.98150E+02 -7735.284+107.111864*T-15.6641*T*LN(T) -.006864515*T**2+6.18878E-07*T**3+370843*T**(-1); 1.10000E+03 Y -16649.474+184.801744*T-26.6047*T*LN(T)-7.9809E-04*T**2-2.556E-08*T**3 +1748270*T**(-1); 2.34800E+03 Y -36667.582+231.336244*T-31.5957527*T*LN(T)-.00159488*T**2 +1.34719E-07*T**3+11205883*T**(-1); 3.00000E+03 Y -21530.653+222.396264*T-31.4*T*LN(T); 6.00000E+03 N ! FUNCTION GHSERCU 2.98150E+02 -7770.458+130.485235*T-24.112392*T*LN(T) -.00265684*T**2+1.29223E-07*T**3+52478*T**(-1); 1.35777E+03 Y -13542.026+183.803828*T-31.38*T*LN(T)+3.64167E+29*T**(-9); 3.20000E+03 N ! FUNCTION GBCCCU 2.98150E+02 +4017-1.255*T+GHSERCU#; 6.00000E+03 N ! FUNCTION GBCCAL 2.98150E+02 +10083-4.813*T+GHSERAL#; 6.00000E+03 N ! FUNCTION GBCCMG 2.98150E+02 +3100-2.1*T+GHSERMG#; 6.00000E+03 N ! FUNCTION GFCCV 2.98150E+02 +7500+1.7*T+GHSERV#; 6.00000E+03 N ! FUNCTION GFCCTI 2.98150E+02 +6000-.1*T+GHSERTI#; 6.00000E+03 N ! FUNCTION GHCPAL 2.98150E+02 +5481-1.8*T+GHSERAL#; 6.00000E+03 N ! FUNCTION GHCPV 2.98150E+02 +4000+2.4*T+GHSERV#; 6.00000E+03 N ! FUNCTION GHSERTIC 2.98150E+02 -207709+307.438*T-48.0195*T*LN(T) -.00272*T**2+819000*T**(-1)-2.03E+09*T**(-3); 6.00000E+03 N ! FUNCTION GHSERTIN 2.98150E+02 -357905+330.498*T-52.4587*T*LN(T) -9.28E-04*T**2+871000*T**(-1)-2.41E+09*T**(-3); 6.00000E+03 N ! FUNCTION GHSERSN 1.00000E+02 -7958.517+122.765451*T-25.858*T*LN(T) +5.1185E-04*T**2-3.192767E-06*T**3+18440*T**(-1); 2.50000E+02 Y -5855.135+65.443315*T-15.961*T*LN(T)-.0188702*T**2+3.121167E-06*T**3 -61960*T**(-1); 5.05080E+02 Y +2524.724+4.005269*T-8.2590486*T*LN(T)-.016814429*T**2 +2.623131E-06*T**3-1081244*T**(-1)-1.2307E+25*T**(-9); 8.00000E+02 Y -8256.959+138.99688*T-28.4512*T*LN(T)-1.2307E+25*T**(-9); 3.00000E+03 N ! FUNCTION GHSERZN 2.98150E+02 -7285.787+118.470069*T-23.701314*T*LN(T) -.001712034*T**2-1.264963E-06*T**3; 6.92680E+02 Y -11070.559+172.34566*T-31.38*T*LN(T)+4.70514E+26*T**(-9); 1.70000E+03 N ! FUNCTION ALFEW1 2.98150E+02 +860*R#; 6.00000E+03 N ! FUNCTION LALFEB0 2.98150E+02 -30740+7.9972*T+ALFEW1#; 6.00000E+03 N ! FUNCTION CUZNL0 2.98150E+02 -51595.87+13.06392*T; 6.00000E+03 N ! FUNCTION CUZNP1 2.98150E+02 -3085; 6.00000E+03 N ! FUNCTION GBCCZN 2.98150E+02 +2886.96-2.5104*T+GHSERZN#; 6.00000E+03 N ! FUNCTION FESIW1 2.98150E+02 +1260*R#; 6.00000E+03 N ! FUNCTION GBCCSI 2.98150E+02 +47000-22.5*T+GHSERSI#; 6.00000E+03 N ! FUNCTION FESIL0 2.98150E+02 -27809+11.62*T; 6.00000E+03 N ! FUNCTION GFCCZN 2.98150E+02 +2969.82-1.56968*T+GHSERZN#; 6.00000E+03 N ! FUNCTION CUZNK4 2.98150E+02 -11552.71-1.67824*T; 6.00000E+03 N ! FUNCTION CUZNK5 2.98150E+02 +15732.3-10.26575*T; 6.00000E+03 N ! FUNCTION CUZNK6 2.98150E+02 +37289.2-13.05259*T; 6.00000E+03 N ! FUNCTION GFCCMN 2.98150E+02 -3439.3+131.884*T-24.5177*T*LN(T) -.006*T**2+69600*T**(-1); 1.51900E+03 Y -26070.1+309.6664*T-48*T*LN(T)+3.86196E+30*T**(-9); 6.00000E+03 N ! FUNCTION GBCCMN 2.98150E+02 -3235.3+127.85*T-23.7*T*LN(T) -.00744271*T**2+60000*T**(-1); 1.51900E+03 Y -23188.83+307.7043*T-48*T*LN(T)+1.265152E+30*T**(-9); 6.00000E+03 N ! FUNCTION GLAVTI 2.98150E+02 +5000+GHSERTI#; 6.00000E+03 N ! FUNCTION GLAVCR 2.98150E+02 +5000+GHSERCR#; 6.00000E+03 N ! FUNCTION LALFEB1 2.98150E+02 368.15; 6.00000E+03 N ! FUNCTION CUZNL1 2.98150E+02 +7562.13-6.45432*T; 6.00000E+03 N ! FUNCTION CUZNL2 2.98150E+02 +30743.74-29.91503*T; 6.00000E+03 N ! FUNCTION CUZNP2 2.98150E+02 -CUZNP1#; 6.00000E+03 N ! FUNCTION FESIL1 2.98150E+02 -11544; 6.00000E+03 N ! FUNCTION FESIL2 2.98150E+02 3890; 6.00000E+03 N ! FUNCTION ETCFESI 2.98150E+02 63; 6.00000E+03 N ! FUNCTION UN_ASS 298.15 0; 300 N ! TYPE_DEFINITION % SEQ *! DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! PHASE LIQUID:L % 1 1.0 ! CONSTITUENT LIQUID:L :AL,B,C,CE,CR,CU,FE,LI,MG,MN,N,ND,NI,SI,SN,TI,V,Y, ZN,ZR : ! $ changed to the expression in COST2 180826 /BoS PARAMETER G(LIQUID,AL;0) 2.98150E+02 GLIQAL; 6000 N REF1 ! $ PARAMETER G(LIQUID,AL;0) 2.98150E+02 +11005.029-11.841867*T $ +7.934E-20*T**7+GHSERAL#; 9.33600E+02 Y $ +10482.382-11.253974*T+1.231E+28*T**(-9)+GHSERAL#; 6.00000E+03 N REF1 ! PARAMETER G(LIQUID,B;0) 2.98150E+02 +40723.275+86.843839*T -15.6641*T*LN(T)-.006864515*T**2+6.18878E-07*T**3+370843*T**(-1); 5.00000E+02 Y +41119.703+82.101722*T-14.9827763*T*LN(T)-.007095669*T**2 +5.07347E-07*T**3+335484*T**(-1); 2.34800E+03 Y +28842.012+200.94731*T-31.4*T*LN(T); 6.00000E+03 N REF1 ! PARAMETER G(LIQUID,C;0) 2.98150E+02 +117369-24.63*T+GHSERCC#; 6.00000E+03 N REF1 ! PARAMETER G(LIQUID,CE;0) 2.98150E+02 +4117.865-11.423898*T -7.5383948*T*LN(T)-.02936407*T**2+4.827734E-06*T**3-198834*T**(-1); 1.00000E+03 Y -6730.605+183.023193*T-37.6978*T*LN(T); 4.00000E+03 N REF1 ! PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T +2.37615E-21*T**7+GHSERCR#; 2.18000E+03 Y +18409.36-8.563683*T+2.88526E+32*T**(-9)+GHSERCR#; 6.00000E+03 N REF1 ! PARAMETER G(LIQUID,CU;0) 2.98150E+02 +5194.277+120.973331*T -24.112392*T*LN(T)-.00265684*T**2+1.29223E-07*T**3+52478*T**(-1) -5.8489E-21*T**7; 1.35777E+03 Y -46.545+173.881484*T-31.38*T*LN(T); 3.20000E+03 N REF1 ! PARAMETER G(LIQUID,FE;0) 2.98150E+02 +12040.17-6.55843*T -3.67516E-21*T**7+GHSERFE#; 1.81100E+03 Y +14544.751-8.01055*T+GHSERFE#-2.29603E+31*T**(-9); 6.00000E+03 N REF1 ! PARAMETER G(LIQUID,LI;0) 2.00000E+02 -7883.612+211.841861*T -38.940488*T*LN(T)+.035466931*T**2-1.9869816E-05*T**3+159994*T**(-1); 2.50000E+02 Y +12015.027-362.187078*T+61.6104424*T*LN(T)-.182426463*T**2 +6.3955671E-05*T**3-559968*T**(-1); 4.53600E+02 Y -6057.31+172.652183*T-31.2283718*T*LN(T)+.002633221*T**2-4.38058E-07*T**3 -102387*T**(-1); 3.00000E+03 N REF1 ! PARAMETER G(LIQUID,MG;0) 2.98150E+02 +8202.243-8.83693*T+GHSERMG# -8.0176E-20*T**7; 9.23000E+02 Y +8690.316-9.392158*T+GHSERMG#-1.038192E+28*T**(-9); 6.00000E+03 N REF1 ! PARAMETER G(LIQUID,MN;0) 2.98150E+02 +17859.91-12.6208*T -4.41929E-21*T**7+GHSERMN#; 1.51900E+03 Y +18739.51-13.2288*T-1.656847E+30*T**(-9)+GHSERMN#; 6.00000E+03 N REF1 ! PARAMETER G(LIQUID,N;0) 2.98150E+02 +29950+59.02*T+GHSERNN#; 6.00000E+03 N REF1 ! PARAMETER G(LIQUID,ND;0) 2.98150E+02 +5350.01-86.593963*T +5.357301*T*LN(T)-.046955463*T**2+6.860782E-06*T**3-374380*T**(-1); 1.12800E+03 Y -16335.232+268.625903*T-48.7854*T*LN(T); 1.80000E+03 N REF1 ! PARAMETER G(LIQUID,NI;0) 2.98150E+02 +16414.686-9.397*T -3.82318E-21*T**7+GHSERNI#; 1.72800E+03 Y +18290.88-10.537*T-1.12754E+31*T**(-9)+GHSERNI#; 6.00000E+03 N REF1 ! PARAMETER G(LIQUID,SI;0) 2.98150E+02 +50696.4-30.0994*T +2.09307E-21*T**7+GHSERSI#; 1.68700E+03 Y +49828.2-29.5591*T+4.20369E+30*T**(-9)+GHSERSI#; 6.00000E+03 N REF1 ! PARAMETER G(LIQUID,SN;0) 2.98150E+02 +GLIQSN#; 6.00000E+03 N REF1 ! PARAMETER G(LIQUID,TI;0) 2.98150E+02 +GLIQTI#; 6.00000E+03 N REF1 ! PARAMETER G(LIQUID,V;0) 2.98150E+02 +20764.117-9.455552*T -5.19136E-22*T**7+GHSERV#; 7.90000E+02 Y +20764.117-9.455552*T-5.19136E-22*T**7+GHSERV#; 2.18300E+03 Y +22072.354-10.0848*T-6.44389E+31*T**(-9)+GHSERV#; 6.00000E+03 N REF1 ! PARAMETER G(LIQUID,Y;0) 2.98150E+02 +3934.121+59.921688*T -14.8146562*T*LN(T)-.015623487*T**2+1.442946E-06*T**3-140695*T**(-1); 1.79900E+03 Y -13337.609+258.004539*T-43.0952*T*LN(T); 3.70000E+03 N REF1 ! PARAMETER G(LIQUID,ZN;0) 2.98150E+02 -128.574+108.177079*T -23.701314*T*LN(T)-.001712034*T**2-1.264963E-06*T**3-3.58958E-19*T**7; 6.92680E+02 Y -3620.391+161.608594*T-31.38*T*LN(T); 1.70000E+03 N REF1 ! PARAMETER G(LIQUID,ZR;0) 1.30000E+02 +18147.703-9.080762*T +1.6275E-22*T**7+GHSERZR#; 2.12800E+03 Y +17804.649-8.91153*T+1.343E+31*T**(-9)+GHSERZR#; 6.00000E+03 N REF1 ! PARAMETER G(LIQUID,AL,B;0) 2.98150E+02 -12671.16+1.81016*T; 6.00000E+03 N REF44 ! PARAMETER G(LIQUID,AL,B;1) 2.98150E+02 31988.28; 6.00000E+03 N REF44 ! PARAMETER G(LIQUID,AL,B;2) 2.98150E+02 -15873.74; 6.00000E+03 N REF44 ! PARAMETER G(LIQUID,AL,C;0) 2.98150E+02 +13872.76-21.59067*T; 6.00000E+03 N REF46 ! PARAMETER G(LIQUID,AL,CE;0) 2.98150E+02 -167593.1+84.87628*T; 6.00000E+03 N REF103 ! PARAMETER G(LIQUID,AL,CE;1) 2.98150E+02 -36060+5.89346*T; 6.00000E+03 N REF103 ! PARAMETER G(LIQUID,AL,CR;0) 2.98150E+02 -29000; 6.00000E+03 N REF8 ! PARAMETER G(LIQUID,AL,CR;1) 2.98150E+02 -11000; 6.00000E+03 N REF8 ! PARAMETER G(LIQUID,AL,CU;0) 2.98150E+02 -66622+8.1*T; 6.00000E+03 N REF72 ! PARAMETER G(LIQUID,AL,CU;1) 2.98150E+02 +46800-90.8*T+10*T*LN(T); 6.00000E+03 N REF72 ! PARAMETER G(LIQUID,AL,CU;2) 2.98150E+02 -2812; 6.00000E+03 N REF72 ! PARAMETER G(LIQUID,AL,CU,LI;0) 2.98150E+02 -100000; 6.00000E+03 N REF119 ! PARAMETER G(LIQUID,AL,FE;0) 2.98150E+02 -91976.5+22.1314*T; 6.00000E+03 N REF76 ! PARAMETER G(LIQUID,AL,FE;1) 2.98150E+02 -5672.58+4.8728*T; 6.00000E+03 N REF76 ! PARAMETER G(LIQUID,AL,FE;2) 2.98150E+02 121.9; 6.00000E+03 N REF76 ! PARAMETER G(LIQUID,AL,FE,MN;0) 2.98150E+02 100414; 6.00000E+03 N REF109 ! PARAMETER G(LIQUID,AL,LI;0) 2.98150E+02 -41500+20.96*T; 6.00000E+03 N REF105 ! PARAMETER G(LIQUID,AL,LI;1) 2.98150E+02 +10000-5.8*T; 6.00000E+03 N REF105 ! PARAMETER G(LIQUID,AL,LI;2) 2.98150E+02 +15902-9.368*T; 6.00000E+03 N REF105 ! PARAMETER G(LIQUID,AL,LI;3) 2.98150E+02 -250; 6.00000E+03 N REF105 ! PARAMETER G(LIQUID,AL,LI,MG;0) 2.98150E+02 -20000; 6.00000E+03 N REF105 ! PARAMETER G(LIQUID,AL,LI,MG;1) 2.98150E+02 -15000; 6.00000E+03 N REF105 ! PARAMETER G(LIQUID,AL,LI,MG;2) 2.98150E+02 -20000; 6.00000E+03 N REF105 ! PARAMETER G(LIQUID,AL,MG;0) 2.98150E+02 -12000+8.566*T; 6.00000E+03 N REF11 ! PARAMETER G(LIQUID,AL,MG;1) 2.98150E+02 +1894-3*T; 6.00000E+03 N REF11 ! PARAMETER G(LIQUID,AL,MG;2) 2.98150E+02 2000; 6.00000E+03 N REF11 ! PARAMETER G(LIQUID,AL,MG,SI;0) 2.98150E+02 +26860.37-3.35754*T; 6.00000E+03 N REF113 ! PARAMETER G(LIQUID,AL,MG,SI;1) 2.98150E+02 -21007.19+2.6259*T; 6.00000E+03 N REF113 ! PARAMETER G(LIQUID,AL,MG,SI;2) 2.98150E+02 -56273.39+7.03418*T; 6.00000E+03 N REF113 ! PARAMETER G(LIQUID,AL,MN;0) 2.98150E+02 -66174+27.0988*T; 6.00000E+03 N REF23 ! PARAMETER G(LIQUID,AL,MN;1) 2.98150E+02 -7509+5.4836*T; 6.00000E+03 N REF23 ! PARAMETER G(LIQUID,AL,MN;2) 2.98150E+02 -2639; 6.00000E+03 N REF23 ! PARAMETER G(LIQUID,AL,MN,SI;0) 2.98150E+02 -47000; 6.00000E+03 N REF115 ! PARAMETER G(LIQUID,AL,N;0) 2.98150E+02 -336826.61+103.22478*T; 6.00000E+03 N REF48 ! PARAMETER G(LIQUID,AL,ND;0) 2.98150E+02 -152967.6+34.13746*T; 6.00000E+03 N REF80 ! PARAMETER G(LIQUID,AL,ND;1) 2.98150E+02 -29325-3.34477*T; 6.00000E+03 N REF80 ! PARAMETER G(LIQUID,AL,SI;0) 2.98150E+02 -11655.93-.92934*T; 6.00000E+03 N REF50 ! PARAMETER G(LIQUID,AL,SI;1) 2.98150E+02 -2873.45+.2945*T; 6.00000E+03 N REF50 ! PARAMETER G(LIQUID,AL,SI;2) 2.98150E+02 2520; 6.00000E+03 N REF50 ! PARAMETER G(LIQUID,AL,SN;0) 2.98150E+02 +16329.85-4.98306*T; 6.00000E+03 N REF15 ! PARAMETER G(LIQUID,AL,SN;1) 2.98150E+02 +4111.97-1.15145*T; 6.00000E+03 N REF15 ! PARAMETER G(LIQUID,AL,SN;2) 2.98150E+02 +1765.43-.5739*T; 6.00000E+03 N REF15 ! PARAMETER G(LIQUID,AL,SN,ZN;0) 2.98150E+02 -2777.03+.59427*T; 6.00000E+03 N REF107 ! PARAMETER G(LIQUID,AL,SN,ZN;1) 2.98150E+02 +15225.63-3.25821*T; 6.00000E+03 N REF107 ! PARAMETER G(LIQUID,AL,SN,ZN;2) 2.98150E+02 -16198.13+3.46632*T; 6.00000E+03 N REF107 ! PARAMETER G(LIQUID,AL,TI;0) 2.98150E+02 -108250+38*T; 6.00000E+03 N REF13 ! PARAMETER G(LIQUID,AL,TI;1) 2.98150E+02 -6000+5*T; 6.00000E+03 N REF13 ! PARAMETER G(LIQUID,AL,TI;2) 2.98150E+02 15000; 6.00000E+03 N REF13 ! PARAMETER G(LIQUID,AL,TI,V;0) 2.98150E+02 1E-05; 6.00000E+03 N REF127 ! PARAMETER G(LIQUID,AL,V;0) 2.98150E+02 -50725+9*T; 6.00000E+03 N REF13 ! PARAMETER G(LIQUID,AL,V;1) 2.98150E+02 -15000+8*T; 6.00000E+03 N REF13 ! PARAMETER G(LIQUID,AL,Y;0) 2.98150E+02 -202611.28+4.63942*T; 2.90000E+03 N REF52 ! PARAMETER G(LIQUID,AL,Y;1) 2.98150E+02 -54350.11+.28402*T; 2.90000E+03 N REF52 ! PARAMETER G(LIQUID,AL,Y;2) 2.98150E+02 +83347.01-34.76401*T; 2.90000E+03 N REF52 ! PARAMETER G(LIQUID,AL,Y;3) 2.98150E+02 +15488.69-.7988*T; 2.90000E+03 N REF52 ! PARAMETER G(LIQUID,AL,Y;4) 2.98150E+02 -51205.9+30.2161*T; 2.90000E+03 N REF52 ! PARAMETER G(LIQUID,AL,ZN;0) 2.98150E+02 +10465.55-3.39259*T; 6.00000E+03 N REF78 ! PARAMETER G(LIQUID,AL,ZR;0) 2.98150E+02 -125000+35*T; 6.00000E+03 N REF74 ! PARAMETER G(LIQUID,AL,ZR;1) 2.98150E+02 -10000+5.57*T; 6.00000E+03 N REF74 ! PARAMETER G(LIQUID,AL,ZR;2) 2.98150E+02 15750; 6.00000E+03 N REF74 ! PARAMETER G(LIQUID,B,C;0) 2.98150E+02 -67045.16+4.46969*T; 6.00000E+03 N REF54 ! PARAMETER G(LIQUID,B,C;1) 2.98150E+02 -36682.57+2.44551*T; 6.00000E+03 N REF54 ! PARAMETER G(LIQUID,B,N;0) 2.98150E+02 +30000-4*T; 6.00000E+03 N REF56 ! PARAMETER G(LIQUID,B,SI;0) 2.98150E+02 +17631.92-1.76321*T; 6.00000E+03 N REF58 ! PARAMETER G(LIQUID,B,SI;1) 2.98150E+02 -3526.99+.3527*T; 6.00000E+03 N REF58 ! PARAMETER G(LIQUID,B,TI;0) 2.98150E+02 -265414.4+15.543418*T; 6.00000E+03 N REF89 ! PARAMETER G(LIQUID,B,TI;1) 2.98150E+02 -134303.03+17.709482*T; 6.00000E+03 N REF89 ! PARAMETER G(LIQUID,B,TI;2) 2.98150E+02 61691.479; 6.00000E+03 N REF89 ! PARAMETER G(LIQUID,B,TI;3) 2.98150E+02 52656.13; 6.00000E+03 N REF89 ! PARAMETER G(LIQUID,C,SI;0) 2.98150E+02 +25644.97-6.39115*T; 6.00000E+03 N REF60 ! PARAMETER G(LIQUID,C,TI;0) 2.98150E+02 -214678-14.314*T; 6.00000E+03 N REF111 ! PARAMETER G(LIQUID,CE,MG;0) 2.98150E+02 -39381.19+16.34052*T; 6.00000E+03 N REF103 ! PARAMETER G(LIQUID,CE,MG;1) 2.98150E+02 +25338.56-11.86885*T; 6.00000E+03 N REF103 ! PARAMETER G(LIQUID,CE,MG;2) 2.98150E+02 -15106.9; 6.00000E+03 N REF103 ! PARAMETER G(LIQUID,CR,CU;0) 2.98150E+02 +62797.75-18.95186*T; 6.00000E+03 N REF96 ! PARAMETER G(LIQUID,CR,CU;1) 2.98150E+02 1183.91; 6.00000E+03 N REF96 ! PARAMETER G(LIQUID,CR,MG;0) 2.98150E+02 94500; 6.00000E+03 N REF83 ! PARAMETER G(LIQUID,CR,MG;1) 2.98150E+02 12500; 6.00000E+03 N REF83 ! PARAMETER G(LIQUID,CR,MN;0) 2.98150E+02 -15009+13.6587*T; 6.00000E+03 N REF2 ! PARAMETER G(LIQUID,CR,MN;1) 2.98150E+02 +504+.9479*T; 6.00000E+03 N REF2 ! PARAMETER G(LIQUID,CR,SI;0) 2.98150E+02 -119216.9+16.11445*T; 6.00000E+03 N REF91 ! PARAMETER G(LIQUID,CR,SI;1) 2.98150E+02 -47614.7+12.17363*T; 6.00000E+03 N REF91 ! PARAMETER G(LIQUID,CR,TI;0) 2.98150E+02 5250; 6.00000E+03 N REF72 ! PARAMETER G(LIQUID,CR,TI;1) 2.98150E+02 1500; 6.00000E+03 N REF72 ! PARAMETER G(LIQUID,CR,ZN;0) 2.98150E+02 19000; 6.00000E+03 N REF83 ! PARAMETER G(LIQUID,CR,ZN;1) 2.98150E+02 -1000; 6.00000E+03 N REF83 ! PARAMETER G(LIQUID,CR,ZR;0) 2.98150E+02 -12971.34+1.20015*T; 6.00000E+03 N REF98 ! PARAMETER G(LIQUID,CR,ZR;1) 2.98150E+02 +8025.96-.74259*T; 6.00000E+03 N REF98 ! PARAMETER G(LIQUID,CR,ZR;2) 2.98150E+02 -9984.87+.92383*T; 6.00000E+03 N REF98 ! PARAMETER G(LIQUID,CU,FE;0) 2.98150E+02 +36087.987-2.3296885*T; 6.00000E+03 N REF85 ! PARAMETER G(LIQUID,CU,FE;1) 2.98150E+02 +324.52964-.032700618*T; 6.00000E+03 N REF85 ! PARAMETER G(LIQUID,CU,FE;2) 2.98150E+02 +10355.386-3.6029763*T; 6.00000E+03 N REF85 ! PARAMETER G(LIQUID,CU,LI;0) 2.98150E+02 +66000-44.723*T; 6.00000E+03 N REF74 ! PARAMETER G(LIQUID,CU,MG;0) 2.98150E+02 -36984+4.75612*T; 6.00000E+03 N REF20 ! PARAMETER G(LIQUID,CU,MG;1) 2.98150E+02 -8191.29; 6.00000E+03 N REF20 ! PARAMETER G(LIQUID,CU,MG,NI;0) 2.98150E+02 +163785-122.28*T; 6.00000E+03 N REF94 ! PARAMETER G(LIQUID,CU,NI;0) 2.98150E+02 +12048.61+1.29893*T; 6.00000E+03 N REF31 ! PARAMETER G(LIQUID,CU,NI;1) 2.98150E+02 -1861.61+.94201*T; 6.00000E+03 N REF31 ! PARAMETER G(LIQUID,CU,SI;0) 2.98150E+02 -39688.86+14.27467*T; 6.00000E+03 N REF94 ! PARAMETER G(LIQUID,CU,SI;1) 2.98150E+02 -49937.13+29.7896*T; 6.00000E+03 N REF94 ! PARAMETER G(LIQUID,CU,SI;2) 2.98150E+02 -31810.16+18.00804*T; 6.00000E+03 N REF94 ! PARAMETER G(LIQUID,CU,ZN;0) 2.98150E+02 -40695.54+12.65269*T; 6.00000E+03 N REF70 ! PARAMETER G(LIQUID,CU,ZN;1) 2.98150E+02 +4402.72-6.55425*T; 6.00000E+03 N REF70 ! PARAMETER G(LIQUID,CU,ZN;2) 2.98150E+02 +7818.1-3.25416*T; 6.00000E+03 N REF70 ! PARAMETER G(LIQUID,CU,ZR;0) 2.98150E+02 -61685.53+11.29235*T; 6.00000E+03 N REF125 ! PARAMETER G(LIQUID,CU,ZR;1) 2.98150E+02 -8830.66+5.04565*T; 6.00000E+03 N REF125 ! PARAMETER G(LIQUID,FE,MG;0) 2.98150E+02 +61343+1.5*T; 6.00000E+03 N REF29 ! PARAMETER G(LIQUID,FE,MG;1) 2.98150E+02 -2700; 6.00000E+03 N REF29 ! PARAMETER G(LIQUID,FE,MN;0) 2.98150E+02 -3950+.489*T; 6.00000E+03 N REF6 ! PARAMETER G(LIQUID,FE,MN;1) 2.98150E+02 1145; 6.00000E+03 N REF6 ! PARAMETER G(LIQUID,FE,SI;0) 2.98150E+02 -164434.6+41.9773*T; 6.00000E+03 N REF26 ! PARAMETER G(LIQUID,FE,SI;1) 2.98150E+02 -21.523*T; 6.00000E+03 N REF26 ! PARAMETER G(LIQUID,FE,SI;2) 2.98150E+02 -18821.542+22.07*T; 6.00000E+03 N REF26 ! PARAMETER G(LIQUID,FE,SI;3) 2.98150E+02 9695.8; 6.00000E+03 N REF26 ! PARAMETER G(LIQUID,LI,MG;0) 2.98150E+02 -14935+10.371*T; 6.00000E+03 N REF105 ! PARAMETER G(LIQUID,LI,MG;1) 2.98150E+02 -1789+1.143*T; 6.00000E+03 N REF105 ! PARAMETER G(LIQUID,LI,MG;2) 2.98150E+02 +6533-6.6915*T; 6.00000E+03 N REF105 ! PARAMETER G(LIQUID,LI,ZR;0) 2.98150E+02 100000; 6.00000E+03 N REF74 ! PARAMETER G(LIQUID,MG,MN;0) 2.98150E+02 +19125+12.5*T; 6.00000E+03 N REF29 ! PARAMETER G(LIQUID,MG,NI;0) 2.98150E+02 -42304.49+7.45704*T; 6.00000E+03 N REF94 ! PARAMETER G(LIQUID,MG,NI;1) 2.98150E+02 -15611.66+9.11885*T; 6.00000E+03 N REF94 ! PARAMETER G(LIQUID,MG,SI;0) 2.98150E+02 -82462.11+32.43049*T; 6.00000E+03 N REF62 ! PARAMETER G(LIQUID,MG,SI;1) 2.98150E+02 +16617.63-17.7922*T; 6.00000E+03 N REF62 ! PARAMETER G(LIQUID,MG,SI;2) 2.98150E+02 +2331.67-.29146*T; 6.00000E+03 N REF62 ! PARAMETER G(LIQUID,MG,SI;3) 2.98150E+02 +17833.02-2.22914*T; 6.00000E+03 N REF62 ! PARAMETER G(LIQUID,MG,SI;4) 2.98150E+02 -11203.22+1.40041*T; 6.00000E+03 N REF62 ! PARAMETER G(LIQUID,MG,Y;0) 2.98150E+02 -25802.51+4.30042*T; 6.00000E+03 N REF64 ! PARAMETER G(LIQUID,MG,Y;1) 2.98150E+02 -19229.76+3.20497*T; 6.00000E+03 N REF64 ! PARAMETER G(LIQUID,MG,ZN;0) 2.98150E+02 -81439.68+518.25145*T -64.714411*T*LN(T); 6.00000E+03 N REF33 ! PARAMETER G(LIQUID,MG,ZN;1) 2.98150E+02 +2627.54+2.93061*T; 6.00000E+03 N REF33 ! PARAMETER G(LIQUID,MG,ZN;2) 2.98150E+02 -1673.28; 6.00000E+03 N REF33 ! PARAMETER G(LIQUID,MG,ZR;0) 2.98150E+02 +14003.84+29.34205*T; 6.00000E+03 N REF68 ! PARAMETER G(LIQUID,MN,SI;0) 2.98150E+02 -139817+29.86137*T; 6.00000E+03 N REF29 ! PARAMETER G(LIQUID,MN,SI;1) 2.98150E+02 -34917.2+3.20488*T; 6.00000E+03 N REF29 ! PARAMETER G(LIQUID,MN,SI;2) 2.98150E+02 +46782.4-18.18969*T; 6.00000E+03 N REF29 ! PARAMETER G(LIQUID,MN,SI;3) 2.98150E+02 16168.2; 6.00000E+03 N REF29 ! PARAMETER G(LIQUID,MN,TI;0) 2.98150E+02 -34000+21.5*T; 6.00000E+03 N REF72 ! PARAMETER G(LIQUID,MN,TI;1) 2.98150E+02 1400; 6.00000E+03 N REF72 ! PARAMETER G(LIQUID,N,TI;0) 2.98150E+02 -376736; 6.00000E+03 N REF111 ! PARAMETER G(LIQUID,N,TI;1) 2.98150E+02 -102480; 6.00000E+03 N REF111 ! PARAMETER G(LIQUID,SI,SN;0) 2.98150E+02 25364.6; 3.00000E+03 N REF94 ! PARAMETER G(LIQUID,SI,SN;1) 2.98150E+02 3148.8; 3.00000E+03 N REF94 ! PARAMETER G(LIQUID,SI,SN;2) 2.98150E+02 4460.9; 3.00000E+03 N REF94 ! PARAMETER G(LIQUID,SI,TI;0) 2.98150E+02 -255852.17+21.87411*T; 6.00000E+03 N REF123 ! PARAMETER G(LIQUID,SI,TI;1) 2.98150E+02 +25025.35-2.00203*T; 6.00000E+03 N REF123 ! PARAMETER G(LIQUID,SI,TI;2) 2.98150E+02 +83940.65-6.71526*T; 6.00000E+03 N REF123 ! PARAMETER G(LIQUID,SI,V;0) 2.98150E+02 -180900+40*T; 6.00000E+03 N REF117 ! PARAMETER G(LIQUID,SI,V;1) 2.98150E+02 37000; 6.00000E+03 N REF117 ! PARAMETER G(LIQUID,SI,V;2) 2.98150E+02 20000; 6.00000E+03 N REF117 ! PARAMETER G(LIQUID,SI,Y;0) 2.98150E+02 -212656.12+25.83471*T; 6.00000E+03 N REF66 ! PARAMETER G(LIQUID,SI,Y;1) 2.98150E+02 +13977.08-31.08941*T; 6.00000E+03 N REF66 ! PARAMETER G(LIQUID,SI,Y;2) 2.98150E+02 +62049.23-50.31476*T; 6.00000E+03 N REF66 ! PARAMETER G(LIQUID,SI,ZN;0) 2.98150E+02 7829.25; 6.00000E+03 N REF94 ! PARAMETER G(LIQUID,SI,ZN;1) 2.98150E+02 -3338.18; 6.00000E+03 N REF94 ! PARAMETER G(LIQUID,SI,ZN;2) 2.98150E+02 -891.33; 6.00000E+03 N REF94 ! PARAMETER G(LIQUID,SI,ZR;0) 2.98150E+02 -190000+16.895515*T; 6.00000E+03 N REF100 ! PARAMETER G(LIQUID,SI,ZR;1) 2.98150E+02 +14.525747*T; 6.00000E+03 N REF100 ! PARAMETER G(LIQUID,SN,TI;0) 2.98150E+02 -90206.13-5.55089*T; 3.00000E+03 N REF39 ! PARAMETER G(LIQUID,SN,TI;1) 2.98150E+02 +44395.59-6.09746*T; 3.00000E+03 N REF39 ! PARAMETER G(LIQUID,SN,ZN;0) 2.98150E+02 +19314.64-75.89939*T +8.751396*T*LN(T); 6.00000E+03 N REF107 ! PARAMETER G(LIQUID,SN,ZN;1) 2.98150E+02 -5696.28+4.20198*T; 6.00000E+03 N REF107 ! PARAMETER G(LIQUID,SN,ZN;2) 2.98150E+02 +1037.22+.98362*T; 6.00000E+03 N REF107 ! PARAMETER G(LIQUID,TI,V;0) 2.98150E+02 1400; 6.00000E+03 N REF13 ! PARAMETER G(LIQUID,TI,V;1) 2.98150E+02 4100; 6.00000E+03 N REF13 ! PHASE AL10V % 2 10 1 ! CONSTITUENT AL10V :AL : V : ! PARAMETER G(AL10V,AL:V;0) 2.98150E+02 -111221+18.909*T+10*GHSERAL# +GHSERV#; 6.00000E+03 N REF13 ! PHASE AL11CR2 % 3 10 1 2 ! CONSTITUENT AL11CR2 :AL : AL : CR : ! PARAMETER G(AL11CR2,AL:AL:CR;0) 2.98150E+02 -175500+25.805*T +11*GHSERAL#+2*GHSERCR#; 6.00000E+03 N REF8 ! PHASE AL11MN4 % 2 11 4 ! CONSTITUENT AL11MN4 :AL : FE,MN : ! PARAMETER G(AL11MN4,AL:FE;0) 2.98150E+02 -354702+103.031*T+11*GHSERAL# +4*GHSERMN#; 6.00000E+03 N REF76 ! PARAMETER G(AL11MN4,AL:MN;0) 2.98150E+02 -354702+103.031*T+11*GHSERAL# +4*GHSERMN#; 6.00000E+03 N REF23 ! PHASE AL11TI5 % 2 17 8 ! CONSTITUENT AL11TI5 :AL : TI : ! PARAMETER G(AL11TI5,AL:TI;0) 2.98150E+02 -971125+236.4*T+17*GHSERAL# +8*GHSERTI#; 6.00000E+03 N REF13 ! PHASE AL11_CEND3 % 2 11 3 ! CONSTITUENT AL11_CEND3 :AL : CE,ND : ! PARAMETER G(AL11_CEND3,AL:CE;0) 2.98150E+02 -574000+179.3087*T +11*GHSERAL#+3*GHSERCE#; 6.00000E+03 N REF103 ! PARAMETER G(AL11_CEND3,AL:ND;0) 2.98150E+02 -574000+78.4*T+11*GHSERAL# +3*GHSERND#; 6.00000E+03 N REF80 ! PHASE AL12MG17 % 3 24 10 24 ! CONSTITUENT AL12MG17 :LI,MG : AL,LI,MG : AL,MG : ! PARAMETER G(AL12MG17,LI:AL:AL;0) 2.98150E+02 -800000+405*T+34*GHSERAL# +24*GHSERLI#; 6.00000E+03 N REF105 ! PARAMETER G(AL12MG17,MG:AL:AL;0) 2.98150E+02 -36800-140*T+34*GHSERAL# +24*GHSERMG#; 6.00000E+03 N REF11 ! PARAMETER G(AL12MG17,LI:LI:AL;0) 2.98150E+02 -750000+405*T+24*GHSERAL# +34*GHSERLI#; 6.00000E+03 N REF105 ! PARAMETER G(AL12MG17,MG:LI:AL;0) 2.98150E+02 -610000+125*T+24*GHSERMG# +10*GHSERLI#+24*GHSERAL#; 6.00000E+03 N REF105 ! PARAMETER G(AL12MG17,LI:MG:AL;0) 2.98150E+02 -625000+269*T+10*GHSERMG# +24*GHSERLI#+24*GHSERAL#; 6.00000E+03 N REF105 ! PARAMETER G(AL12MG17,MG:MG:AL;0) 2.98150E+02 -123200-56.26*T +24*GHSERAL#+34*GHSERMG#; 6.00000E+03 N REF11 ! PARAMETER G(AL12MG17,LI:AL:MG;0) 2.98150E+02 +24*GHSERMG#+10*GHSERLI# +24*GHSERAL#; 6.00000E+03 N REF105 ! PARAMETER G(AL12MG17,MG:AL:MG;0) 2.98150E+02 +151000+10*GHSERAL# +48*GHSERMG#; 6.00000E+03 N REF11 ! PARAMETER G(AL12MG17,LI:LI:MG;0) 2.98150E+02 +290000+34*GHSERLI# +24*GHSERLI#; 6.00000E+03 N REF105 ! PARAMETER G(AL12MG17,MG:LI:MG;0) 2.98150E+02 +290000+10*GHSERLI# +48*GHSERLI#; 6.00000E+03 N REF105 ! PARAMETER G(AL12MG17,LI:MG:MG;0) 2.98150E+02 +290000+24*GHSERLI# +34*GHSERLI#; 6.00000E+03 N REF105 ! PARAMETER G(AL12MG17,MG:MG:MG;0) 2.98150E+02 +290000+58*GHSERMG#; 6.00000E+03 N REF11 ! PARAMETER G(AL12MG17,LI,MG:AL:AL;0) 2.98150E+02 -220000; 6.00000E+03 N REF105 ! PARAMETER G(AL12MG17,MG:AL,LI:AL;0) 2.98150E+02 -50000; 6.00000E+03 N REF105 ! PARAMETER G(AL12MG17,MG:AL,MG:AL;0) 2.98150E+02 -17000; 6.00000E+03 N REF11 ! PARAMETER G(AL12MG17,MG:AL,MG:MG;0) 2.98150E+02 -17000; 6.00000E+03 N REF11 ! PHASE AL12MN % 2 12 1 ! CONSTITUENT AL12MN :AL : FE,MN : ! PARAMETER G(AL12MN,AL:FE;0) 2.98150E+02 -105818+33.5848*T+12*GHSERAL# +GHSERMN#; 6.00000E+03 N REF76 ! PARAMETER G(AL12MN,AL:MN;0) 2.98150E+02 -105818+33.5848*T+12*GHSERAL# +GHSERMN#; 6.00000E+03 N REF23 ! PHASE AL13CR2 % 2 13 2 ! CONSTITUENT AL13CR2 :AL : CR : ! PARAMETER G(AL13CR2,AL:CR;0) 2.98150E+02 -174405+22.2*T+13*GHSERAL# +2*GHSERCR#; 6.00000E+03 N REF8 ! PHASE AL13FE4 % 3 .6275 .235 .1375 ! CONSTITUENT AL13FE4 :AL : FE,MN : AL,SI,VA : ! PARAMETER G(AL13FE4,AL:FE:AL;0) 2.98150E+02 -30714.4+7.44*T +.765*GHSERAL#+.235*GHSERFE#; 6.00000E+03 N REF76 ! PARAMETER G(AL13FE4,AL:MN:AL;0) 2.98150E+02 -20000+10*T+.765*GHSERAL# +.235*GHSERMN#; 6.00000E+03 N REF23 ! PARAMETER G(AL13FE4,AL:FE:SI;0) 2.98150E+02 -22013.336+.6275*GHSERAL# +.235*GHSERFE#+.1375*GHSERSI#; 6.00000E+03 N REF121 ! PARAMETER G(AL13FE4,AL:MN:SI;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(AL13FE4,AL:FE:VA;0) 2.98150E+02 -27781.3+7.2566*T +.6275*GHSERAL#+.235*GHSERFE#; 6.00000E+03 N REF76 ! PARAMETER G(AL13FE4,AL:MN:VA;0) 2.98150E+02 -17000+10*T+.6275*GHSERAL# +.235*GHSERMN#; 6.00000E+03 N REF23 ! PHASE AL23V4 % 2 23 4 ! CONSTITUENT AL23V4 :AL : V : ! PARAMETER G(AL23V4,AL:V;0) 2.98150E+02 -430650+64.665*T+23*GHSERAL# +4*GHSERV#; 6.00000E+03 N REF13 ! PHASE AL2FE % 2 2 1 ! CONSTITUENT AL2FE :AL : FE,MN : ! PARAMETER G(AL2FE,AL:FE;0) 2.98150E+02 -98096.9+18.7503*T+2*GHSERAL# +GHSERFE#; 6.00000E+03 N REF76 ! PARAMETER G(AL2FE,AL:MN;0) 2.98150E+02 -14064+2*GHSERAL#+GHSERMN#; 6.00000E+03 N REF23 ! PHASE AL2LI3 % 2 2 3 ! CONSTITUENT AL2LI3 :AL : LI : ! PARAMETER G(AL2LI3,AL:LI;0) 2.98150E+02 -89640+32.79*T+2*GHSERAL# +3*GHSERLI#; 6.00000E+03 N REF105 ! PHASE AL2TI % 2 2 1 ! CONSTITUENT AL2TI :AL : TI : ! PARAMETER G(AL2TI,AL:TI;0) 2.98150E+02 -121500+31.2*T+2*GHSERAL# +GHSERTI#; 6.00000E+03 N REF13 ! PHASE AL2Y1 % 2 2 1 ! CONSTITUENT AL2Y1 :AL : Y : ! PARAMETER G(AL2Y1,AL:Y;0) 2.98150E+02 -246018+35.32809*T+2*GHSERAL# +GHSERY#; 2.90000E+03 N REF52 ! PHASE AL2Y3 % 2 2 3 ! CONSTITUENT AL2Y3 :AL : Y : ! PARAMETER G(AL2Y3,AL:Y;0) 2.98150E+02 -373605+84.4101*T+2*GHSERAL# +3*GHSERY#; 2.90000E+03 N REF52 ! PHASE AL2ZR1 % 2 2 1 ! CONSTITUENT AL2ZR1 :AL : LI,ZR : ! PARAMETER G(AL2ZR1,AL:LI;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(AL2ZR1,AL:ZR;0) 2.98150E+02 -137430+25.44*T+2*GHSERAL# +GHSERZR#; 6.00000E+03 N REF74 ! PHASE AL2ZR3 % 2 2 3 ! CONSTITUENT AL2ZR3 :AL : ZR : ! PARAMETER G(AL2ZR3,AL:ZR;0) 2.98150E+02 -192135+33*T+2*GHSERAL# +3*GHSERZR#; 6.00000E+03 N REF74 ! PHASE AL3M_DO22 % 2 3 1 ! CONSTITUENT AL3M_DO22 :AL : TI,V : ! PARAMETER G(AL3M_DO22,AL:TI;0) 2.98150E+02 -144592+37.024*T+3*GHSERAL# +GHSERTI#; 6.00000E+03 N REF13 ! PARAMETER G(AL3M_DO22,AL:V;0) 2.98150E+02 -104308+15.2*T+3*GHSERAL# +GHSERV#; 6.00000E+03 N REF13 ! PHASE AL3Y1 % 2 3 1 ! CONSTITUENT AL3Y1 :AL : Y : ! PARAMETER G(AL3Y1,AL:Y;0) 2.98150E+02 -267460+46.48084*T+3*GHSERAL# +GHSERY#; 2.90000E+03 N REF52 ! PHASE AL3Y5 % 2 3 5 ! CONSTITUENT AL3Y5 :AL : Y : ! PARAMETER G(AL3Y5,AL:Y;0) 2.98150E+02 -564479.2+127.7201*T+3*GHSERAL# +5*GHSERY#; 2.90000E+03 N REF52 ! PHASE AL3ZR1 % 2 3 1 ! CONSTITUENT AL3ZR1 :AL : LI,ZR : ! PARAMETER G(AL3ZR1,AL:LI;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(AL3ZR1,AL:ZR;0) 2.98150E+02 -162500+28.92*T+3*GHSERAL# +GHSERZR#; 6.00000E+03 N REF74 ! PHASE AL3ZR2 % 2 3 2 ! CONSTITUENT AL3ZR2 :AL : ZR : ! PARAMETER G(AL3ZR2,AL:ZR;0) 2.98150E+02 -234700+44.1*T+3*GHSERAL# +2*GHSERZR#; 6.00000E+03 N REF74 ! PHASE AL3ZR5 % 2 3 5 ! CONSTITUENT AL3ZR5 :AL : ZR : ! PARAMETER G(AL3ZR5,AL:ZR;0) 2.98150E+02 -289984+48.72*T+3*GHSERAL# +5*GHSERZR#; 6.00000E+03 N REF74 ! PHASE AL3_CEND % 2 3 1 ! CONSTITUENT AL3_CEND :AL : CE,ND : ! PARAMETER G(AL3_CEND,AL:CE;0) 2.98150E+02 -176000+54.97964*T+3*GHSERAL# +GHSERCE#; 6.00000E+03 N REF103 ! PARAMETER G(AL3_CEND,AL:ND;0) 2.98150E+02 -184000+28.16*T+3*GHSERAL# +GHSERND#; 6.00000E+03 N REF80 ! PHASE AL4C3 % 2 4 3 ! CONSTITUENT AL4C3 :AL : C : ! PARAMETER G(AL4C3,AL:C;0) 2.98150E+02 -224361+54.722*T+4*GHSERAL# +3*GHSERCC#; 6.00000E+03 N REF46 ! PHASE AL4CR % 2 4 1 ! CONSTITUENT AL4CR :AL : CR : ! PARAMETER G(AL4CR,AL:CR;0) 2.98150E+02 -89025+19.05*T+4*GHSERAL# +GHSERCR#; 6.00000E+03 N REF8 ! PHASE AL4LI9 % 2 4 9 ! CONSTITUENT AL4LI9 :AL : LI : ! PARAMETER G(AL4LI9,AL:LI;0) 2.98150E+02 -185250+67.8*T+4*GHSERAL# +9*GHSERLI#; 6.00000E+03 N REF105 ! PHASE AL4MN % 2 4 1 ! CONSTITUENT AL4MN :AL : MN,FE : ! PARAM G(AL4MN,AL:FE;0) 298.15 -131445+50.0*T+4*GHSERAL +GHSERFE; 6000.00 N 93AKE ! PARAM G(AL4MN,AL:MN;0) 298.15 -100005+30*T+4*GHSERAL +GHSERMN; 6000.00 N 93AKE! PARAM L(AL4MN,AL:FE,MN;0) 298.15 -10000; 6000.00 N 93AKE ! $ replaced by data from cost2.TDB 180825/BoS $ PARAMETER G(AL4MN,AL:MN;0) 2.98150E+02 -105661+34.761*T+4*GHSERAL# $ +GHSERMN#; 6.00000E+03 N REF23 ! PHASE AL4ZR5 % 2 4 5 ! CONSTITUENT AL4ZR5 :AL : ZR : ! PARAMETER G(AL4ZR5,AL:ZR;0) 2.98150E+02 -369000+62.55*T+4*GHSERAL# +5*GHSERZR#; 6.00000E+03 N REF74 ! PHASE AL5FE2 % 2 5 2 ! CONSTITUENT AL5FE2 :AL : FE,MN : ! PARAMETER G(AL5FE2,AL:FE;0) 2.98150E+02 -228576+48.99503*T+5*GHSERAL# +2*GHSERFE#; 6.00000E+03 N REF76 ! PARAMETER G(AL5FE2,AL:MN;0) 2.98150E+02 +5*GHSERAL#+2*GHSERMN#; 6.00000E+03 N REF23 ! PHASE AL5FE4 % 1 1.0 ! CONSTITUENT AL5FE4 :AL,FE,MN : ! PARAMETER G(AL5FE4,AL;0) 2.98150E+02 +12178.9-4.813*T+GHSERAL#; 6.00000E+03 N REF76 ! PARAMETER G(AL5FE4,FE;0) 2.98150E+02 +5009.03+GHSERFE#; 6.00000E+03 N REF76 ! PARAMETER G(AL5FE4,MN;0) 2.98150E+02 -4440+133.007*T-24.5177*T*LN(T) -.006*T**2+69600*T**(-1); 6.00000E+03 N REF23 ! PARAMETER G(AL5FE4,AL,FE;0) 2.98150E+02 -131649+29.4833*T; 6.00000E+03 N REF76 ! PARAMETER G(AL5FE4,AL,FE;1) 2.98150E+02 -18619.5; 6.00000E+03 N REF76 ! PHASE AL6MN % 2 6 1 ! CONSTITUENT AL6MN :AL : FE,MN : ! PARAM G(AL6MN,AL:FE;0) 298.15 -130984+38.5*T +6.0*GHSERAL+GHSERFE; 6000.00 N 93AKE! PARAM G(AL6MN,AL:MN;0) 298.15 -124564.3+53.65930*T+6*GHSERAL +GHSERMN; 6000.00 N 93AKE ! PARAM L(AL6MN,AL:FE,MN;0) 298.15 -32753+21*T; 6000.00 N 93AKE ! $ replaced by data in cost2.TDB 180825 /BoS $ PARAMETER G(AL6MN,AL:FE;0) 2.98150E+02 -128100+35*T+6*GHSERAL#+GHSERFE#; $ 6.00000E+03 N REF76 ! $ PARAMETER G(AL6MN,AL:MN;0) 2.98150E+02 -105013+32.6593*T+6*GHSERAL# $ +GHSERMN#; 6.00000E+03 N REF23 ! $ PARAMETER G(AL6MN,AL:FE,MN;0) 2.98150E+02 -197015+200.55*T; $ 6.00000E+03 N REF109 ! PHASE AL7V % 2 7 1 ! CONSTITUENT AL7V :AL : V : ! PARAMETER G(AL7V,AL:V;0) 2.98150E+02 -108800+16.8*T+7*GHSERAL#+GHSERV#; 6.00000E+03 N REF13 ! PHASE AL8CR5_H % 2 8 5 ! CONSTITUENT AL8CR5_H :AL : CR : ! PARAMETER G(AL8CR5_H,AL:CR;0) 2.98150E+02 -147732-58.5*T+8*GHSERAL# +5*GHSERCR#; 6.00000E+03 N REF8 ! PHASE AL8CR5_L % 2 8 5 ! CONSTITUENT AL8CR5_L :AL : CR : ! PARAMETER G(AL8CR5_L,AL:CR;0) 2.98150E+02 -229515+8*GHSERAL#+5*GHSERCR#; 6.00000E+03 N REF8 ! PHASE AL8MN5_D810 % 3 12 4 10 ! CONSTITUENT AL8MN5_D810 :AL,SI : MN : AL,FE,MN : ! PARAMETER G(AL8MN5_D810,AL:MN:AL;0) 2.98150E+02 -308671+56.6497*T +22*GHSERAL#+4*GHSERMN#; 6.00000E+03 N REF23 ! PARAMETER G(AL8MN5_D810,SI:MN:AL;0) 2.98150E+02 +10*GHSERAL#+4*GHSERMN# +12*GHSERSI#; 6.00000E+03 N REF115 ! PARAMETER G(AL8MN5_D810,AL:MN:FE;0) 2.98150E+02 -632554+12*GHSERAL# +4*GHSERMN#+10*GHSERFE#; 6.00000E+03 N REF109 ! PARAMETER G(AL8MN5_D810,SI:MN:FE;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(AL8MN5_D810,AL:MN:MN;0) 2.98150E+02 -596867+94.612*T +12*GHSERAL#+14*GHSERMN#; 6.00000E+03 N REF23 ! PARAMETER G(AL8MN5_D810,SI:MN:MN;0) 2.98150E+02 +14*GHSERMN# +12*GHSERSI#; 6.00000E+03 N REF29 ! PARAMETER G(AL8MN5_D810,AL:MN:AL,FE;0) 2.98150E+02 -457834; 6.00000E+03 N REF109 ! PARAMETER G(AL8MN5_D810,AL:MN:AL,MN;0) 2.98150E+02 -546255+387.348*T; 6.00000E+03 N REF23 ! PARAMETER G(AL8MN5_D810,AL:MN:FE,MN;0) 2.98150E+02 -11169.6; 6.00000E+03 N REF109 ! PHASE AL8V5 % 2 8 5 ! CONSTITUENT AL8V5 :AL : V : ! PARAMETER G(AL8V5,AL:V;0) 2.98150E+02 -294320-13*T+8*GHSERAL#+5*GHSERV#; 6.00000E+03 N REF13 ! PHASE AL9CR4_H % 2 9 4 ! CONSTITUENT AL9CR4_H :AL : CR : ! PARAMETER G(AL9CR4_H,AL:CR;0) 2.98150E+02 -134433-56.16*T+9*GHSERAL# +4*GHSERCR#; 6.00000E+03 N REF8 ! PHASE AL9CR4_L % 2 9 4 ! CONSTITUENT AL9CR4_L :AL : CR : ! PARAMETER G(AL9CR4_L,AL:CR;0) 2.98150E+02 -230750+16.094*T+9*GHSERAL# +4*GHSERCR#; 6.00000E+03 N REF8 ! PHASE ALB12_ALPHA % 2 1 12 ! CONSTITUENT ALB12_ALPHA :AL : B : ! PARAMETER G(ALB12_ALPHA,AL:B;0) 2.98150E+02 -198290.69+33.68638*T +GHSERAL#+12*GHSERBB#; 6.00000E+03 N REF44 ! PHASE ALB12_BETA % 2 1 12 ! CONSTITUENT ALB12_BETA :AL : B : ! PARAMETER G(ALB12_BETA,AL:B;0) 2.98150E+02 -75292.23-33.66376*T +GHSERAL#+12*GHSERBB#; 6.00000E+03 N REF44 ! PHASE ALB2 % 2 1 2 ! CONSTITUENT ALB2 :AL : B : ! PARAMETER G(ALB2,AL:B;0) 2.98150E+02 -85808.76+45.46923*T+GHSERAL# +2*GHSERBB#; 6.00000E+03 N REF44 ! PHASE ALCR2 % 2 1 2 ! CONSTITUENT ALCR2 :AL : CR : ! PARAMETER G(ALCR2,AL:CR;0) 2.98150E+02 -32700-8.79*T+GHSERAL# +2*GHSERCR#; 6.00000E+03 N REF8 ! PHASE ALCULI_R % 3 .55 .117 .333 ! CONSTITUENT ALCULI_R :AL : CU : LI : ! PARAMETER G(ALCULI_R,AL:CU:LI;0) 2.98150E+02 -20983+6*T+.55*GHSERAL# +.117*GHSERCU#+.333*GHSERLI#; 6.00000E+03 N REF119 ! PHASE ALCULI_T1 % 3 .5 .25 .25 ! CONSTITUENT ALCULI_T1 :AL : CU : LI : ! PARAMETER G(ALCULI_T1,AL:CU:LI;0) 2.98150E+02 -24560+6*T+.5*GHSERAL# +.25*GHSERCU#+.25*GHSERLI#; 6.00000E+03 N REF119 ! PHASE ALCULI_T2 % 3 .57 .11 .32 ! CONSTITUENT ALCULI_T2 :AL : CU : LI : ! PARAMETER G(ALCULI_T2,AL:CU:LI;0) 2.98150E+02 -20000+5.497*T +.57*GHSERAL#+.11*GHSERCU#+.32*GHSERLI#; 6.00000E+03 N REF119 ! PHASE ALCULI_TB % 3 .6 .32 .08 ! CONSTITUENT ALCULI_TB :AL : CU : LI : ! PARAMETER G(ALCULI_TB,AL:CU:LI;0) 2.98150E+02 -19918+4*T+.6*GHSERAL# +.32*GHSERCU#+.08*GHSERLI#; 6.00000E+03 N REF119 ! PHASE ALCU_DELTA % 2 2 3 ! CONSTITUENT ALCU_DELTA :AL : CU : ! PARAMETER G(ALCU_DELTA,AL:CU;0) 2.98150E+02 -106700+3*T+2*GHSERAL# +3*GHSERCU#; 6.00000E+03 N REF72 ! PHASE ALCU_EPSILON % 2 1 1 ! CONSTITUENT ALCU_EPSILON :AL,CU : CU : ! PARAMETER G(ALCU_EPSILON,AL:CU;0) 2.98150E+02 -36976+1.2*T+GHSERAL# +GHSERCU#; 6.00000E+03 N REF72 ! PARAMETER G(ALCU_EPSILON,CU:CU;0) 2.98150E+02 +2*GBCCCU#; 6.00000E+03 N REF72 ! PARAMETER G(ALCU_EPSILON,AL,CU:CU;0) 2.98150E+02 +7600-24*T; 6.00000E+03 N REF72 ! PARAMETER G(ALCU_EPSILON,AL,CU:CU;1) 2.98150E+02 -72000; 6.00000E+03 N REF72 ! PHASE ALCU_ETA % 2 1 1 ! CONSTITUENT ALCU_ETA :AL,CU : CU : ! PARAMETER G(ALCU_ETA,AL:CU;0) 2.98150E+02 -40560+3.14*T+GHSERAL# +GHSERCU#; 6.00000E+03 N REF72 ! PARAMETER G(ALCU_ETA,CU:CU;0) 2.98150E+02 +2*GBCCCU#; 6.00000E+03 N REF72 ! PARAMETER G(ALCU_ETA,AL,CU:CU;0) 2.98150E+02 -25740-20*T; 6.00000E+03 N REF72 ! PHASE ALCU_PRIME % 2 2 1 ! CONSTITUENT ALCU_PRIME :AL : CU : ! PARAMETER G(ALCU_PRIME,AL:CU;0) 2.98150E+02 -46500+6.5*T+2*GHSERAL# +GHSERCU#; 6.00000E+03 N REF72 ! PHASE ALCU_THETA % 2 2 1 ! CONSTITUENT ALCU_THETA :AL : AL,CU : ! PARAMETER G(ALCU_THETA,AL:AL;0) 2.98150E+02 +3*GBCCAL#; 6.00000E+03 N REF72 ! PARAMETER G(ALCU_THETA,AL:CU;0) 2.98150E+02 -47406+6.75*T+2*GHSERAL# +GHSERCU#; 6.00000E+03 N REF72 ! PARAMETER G(ALCU_THETA,AL:AL,CU;0) 2.98150E+02 2211; 6.00000E+03 N REF72 ! PHASE ALCU_ZETA % 2 9 11 ! CONSTITUENT ALCU_ZETA :AL : CU : ! PARAMETER G(ALCU_ZETA,AL:CU;0) 2.98150E+02 -420000+18*T+9*GHSERAL# +11*GHSERCU#; 6.00000E+03 N REF72 ! PHASE ALFESI_ALPHA % 4 .6612 .19 .0496 .0992 ! CONSTITUENT ALFESI_ALPHA :AL : FE : SI : AL,SI : ! PARAMETER G(ALFESI_ALPHA,AL:FE:SI:AL;0) 2.98150E+02 -24920.609 +5.4893676*T+.7604*GHSERAL#+.1901*GHSERFE#+.0496*GHSERSI#; 6.00000E+03 N REF121 ! PARAMETER G(ALFESI_ALPHA,AL:FE:SI:SI;0) 2.98150E+02 -24920.609 -420.31313+5.4893676*T+.6612*GHSERAL#+.1901*GHSERFE#+.1488*GHSERSI#; 6.00000E+03 N REF121 ! PHASE ALFESI_BETA % 3 14 3 3 ! CONSTITUENT ALFESI_BETA :AL : FE : SI : ! PARAMETER G(ALFESI_BETA,AL:FE:SI;0) 2.98150E+02 -391310.9+558.4756*T +14*GHSERAL#+3*GHSERFE#+3*GHSERSI#; 6.00000E+03 N REF121 ! PHASE ALFESI_DELTA % 3 .55 .15 .3 ! CONSTITUENT ALFESI_DELTA :AL : FE : SI : ! PARAMETER G(ALFESI_DELTA,AL:FE:SI;0) 2.98150E+02 -14431.105-2.9006199*T +.55*GHSERAL#+.15*GHSERFE#+.3*GHSERSI#; 6.00000E+03 N REF121 ! PHASE ALFESI_GAMMA % 3 3 1 1 ! CONSTITUENT ALFESI_GAMMA :AL : FE : SI : ! PARAMETER G(ALFESI_GAMMA,AL:FE:SI;0) 2.98150E+02 -116929.6+8.399833*T +3*GHSERAL#+GHSERFE#+GHSERSI#; 6.00000E+03 N REF121 ! PHASE ALFESI_TAU1 % 3 2 2 1 ! CONSTITUENT ALFESI_TAU1 :AL : FE : SI : ! PARAMETER G(ALFESI_TAU1,AL:FE:SI;0) 2.98150E+02 -153000+2*GHSERAL# +2*GHSERFE#+GHSERSI#; 6.00000E+03 N REF121 ! PHASE ALFESI_TAU3 % 3 2 1 1 ! CONSTITUENT ALFESI_TAU3 :AL : FE : SI : ! PARAMETER G(ALFESI_TAU3,AL:FE:SI;0) 2.98150E+02 -99325.65+2*GHSERAL# +GHSERFE#+GHSERSI#; 6.00000E+03 N REF121 ! PHASE AL1LI1 % 2 1 1 ! CONSTITUENT AL1LI1 :AL,LI,MG : LI,MG,VA : ! PARAMETER G(AL1LI1,AL:LI;0) 2.98150E+02 -41300+16.86*T+GHSERAL#+GHSERLI#; 6.00000E+03 N REF105 ! PARAMETER G(AL1LI1,LI:LI;0) 2.98150E+02 +2*GHSERLI#; 6.00000E+03 N REF105 ! PARAMETER G(AL1LI1,MG:LI;0) 2.98150E+02 -9168+4.2*T+GBCCMG#+GHSERLI#; 6.00000E+03 N REF105 ! PARAMETER G(AL1LI1,AL:MG;0) 2.98150E+02 +2486-1.75*T+GBCCAL#+GHSERLI#; 6.00000E+03 N REF11 ! PARAMETER G(AL1LI1,LI:MG;0) 2.98150E+02 -9168+4.2*T+GBCCMG#+GHSERLI#; 6.00000E+03 N REF105 ! PARAMETER G(AL1LI1,MG:MG;0) 2.98150E+02 +2*GBCCMG#; 6.00000E+03 N REF11 ! PARAMETER G(AL1LI1,AL:VA;0) 2.98150E+02 +24000+GHSERAL#; 6.00000E+03 N REF105 ! PARAMETER G(AL1LI1,LI:VA;0) 2.98150E+02 +50000+GHSERLI#; 6.00000E+03 N REF105 ! PARAMETER G(AL1LI1,MG:VA;0) 2.98150E+02 +50000+GHSERMG#; 6.00000E+03 N REF11 ! PARAMETER G(AL1LI1,AL,LI:LI;0) 2.98150E+02 20000; 6.00000E+03 N REF105 ! PARAMETER G(AL1LI1,AL,LI:LI;1) 2.98150E+02 -26000; 6.00000E+03 N REF105 ! PARAMETER G(AL1LI1,AL,MG:LI;0) 2.98150E+02 +3300-2*T; 6.00000E+03 N REF105 ! PARAMETER G(AL1LI1,AL,MG:LI,MG;0) 2.98150E+02 -43460+60*T; 6.00000E+03 N REF105 ! PARAMETER G(AL1LI1,AL:LI,MG;0) 2.98150E+02 -25000+10*T; 6.00000E+03 N REF105 ! PARAMETER G(AL1LI1,AL:LI,VA;0) 2.98150E+02 -24000+10*T; 6.00000E+03 N REF105 ! PARAMETER G(AL1LI1,AL,LI:VA;0) 2.98150E+02 2000; 6.00000E+03 N REF105 ! PHASE ALLIMG_TAU % 3 .53 .33 .14 ! CONSTITUENT ALLIMG_TAU :AL : LI : MG : ! PARAMETER G(ALLIMG_TAU,AL:LI:MG;0) 2.98150E+02 -15500+23.93*T-3*T*LN(T) +.53*GHSERAL#+.33*GHSERLI#+.14*GHSERMG#; 6.00000E+03 N REF105 ! PHASE ALMGMN_T % 3 18 3 2 ! CONSTITUENT ALMGMN_T :AL : MG : MN : ! PARAMETER G(ALMGMN_T,AL:MG:MN;0) 2.98150E+02 -206402+11.849833*T; 6.00000E+03 N REF126 ! PHASE ALMG_BETA % 2 .615 .385 ! CONSTITUENT ALMG_BETA :AL : LI,MG : ! PARAMETER G(ALMG_BETA,AL:LI;0) 2.98150E+02 -10750+5*T+.615*GHSERAL# +.385*GHSERLI#; 6.00000E+03 N REF105 ! PARAMETER G(ALMG_BETA,AL:MG;0) 2.98150E+02 -1000-3.017*T+.615*GHSERAL# +.385*GHSERMG#; 6.00000E+03 N REF11 ! PARAMETER G(ALMG_BETA,AL:LI,MG;0) 2.98150E+02 -4250; 6.00000E+03 N REF105 ! PHASE ALMG_DZETA % 2 21 19 ! CONSTITUENT ALMG_DZETA :AL : MG : ! PARAMETER G(ALMG_DZETA,AL:MG;0) 2.98150E+02 -21040-163.76*T+21*GHSERAL# +19*GHSERMG#; 6.00000E+03 N REF11 ! PHASE ALMG_UPSILON % 2 14 11 ! CONSTITUENT ALMG_UPSILON :AL : MG : ! PARAMETER G(ALMG_UPSILON,AL:MG;0) 2.98150E+02 -9275-104*T+14*GHSERAL# +11*GHSERMG#; 6.00000E+03 N REF11 ! PHASE ALMNSI_ALPHA % 4 16 4 1 2 ! CONSTITUENT ALMNSI_ALPHA :AL : MN : SI : AL,SI : ! PARAMETER G(ALMNSI_ALPHA,AL:MN:SI:AL;0) 2.98150E+02 -250000+200*T -14.42*T*LN(T)+.0464*T**2+18*GHSERAL#+4*GHSERMN#+GHSERSI#; 2.00000E+03 N REF115 ! PARAMETER G(ALMNSI_ALPHA,AL:MN:SI:SI;0) 2.98150E+02 -500000+200*T -14.42*T*LN(T)+.0464*T**2+16*GHSERAL#+4*GHSERMN#+3*GHSERSI#; 2.00000E+03 N REF115 ! PHASE ALMNSI_DELTA % 3 2 1 3 ! CONSTITUENT ALMNSI_DELTA :AL : MN : SI : ! PARAMETER G(ALMNSI_DELTA,AL:MN:SI;0) 2.98150E+02 -75000-20*T+2*GHSERAL# +GHSERMN#+3*GHSERSI#; 6.00000E+03 N REF115 ! $ PHASE ALMNSI_BETA % 3 7.5 2.5 3 ! $ CONSTITUENT ALMNSI_BETA :AL : AL,SI : MN : ! $ Changed to expression in COST2.TDB 180825 /BoS $ PARAMETER G(ALMNSI_NBETA,AL:AL:MN;0) 2.98150E+02 -260000-745*T $ +10*GHSERAL#+3*GHSERMN#; 6.00000E+03 N REF115 ! $ PARAMETER G(ALMNSI_NBETA,AL:SI:MN;0) 2.98150E+02 -230000-745*T $ +7.5*GHSERAL#+2.5*GHSERSI#+3*GHSERMN#; 2.00000E+03 N REF115 ! PHASE ALMNSI_BETA % 4 15.0 1.0 4.0 6.0 ! CONSTITUENT ALMNSI_BETA :AL : SI : AL,SI : MN : ! PARAM G(ALMNSI_BETA,AL:SI:AL:MN;0) 298.15 -8.8064800E+05+3.4510400E+03*T-572.749*T*LN(T) -.201935*T**2+2.00008E-05*T**3+2184750*T**(-1); 6000.00 N REF115! PARAM G(ALMNSI_BETA,AL:SI:SI:MN;0) 298.15 -7.7998000E+05+3.4510400E+03*T-593.657*T*LN(T) -.16164*T**2+1.35092E-05*T**3+2946120*T**(-1); 6000.00 N REF115! PARAM L(ALMNSI_BETA,AL:SI:AL,SI:MN;0) 298.15 1.0E-4; 6000 N REF115! PHASE ALN % 2 1 1 ! CONSTITUENT ALN :AL : N : ! PARAMETER G(ALN,AL:N;0) 2.98150E+02 -338005.5+305.211*T -46.94867*T*LN(T)-.00189068*T**2+874528*T**(-1)+1.3756E-07*T**3; 6.00000E+03 N REF48 ! PHASE AL1ND2 % 2 1 2 ! CONSTITUENT AL1ND2 :AL : ND : ! PARAMETER G(AL1ND2,AL:ND;0) 2.98150E+02 -108540+20.64*T+GHSERAL# +2*GHSERND#; 6.00000E+03 N REF80 ! PHASE ALPHA_TIMN % 2 1 1 ! CONSTITUENT ALPHA_TIMN :MN : TI : ! PARAMETER G(ALPHA_TIMN,MN:TI;0) 2.98150E+02 -11478-4*T+GHSERMN# +GHSERTI#; 6.00000E+03 N REF72 ! PHASE AL1TI1 % 2 1 1 ! CONSTITUENT AL1TI1 :AL%,TI,V : AL,TI%,V : ! PARAMETER G(AL1TI1,AL:AL;0) 2.98150E+02 +2*GHSERAL#+1000; 6.00000E+03 N REF13 ! PARAMETER G(AL1TI1,TI:AL;0) 2.98150E+02 -79644+19.2*T+GHSERAL#+GHSERTI#; 6.00000E+03 N REF13 ! PARAMETER G(AL1TI1,V:AL;0) 2.98150E+02 -112756+140.9629*T+GHSERAL#+GFCCV#; 6.00000E+03 N REF13 ! PARAMETER G(AL1TI1,AL:TI;0) 2.98150E+02 -79644+19.2*T+GHSERAL#+GHSERTI#; 6.00000E+03 N REF13 ! PARAMETER G(AL1TI1,TI:TI;0) 2.98150E+02 +2*GFCCTI#; 6.00000E+03 N REF13 ! PARAMETER G(AL1TI1,V:TI;0) 2.98150E+02 +245018.5+GFCCTI#+GFCCV#; 6.00000E+03 N REF13 ! PARAMETER G(AL1TI1,AL:V;0) 2.98150E+02 -112756+140.9629*T+GHSERAL#+GFCCV#; 6.00000E+03 N REF13 ! PARAMETER G(AL1TI1,TI:V;0) 2.98150E+02 +245018.5+GFCCTI#+GFCCV#; 6.00000E+03 N REF13 ! PARAMETER G(AL1TI1,V:V;0) 2.98150E+02 +2*GFCCV#; 6.00000E+03 N REF13 ! PARAMETER G(AL1TI1,AL,TI:AL;0) 2.98150E+02 -89892+44*T; 6.00000E+03 N REF13 ! PARAMETER G(AL1TI1,AL,TI:AL;1) 2.98150E+02 30000; 6.00000E+03 N REF13 ! PARAMETER G(AL1TI1,AL,TI:AL;2) 2.98150E+02 20000; 6.00000E+03 N REF13 ! PARAMETER G(AL1TI1,AL:AL,TI;0) 2.98150E+02 -89892+44*T; 6.00000E+03 N REF13 ! PARAMETER G(AL1TI1,AL:AL,TI;1) 2.98150E+02 30000; 6.00000E+03 N REF13 ! PARAMETER G(AL1TI1,AL:AL,TI;2) 2.98150E+02 20000; 6.00000E+03 N REF13 ! PARAMETER G(AL1TI1,TI:AL,TI;0) 2.98150E+02 -15134-2.36*T; 6.00000E+03 N REF13 ! PARAMETER G(AL1TI1,AL,TI:TI;0) 2.98150E+02 -15134-2.36*T; 6.00000E+03 N REF13 ! PHASE ALTI3 % 2 3 1 ! CONSTITUENT ALTI3 :AL,TI%,V : AL%,TI,V : ! PARAMETER G(ALTI3,AL:AL;0) 2.98150E+02 +4*GHCPAL#; 6.00000E+03 N REF13 ! PARAMETER G(ALTI3,TI:AL;0) 2.98150E+02 -110080+23.88*T+GHSERAL# +3*GHSERTI#; 6.00000E+03 N REF13 ! PARAMETER G(ALTI3,V:AL;0) 2.98150E+02 -112566.1+52.28308*T+GHCPAL# +3*GHCPV#; 6.00000E+03 N REF13 ! PARAMETER G(ALTI3,AL:TI;0) 2.98150E+02 -99120+32.28*T+3*GHSERAL# +GHSERTI#; 6.00000E+03 N REF13 ! PARAMETER G(ALTI3,TI:TI;0) 2.98150E+02 +4*GHSERTI#; 6.00000E+03 N REF13 ! PARAMETER G(ALTI3,V:TI;0) 2.98150E+02 +82314.05+GHSERTI#+3*GHSERV#; 6.00000E+03 N REF13 ! PARAMETER G(ALTI3,AL:V;0) 2.98150E+02 -112566.1+52.28308*T+3*GHCPAL# +GHCPV#; 6.00000E+03 N REF13 ! PARAMETER G(ALTI3,TI:V;0) 2.98150E+02 +82314.05+3*GHSERTI#+GHSERV#; 6.00000E+03 N REF13 ! PARAMETER G(ALTI3,V:V;0) 2.98150E+02 +4*GHCPV#; 6.00000E+03 N REF13 ! PARAMETER G(ALTI3,AL,TI:AL;0) 2.98150E+02 -297200+100*T; 6.00000E+03 N REF13 ! PARAMETER G(ALTI3,AL:AL,TI;0) 2.98150E+02 -98968+33.3*T; 6.00000E+03 N REF13 ! PARAMETER G(ALTI3,TI:AL,TI;0) 2.98150E+02 +10656-1.332*T; 6.00000E+03 N REF13 ! PARAMETER G(ALTI3,AL,TI:TI;0) 2.98150E+02 +32000-4*T; 6.00000E+03 N REF13 ! PARAMETER G(ALTI3,TI,V:TI;0) 2.98150E+02 1E-05; 6.00000E+03 N REF13 ! PARAMETER G(ALTI3,TI:TI,V;0) 2.98150E+02 1E-05; 6.00000E+03 N REF13 ! PHASE AL1Y1 % 2 1 1 ! CONSTITUENT AL1Y1 :AL : Y : ! PARAMETER G(AL1Y1,AL:Y;0) 2.98150E+02 -173810+40.86834*T+GHSERAL#+GHSERY#; 2.90000E+03 N REF52 ! PHASE ALY2 % 2 1 2 ! CONSTITUENT ALY2 :AL : Y : ! PARAMETER G(ALY2,AL:Y;0) 2.98150E+02 -190908+44.38629*T+GHSERAL# +2*GHSERY#; 2.90000E+03 N REF52 ! PHASE AL1ZR1 % 2 1 1 ! CONSTITUENT AL1ZR1 :AL : ZR : ! PARAMETER G(AL1ZR1,AL:ZR;0) 2.98150E+02 -89000+17.0384*T+GHSERAL# +GHSERZR#; 6.00000E+03 N REF74 ! PHASE ALZR2 % 2 1 2 ! CONSTITUENT ALZR2 :AL : ZR : ! PARAMETER G(ALZR2,AL:ZR;0) 2.98150E+02 -100125+17.553*T+GHSERAL# +2*GHSERZR#; 6.00000E+03 N REF74 ! PHASE ALZR3 % 2 1 3 ! CONSTITUENT ALZR3 :AL : ZR : ! PARAMETER G(ALZR3,AL:ZR;0) 2.98150E+02 -108000+22.38*T+GHSERAL# +3*GHSERZR#; 6.00000E+03 N REF74 ! PHASE AL_CEND1 % 2 1 1 ! CONSTITUENT AL_CEND1 :AL : CE,ND : ! PARAMETER G(AL_CEND1,AL:CE;0) 2.98150E+02 -92000+33.90118*T+GHSERAL# +GHSERCE#; 6.00000E+03 N REF103 ! PARAMETER G(AL_CEND1,AL:ND;0) 2.98150E+02 -99880+20.4*T+GHSERAL# +GHSERND#; 6.00000E+03 N REF80 ! PHASE ALCEND3 % 2 1 3 ! CONSTITUENT ALCEND3 :AL : CE,ND : ! PARAMETER G(ALCEND3,AL:CE;0) 2.98150E+02 -108000+41.3726*T+GHSERAL# +3*GHSERCE#; 6.00000E+03 N REF103 ! PARAMETER G(ALCEND3,AL:ND;0) 2.98150E+02 -108840+19.52*T+GHSERAL# +3*GHSERND#; 6.00000E+03 N REF80 ! PHASE B2TI % 2 2 1 ! CONSTITUENT B2TI :B : TI : ! PARAMETER G(B2TI,B:TI;0) 2.98150E+02 -318253.47-2.5557*T +.799221*T*LN(T)+.002843367*T**2+2*GHSERBB#+GHSERTI#; 6.00000E+03 N REF89 ! PHASE B3SI % 3 6 2 6 ! CONSTITUENT B3SI :B : SI : B,SI : ! PARAMETER G(B3SI,B:SI:B;0) 2.98150E+02 +112000+12*GHSERBB#+2*GHSERSI#; 6.00000E+03 N REF58 ! PARAMETER G(B3SI,B:SI:SI;0) 2.98150E+02 +1120000+6*GHSERBB#+8*GHSERSI#; 6.00000E+03 N REF58 ! PARAMETER G(B3SI,B:SI:B,SI;0) 2.98150E+02 -2400475+240.0475*T; 6.00000E+03 N REF58 ! PHASE B4C % 2 12 1 ! CONSTITUENT B4C :B : B4,C2B,C2SI,C3 : ! PARAMETER G(B4C,B:B4;0) 2.98150E+02 +85617.28+1.82192*T+16*GHSERBB#; 6.00000E+03 N REF54 ! PARAMETER G(B4C,B:C2B;0) 2.98150E+02 -190446-25.02645*T+14*GHSERBB# +GHSERCC#; 6.00000E+03 N REF54 ! PARAMETER G(B4C,B:C2SI;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(B4C,B:C3;0) 2.98150E+02 -221960.55-21.50175*T+12*GHSERBB# +3*GHSERCC#; 6.00000E+03 N REF54 ! PARAMETER G(B4C,B:B4,C2B;0) 2.98150E+02 -130000-2*T; 6.00000E+03 N REF54 ! PARAMETER G(B4C,B:C2B,C3;0) 2.98150E+02 -30000+9*T; 6.00000E+03 N REF54 ! PHASE B4TI3 % 2 4 3 ! CONSTITUENT B4TI3 :B : TI : ! PARAMETER G(B4TI3,B:TI;0) 2.98150E+02 -660745.8+4.3472923*T +2.162216*T*LN(T)+4*GHSERBB#+3*GHSERTI#; 6.00000E+03 N REF89 ! PHASE B6SI % 3 210 23 48 ! CONSTITUENT B6SI :B : SI : B,SI : ! PARAMETER G(B6SI,B:SI:B;0) 2.98150E+02 +729824.4-72.98244*T +258*GHSERBB#+23*GHSERSI#; 6.00000E+03 N REF58 ! PARAMETER G(B6SI,B:SI:SI;0) 2.98150E+02 +5454560-545.456*T+210*GHSERBB# +71*GHSERSI#; 6.00000E+03 N REF58 ! PARAMETER G(B6SI,B:SI:B,SI;0) 2.98150E+02 -15715630+1571.563*T; 6.00000E+03 N REF58 ! TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! PHASE BCC_A2 %& 2 1 3 ! CONSTITUENT BCC_A2 :AL,CE,CR%,CU,FE%,LI,MG,MN,ND,SI,SN,TI%,V%,Y%,ZN,ZR% : B,C,N,VA% : ! PARAMETER G(BCC_A2,AL:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,CE:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,CR:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,CU:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,FE:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,LI:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,MG:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,MN:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,ND:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,SI:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,SN:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,TI:B;0) 2.98150E+02 -200000+14*T+GHSERTI#+3*GHSERBB#; 6.00000E+03 N REF89 ! PARAMETER G(BCC_A2,V:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,Y:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,ZN:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,ZR:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,AL:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,CE:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,CR:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,CU:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,FE:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,LI:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,MG:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,MN:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,ND:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,SI:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,SN:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,TI:C;0) 2.98150E+02 +2295533+GHSERTIC#+2*GHSERCC#; 6.00000E+03 N REF111 ! PARAMETER G(BCC_A2,V:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,Y:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,ZN:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,ZR:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,AL:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,CE:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,CR:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,CU:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,FE:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,LI:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,MG:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,MN:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,ND:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,SI:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,SN:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,TI:N;0) 2.98150E+02 +1561293+118.04*T+GHSERTIN# +2*GHSERNN#; 6.00000E+03 N REF111 ! PARAMETER G(BCC_A2,V:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,Y:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,ZN:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,ZR:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_A2,AL:VA;0) 2.98150E+02 +10083-4.813*T+GHSERAL#; 6.00000E+03 N REF1 ! PARAMETER G(BCC_A2,CE:VA;0) 2.98150E+02 -1354.69-5.21501*T -7.7305867*T*LN(T)-.029098402*T**2+4.784299E-06*T**3-196303*T**(-1); 1.00000E+03 Y -12101.106+187.449688*T-37.6142*T*LN(T); 1.07200E+03 Y -11950.375+186.333811*T-37.4627992*T*LN(T)-5.7145E-05*T**2+2.348E-09*T**3 -25897*T**(-11); 6.00000E+03 N REF1 ! PARAMETER G(BCC_A2,CR:VA;0) 2.98150E+02 +GHSERCR#; 6.00000E+03 N REF1 ! PARAMETER TC(BCC_A2,CR:VA;0) 2.98150E+02 -311.5; 6.00000E+03 N REF1 ! PARAMETER BMAGN(BCC_A2,CR:VA;0) 2.98150E+02 -.008; 6.00000E+03 N REF1 ! PARAMETER G(BCC_A2,CU:VA;0) 2.98150E+02 +GBCCCU#; 6.00000E+03 N REF1 ! PARAMETER G(BCC_A2,FE:VA;0) 2.98150E+02 +GHSERFE#; 6.00000E+03 N REF1 ! PARAMETER TC(BCC_A2,FE:VA;0) 2.98150E+02 1043; 6.00000E+03 N REF1 ! PARAMETER BMAGN(BCC_A2,FE:VA;0) 2.98150E+02 2.22; 6.00000E+03 N REF1 ! PARAMETER G(BCC_A2,LI:VA;0) 2.98150E+02 +GHSERLI#; 6.00000E+03 N REF1 ! PARAMETER G(BCC_A2,MG:VA;0) 2.98150E+02 +3100-2.1*T+GHSERMG#; 6.00000E+03 N REF1 ! PARAMETER G(BCC_A2,MN:VA;0) 2.98150E+02 -3235.3+127.85*T-23.7*T*LN(T) -.00744271*T**2+60000*T**(-1); 1.51900E+03 Y -23188.83+307.7043*T-48*T*LN(T)+1.265152E+30*T**(-9); 6.00000E+03 N REF1 ! PARAMETER TC(BCC_A2,MN:VA;0) 2.98150E+02 -580; 6.00000E+03 N REF1 ! PARAMETER BMAGN(BCC_A2,MN:VA;0) 2.98150E+02 -.27; 6.00000E+03 N REF1 ! PARAMETER G(BCC_A2,ND:VA;0) 2.98150E+02 -6965.635+110.556109*T -27.0858*T*LN(T)+5.56125E-04*T**2-2.6923E-06*T**3+34887*T**(-1); 4.00000E+02 Y +7312.2-153.033976*T+14.9956777*T*LN(T)-.050479*T**2+7.287217E-06*T**3 -831810*T**(-1); 1.12800E+03 Y -18030.266+239.677322*T-44.5596*T*LN(T); 1.28900E+03 Y +334513.017-2363.9199*T+311.409193*T*LN(T)-.156030778*T**2 +1.2408421E-05*T**3-64319604*T**(-1); 1.80000E+03 N REF1 ! PARAMETER G(BCC_A2,SI:VA;0) 2.98150E+02 +47000-22.5*T+GHSERSI#; 6.00000E+03 N REF1 ! PARAMETER G(BCC_A2,SN:VA;0) 2.98150E+02 +4400-6*T+GHSERSN#; 3.00000E+03 N REF1 ! PARAMETER G(BCC_A2,TI:VA;0) 2.98150E+02 -1272.064+134.71418*T -25.5768*T*LN(T)-6.63845E-04*T**2-2.78803E-07*T**3+7208*T**(-1); 1.15500E+03 Y +6667.385+105.366379*T-22.3771*T*LN(T)+.00121707*T**2-8.4534E-07*T**3 -2002750*T**(-1); 1.94100E+03 Y +26483.26-182.426471*T+19.0900905*T*LN(T)-.02200832*T**2 +1.228863E-06*T**3+1400501*T**(-1); 4.00000E+03 N REF1 ! PARAMETER G(BCC_A2,V:VA;0) 2.98150E+02 +GHSERV#; 6.00000E+03 N REF1 ! PARAMETER G(BCC_A2,Y:VA;0) 2.98150E+02 -1861.198+97.522398*T -20.940576*T*LN(T)-.007995833*T**2+7.58716E-07*T**3-54349*T**(-1); 1.75200E+03 Y -10207.724+195.741984*T-35.0201*T*LN(T); 1.79900E+03 Y +104813.954-386.167564*T+39.8075986*T*LN(T); 3.70000E+03 N REF1 ! PARAMETER G(BCC_A2,ZN:VA;0) 2.98150E+02 +2886.96-2.5104*T+GHSERZN#; 6.00000E+03 N REF1 ! PARAMETER G(BCC_A2,ZR:VA;0) 2.98150E+02 +7302.056-.70335*T -1.445606*T*LN(T)+.004037826*T**2-9.7289735E-09*T**3-7.6142894E-11*T**4 -9737*T**(-1)+GHSERZR#; 2.12800E+03 Y -4620.034+1.55998*T+1.41035E+32*T**(-9); 6.00000E+03 N REF1 ! PARAMETER G(BCC_A2,TI:B,VA;0) 2.98150E+02 -260162.96+156.48207*T; 6.00000E+03 N REF89 ! PARAMETER G(BCC_A2,TI:C,VA;0) 2.98150E+02 -2590609; 6.00000E+03 N REF111 ! PARAMETER G(BCC_A2,TI:N,VA;0) 2.98150E+02 -2140513; 6.00000E+03 N REF111 ! PARAMETER G(BCC_A2,AL,CE:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N REF129 ! PARAMETER G(BCC_A2,AL,CR:VA;0) 2.98150E+02 -54900+10*T; 6.00000E+03 N REF8 ! PARAMETER G(BCC_A2,AL,CU:VA;0) 2.98150E+02 -73554+4*T; 6.00000E+03 N REF72 ! PARAMETER G(BCC_A2,AL,CU:VA;1) 2.98150E+02 +51500-11.84*T; 6.00000E+03 N REF72 ! PARAMETER G(BCC_A2,AL,LI:VA;0) 2.98150E+02 -27000+8*T; 6.00000E+03 N REF105 ! PARAMETER G(BCC_A2,AL,LI:VA;1) 2.98150E+02 1E-06; 6.00000E+03 N REF105 ! PARAMETER G(BCC_A2,AL,LI:VA;2) 2.98150E+02 3000; 6.00000E+03 N REF105 ! PARAMETER G(BCC_A2,AL,LI,MG:VA;0) 2.98150E+02 -71200+50*T; 6.00000E+03 N REF105 ! PARAMETER G(BCC_A2,AL,MG:VA;0) 2.98150E+02 +4971-3.5*T; 6.00000E+03 N REF11 ! PARAMETER G(BCC_A2,AL,MG:VA;1) 2.98150E+02 +900+.423*T; 6.00000E+03 N REF11 ! PARAMETER G(BCC_A2,AL,MG:VA;2) 2.98150E+02 950; 6.00000E+03 N REF11 ! PARAMETER G(BCC_A2,AL,MN:VA;0) 2.98150E+02 -120077+52.851*T; 6.00000E+03 N REF23 ! PARAMETER G(BCC_A2,AL,MN:VA;1) 2.98150E+02 -40652+29.2764*T; 6.00000E+03 N REF23 ! PARAMETER G(BCC_A2,AL,TI:VA;0) 2.98150E+02 -128500+39*T; 6.00000E+03 N REF13 ! PARAMETER G(BCC_A2,AL,TI:VA;1) 2.98150E+02 6000; 6.00000E+03 N REF13 ! PARAMETER G(BCC_A2,AL,TI:VA;2) 2.98150E+02 21200; 6.00000E+03 N REF13 ! PARAMETER G(BCC_A2,AL,TI,V:VA;0) 2.98150E+02 32045.963; 6.00000E+03 N REF127 ! PARAMETER G(BCC_A2,AL,V:VA;0) 2.98150E+02 -95000+20*T; 6.00000E+03 N REF13 ! PARAMETER G(BCC_A2,AL,V:VA;1) 2.98150E+02 -6000; 6.00000E+03 N REF13 ! PARAMETER G(BCC_A2,AL,Y:VA;0) 2.98150E+02 +90*T; 6.00000E+03 N REF52 ! PARAMETER G(BCC_A2,AL,ZR:VA;0) 2.98150E+02 -122300+32*T; 6.00000E+03 N REF74 ! PARAMETER G(BCC_A2,AL,ZR:VA;1) 2.98150E+02 -11000; 6.00000E+03 N REF74 ! PARAMETER G(BCC_A2,AL,ZR:VA;2) 2.98150E+02 15000; 6.00000E+03 N REF74 ! PARAMETER G(BCC_A2,CE,MG:VA;0) 2.98150E+02 -27000+3.3*T; 6.00000E+03 N REF103 ! PARAMETER G(BCC_A2,CE,MG:VA;1) 2.98150E+02 +25338.56-11.86885*T; 6.00000E+03 N REF103 ! PARAMETER G(BCC_A2,CE,MG:VA;2) 2.98150E+02 -15106.9; 6.00000E+03 N REF103 ! PARAMETER G(BCC_A2,CR,CU:VA;0) 2.98150E+02 77107.48; 6.00000E+03 N REF96 ! PARAMETER G(BCC_A2,CR,MG:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N REF83 ! PARAMETER G(BCC_A2,CR,MN:VA;0) 2.98150E+02 -20328+18.7339*T; 6.00000E+03 N REF2 ! PARAMETER G(BCC_A2,CR,MN:VA;1) 2.98150E+02 -9162+4.4183*T; 6.00000E+03 N REF2 ! PARAMETER TC(BCC_A2,CR,MN:VA;0) 2.98150E+02 -1325; 6.00000E+03 N REF2 ! PARAMETER TC(BCC_A2,CR,MN:VA;2) 2.98150E+02 -1133; 6.00000E+03 N REF2 ! PARAMETER TC(BCC_A2,CR,MN:VA;4) 2.98150E+02 -10294; 6.00000E+03 N REF2 ! PARAMETER TC(BCC_A2,CR,MN:VA;6) 2.98150E+02 26706; 6.00000E+03 N REF2 ! PARAMETER TC(BCC_A2,CR,MN:VA;8) 2.98150E+02 -28117; 6.00000E+03 N REF2 ! PARAMETER BMAGN(BCC_A2,CR,MN:VA;0) 2.98150E+02 .48643; 6.00000E+03 N REF2 ! PARAMETER BMAGN(BCC_A2,CR,MN:VA;2) 2.98150E+02 -.72035; 6.00000E+03 N REF2 ! PARAMETER BMAGN(BCC_A2,CR,MN:VA;4) 2.98150E+02 -1.93265; 6.00000E+03 N REF2 ! PARAMETER G(BCC_A2,CR,SI:VA;0) 2.98150E+02 -104537.94+10.69527*T; 6.00000E+03 N REF91 ! PARAMETER G(BCC_A2,CR,SI:VA;1) 2.98150E+02 -47614.7+12.17363*T; 6.00000E+03 N REF91 ! PARAMETER G(BCC_A2,CR,TI:VA;0) 2.98150E+02 19100; 6.00000E+03 N REF72 ! PARAMETER G(BCC_A2,CR,TI:VA;1) 2.98150E+02 5500; 6.00000E+03 N REF72 ! PARAMETER G(BCC_A2,CR,TI:VA;2) 2.98150E+02 1750; 6.00000E+03 N REF72 ! PARAMETER G(BCC_A2,CR,ZN:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N REF83 ! PARAMETER G(BCC_A2,CR,ZR:VA;0) 2.98150E+02 +16555.47+4.92028*T; 6.00000E+03 N REF98 ! PARAMETER G(BCC_A2,CR,ZR:VA;1) 2.98150E+02 11365.57; 6.00000E+03 N REF98 ! PARAMETER G(BCC_A2,CU,FE:VA;0) 2.98150E+02 +39257.976-4.1498304*T; 6.00000E+03 N REF85 ! PARAMETER G(BCC_A2,CU,LI:VA;0) 2.98150E+02 50000; 6.00000E+03 N REF74 ! PARAMETER G(BCC_A2,CU,MG:VA;0) 2.98150E+02 20000; 6.00000E+03 N REF20 ! PARAMETER G(BCC_A2,CU,ZR:VA;0) 2.98150E+02 -7381.13; 6.00000E+03 N REF125 ! PARAMETER G(BCC_A2,FE,MG:VA;0) 2.98150E+02 65700; 6.00000E+03 N REF29 ! PARAMETER G(BCC_A2,FE,MN:VA;0) 2.98150E+02 -2759+1.237*T; 6.00000E+03 N REF6 ! PARAMETER TC(BCC_A2,FE,MN:VA;0) 2.98150E+02 123; 6.00000E+03 N REF6 ! PARAMETER G(BCC_A2,LI,MG:VA;0) 2.98150E+02 -18335+8.49*T; 6.00000E+03 N REF105 ! PARAMETER G(BCC_A2,LI,MG:VA;1) 2.98150E+02 3481; 6.00000E+03 N REF105 ! PARAMETER G(BCC_A2,LI,MG:VA;2) 2.98150E+02 +2658-.114*T; 6.00000E+03 N REF105 ! PARAMETER G(BCC_A2,LI,ZR:VA;0) 2.98150E+02 100000; 6.00000E+03 N REF74 ! PARAMETER G(BCC_A2,MG,MN:VA;0) 2.98150E+02 70000; 6.00000E+03 N REF29 ! PARAMETER G(BCC_A2,MG,Y:VA;0) 2.98150E+02 -38570+15*T; 6.00000E+03 N REF64 ! PARAMETER G(BCC_A2,MG,Y:VA;1) 2.98150E+02 -8204.21; 6.00000E+03 N REF64 ! PARAMETER G(BCC_A2,MG,ZR:VA;0) 2.98150E+02 +5720.44+50.11642*T; 6.00000E+03 N REF68 ! PARAMETER G(BCC_A2,MN,SI:VA;0) 2.98150E+02 -89620.7+2.94097*T; 6.00000E+03 N REF29 ! PARAMETER G(BCC_A2,MN,SI:VA;1) 2.98150E+02 -7500; 6.00000E+03 N REF29 ! PARAMETER G(BCC_A2,MN,TI:VA;0) 2.98150E+02 -23200+20*T; 6.00000E+03 N REF72 ! PARAMETER G(BCC_A2,MN,TI:VA;1) 2.98150E+02 -1000; 6.00000E+03 N REF72 ! PARAMETER G(BCC_A2,SI,TI:VA;0) 2.98150E+02 -275629.1+42.5094*T; 6.00000E+03 N REF123 ! PARAMETER G(BCC_A2,SI,TI:VA;1) 2.98150E+02 +25025.35-2.00203*T; 6.00000E+03 N REF123 ! PARAMETER G(BCC_A2,SI,TI:VA;2) 2.98150E+02 +83940.65-6.71526*T; 6.00000E+03 N REF123 ! PARAMETER G(BCC_A2,SI,V:VA;0) 2.98150E+02 -164505+30.1*T; 6.00000E+03 N REF117 ! PARAMETER G(BCC_A2,SI,V:VA;1) 2.98150E+02 37000; 6.00000E+03 N REF117 ! PARAMETER G(BCC_A2,SI,V:VA;2) 2.98150E+02 20000; 6.00000E+03 N REF117 ! PARAMETER G(BCC_A2,SI,Y:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N REF66 ! PARAMETER G(BCC_A2,SI,ZR:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N REF100 ! PARAMETER G(BCC_A2,SN,TI:VA;0) 2.98150E+02 -115000+6.77583*T; 3.00000E+03 N REF39 ! PARAMETER G(BCC_A2,SN,TI:VA;1) 2.98150E+02 +45000+1.58018*T; 3.00000E+03 N REF39 ! PARAMETER G(BCC_A2,TI,V:VA;0) 2.98150E+02 +10500-1.5*T; 6.00000E+03 N REF13 ! PARAMETER G(BCC_A2,TI,V:VA;1) 2.98150E+02 2000; 6.00000E+03 N REF13 ! PARAMETER G(BCC_A2,TI,V:VA;2) 2.98150E+02 1000; 6.00000E+03 N REF13 ! TYPE_DEFINITION ' GES A_P_D BCC_B2 MAGNETIC -1.0 4.00000E-01 ! PHASE BCC_B2 %' 2 .5 .5 ! CONSTITUENT BCC_B2 :AL,CU,FE,SI,ZN : AL,CU,FE,SI,ZN : ! PARAMETER G(BCC_B2,AL:AL;0) 2.98150E+02 +GBCCAL#; 6.00000E+03 N REF1 ! PARAMETER G(BCC_B2,CU:AL;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_B2,FE:AL;0) 2.98150E+02 -2*ALFEW1#+.5*GHSERFE# +.5*GBCCAL#+LALFEB0#; 6.00000E+03 N REF76 ! PARAMETER TC(BCC_B2,FE:AL;0) 2.98150E+02 521.5; 6.00000E+03 N REF76 ! PARAMETER BMAGN(BCC_B2,FE:AL;0) 2.98150E+02 1.11; 6.00000E+03 N REF76 ! PARAMETER G(BCC_B2,SI:AL;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_B2,ZN:AL;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_B2,AL:CU;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_B2,CU:CU;0) 2.98150E+02 +GBCCCU#; 6.00000E+03 N REF70 ! PARAMETER G(BCC_B2,FE:CU;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_B2,SI:CU;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_B2,ZN:CU;0) 2.98150E+02 +.25*CUZNL0#+CUZNP1#+.5*GBCCCU# +.5*GBCCZN#; 6.00000E+03 N REF70 ! PARAMETER G(BCC_B2,AL:FE;0) 2.98150E+02 -2*ALFEW1#+.5*GHSERFE# +.5*GBCCAL#+LALFEB0#; 6.00000E+03 N REF76 ! PARAMETER TC(BCC_B2,AL:FE;0) 2.98150E+02 521.5; 6.00000E+03 N REF76 ! PARAMETER BMAGN(BCC_B2,AL:FE;0) 2.98150E+02 1.11; 6.00000E+03 N REF76 ! PARAMETER G(BCC_B2,CU:FE;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_B2,FE:FE;0) 2.98150E+02 +GHSERFE#; 6.00000E+03 N REF1 ! PARAMETER TC(BCC_B2,FE:FE;0) 2.98150E+02 1043; 6.00000E+03 N REF1 ! PARAMETER BMAGN(BCC_B2,FE:FE;0) 2.98150E+02 2.22; 6.00000E+03 N REF1 ! PARAMETER G(BCC_B2,SI:FE;0) 2.98150E+02 -2*FESIW1#+.5*GHSERFE# +.5*GBCCSI#+FESIL0#; 6.00000E+03 N REF26 ! PARAMETER TC(BCC_B2,SI:FE;0) 2.98150E+02 521.5; 6.00000E+03 N REF26 ! PARAMETER BMAGN(BCC_B2,SI:FE;0) 2.98150E+02 1.11; 6.00000E+03 N REF26 ! PARAMETER G(BCC_B2,ZN:FE;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_B2,AL:SI;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_B2,CU:SI;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_B2,FE:SI;0) 2.98150E+02 -2*FESIW1#+.5*GHSERFE# +.5*GBCCSI#+FESIL0#; 6.00000E+03 N REF26 ! PARAMETER TC(BCC_B2,FE:SI;0) 2.98150E+02 521.5; 6.00000E+03 N REF26 ! PARAMETER BMAGN(BCC_B2,FE:SI;0) 2.98150E+02 1.11; 6.00000E+03 N REF26 ! PARAMETER G(BCC_B2,SI:SI;0) 2.98150E+02 +GBCCSI#; 6.00000E+03 N REF1 ! PARAMETER G(BCC_B2,ZN:SI;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_B2,AL:ZN;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_B2,CU:ZN;0) 2.98150E+02 +.25*CUZNL0#+CUZNP1#+.5*GBCCCU# +.5*GBCCZN#; 6.00000E+03 N REF70 ! PARAMETER G(BCC_B2,FE:ZN;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_B2,SI:ZN;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(BCC_B2,ZN:ZN;0) 2.98150E+02 +GBCCZN#; 6.00000E+03 N REF70 ! PARAMETER G(BCC_B2,AL,FE:AL;0) 2.98150E+02 +LALFEB0#+3*LALFEB1#; 6.00000E+03 N REF76 ! PARAMETER G(BCC_B2,AL,FE:AL;1) 2.98150E+02 +LALFEB1#; 6.00000E+03 N REF76 ! PARAMETER TC(BCC_B2,AL,FE:AL;0) 2.98150E+02 189; 6.00000E+03 N REF76 ! PARAMETER TC(BCC_B2,AL,FE:AL;1) 2.98150E+02 63; 6.00000E+03 N REF76 ! PARAMETER G(BCC_B2,AL:AL,FE;0) 2.98150E+02 +LALFEB0#+3*LALFEB1#; 6.00000E+03 N REF76 ! PARAMETER G(BCC_B2,AL:AL,FE;1) 2.98150E+02 +LALFEB1#; 6.00000E+03 N REF76 ! PARAMETER TC(BCC_B2,AL:AL,FE;0) 2.98150E+02 189; 6.00000E+03 N REF76 ! PARAMETER TC(BCC_B2,AL:AL,FE;1) 2.98150E+02 63; 6.00000E+03 N REF76 ! PARAMETER G(BCC_B2,FE:AL,FE;0) 2.98150E+02 +LALFEB0#-3*LALFEB1#; 6.00000E+03 N REF76 ! PARAMETER G(BCC_B2,FE:AL,FE;1) 2.98150E+02 +LALFEB1#; 6.00000E+03 N REF76 ! PARAMETER TC(BCC_B2,FE:AL,FE;0) 2.98150E+02 -189; 6.00000E+03 N REF76 ! PARAMETER TC(BCC_B2,FE:AL,FE;1) 2.98150E+02 63; 6.00000E+03 N REF76 ! PARAMETER G(BCC_B2,CU,ZN:CU;0) 2.98150E+02 +.25*CUZNL0#+.375*CUZNL1# +.1875*CUZNL2#+CUZNP2#; 6.00000E+03 N REF70 ! PARAMETER G(BCC_B2,CU,ZN:CU;1) 2.98150E+02 +.125*CUZNL1#+.25*CUZNL2#; 6.00000E+03 N REF70 ! PARAMETER G(BCC_B2,CU,ZN:CU;2) 2.98150E+02 +.0625*CUZNL2#; 6.00000E+03 N REF70 ! PARAMETER G(BCC_B2,CU,ZN:CU,ZN;0) 2.98150E+02 -1.5*CUZNL2#; 6.00000E+03 N REF70 ! PARAMETER G(BCC_B2,CU:CU,ZN;0) 2.98150E+02 +.25*CUZNL0#+.375*CUZNL1# +.1875*CUZNL2#+CUZNP2#; 6.00000E+03 N REF70 ! PARAMETER G(BCC_B2,CU:CU,ZN;1) 2.98150E+02 +.125*CUZNL1#+.25*CUZNL2#; 6.00000E+03 N REF70 ! PARAMETER G(BCC_B2,CU:CU,ZN;2) 2.98150E+02 +.0625*CUZNL2#; 6.00000E+03 N REF70 ! PARAMETER G(BCC_B2,ZN:CU,ZN;0) 2.98150E+02 +.25*CUZNL0#-.375*CUZNL1# +.1875*CUZNL2#+CUZNP2#; 6.00000E+03 N REF70 ! PARAMETER G(BCC_B2,ZN:CU,ZN;1) 2.98150E+02 +.125*CUZNL1#-.25*CUZNL2#; 6.00000E+03 N REF70 ! PARAMETER G(BCC_B2,ZN:CU,ZN;2) 2.98150E+02 +.0625*CUZNL2#; 6.00000E+03 N REF70 ! PARAMETER G(BCC_B2,AL,FE:FE;0) 2.98150E+02 +LALFEB0#-3*LALFEB1#; 6.00000E+03 N REF76 ! PARAMETER G(BCC_B2,AL,FE:FE;1) 2.98150E+02 +LALFEB1#; 6.00000E+03 N REF76 ! PARAMETER TC(BCC_B2,AL,FE:FE;0) 2.98150E+02 -189; 6.00000E+03 N REF76 ! PARAMETER TC(BCC_B2,AL,FE:FE;1) 2.98150E+02 63; 6.00000E+03 N REF76 ! PARAMETER G(BCC_B2,FE,SI:FE;0) 2.98150E+02 +FESIL0#+3*FESIL1#+3*FESIL2#; 6.00000E+03 N REF26 ! PARAMETER G(BCC_B2,FE,SI:FE;1) 2.98150E+02 +FESIL1#+4*FESIL2#; 6.00000E+03 N REF26 ! PARAMETER G(BCC_B2,FE,SI:FE;2) 2.98150E+02 +FESIL2#; 6.00000E+03 N REF26 ! PARAMETER TC(BCC_B2,FE,SI:FE;0) 2.98150E+02 +3*ETCFESI#; 6.00000E+03 N REF26 ! PARAMETER TC(BCC_B2,FE,SI:FE;1) 2.98150E+02 +ETCFESI#; 6.00000E+03 N REF26 ! PARAMETER G(BCC_B2,FE,SI:FE,SI;0) 2.98150E+02 -24*FESIL2#; 6.00000E+03 N REF26 ! PARAMETER G(BCC_B2,FE:FE,SI;0) 2.98150E+02 +FESIL0#+3*FESIL1#+3*FESIL2#; 6.00000E+03 N REF26 ! PARAMETER G(BCC_B2,FE:FE,SI;1) 2.98150E+02 +FESIL1#+4*FESIL2#; 6.00000E+03 N REF26 ! PARAMETER G(BCC_B2,FE:FE,SI;2) 2.98150E+02 +FESIL2#; 6.00000E+03 N REF26 ! PARAMETER TC(BCC_B2,FE:FE,SI;0) 2.98150E+02 +3*ETCFESI#; 6.00000E+03 N REF26 ! PARAMETER TC(BCC_B2,FE:FE,SI;1) 2.98150E+02 +ETCFESI#; 6.00000E+03 N REF26 ! PARAMETER G(BCC_B2,SI:FE,SI;0) 2.98150E+02 +FESIL0#-3*FESIL1#+3*FESIL2#; 6.00000E+03 N REF26 ! PARAMETER G(BCC_B2,SI:FE,SI;1) 2.98150E+02 +FESIL1#-4*FESIL2#; 6.00000E+03 N REF26 ! PARAMETER G(BCC_B2,SI:FE,SI;2) 2.98150E+02 +FESIL2#; 6.00000E+03 N REF26 ! PARAMETER TC(BCC_B2,SI:FE,SI;0) 2.98150E+02 -3*ETCFESI#; 6.00000E+03 N REF26 ! PARAMETER TC(BCC_B2,SI:FE,SI;1) 2.98150E+02 +ETCFESI#; 6.00000E+03 N REF26 ! PARAMETER G(BCC_B2,FE,SI:SI;0) 2.98150E+02 +FESIL0#-3*FESIL1#+3*FESIL2#; 6.00000E+03 N REF26 ! PARAMETER G(BCC_B2,FE,SI:SI;1) 2.98150E+02 +FESIL1#-4*FESIL2#; 6.00000E+03 N REF26 ! PARAMETER G(BCC_B2,FE,SI:SI;2) 2.98150E+02 +FESIL2#; 6.00000E+03 N REF26 ! PARAMETER TC(BCC_B2,FE,SI:SI;0) 2.98150E+02 -3*ETCFESI#; 6.00000E+03 N REF26 ! PARAMETER TC(BCC_B2,FE,SI:SI;1) 2.98150E+02 +ETCFESI#; 6.00000E+03 N REF26 ! PARAMETER G(BCC_B2,CU,ZN:ZN;0) 2.98150E+02 +.25*CUZNL0#-.375*CUZNL1# +.1875*CUZNL2#+CUZNP2#; 6.00000E+03 N REF70 ! PARAMETER G(BCC_B2,CU,ZN:ZN;1) 2.98150E+02 +.125*CUZNL1#-.25*CUZNL2#; 6.00000E+03 N REF70 ! PARAMETER G(BCC_B2,CU,ZN:ZN;2) 2.98150E+02 +.0625*CUZNL2#; 6.00000E+03 N REF70 ! PHASE BCT_A5 % 1 1.0 ! CONSTITUENT BCT_A5 :AL,SN,ZN : ! PARAMETER G(BCT_A5,AL;0) 2.98150E+02 +10083-4.813*T+GHSERAL#; 6.00000E+03 N REF1 ! PARAMETER G(BCT_A5,SN;0) 2.98150E+02 +GHSERSN#; 6.00000E+03 N REF1 ! PARAMETER G(BCT_A5,ZN;0) 2.98150E+02 +2886.96-2.5104*T+GHSERZN#; 6.00000E+03 N REF1 ! PARAMETER G(BCT_A5,AL,SN;0) 2.98150E+02 +14136.95-4.71231*T; 6.00000E+03 N REF15 ! PARAMETER G(BCT_A5,SN,ZN;0) 2.98150E+02 +6514.76+25.70957*T; 6.00000E+03 N REF107 ! PHASE BETA_RHOMBO_B % 2 93 12 ! CONSTITUENT BETA_RHOMBO_B :B : B,SI : ! PARAMETER G(BETA_RHOMBO_B,B:B;0) 2.98150E+02 +105*GHSERBB#; 6.00000E+03 N REF58 ! PARAMETER G(BETA_RHOMBO_B,B:SI;0) 2.98150E+02 -6160.245+.6160245*T +93*GHSERBB#+12*GHSERSI#; 6.00000E+03 N REF58 ! PARAMETER G(BETA_RHOMBO_B,B:B,SI;0) 2.98150E+02 -725614+72.5614*T; 6.00000E+03 N REF58 ! PHASE BETA_TIMN % 2 .515 .485 ! CONSTITUENT BETA_TIMN :MN : TI : ! PARAMETER G(BETA_TIMN,MN:TI;0) 2.98150E+02 -5540-2.29*T+.515*GHSERMN# +.485*GHSERTI#; 6.00000E+03 N REF72 ! PHASE BN_HP4 % 2 1 1 ! CONSTITUENT BN_HP4 :B : N : ! PARAMETER G(BN_HP4,B:N;0) 2.98150E+02 -250600+91.281942*T+GHSERBB# +GHSERNN#; 6.00000E+03 N REF56 ! PHASE BTI % 2 1 1 ! CONSTITUENT BTI :B : TI : ! PARAMETER G(BTI,B:TI;0) 2.98150E+02 -166196.8+3.2968*T+GHSERBB# +GHSERTI#; 6.00000E+03 N REF89 ! PHASE B_NSI % 3 61 1 8 ! CONSTITUENT B_NSI :B : SI : B,SI : ! PARAMETER G(B_NSI,B:SI:B;0) 2.98150E+02 -89819.86+8.981986*T +69*GHSERBB#+GHSERSI#; 6.00000E+03 N REF58 ! PARAMETER G(B_NSI,B:SI:SI;0) 2.98150E+02 -176659.7+17.66597*T +61*GHSERBB#+9*GHSERSI#; 6.00000E+03 N REF58 ! PARAMETER G(B_NSI,B:SI:B,SI;0) 2.98150E+02 -281573.6+28.15736*T; 6.00000E+03 N REF58 ! TYPE_DEFINITION ( GES A_P_D CBCC_A12 MAGNETIC -3.0 2.80000E-01 ! PHASE CBCC_A12 %( 2 1 1 ! CONSTITUENT CBCC_A12 :AL,CR,FE,MG,MN,SI,TI : VA : ! PARAMETER G(CBCC_A12,AL:VA;0) 2.98150E+02 +10083-4.813*T+GHSERAL#; 6.00000E+03 N REF1 ! PARAMETER G(CBCC_A12,CR:VA;0) 2.98150E+02 +11087+2.7196*T+GHSERCR#; 6.00000E+03 N REF1 ! PARAMETER G(CBCC_A12,FE:VA;0) 2.98150E+02 +4745+GHSERFE#; 6.00000E+03 N REF1 ! PARAMETER G(CBCC_A12,MG:VA;0) 2.98150E+02 +4602.4-3.011*T+GHSERMG#; 6.00000E+03 N REF1 ! PARAMETER G(CBCC_A12,MN:VA;0) 2.98150E+02 +GHSERMN#; 6.00000E+03 N REF1 ! PARAMETER TC(CBCC_A12,MN:VA;0) 2.98150E+02 -285; 6.00000E+03 N REF1 ! PARAMETER BMAGN(CBCC_A12,MN:VA;0) 2.98150E+02 -.66; 6.00000E+03 N REF1 ! PARAMETER G(CBCC_A12,SI:VA;0) 2.98150E+02 +50208-20.377*T+GHSERSI#; 6.00000E+03 N REF1 ! PARAMETER G(CBCC_A12,TI:VA;0) 2.98150E+02 +4602.2+GHSERTI#; 6.00000E+03 N REF1 ! PARAMETER G(CBCC_A12,AL,FE:VA;0) 2.98150E+02 -114000+20*T; 6.00000E+03 N REF76 ! PARAMETER G(CBCC_A12,AL,MN:VA;0) 2.98150E+02 -101410+43*T; 6.00000E+03 N REF23 ! PARAMETER G(CBCC_A12,CR,MN:VA;0) 2.98150E+02 -36796+20.385*T; 6.00000E+03 N REF2 ! PARAMETER G(CBCC_A12,FE,MG:VA;0) 2.98150E+02 70000; 6.00000E+03 N REF29 ! PARAMETER G(CBCC_A12,FE,MN:VA;0) 2.98150E+02 -10184; 6.00000E+03 N REF6 ! PARAMETER G(CBCC_A12,FE,SI:VA;0) 2.98150E+02 -156180+34.81*T; 6.00000E+03 N REF26 ! PARAMETER G(CBCC_A12,FE,SI:VA;1) 2.98150E+02 -33470-.41*T; 6.00000E+03 N REF26 ! PARAMETER G(CBCC_A12,FE,SI:VA;2) 2.98150E+02 +35780-11.08*T; 6.00000E+03 N REF26 ! PARAMETER G(CBCC_A12,FE,SI:VA;3) 2.98150E+02 +28800-6.92*T; 6.00000E+03 N REF26 ! PARAMETER G(CBCC_A12,MG,MN:VA;0) 2.98150E+02 70000; 6.00000E+03 N REF29 ! PARAMETER G(CBCC_A12,MN,SI:VA;0) 2.98150E+02 -142743.62+22.3961*T; 6.00000E+03 N REF29 ! PARAMETER G(CBCC_A12,MN,SI:VA;1) 2.98150E+02 +16440.608-3.5300332*T; 6.00000E+03 N REF29 ! PARAMETER G(CBCC_A12,MN,TI:VA;0) 2.98150E+02 -29500+20*T; 6.00000E+03 N REF72 ! PARAMETER G(CBCC_A12,MN,TI:VA;1) 2.98150E+02 -3635-5*T; 6.00000E+03 N REF72 ! PHASE CE2MG17 % 2 2 17 ! CONSTITUENT CE2MG17 :CE : MG : ! PARAMETER G(CE2MG17,CE:MG;0) 2.98150E+02 -217170+104.5*T+2*GHSERCE# +17*GHSERMG#; 6.00000E+03 N REF103 ! PHASE CE5MG41 % 2 5 41 ! CONSTITUENT CE5MG41 :CE : MG : ! PARAMETER G(CE5MG41,CE:MG;0) 2.98150E+02 -575000+299*T+5*GHSERCE# +41*GHSERMG#; 6.00000E+03 N REF103 ! PHASE CE1MG1 % 2 1 1 ! CONSTITUENT CE1MG1 :CE : MG : ! PARAMETER G(CE1MG1,CE:MG;0) 2.98150E+02 -46000+23.32*T+GHSERCE#+GHSERMG#; 6.00000E+03 N REF103 ! PHASE CEMG12 % 2 1 12 ! CONSTITUENT CEMG12 :CE : MG : ! PARAMETER G(CEMG12,CE:MG;0) 2.98150E+02 -139880+84.5*T+GHSERCE# +12*GHSERMG#; 6.00000E+03 N REF103 ! PHASE CEMG2 % 2 1 2 ! CONSTITUENT CEMG2 :CE : MG : ! PARAMETER G(CEMG2,CE:MG;0) 2.98150E+02 -52744.6+15.163*T+GHSERCE# +2*GHSERMG#; 6.00000E+03 N REF103 ! PHASE CEMG3 % 2 1 3 ! CONSTITUENT CEMG3 :CE : MG : ! PARAMETER G(CEMG3,CE:MG;0) 2.98150E+02 -76800+26.5*T+GHSERCE# +3*GHSERMG#; 6.00000E+03 N REF103 ! PHASE CR2TI % 2 .645 .355 ! CONSTITUENT CR2TI :CR : TI : ! PARAMETER G(CR2TI,CR:TI;0) 298.15 UN_ASS; 300 N REF0 ! PHASE CR3MN5 % 2 3 5 ! CONSTITUENT CR3MN5 :CR : MN : ! PARAMETER G(CR3MN5,CR:MN;0) 2.98150E+02 -72550+21.1732*T+3*GHSERCR# +5*GHSERMN#; 6.00000E+03 N REF2 ! PHASE CR3SI_A15 % 2 3 1 ! CONSTITUENT CR3SI_A15 :CR,SI : CR,SI : ! PARAMETER G(CR3SI_A15,CR:CR;0) 2.98150E+02 +20000+10*T+4*GHSERCR#; 6.00000E+03 N REF91 ! PARAMETER G(CR3SI_A15,SI:CR;0) 2.98150E+02 +233507.47-74.15051*T +GHSERCR#+3*GHSERSI#; 6.00000E+03 N REF91 ! PARAMETER G(CR3SI_A15,CR:SI;0) 2.98150E+02 -126369.35+4.15051*T +3*GHSERCR#+GHSERSI#; 6.00000E+03 N REF91 ! PARAMETER G(CR3SI_A15,SI:SI;0) 2.98150E+02 +208000-80*T+4*GHSERSI#; 6.00000E+03 N REF91 ! PARAMETER G(CR3SI_A15,CR,SI:CR;0) 2.98150E+02 -107840.95; 6.00000E+03 N REF91 ! PARAMETER G(CR3SI_A15,CR:CR,SI;0) 2.98150E+02 -13020.93; 6.00000E+03 N REF91 ! PARAMETER G(CR3SI_A15,SI:CR,SI;0) 2.98150E+02 -13020.93; 6.00000E+03 N REF91 ! PARAMETER G(CR3SI_A15,CR,SI:SI;0) 2.98150E+02 -107840.95; 6.00000E+03 N REF91 ! PHASE CR5SI3 % 2 5 3 ! CONSTITUENT CR5SI3 :CR : SI : ! PARAMETER G(CR5SI3,CR:SI;0) 2.98150E+02 -316433+1065.82816*T -182.578184*T*LN(T)-.023919688*T**2-2.31728E-06*T**3; 6.00000E+03 N REF91 ! PHASE CR1SI1 % 2 1 1 ! CONSTITUENT CR1SI1 :CR : SI : ! PARAMETER G(CR1SI1,CR:SI;0) 2.98150E+02 -78732.28+311.58392*T -51.62865*T*LN(T)-.00447355*T**2+391330*T**(-1); 6.00000E+03 N REF91 ! PHASE CRSI2 % 2 1 2 ! CONSTITUENT CRSI2 :CR,SI : CR,SI : ! PARAMETER G(CRSI2,CR:CR;0) 2.98150E+02 +10000-T+3*GHSERCR#; 6.00000E+03 N REF91 ! PARAMETER G(CRSI2,SI:CR;0) 2.98150E+02 +148569.93-12.65342*T+2*GHSERCR# +GHSERSI#; 6.00000E+03 N REF91 ! PARAMETER G(CRSI2,CR:SI;0) 2.98150E+02 -96694.43+333.33835*T -57.855747*T*LN(T)-.01322769*T**2-4.3203E-07*T**3; 6.00000E+03 N REF91 ! PARAMETER G(CRSI2,SI:SI;0) 2.98150E+02 +78860.26-15.77206*T+3*GHSERSI#; 6.00000E+03 N REF91 ! PARAMETER G(CRSI2,CR:CR,SI;0) 2.98150E+02 -35879.97+7.17599*T; 6.00000E+03 N REF91 ! PARAMETER G(CRSI2,SI:CR,SI;0) 2.98150E+02 -35879.97+7.17599*T; 6.00000E+03 N REF91 ! PHASE CRZN13 % 2 1 13 ! CONSTITUENT CRZN13 :CR : ZN : ! PARAMETER G(CRZN13,CR:ZN;0) 2.98150E+02 -9800+GHSERCR#+13*GHSERZN#; 6.00000E+03 N REF83 ! PHASE CRZN17 % 2 1 17 ! CONSTITUENT CRZN17 :CR : ZN : ! PARAMETER G(CRZN17,CR:ZN;0) 2.98150E+02 -11700+GHSERCR#+17*GHSERZN#; 6.00000E+03 N REF83 ! PHASE CSI % 2 1 1 ! CONSTITUENT CSI :C : SI : ! PARAMETER G(CSI,C:SI;0) 2.98150E+02 -88583.96+271.1462*T -41.27945*T*LN(T)-.00436266*T**2+800000*T**(-1)+2E-07*T**3; 6.00000E+03 N REF60 ! PHASE CU10ZR7 % 2 10 7 ! CONSTITUENT CU10ZR7 :CU : ZR : ! PARAMETER G(CU10ZR7,CU:ZR;0) 2.98150E+02 -241750+10*GHSERCU#+7*GHSERZR#; 6.00000E+03 N REF125 ! PHASE CU19SI6_ETA % 2 19 6 ! CONSTITUENT CU19SI6_ETA :CU : SI : ! PARAMETER G(CU19SI6_ETA,CU:SI;0) 2.98150E+02 -137488.5+3119.537*T -595.1259*T*LN(T)-.0619575*T**2+2.434E-06*T**3+2057075*T**(-1); 6.00000E+03 N REF94 ! PHASE CU33SI7_DELTA % 2 33 7 ! CONSTITUENT CU33SI7_DELTA :CU : SI : ! PARAMETER G(CU33SI7_DELTA,CU:SI;0) 2.98150E+02 -200372.4+4985.675*T -955.5312*T*LN(T)-.101066*T**2+4.2396E-06*T**3+2968440*T**(-1); 6.00000E+03 N REF94 ! PHASE CU4SI_EPSILON % 2 4 1 ! CONSTITUENT CU4SI_EPSILON :CU : SI : ! PARAMETER G(CU4SI_EPSILON,CU:SI;0) 2.98150E+02 -39974.35+858.5047*T -154.6764*T*LN(T)+.01074864*T**2+5.1335E-07*T**3+386580*T**(-1); 6.00000E+03 N REF94 ! PHASE CU51ZR14 % 2 51 14 ! CONSTITUENT CU51ZR14 :CU : ZR : ! PARAMETER G(CU51ZR14,CU:ZR;0) 2.98150E+02 -843412.7+51*GHSERCU# +14*GHSERZR#; 6.00000E+03 N REF125 ! PHASE CU56SI11_GAMMA % 2 56 11 ! CONSTITUENT CU56SI11_GAMMA :CU : SI : ! PARAMETER G(CU56SI11_GAMMA,CU:SI;0) 2.98150E+02 -455415+9222.496*T -1709.412*T*LN(T)-.1698242*T**2+7.19714E-06*T**3+4882290*T**(-1); 6.00000E+03 N REF94 ! PHASE CU5ZR % 2 5 1 ! CONSTITUENT CU5ZR :CU : ZR : ! PARAMETER G(CU5ZR,CU:ZR;0) 2.98150E+02 -61794+5*GHSERCU#+GHSERZR#; 6.00000E+03 N REF125 ! PHASE CU85SI15_BETA % 2 .85 .15 ! CONSTITUENT CU85SI15_BETA :CU : SI : ! PARAMETER G(CU85SI15_BETA,CU:SI;0) 2.98150E+02 -4021.08+123.92192*T -23.920296*T*LN(T)-.00254525*T**2+1.0931E-07*T**3+71106*T**(-1); 6.00000E+03 N REF94 ! PHASE CU87SI13_KAPPA % 2 .87 .13 ! CONSTITUENT CU87SI13_KAPPA :CU : SI : ! PARAMETER G(CU87SI13_KAPPA,CU:SI;0) 2.98150E+02 -5368.51+125.36694*T -23.945909*T*LN(T)-.00256013*T**2+1.1196E-07*T**3+68623*T**(-1); 6.00000E+03 N REF94 ! PHASE CU8ZR3 % 2 8 3 ! CONSTITUENT CU8ZR3 :CU : ZR : ! PARAMETER G(CU8ZR3,CU:ZR;0) 2.98150E+02 -148063.1+8*GHSERCU#+3*GHSERZR#; 6.00000E+03 N REF125 ! PHASE CUB_A13 % 2 1 1 ! CONSTITUENT CUB_A13 :AL,CR,FE,MN,SI,TI : VA : ! PARAMETER G(CUB_A13,AL:VA;0) 2.98150E+02 +10920.44-4.8116*T+GHSERAL#; 6.00000E+03 N REF1 ! PARAMETER G(CUB_A13,CR:VA;0) 2.98150E+02 +15899+.6276*T+GHSERCR#; 6.00000E+03 N REF1 ! PARAMETER G(CUB_A13,FE:VA;0) 2.98150E+02 +3745+GHSERFE#; 6.00000E+03 N REF1 ! PARAMETER G(CUB_A13,MN:VA;0) 2.98150E+02 +2314.88+5.936*T -1.4203*T*LN(T)+.00151409*T**2+442*T**(-1)+GHSERMN#; 1.51900E+03 Y +442.65-.9715*T+2.3107229E+30*T**(-9)+GHSERMN#; 6.00000E+03 N REF1 ! PARAMETER G(CUB_A13,SI:VA;0) 2.98150E+02 +47279-20.377*T+GHSERSI#; 6.00000E+03 N REF1 ! PARAMETER G(CUB_A13,TI:VA;0) 2.98150E+02 +7531.2+GHSERTI#; 6.00000E+03 N REF1 ! PARAMETER G(CUB_A13,AL,FE,MN:VA;0) 2.98150E+02 13906; 6.00000E+03 N REF109 ! PARAMETER G(CUB_A13,AL,FE,MN:VA;1) 2.98150E+02 13906; 6.00000E+03 N REF109 ! PARAMETER G(CUB_A13,AL,FE,MN:VA;2) 2.98150E+02 13906; 6.00000E+03 N REF109 ! PARAMETER G(CUB_A13,AL,MN:VA;0) 2.98150E+02 -119022+52.507*T; 6.00000E+03 N REF23 ! PARAMETER G(CUB_A13,AL,MN:VA;1) 2.98150E+02 -1763; 6.00000E+03 N REF23 ! PARAMETER G(CUB_A13,CR,MN:VA;0) 2.98150E+02 -31260+16.4919*T; 6.00000E+03 N REF2 ! PARAMETER G(CUB_A13,FE,MN:VA;0) 2.98150E+02 -11518+2.819*T; 6.00000E+03 N REF6 ! PARAMETER G(CUB_A13,FE,SI:VA;0) 2.98150E+02 -156180+34.81*T; 6.00000E+03 N REF26 ! PARAMETER G(CUB_A13,FE,SI:VA;1) 2.98150E+02 -33470-.41*T; 6.00000E+03 N REF26 ! PARAMETER G(CUB_A13,FE,SI:VA;2) 2.98150E+02 +35780-11.08*T; 6.00000E+03 N REF26 ! PARAMETER G(CUB_A13,FE,SI:VA;3) 2.98150E+02 +28800-6.92*T; 6.00000E+03 N REF26 ! PARAMETER G(CUB_A13,MN,SI:VA;0) 2.98150E+02 -142343.62+21.89261*T; 6.00000E+03 N REF29 ! PARAMETER G(CUB_A13,MN,SI:VA;1) 2.98150E+02 +16440.608-3.5300332*T; 6.00000E+03 N REF29 ! PARAMETER G(CUB_A13,MN,TI:VA;0) 2.98150E+02 -34000+20*T; 6.00000E+03 N REF72 ! PHASE CUMG2 % 2 1 2 ! CONSTITUENT CUMG2 :CU : MG : ! PARAMETER G(CUMG2,CU:MG;0) 2.98150E+02 -28620+1.85973*T+GHSERCU# +2*GHSERMG#; 6.00000E+03 N REF20 ! PHASE CUZN_EPS % 2 1 1 ! CONSTITUENT CUZN_EPS :CU,ZN : VA : ! PARAMETER G(CUZN_EPS,CU:VA;0) 2.98150E+02 +GHSERCU#+10; 6.00000E+03 N REF70 ! PARAMETER G(CUZN_EPS,ZN:VA;0) 2.98150E+02 +GFCCZN#; 6.00000E+03 N REF70 ! PARAMETER G(CUZN_EPS,CU,ZN:VA;0) 2.98150E+02 -35433.3+5.24516*T; 6.00000E+03 N REF70 ! PARAMETER G(CUZN_EPS,CU,ZN:VA;1) 2.98150E+02 +25276.81-9.96989*T; 6.00000E+03 N REF70 ! PHASE CUZN_GAMMA % 4 .15385 .15385 .23076 .46154 ! CONSTITUENT CUZN_GAMMA :CU,ZN : CU,ZN : CU : ZN : ! PARAMETER G(CUZN_GAMMA,CU:CU:CU:ZN;0) 2.98150E+02 +CUZNK4# +.15385*CUZNK5#+.53846*GHSERCU#+.46154*GHSERZN#; 6.00000E+03 N REF70 ! PARAMETER G(CUZN_GAMMA,ZN:CU:CU:ZN;0) 2.98150E+02 +CUZNK4# +.15385*CUZNK5#+.15385*CUZNK6#+.38462*GHSERCU#+.61538*GHSERZN#; 6.00000E+03 N REF70 ! PARAMETER G(CUZN_GAMMA,CU:ZN:CU:ZN;0) 2.98150E+02 +CUZNK4# +.38462*GHSERCU#+.61538*GHSERZN#; 6.00000E+03 N REF70 ! PARAMETER G(CUZN_GAMMA,ZN:ZN:CU:ZN;0) 2.98150E+02 +CUZNK4# +.15385*CUZNK6#+.23076*GHSERCU#+.76924*GHSERZN#; 6.00000E+03 N REF70 ! PHASE CU1ZR1 % 2 1 1 ! CONSTITUENT CU1ZR1 :CU : ZR : ! PARAMETER G(CU1ZR1,CU:ZR;0) 2.98150E+02 -20104.24-7.63196*T+GHSERCU# +GHSERZR#; 6.00000E+03 N REF125 ! PHASE CU1ZR2 % 2 1 2 ! CONSTITUENT CU1ZR2 :CU : ZR : ! PARAMETER G(CU1ZR2,CU:ZR;0) 2.98150E+02 -43904.01+5.19051*T+GHSERCU# +2*GHSERZR#; 6.00000E+03 N REF125 ! PHASE DHCP % 1 1.0 ! CONSTITUENT DHCP :CE,ND : ! PARAMETER G(DHCP,CE;0) 2.98150E+02 -190+.56886*T+GHSERCE#; 6.00000E+03 N REF1 ! PARAMETER G(DHCP,ND;0) 2.98150E+02 +GHSERND#; 6.00000E+03 N REF1 ! PHASE DIAMOND_A4 % 1 1.0 ! CONSTITUENT DIAMOND_A4 :AL,B,C,SI%,SN,TI,ZN : ! PARAMETER G(DIAMOND_A4,AL;0) 2.98150E+02 +30*T+GHSERAL#; 6.00000E+03 N REF1 ! PARAMETER G(DIAMOND_A4,B;0) 2.98150E+02 +GHSERBB#; 6.00000E+03 N REF1 ! PARAMETER G(DIAMOND_A4,C;0) 2.98150E+02 -16359.441+175.61*T -24.31*T*LN(T)-4.723E-04*T**2+2698000*T**(-1)-2.61E+08*T**(-2) +1.11E+10*T**(-3); 6.00000E+03 N REF1 ! PARAMETER G(DIAMOND_A4,SI;0) 2.98150E+02 +GHSERSI#; 6.00000E+03 N REF1 ! PARAMETER G(DIAMOND_A4,SN;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(DIAMOND_A4,TI;0) 2.98150E+02 +25000+GHSERTI#; 6.00000E+03 N REF1 ! PARAMETER G(DIAMOND_A4,ZN;0) 2.98150E+02 +30*T+GHSERZN#; 6.00000E+03 N REF1 ! PARAMETER G(DIAMOND_A4,AL,SI;0) 2.98150E+02 +111417.7-46.1392*T; 6.00000E+03 N REF50 ! PARAMETER G(DIAMOND_A4,AL,ZN;0) 2.98150E+02 +80*T; 6.00000E+03 N REF129 ! PARAMETER G(DIAMOND_A4,B,SI;0) 2.98150E+02 57978.16; 6.00000E+03 N REF58 ! PARAMETER G(DIAMOND_A4,C,SI;0) 2.98150E+02 93386.78; 6.00000E+03 N REF60 ! PARAMETER G(DIAMOND_A4,SI,SN;0) 2.98150E+02 +25265.65+23.84*T; 3.00000E+03 N REF94 ! PARAMETER G(DIAMOND_A4,SI,TI;0) 2.98150E+02 +80*T; 6.00000E+03 N REF123 ! PARAMETER G(DIAMOND_A4,SI,ZN;0) 2.98150E+02 +100*T; 6.00000E+03 N REF94 ! TYPE_DEFINITION ) GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! PHASE FCC_A1 %) 2 1 1 ! CONSTITUENT FCC_A1 :AL%,B,CE,CR,CU%,FE%,LI,MG,MN,ND,NI,SI,SN,TI,V,Y,ZN, ZR : C,N,VA% : ! PARAMETER G(FCC_A1,AL:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,B:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,CE:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,CR:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,CU:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,FE:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,LI:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,MG:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,MN:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,ND:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,NI:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,SI:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,SN:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,TI:C;0) 2.98150E+02 +GHSERTIC#; 6.00000E+03 N REF111 ! PARAMETER G(FCC_A1,V:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,Y:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,ZN:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,ZR:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,AL:N;0) 2.98150E+02 +80*T; 6.00000E+03 N REF129 ! PARAMETER G(FCC_A1,B:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,CE:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,CR:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,CU:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,FE:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,LI:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,MG:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,MN:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,ND:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,NI:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,SI:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,SN:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,TI:N;0) 2.98150E+02 +GHSERTIN#; 6.00000E+03 N REF111 ! PARAMETER G(FCC_A1,V:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,Y:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,ZN:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,ZR:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,AL:VA;0) 2.98150E+02 +GHSERAL#; 6.00000E+03 N REF1 ! PARAMETER G(FCC_A1,B:VA;0) 2.98150E+02 +43514-12.217*T+GHSERBB#; 6.00000E+03 N REF1 ! PARAMETER G(FCC_A1,CE:VA;0) 2.98150E+02 +GHSERCE#; 6.00000E+03 N REF1 ! PARAMETER G(FCC_A1,CR:VA;0) 2.98150E+02 +7284+.163*T+GHSERCR#; 6.00000E+03 N REF1 ! PARAMETER TC(FCC_A1,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N REF1 ! PARAMETER BMAGN(FCC_A1,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N REF1 ! PARAMETER G(FCC_A1,CU:VA;0) 2.98150E+02 +GHSERCU#; 6.00000E+03 N REF1 ! PARAMETER G(FCC_A1,FE:VA;0) 2.98150E+02 -236.7+132.416*T -24.6643*T*LN(T)-.00375752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y -27097.396+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6.00000E+03 N REF1 ! PARAMETER TC(FCC_A1,FE:VA;0) 2.98150E+02 -201; 6.00000E+03 N REF1 ! PARAMETER BMAGN(FCC_A1,FE:VA;0) 2.98150E+02 -2.1; 6.00000E+03 N REF1 ! PARAMETER G(FCC_A1,LI:VA;0) 2.98150E+02 -108+1.3*T+GHSERLI#; 6.00000E+03 N REF1 ! PARAMETER G(FCC_A1,MG:VA;0) 2.98150E+02 +2600-.9*T+GHSERMG#; 6.00000E+03 N REF1 ! PARAMETER G(FCC_A1,MN:VA;0) 2.98150E+02 -3439.3+131.884*T -24.5177*T*LN(T)-.006*T**2+69600*T**(-1); 1.51900E+03 Y -26070.1+309.6664*T-48*T*LN(T)+3.86196E+30*T**(-9); 6.00000E+03 N REF1 ! PARAMETER TC(FCC_A1,MN:VA;0) 2.98150E+02 -1620; 6.00000E+03 N REF1 ! PARAMETER BMAGN(FCC_A1,MN:VA;0) 2.98150E+02 -1.86; 6.00000E+03 N REF1 ! PARAMETER G(FCC_A1,ND:VA;0) 2.98150E+02 +500+GHSERND#; 6.00000E+03 N REF1 ! PARAMETER G(FCC_A1,NI:VA;0) 2.98150E+02 +GHSERNI#; 6.00000E+03 N REF1 ! PARAMETER TC(FCC_A1,NI:VA;0) 2.98150E+02 633; 6.00000E+03 N REF1 ! PARAMETER BMAGN(FCC_A1,NI:VA;0) 2.98150E+02 .52; 6.00000E+03 N REF1 ! PARAMETER G(FCC_A1,SI:VA;0) 2.98150E+02 +51000-21.8*T+GHSERSI#; 6.00000E+03 N REF1 ! PARAMETER G(FCC_A1,SN:VA;0) 2.98150E+02 +5510-8.46*T+GHSERSN#; 6.00000E+03 N REF1 ! PARAMETER G(FCC_A1,TI:VA;0) 2.98150E+02 +6000-.1*T+GHSERTI#; 6.00000E+03 N REF1 ! PARAMETER G(FCC_A1,V:VA;0) 2.98150E+02 +7500+1.7*T+GHSERV#; 6.00000E+03 N REF1 ! PARAMETER G(FCC_A1,Y:VA;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(FCC_A1,ZN:VA;0) 2.98150E+02 +2969.82-1.56968*T+GHSERZN#; 6.00000E+03 N REF1 ! PARAMETER G(FCC_A1,ZR:VA;0) 2.98150E+02 +7600-.9*T+GHSERZR#; 6.00000E+03 N REF1 ! PARAMETER G(FCC_A1,AL:C,VA;0) 2.98150E+02 +80*T; 6.00000E+03 N REF46 ! PARAMETER G(FCC_A1,TI:C,VA;0) 2.98150E+02 -85115+6.756*T; 6.00000E+03 N REF111 ! PARAMETER G(FCC_A1,TI:C,VA;1) 2.98150E+02 -129429+31.79*T; 6.00000E+03 N REF111 ! PARAMETER G(FCC_A1,TI:N,VA;0) 2.98150E+02 -47739; 6.00000E+03 N REF111 ! PARAMETER G(FCC_A1,TI:N,VA;1) 2.98150E+02 -9877; 6.00000E+03 N REF111 ! PARAMETER G(FCC_A1,AL,B:VA;0) 2.98150E+02 +12242.44-1.74891*T; 6.00000E+03 N REF44 ! PARAMETER G(FCC_A1,AL,CE:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N REF129 ! PARAMETER G(FCC_A1,AL,CR:VA;0) 2.98150E+02 -45900+6*T; 6.00000E+03 N REF8 ! PARAMETER G(FCC_A1,AL,CU:VA;0) 2.98150E+02 -53520+2*T; 6.00000E+03 N REF72 ! PARAMETER G(FCC_A1,AL,CU:VA;1) 2.98150E+02 +38590-2*T; 6.00000E+03 N REF72 ! PARAMETER G(FCC_A1,AL,CU:VA;2) 2.98150E+02 1170; 6.00000E+03 N REF72 ! PARAMETER G(FCC_A1,AL,FE:VA;0) 2.98150E+02 -76066.1+18.6758*T; 6.00000E+03 N REF76 ! PARAMETER G(FCC_A1,AL,FE:VA;1) 2.98150E+02 +21167.4+1.3398*T; 6.00000E+03 N REF76 ! PARAMETER G(FCC_A1,AL,FE,MN:VA;1) 2.98150E+02 -63652; 6.00000E+03 N REF109 ! PARAMETER G(FCC_A1,AL,FE,MN:VA;2) 2.98150E+02 -26753; 6.00000E+03 N REF109 ! PARAMETER G(FCC_A1,AL,LI:VA;0) 2.98150E+02 -27000+8*T; 6.00000E+03 N REF105 ! PARAMETER G(FCC_A1,AL,LI:VA;1) 2.98150E+02 1E-06; 6.00000E+03 N REF105 ! PARAMETER G(FCC_A1,AL,LI:VA;2) 2.98150E+02 +3000+T; 6.00000E+03 N REF105 ! PARAMETER G(FCC_A1,AL,LI,MG:VA;0) 2.98150E+02 -63650+50*T; 6.00000E+03 N REF105 ! PARAMETER G(FCC_A1,AL,MG:VA;0) 2.98150E+02 +4971-3.5*T; 6.00000E+03 N REF11 ! PARAMETER G(FCC_A1,AL,MG:VA;1) 2.98150E+02 +900+.423*T; 6.00000E+03 N REF11 ! PARAMETER G(FCC_A1,AL,MG:VA;2) 2.98150E+02 950; 6.00000E+03 N REF11 ! PARAMETER G(FCC_A1,AL,MN:VA;0) 2.98150E+02 -69300+25*T; 6.00000E+03 N REF23 ! PARAMETER G(FCC_A1,AL,MN:VA;1) 2.98150E+02 8800; 6.00000E+03 N REF23 ! PARAMETER G(FCC_A1,AL,SI:VA;0) 2.98150E+02 -3423.91-.09584*T; 6.00000E+03 N REF50 ! PARAMETER G(FCC_A1,AL,SN:VA;0) 2.98150E+02 +45297.84-8.39814*T; 6.00000E+03 N REF15 ! PARAMETER G(FCC_A1,AL,TI:VA;0) 2.98150E+02 -128970+39*T; 6.00000E+03 N REF13 ! PARAMETER G(FCC_A1,AL,TI:VA;1) 2.98150E+02 -5000; 6.00000E+03 N REF13 ! PARAMETER G(FCC_A1,AL,TI:VA;2) 2.98150E+02 20000; 6.00000E+03 N REF13 ! PARAMETER G(FCC_A1,AL,V:VA;0) 2.98150E+02 -69800+15*T; 6.00000E+03 N REF13 ! PARAMETER G(FCC_A1,AL,V:VA;1) 2.98150E+02 -8000; 6.00000E+03 N REF13 ! PARAMETER G(FCC_A1,AL,Y:VA;0) 2.98150E+02 +90*T; 6.00000E+03 N REF52 ! PARAMETER G(FCC_A1,AL,ZN:VA;0) 2.98150E+02 +7297.48+.47512*T; 6.00000E+03 N REF78 ! PARAMETER G(FCC_A1,AL,ZN:VA;1) 2.98150E+02 +6612.88-4.5911*T; 6.00000E+03 N REF78 ! PARAMETER G(FCC_A1,AL,ZN:VA;2) 2.98150E+02 -3097.19+3.30635*T; 6.00000E+03 N REF78 ! PARAMETER G(FCC_A1,AL,ZR:VA;0) 2.98150E+02 -120000+30*T; 6.00000E+03 N REF74 ! PARAMETER G(FCC_A1,AL,ZR:VA;1) 2.98150E+02 -10000; 6.00000E+03 N REF74 ! PARAMETER G(FCC_A1,AL,ZR:VA;2) 2.98150E+02 15000; 6.00000E+03 N REF74 ! PARAMETER G(FCC_A1,CE,MG:VA;0) 2.98150E+02 -15000+.5*T; 6.00000E+03 N REF103 ! PARAMETER G(FCC_A1,CR,CU:VA;0) 2.98150E+02 +53195.87-3.31182*T; 6.00000E+03 N REF96 ! PARAMETER G(FCC_A1,CR,MN:VA;0) 2.98150E+02 -19088+17.5423*T; 6.00000E+03 N REF2 ! PARAMETER G(FCC_A1,CR,TI:VA;0) 2.98150E+02 +66300-27.7*T; 6.00000E+03 N REF72 ! PARAMETER G(FCC_A1,CU,FE:VA;0) 2.98150E+02 +48232.565-8.6095425*T; 6.00000E+03 N REF85 ! PARAMETER G(FCC_A1,CU,FE:VA;1) 2.98150E+02 +8861.8816-5.2897513*T; 6.00000E+03 N REF85 ! PARAMETER G(FCC_A1,CU,LI:VA;0) 2.98150E+02 +2750+13*T; 6.00000E+03 N REF74 ! PARAMETER G(FCC_A1,CU,LI:VA;1) 2.98150E+02 -1000; 6.00000E+03 N REF74 ! PARAMETER G(FCC_A1,CU,MG:VA;0) 2.98150E+02 -22279.28+5.868*T; 6.00000E+03 N REF20 ! PARAMETER G(FCC_A1,CU,NI:VA;0) 2.98150E+02 +8047.72+3.42217*T; 6.00000E+03 N REF31 ! PARAMETER G(FCC_A1,CU,NI:VA;1) 2.98150E+02 -2041.3+.99714*T; 6.00000E+03 N REF31 ! PARAMETER TC(FCC_A1,CU,NI:VA;0) 2.98150E+02 -935.5; 6.00000E+03 N REF31 ! PARAMETER TC(FCC_A1,CU,NI:VA;1) 2.98150E+02 -594.9; 6.00000E+03 N REF31 ! PARAMETER BMAGN(FCC_A1,CU,NI:VA;0) 2.98150E+02 .52; 6.00000E+03 N REF31 ! PARAMETER BMAGN(FCC_A1,CU,NI:VA;1) 2.98150E+02 -.7316; 6.00000E+03 N REF31 ! PARAMETER BMAGN(FCC_A1,CU,NI:VA;2) 2.98150E+02 -.3174; 6.00000E+03 N REF31 ! PARAMETER G(FCC_A1,CU,SI:VA;0) 2.98150E+02 -34105.96-1.908*T; 6.00000E+03 N REF94 ! PARAMETER G(FCC_A1,CU,ZN:VA;0) 2.98150E+02 -42803.75+10.02258*T; 6.00000E+03 N REF70 ! PARAMETER G(FCC_A1,CU,ZN:VA;1) 2.98150E+02 +2936.39-3.05323*T; 6.00000E+03 N REF70 ! PARAMETER G(FCC_A1,CU,ZN:VA;2) 2.98150E+02 +9034.2-5.39314*T; 6.00000E+03 N REF70 ! PARAMETER G(FCC_A1,CU,ZR:VA;0) 2.98150E+02 2058; 6.00000E+03 N REF125 ! PARAMETER G(FCC_A1,FE,MG:VA;0) 2.98150E+02 65200; 6.00000E+03 N REF29 ! PARAMETER G(FCC_A1,FE,MN:VA;0) 2.98150E+02 -7762+3.865*T; 6.00000E+03 N REF6 ! PARAMETER G(FCC_A1,FE,MN:VA;1) 2.98150E+02 -259; 6.00000E+03 N REF6 ! PARAMETER TC(FCC_A1,FE,MN:VA;0) 2.98150E+02 -2282; 6.00000E+03 N REF6 ! PARAMETER TC(FCC_A1,FE,MN:VA;1) 2.98150E+02 -2068; 6.00000E+03 N REF6 ! PARAMETER G(FCC_A1,FE,SI:VA;0) 2.98150E+02 -125247.7+41.166*T; 6.00000E+03 N REF26 ! PARAMETER G(FCC_A1,FE,SI:VA;1) 2.98150E+02 -142707.6; 6.00000E+03 N REF26 ! PARAMETER G(FCC_A1,FE,SI:VA;2) 2.98150E+02 89907.3; 6.00000E+03 N REF26 ! PARAMETER G(FCC_A1,LI,MG:VA;0) 2.98150E+02 7500; 6.00000E+03 N REF105 ! PARAMETER G(FCC_A1,MG,MN:VA;0) 2.98150E+02 70000; 6.00000E+03 N REF29 ! PARAMETER G(FCC_A1,MG,NI:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N REF94 ! PARAMETER G(FCC_A1,MG,ZR:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N REF68 ! PARAMETER G(FCC_A1,MN,SI:VA;0) 2.98150E+02 -95600+2.94097*T; 6.00000E+03 N REF29 ! PARAMETER G(FCC_A1,MN,SI:VA;1) 2.98150E+02 -7500; 6.00000E+03 N REF29 ! PARAMETER G(FCC_A1,MN,TI:VA;0) 2.98150E+02 -26200+20*T; 6.00000E+03 N REF72 ! PARAMETER G(FCC_A1,SI,ZN:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N REF94 ! PARAMETER G(FCC_A1,SI,ZR:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N REF100 ! PARAMETER G(FCC_A1,SN,ZN:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N REF107 ! PARAMETER G(FCC_A1,TI,V:VA;0) 2.98150E+02 23400; 6.00000E+03 N REF13 ! PHASE FE2SI % 2 2 1 ! CONSTITUENT FE2SI :FE : SI : ! PARAMETER G(FE2SI,FE:SI;0) 2.98150E+02 -71256.6-10.62*T+2*GHSERFE# +GHSERSI#; 6.00000E+03 N REF26 ! PHASE FE5SI3 % 2 5 3 ! CONSTITUENT FE5SI3 :FE : SI : ! PARAMETER G(FE5SI3,FE:SI;0) 2.98150E+02 -241144+2.16*T+5*GHSERFE# +3*GHSERSI#; 6.00000E+03 N REF26 ! PHASE FE1SI1 % 2 1 1 ! CONSTITUENT FE1SI1 :FE : SI : ! PARAMETER G(FE1SI1,FE:SI;0) 2.98150E+02 -72761.2+4.44*T+GHSERFE#+GHSERSI#; 6.00000E+03 N REF26 ! PHASE FESI2_H % 2 3 7 ! CONSTITUENT FESI2_H :FE : SI : ! PARAMETER G(FESI2_H,FE:SI;0) 2.98150E+02 -196490-9.2*T+3*GHSERFE# +7*GHSERSI#; 6.00000E+03 N REF26 ! PHASE FESI2_L % 2 1 2 ! CONSTITUENT FESI2_L :FE : SI : ! PARAMETER G(FESI2_L,FE:SI;0) 2.98150E+02 -82149+10.44*T+GHSERFE# +2*GHSERSI#; 6.00000E+03 N REF26 ! PHASE GAMMA_D83 % 3 4 1 8 ! CONSTITUENT GAMMA_D83 :AL : AL,CU : CU : ! PARAMETER G(GAMMA_D83,AL:AL:CU;0) 2.98150E+02 -300716+390*T-52*T*LN(T) +5*GHSERAL#+8*GHSERCU#; 6.00000E+03 N REF72 ! PARAMETER G(GAMMA_D83,AL:CU:CU;0) 2.98150E+02 -280501+379.6*T -52*T*LN(T)+4*GHSERAL#+9*GHSERCU#; 6.00000E+03 N REF72 ! PHASE GAMMA_H % 3 4 1 8 ! CONSTITUENT GAMMA_H :AL : AL,CU : CU : ! PARAMETER G(GAMMA_H,AL:AL:CU;0) 2.98150E+02 -219258-45.5*T+5*GHSERAL# +8*GHSERCU#; 6.00000E+03 N REF72 ! PARAMETER G(GAMMA_H,AL:CU:CU;0) 2.98150E+02 -200460-58.5*T+4*GHSERAL# +9*GHSERCU#; 6.00000E+03 N REF72 ! PHASE GRAPHITE % 1 1.0 ! CONSTITUENT GRAPHITE :B,C : ! PARAMETER G(GRAPHITE,B;0) 2.98150E+02 +5000+GHSERBB#; 6.00000E+03 N REF1 ! PARAMETER G(GRAPHITE,C;0) 2.98150E+02 +GHSERCC#; 6.00000E+03 N REF1 ! PARAMETER G(GRAPHITE,B,C;0) 2.98150E+02 +34385.95+8.6792*T; 6.00000E+03 N REF54 ! TYPE_DEFINITION * GES A_P_D HCP_A3 MAGNETIC -3.0 2.80000E-01 ! PHASE HCP_A3 %* 2 1 .5 ! CONSTITUENT HCP_A3 :AL,CE,CR,CU,FE,LI,MG%,MN,NI,SI,SN,TI%,V,Y,ZN%,ZR% : B,C,N,VA% : ! PARAMETER G(HCP_A3,AL:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,CE:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,CR:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,CU:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,FE:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,LI:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,MG:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,MN:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,NI:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,SI:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,SN:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,TI:B;0) 2.98150E+02 -50000+15*T+GHSERTI#+.5*GHSERBB#; 6.00000E+03 N REF89 ! PARAMETER G(HCP_A3,V:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,Y:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,ZN:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,ZR:B;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,AL:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,CE:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,CR:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,CU:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,FE:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,LI:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,MG:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,MN:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,NI:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,SI:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,SN:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,TI:C;0) 2.98150E+02 -1432-4.1241*T+.5*GHSERTI# +.5*GHSERTIC#; 6.00000E+03 N REF111 ! PARAMETER G(HCP_A3,V:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,Y:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,ZN:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,ZR:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,AL:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,CE:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,CR:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,CU:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,FE:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,LI:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,MG:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,MN:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,NI:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,SI:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,SN:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,TI:N;0) 2.98150E+02 -9888.08-3.0822*T+.5*GHSERTI# +.5*GHSERTIN#; 6.00000E+03 N REF111 ! PARAMETER G(HCP_A3,V:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,Y:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,ZN:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,ZR:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,AL:VA;0) 2.98150E+02 +5481-1.8*T+GHSERAL#; 6.00000E+03 N REF1 ! PARAMETER G(HCP_A3,CE:VA;0) 2.98150E+02 +50000+GHSERCE#; 4.00000E+03 N REF1 ! PARAMETER G(HCP_A3,CR:VA;0) 2.98150E+02 +4438+GHSERCR#; 6.00000E+03 N REF1 ! PARAMETER TC(HCP_A3,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N REF1 ! PARAMETER BMAGN(HCP_A3,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N REF1 ! PARAMETER G(HCP_A3,CU:VA;0) 2.98150E+02 +600+.2*T+GHSERCU#; 6.00000E+03 N REF1 ! PARAMETER G(HCP_A3,FE:VA;0) 2.98150E+02 -3705.78+12.591*T-1.15*T*LN(T) +6.4E-04*T**2+GHSERFE#; 1.81100E+03 Y -3957.199+5.24951*T+4.9251E+30*T**(-9)+GHSERFE#; 6.00000E+03 N REF1 ! PARAMETER G(HCP_A3,LI:VA;0) 2.98150E+02 -154+2*T+GHSERLI#; 6.00000E+03 N REF1 ! PARAMETER G(HCP_A3,MG:VA;0) 2.98150E+02 +GHSERMG#; 6.00000E+03 N REF1 ! PARAMETER G(HCP_A3,MN:VA;0) 2.98150E+02 -4439.3+133.007*T -24.5177*T*LN(T)-.006*T**2+69600*T**(-1); 1.51900E+03 Y -27070.1+310.7894*T-48*T*LN(T)+3.86196E+30*T**(-9); 6.00000E+03 N REF1 ! PARAMETER TC(HCP_A3,MN:VA;0) 2.98150E+02 -1620; 6.00000E+03 N REF1 ! PARAMETER BMAGN(HCP_A3,MN:VA;0) 2.98150E+02 -1.86; 6.00000E+03 N REF1 ! PARAMETER G(HCP_A3,NI:VA;0) 2.98150E+02 +1046+1.2552*T+GHSERNI#; 6.00000E+03 N REF1 ! PARAMETER G(HCP_A3,SI:VA;0) 2.98150E+02 +49200-20.8*T+GHSERSI#; 6.00000E+03 N REF1 ! PARAMETER G(HCP_A3,SN:VA;0) 2.98150E+02 +3900-4.4*T+GHSERSN#; 6.00000E+03 N REF1 ! PARAMETER G(HCP_A3,TI:VA;0) 2.98150E+02 +GHSERTI#; 6.00000E+03 N REF1 ! PARAMETER G(HCP_A3,V:VA;0) 2.98150E+02 +4000+2.4*T+GHSERV#; 6.00000E+03 N REF1 ! PARAMETER G(HCP_A3,Y:VA;0) 2.98150E+02 +GHSERY#; 3.70000E+03 N REF1 ! PARAMETER G(HCP_A3,ZN:VA;0) 2.98150E+02 +GHSERZN#; 6.00000E+03 N REF1 ! PARAMETER G(HCP_A3,ZR:VA;0) 2.98150E+02 +GHSERZR#; 6.00000E+03 N REF1 ! PARAMETER G(HCP_A3,TI:B,VA;0) 2.98150E+02 -21213.442; 6.00000E+03 N REF89 ! PARAMETER G(HCP_A3,TI:N,VA;0) 2.98150E+02 -4743; 6.00000E+03 N REF111 ! PARAMETER G(HCP_A3,AL,FE:VA;0) 2.98150E+02 -106903+20*T; 6.00000E+03 N REF76 ! PARAMETER G(HCP_A3,AL,LI:VA;0) 2.98150E+02 -27000+8*T; 6.00000E+03 N REF105 ! PARAMETER G(HCP_A3,AL,LI,MG:VA;2) 2.98150E+02 -80000+50*T; 6.00000E+03 N REF105 ! PARAMETER G(HCP_A3,AL,MG:VA;0) 2.98150E+02 +1950-2*T; 6.00000E+03 N REF11 ! PARAMETER G(HCP_A3,AL,MG:VA;1) 2.98150E+02 +1480-2.08*T; 6.00000E+03 N REF11 ! PARAMETER G(HCP_A3,AL,MG:VA;2) 2.98150E+02 3500; 6.00000E+03 N REF11 ! PARAMETER G(HCP_A3,AL,MN:VA;0) 2.98150E+02 -108066+43.83*T; 6.00000E+03 N REF23 ! PARAMETER G(HCP_A3,AL,MN:VA;1) 2.98150E+02 -54519.6+40*T; 6.00000E+03 N REF23 ! PARAMETER G(HCP_A3,AL,SN:VA;0) 2.98150E+02 1E-05; 6.00000E+03 N REF15 ! PARAMETER G(HCP_A3,AL,TI:VA;0) 2.98150E+02 -133500+39*T; 6.00000E+03 N REF13 ! PARAMETER G(HCP_A3,AL,TI:VA;1) 2.98150E+02 750; 6.00000E+03 N REF13 ! PARAMETER G(HCP_A3,AL,TI:VA;2) 2.98150E+02 17500; 6.00000E+03 N REF13 ! PARAMETER G(HCP_A3,AL,V:VA;0) 2.98150E+02 -95000+20*T; 6.00000E+03 N REF13 ! PARAMETER G(HCP_A3,AL,V:VA;1) 2.98150E+02 -6000; 6.00000E+03 N REF13 ! PARAMETER G(HCP_A3,AL,Y:VA;0) 2.98150E+02 +90*T; 6.00000E+03 N REF52 ! PARAMETER G(HCP_A3,AL,ZN:VA;0) 2.98150E+02 +18820.95-8.95255*T; 6.00000E+03 N REF78 ! PARAMETER G(HCP_A3,AL,ZN:VA;1) 2.98150E+02 +1E-06; 6.00000E+03 N REF78 ! PARAMETER G(HCP_A3,AL,ZN:VA;2) 2.98150E+02 +1E-06; 6.00000E+03 N REF78 ! PARAMETER G(HCP_A3,AL,ZN:VA;3) 2.98150E+02 -702.79; 6.00000E+03 N REF78 ! PARAMETER G(HCP_A3,AL,ZR:VA;0) 2.98150E+02 -122300+32*T; 6.00000E+03 N REF74 ! PARAMETER G(HCP_A3,AL,ZR:VA;1) 2.98150E+02 -8000; 6.00000E+03 N REF74 ! PARAMETER G(HCP_A3,AL,ZR:VA;2) 2.98150E+02 17000; 6.00000E+03 N REF74 ! PARAMETER G(HCP_A3,CE,MG:VA;0) 2.98150E+02 -94337.51+79.95155*T; 6.00000E+03 N REF103 ! PARAMETER G(HCP_A3,CR,CU:VA;0) 2.98150E+02 +81100-25*T; 6.00000E+03 N REF96 ! PARAMETER G(HCP_A3,CR,MG:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N REF83 ! PARAMETER G(HCP_A3,CR,MN:VA;0) 2.98150E+02 41800; 6.00000E+03 N REF2 ! PARAMETER G(HCP_A3,CR,TI:VA;0) 2.98150E+02 32500; 6.00000E+03 N REF72 ! PARAMETER G(HCP_A3,CR,ZN:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N REF83 ! PARAMETER G(HCP_A3,CR,ZR:VA;0) 2.98150E+02 15800; 6.00000E+03 N REF98 ! PARAMETER G(HCP_A3,CU,LI:VA;0) 2.98150E+02 +2042+10.9617*T; 6.00000E+03 N REF74 ! PARAMETER G(HCP_A3,CU,MG:VA;0) 2.98150E+02 +184.5*T; 6.00000E+03 N REF20 ! PARAMETER G(HCP_A3,CU,NI:VA;0) 2.98150E+02 +12048.61+1.29893*T; 6.00000E+03 N BO2021 ! PARAMETER G(HCP_A3,CU,ZN:VA;0) 2.98150E+02 -14432.17-10.7814*T; 6.00000E+03 N REF70 ! PARAMETER G(HCP_A3,CU,ZR:VA;0) 2.98150E+02 5668.425; 6.00000E+03 N REF125 ! PARAMETER G(HCP_A3,FE,MG:VA;0) 2.98150E+02 92400; 6.00000E+03 N REF29 ! PARAMETER G(HCP_A3,FE,MN:VA;0) 2.98150E+02 -5582+3.865*T; 6.00000E+03 N REF6 ! PARAMETER G(HCP_A3,FE,MN:VA;1) 2.98150E+02 273; 6.00000E+03 N REF6 ! PARAMETER G(HCP_A3,LI,MG:VA;0) 2.98150E+02 -6856; 6.00000E+03 N REF105 ! PARAMETER G(HCP_A3,LI,MG:VA;1) 2.98150E+02 4000; 6.00000E+03 N REF105 ! PARAMETER G(HCP_A3,LI,MG:VA;2) 2.98150E+02 4000; 6.00000E+03 N REF105 ! PARAMETER G(HCP_A3,LI,ZR:VA;0) 2.98150E+02 200000; 6.00000E+03 N REF74 ! PARAMETER G(HCP_A3,MG,MN:VA;0) 2.98150E+02 +32985+2.5*T; 6.00000E+03 N REF29 ! PARAMETER G(HCP_A3,MG,NI:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N REF94 ! PARAMETER G(HCP_A3,MG,SI:VA;0) 2.98150E+02 -5063.7+.63297*T; 6.00000E+03 N REF62 ! PARAMETER G(HCP_A3,MG,Y:VA;0) 2.98150E+02 -16582.94+4.77482*T; 6.00000E+03 N REF64 ! PARAMETER G(HCP_A3,MG,Y:VA;1) 2.98150E+02 -7077.87; 6.00000E+03 N REF64 ! PARAMETER G(HCP_A3,MG,ZN:VA;0) 2.98150E+02 -1600.77+7.62441*T; 6.00000E+03 N REF33 ! PARAMETER G(HCP_A3,MG,ZN:VA;1) 2.98150E+02 -3823.03+8.02575*T; 6.00000E+03 N REF33 ! PARAMETER G(HCP_A3,MG,ZR:VA;0) 2.98150E+02 +42063.55+1.01789*T; 6.00000E+03 N REF68 ! PARAMETER G(HCP_A3,MG,ZR:VA;1) 2.98150E+02 -2885.9; 6.00000E+03 N REF68 ! PARAMETER G(HCP_A3,MN,TI:VA;0) 2.98150E+02 22100; 6.00000E+03 N REF72 ! PARAMETER G(HCP_A3,SI,TI:VA;0) 2.98150E+02 -302731.04+69.08469*T; 6.00000E+03 N REF123 ! PARAMETER G(HCP_A3,SI,TI:VA;1) 2.98150E+02 +25025.35-2.00203*T; 6.00000E+03 N REF123 ! PARAMETER G(HCP_A3,SI,TI:VA;2) 2.98150E+02 +83940.65-6.71526*T; 6.00000E+03 N REF123 ! PARAMETER G(HCP_A3,SI,Y:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N REF66 ! PARAMETER G(HCP_A3,SI,ZN:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N REF94 ! PARAMETER G(HCP_A3,SI,ZR:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N REF100 ! PARAMETER G(HCP_A3,SN,TI:VA;0) 2.98150E+02 -111502.08+1.8068*T; 3.00000E+03 N REF39 ! PARAMETER G(HCP_A3,SN,TI:VA;1) 2.98150E+02 +43871.41+2.08175*T; 3.00000E+03 N REF39 ! PARAMETER G(HCP_A3,SN,ZN:VA;0) 2.98150E+02 +33438.94-11.14466*T; 6.00000E+03 N REF107 ! PARAMETER G(HCP_A3,TI,V:VA;0) 2.98150E+02 20000; 6.00000E+03 N REF13 ! PHASE HIGH_SIGMA % 3 8 4 18 ! CONSTITUENT HIGH_SIGMA :MN : CR : CR,MN : ! PARAMETER G(HIGH_SIGMA,MN:CR:CR;0) 2.98150E+02 -192369+152.4742*T +8*GFCCMN#+22*GHSERCR#; 6.00000E+03 N REF2 ! PARAMETER G(HIGH_SIGMA,MN:CR:MN;0) 2.98150E+02 +18*GBCCMN#-74263 -10.7082*T+8*GFCCMN#+4*GHSERCR#; 6.00000E+03 N REF2 ! PARAMETER G(HIGH_SIGMA,MN:CR:CR,MN;0) 2.98150E+02 90000; 6.00000E+03 N REF2 ! PHASE LAVES_C14 % 2 2 1 ! CONSTITUENT LAVES_C14 :CR%,MN,TI,ZR : CR,MN,TI,ZR% : ! PARAMETER G(LAVES_C14,CR:CR;0) 2.98150E+02 +15000+3*GHSERCR#; 6.00000E+03 N REF98 ! PARAMETER G(LAVES_C14,MN:CR;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C14,TI:CR;0) 2.98150E+02 +2*GLAVTI#+GLAVCR#; 6.00000E+03 N REF72 ! PARAMETER G(LAVES_C14,ZR:CR;0) 2.98150E+02 +8114+11.652*T+30000 +GHSERCR#+2*GHSERZR#; 6.00000E+03 N REF98 ! PARAMETER G(LAVES_C14,CR:MN;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C14,MN:MN;0) 2.98150E+02 +3000+3*GHSERMN#; 6.00000E+03 N REF1 ! PARAMETER G(LAVES_C14,TI:MN;0) 2.98150E+02 +3000+GHSERMN#+2*GHSERTI#; 6.00000E+03 N REF72 ! PARAMETER G(LAVES_C14,ZR:MN;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C14,CR:TI;0) 2.98150E+02 -1440-6.75*T+GHSERTI# +2*GHSERCR#; 6.00000E+03 N REF72 ! PARAMETER G(LAVES_C14,MN:TI;0) 2.98150E+02 -26400+2*GHSERMN#+GHSERTI#; 6.00000E+03 N REF72 ! PARAMETER G(LAVES_C14,TI:TI;0) 2.98150E+02 +15000+3*GHSERTI#; 6.00000E+03 N REF1 ! PARAMETER G(LAVES_C14,ZR:TI;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C14,CR:ZR;0) 2.98150E+02 -8114-11.652*T+2*GHSERCR# +GHSERZR#; 6.00000E+03 N REF98 ! PARAMETER G(LAVES_C14,MN:ZR;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C14,TI:ZR;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C14,ZR:ZR;0) 2.98150E+02 +15000+3*GHSERZR#; 6.00000E+03 N REF98 ! PARAMETER G(LAVES_C14,CR,TI:CR;0) 2.98150E+02 60000; 6.00000E+03 N REF72 ! PARAMETER G(LAVES_C14,CR,ZR:CR;0) 2.98150E+02 52299; 6.00000E+03 N REF98 ! PARAMETER G(LAVES_C14,CR:CR,TI;0) 2.98150E+02 60000; 6.00000E+03 N REF72 ! PARAMETER G(LAVES_C14,CR:CR,ZR;0) 2.98150E+02 26060; 6.00000E+03 N REF98 ! PARAMETER G(LAVES_C14,TI:CR,TI;0) 2.98150E+02 60000; 6.00000E+03 N REF72 ! PARAMETER G(LAVES_C14,ZR:CR,ZR;0) 2.98150E+02 26060; 6.00000E+03 N REF98 ! PARAMETER G(LAVES_C14,MN,TI:MN;0) 2.98150E+02 27000; 6.00000E+03 N REF72 ! PARAMETER G(LAVES_C14,MN:MN,TI;0) 2.98150E+02 15000; 6.00000E+03 N REF72 ! PARAMETER G(LAVES_C14,TI:MN,TI;0) 2.98150E+02 15000; 6.00000E+03 N REF72 ! PARAMETER G(LAVES_C14,CR,TI:TI;0) 2.98150E+02 60000; 6.00000E+03 N REF72 ! PARAMETER G(LAVES_C14,MN,TI:TI;0) 2.98150E+02 27000; 6.00000E+03 N REF72 ! PARAMETER G(LAVES_C14,CR,ZR:ZR;0) 2.98150E+02 52299; 6.00000E+03 N REF98 ! PHASE LAVES_C15 % 2 2 1 ! CONSTITUENT LAVES_C15 :AL,CR%,CU%,MG,TI,ZR : CE,CR,CU,MG%,ND,TI,ZR : ! PARAMETER G(LAVES_C15,AL:CE;0) 2.98150E+02 -150000+45.66405*T +2*GHSERAL#+GHSERCE#; 6.00000E+03 N REF103 ! PARAMETER G(LAVES_C15,CR:CE;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,CU:CE;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,MG:CE;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,TI:CE;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,ZR:CE;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,AL:CR;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,CR:CR;0) 2.98150E+02 +15000+3*GHSERCR#; 6.00000E+03 N REF1 ! PARAMETER G(LAVES_C15,CU:CR;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,MG:CR;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,TI:CR;0) 2.98150E+02 +2*GLAVTI#+GLAVCR#; 6.00000E+03 N REF72 ! PARAMETER G(LAVES_C15,ZR:CR;0) 2.98150E+02 +87272.834-29.915156*T+30000 +GHSERCR#+2*GHSERZR#; 6.00000E+03 N REF98 ! PARAMETER G(LAVES_C15,AL:CU;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,CR:CU;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,CU:CU;0) 2.98150E+02 +21014.88+3*GHSERCU#; 6.00000E+03 N REF20 ! PARAMETER G(LAVES_C15,MG:CU;0) 2.98150E+02 +105000-16.5*T+2*GHSERMG# +GHSERCU#; 6.00000E+03 N REF20 ! PARAMETER G(LAVES_C15,TI:CU;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,ZR:CU;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,AL:MG;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,CR:MG;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,CU:MG;0) 2.98150E+02 -54720.03+364.76678*T -69.27641*T*LN(T)-5.19246E-04*T**2+143502*T**(-1)-5.65953E-06*T**3; 6.00000E+03 N REF20 ! PARAMETER G(LAVES_C15,MG:MG;0) 2.98150E+02 +27359.33+3*GHSERMG#; 6.00000E+03 N REF20 ! PARAMETER G(LAVES_C15,TI:MG;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,ZR:MG;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,AL:ND;0) 2.98150E+02 -165400+26.1*T+2*GHSERAL# +GHSERND#; 6.00000E+03 N REF80 ! PARAMETER G(LAVES_C15,CR:ND;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,CU:ND;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,MG:ND;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,TI:ND;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,ZR:ND;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,AL:TI;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,CR:TI;0) 2.98150E+02 -1780-6.3*T+2*GHSERCR# +GHSERTI#; 6.00000E+03 N REF72 ! PARAMETER G(LAVES_C15,CU:TI;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,MG:TI;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,TI:TI;0) 2.98150E+02 +15000+3*GHSERTI#; 6.00000E+03 N REF1 ! PARAMETER G(LAVES_C15,ZR:TI;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,AL:ZR;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,CR:ZR;0) 2.98150E+02 -87272.834+29.915156*T +2*GHSERCR#+GHSERZR#; 6.00000E+03 N REF98 ! PARAMETER G(LAVES_C15,CU:ZR;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,MG:ZR;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,TI:ZR;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C15,ZR:ZR;0) 2.98150E+02 +15000+3*GHSERZR#; 6.00000E+03 N REF1 ! PARAMETER G(LAVES_C15,CR,TI:CR;0) 2.98150E+02 +10800+27*T; 6.00000E+03 N REF72 ! PARAMETER G(LAVES_C15,CR,ZR:CR;0) 2.98150E+02 70327.735; 6.00000E+03 N REF98 ! PARAMETER G(LAVES_C15,CR:CR,TI;0) 2.98150E+02 50000; 6.00000E+03 N REF72 ! PARAMETER G(LAVES_C15,CR:CR,ZR;0) 2.98150E+02 62909.158; 6.00000E+03 N REF98 ! PARAMETER G(LAVES_C15,TI:CR,TI;0) 2.98150E+02 50000; 6.00000E+03 N REF72 ! PARAMETER G(LAVES_C15,ZR:CR,ZR;0) 2.98150E+02 62909.158; 6.00000E+03 N REF98 ! PARAMETER G(LAVES_C15,CR,TI:TI;0) 2.98150E+02 +10800+27*T; 6.00000E+03 N REF72 ! PARAMETER G(LAVES_C15,CR,ZR:ZR;0) 2.98150E+02 70327.735; 6.00000E+03 N REF98 ! PHASE LAVES_C36 % 2 2 1 ! CONSTITUENT LAVES_C36 :CR%,NI,ZR : CR,MG,ZR% : ! PARAMETER G(LAVES_C36,CR:CR;0) 2.98150E+02 +15000+3*GHSERCR#; 6.00000E+03 N REF98 ! PARAMETER G(LAVES_C36,NI:CR;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C36,ZR:CR;0) 2.98150E+02 +70026-20.901*T+30000 +GHSERCR#+2*GHSERZR#; 6.00000E+03 N REF98 ! PARAMETER G(LAVES_C36,CR:MG;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C36,NI:MG;0) 2.98150E+02 -74136+293.9216*T -54.35385*T*LN(T)-.03329235*T**2-99*T**(-1)+5.14203E-06*T**3; 6.00000E+03 N REF94 ! PARAMETER G(LAVES_C36,ZR:MG;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C36,CR:ZR;0) 2.98150E+02 -70026+20.901*T+2*GHSERCR# +GHSERZR#; 6.00000E+03 N REF98 ! PARAMETER G(LAVES_C36,NI:ZR;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(LAVES_C36,ZR:ZR;0) 2.98150E+02 +15000+3*GHSERZR#; 6.00000E+03 N REF98 ! PARAMETER G(LAVES_C36,CR,ZR:CR;0) 2.98150E+02 52614; 6.00000E+03 N REF98 ! PARAMETER G(LAVES_C36,CR:CR,ZR;0) 2.98150E+02 29399; 6.00000E+03 N REF98 ! PARAMETER G(LAVES_C36,ZR:CR,ZR;0) 2.98150E+02 29399; 6.00000E+03 N REF98 ! PARAMETER G(LAVES_C36,CR,ZR:ZR;0) 2.98150E+02 52614; 6.00000E+03 N REF98 ! PHASE MG24Y5 % 2 24 5 ! CONSTITUENT MG24Y5 :MG : MG,Y : ! PARAMETER G(MG24Y5,MG:MG;0) 2.98150E+02 +44506.01+29*GHSERMG#; 6.00000E+03 N REF64 ! PARAMETER G(MG24Y5,MG:Y;0) 2.98150E+02 -227282.28+36.52985*T +24*GHSERMG#+5*GHSERY#; 6.00000E+03 N REF64 ! PHASE MG2NI % 2 2 1 ! CONSTITUENT MG2NI :MG : NI : ! PARAMETER G(MG2NI,MG:NI;0) 2.98150E+02 -82211.2+571.0183*T -95.992*T*LN(T); 6.00000E+03 N REF94 ! PHASE MG2SI % 2 2 1 ! CONSTITUENT MG2SI :MG : SI : ! PARAMETER G(MG2SI,MG:SI;0) 2.98150E+02 -82500+348*T-62.46*T*LN(T) -.0096*T**2; 6.00000E+03 N REF62 ! PHASE MG2SN % 2 2 1 ! CONSTITUENT MG2SN :MG : SN : ! PARAMETER G(MG2SN,MG:SN;0) 298.15 UN_ASS; 300 N REF0 ! PHASE MG2Y % 2 2 1 ! CONSTITUENT MG2Y :MG : Y : ! PARAMETER G(MG2Y,MG:Y;0) 2.98150E+02 -39075.78+6.51258*T+2*GHSERMG# +GHSERY#; 6.00000E+03 N REF0 ! PHASE MG2ZN11 % 2 2 11 ! CONSTITUENT MG2ZN11 :MG : ZN : ! PARAMETER G(MG2ZN11,MG:ZN;0) 2.98150E+02 -75699.65+25.262*T+2*GHSERMG# +11*GHSERZN#; 6.00000E+03 N REF33 ! PHASE MG2ZN3 % 2 2 3 ! CONSTITUENT MG2ZN3 :MG : ZN : ! PARAMETER G(MG2ZN3,MG:ZN;0) 2.98150E+02 -55070+18.35755*T+2*GHSERMG# +3*GHSERZN#; 6.00000E+03 N REF33 ! PHASE MG7ZN3 % 2 51 20 ! CONSTITUENT MG7ZN3 :MG : ZN : ! PARAMETER G(MG7ZN3,MG:ZN;0) 2.98150E+02 -341794+71*T+51*GHSERMG# +20*GHSERZN#; 6.00000E+03 N REF33 ! PHASE MGY_GAMMA % 2 1 1 ! CONSTITUENT MGY_GAMMA :MG : MG,Y : ! PARAMETER G(MGY_GAMMA,MG:MG;0) 2.98150E+02 +9891.48+2*GHSERMG#; 6.00000E+03 N REF64 ! PARAMETER G(MGY_GAMMA,MG:Y;0) 2.98150E+02 -32162.76+8*T+GHSERMG# +GHSERY#; 6.00000E+03 N REF64 ! PHASE MG1ZN1 % 2 12 13 ! CONSTITUENT MG1ZN1 :MG : ZN : ! PARAMETER G(MG1ZN1,MG:ZN;0) 2.98150E+02 -239761+79.92025*T+12*GHSERMG# +13*GHSERZN#; 6.00000E+03 N REF33 ! PHASE MGZN2 % 2 1 2 ! CONSTITUENT MGZN2 :MG : ZN : ! PARAMETER G(MGZN2,MG:ZN;0) 2.98150E+02 -35048.16+10.60683*T+GHSERMG# +2*GHSERZN#; 6.00000E+03 N REF33 ! PHASE MN11SI19 % 2 11 19 ! CONSTITUENT MN11SI19 :MN : SI : ! PARAMETER G(MN11SI19,MN:SI;0) 2.98150E+02 -636300.49+1624.9288*T -378.69397*T*LN(T)-.16391259*T**2-15432618*T**(-1); 6.00000E+03 N REF29 ! PHASE MN3SI % 2 3 1 ! CONSTITUENT MN3SI :MN : SI : ! PARAMETER G(MN3SI,MN:SI;0) 2.98150E+02 -124189.87+782.4373*T -131.682*T*LN(T)-.007770061*T**2+1657200*T**(-1); 9.50000E+02 Y -119740.6+777.7538*T-131.682*T*LN(T)-.007770061*T**2+1657200*T**(-1); 6.00000E+03 N REF29 ! PHASE MN3TI % 2 3 1 ! CONSTITUENT MN3TI :MN : TI : ! PARAMETER G(MN3TI,MN:TI;0) 2.98150E+02 -18552-9.12*T+3*GHSERMN# +GHSERTI#; 6.00000E+03 N REF72 ! PHASE MN4TI % 2 .815 .185 ! CONSTITUENT MN4TI :MN : TI : ! PARAMETER G(MN4TI,MN:TI;0) 2.98150E+02 -2445-2.9*T+.815*GHSERMN# +.185*GHSERTI#; 6.00000E+03 N REF72 ! PHASE MN5SI3 % 2 5 3 ! CONSTITUENT MN5SI3 :MN : SI : ! PARAMETER G(MN5SI3,MN:SI;0) 2.98150E+02 -261930.32+1170.7779*T -211.15016*T*LN(T)-.01529344*T**2-149263.11*T**(-1); 6.00000E+03 N REF29 ! PHASE MN6SI % 2 17 3 ! CONSTITUENT MN6SI :MN : SI : ! PARAMETER G(MN6SI,MN:SI;0) 2.98150E+02 -250180.6+84.8444*T -.02850984*T**2-12.07755*T*LN(T)+7514*T**(-1)+17*GHSERMN#+3*GHSERSI#; 1.51900E+03 Y -282008.6-32.58304*T+12.06754*T*LN(T)-.05879165*T**2+3.928228E+31*T**(-9) +17*GHSERMN#+3*GHSERSI#; 6.00000E+03 N REF29 ! PHASE MN9SI2 % 2 33 7 ! CONSTITUENT MN9SI2 :MN : SI : ! PARAMETER G(MN9SI2,MN:SI;0) 2.98150E+02 -578208.4+381.294*T -56.86988*T*LN(T)-.0500355*T**2+1458600*T**(-1)+33*GHSERMN#+7*GHSERSI#; 1.51900E+03 Y -639992+153.3464*T-10*T*LN(T)-.1*T**2+7.625384E+31*T**(-9)+33*GHSERMN# +7*GHSERSI#; 6.00000E+03 N REF29 ! PHASE MNSI % 2 1 1 ! CONSTITUENT MNSI :MN : SI : ! PARAMETER G(MNSI,MN:SI;0) 2.98150E+02 -78135.144+308.2488*T -52.42121*T*LN(T)-.006903355*T**2+876442.9*T**(-1); 6.00000E+03 N REF29 ! PHASE OMEGA % 1 1.0 ! CONSTITUENT OMEGA :ZR : ! PARAMETER G(OMEGA,ZR;0) 2.98150E+02 -8878.082+144.432234*T -26.8556*T*LN(T)-.002799446*T**2+38376*T**(-1); 2.12800E+03 Y -29500.524+265.290858*T-42.144*T*LN(T)+7.17445E+31*T**(-9); 6.00000E+03 N REF1 ! PHASE SI2TI % 2 2 1 ! CONSTITUENT SI2TI :SI : TI : ! PARAMETER G(SI2TI,SI:TI;0) 2.98150E+02 -175038.5+4.548*T+GHSERTI# +2*GHSERSI#; 6.00000E+03 N REF123 ! PHASE SI2V % 2 2 1 ! CONSTITUENT SI2V :SI : V : ! PARAMETER G(SI2V,SI:V;0) 2.98150E+02 -143160+401.98*T-67.8*T*LN(T) -.0075*T**2+330000*T**(-1); 6.00000E+03 N REF117 ! PHASE SI2Y_H % 2 2 1 ! CONSTITUENT SI2Y_H :SI : Y : ! PARAMETER G(SI2Y_H,SI:Y;0) 2.98150E+02 -214632+28.5*T+2*GHSERSI# +GHSERY#; 6.00000E+03 N REF66 ! PHASE SI2Y_R % 2 2 1 ! CONSTITUENT SI2Y_R :SI : Y : ! PARAMETER G(SI2Y_R,SI:Y;0) 2.98150E+02 -219201+31.5*T+2*GHSERSI# +GHSERY#; 6.00000E+03 N REF66 ! PHASE SI2ZR1 % 2 2 1 ! CONSTITUENT SI2ZR1 :SI : ZR : ! PARAMETER G(SI2ZR1,SI:ZR;0) 2.98150E+02 -189332.05+354.93695*T -63.16867*T*LN(T)-.00767745*T**2+139751.1*T**(-1)-1.97204833E-11*T**3; 6.00000E+03 N REF100 ! PHASE SI2ZR3 % 2 2 3 ! CONSTITUENT SI2ZR3 :SI : ZR : ! PARAMETER G(SI2ZR3,SI:ZR;0) 2.98150E+02 -493990.62+844.44793*T -140.103*T*LN(T)-.003701*T**2+1.02833333E-07*T**3+1167755*T**(-1); 6.00000E+03 N REF100 ! PHASE SI3TI5 % 3 2 3 3 ! CONSTITUENT SI3TI5 :SI,TI : SI,TI : TI : ! PARAMETER G(SI3TI5,SI:SI:TI;0) 2.98150E+02 -206191.45+16.49531*T +5*GHSERSI#+3*GHSERTI#; 6.00000E+03 N REF123 ! PARAMETER G(SI3TI5,TI:SI:TI;0) 2.98150E+02 -583564.31+2.68514*T +5*GHSERTI#+3*GHSERSI#; 6.00000E+03 N REF123 ! PARAMETER G(SI3TI5,SI:TI:TI;0) 2.98150E+02 +417372.85+33.81017*T +2*GHSERSI#+6*GHSERTI#; 6.00000E+03 N REF123 ! PARAMETER G(SI3TI5,TI:TI:TI;0) 2.98150E+02 +40000+20*T+8*GHSERTI#; 6.00000E+03 N REF123 ! PARAMETER G(SI3TI5,SI,TI:SI:TI;0) 2.98150E+02 -500000+40*T; 6.00000E+03 N REF123 ! PARAMETER G(SI3TI5,SI:SI,TI:TI;0) 2.98150E+02 +43024.29-3.44194*T; 6.00000E+03 N REF123 ! PARAMETER G(SI3TI5,TI:SI,TI:TI;0) 2.98150E+02 +43024.29-3.44194*T; 6.00000E+03 N REF123 ! PARAMETER G(SI3TI5,SI,TI:TI:TI;0) 2.98150E+02 -500000+40*T; 6.00000E+03 N REF123 ! PHASE SI3V5 % 2 3 5 ! CONSTITUENT SI3V5 :SI : V : ! PARAMETER G(SI3V5,SI:V;0) 2.98150E+02 -504000+1259.03*T-211.04*T*LN(T) -.00748*T**2+1680000*T**(-1); 6.00000E+03 N REF117 ! PHASE SI3Y5 % 2 3 5 ! CONSTITUENT SI3Y5 :SI : Y : ! PARAMETER G(SI3Y5,SI:Y;0) 2.98150E+02 -588000+76*T+3*GHSERSI#+5*GHSERY#; 6.00000E+03 N REF66 ! PHASE SI3ZR5 % 2 3 5 ! CONSTITUENT SI3ZR5 :SI : ZR : ! PARAMETER G(SI3ZR5,SI:ZR;0) 2.98150E+02 -685146.78+1044.78*T -187*T*LN(T)-.0161754*T**2+5.22283E-08*T**3+381210*T**(-1); 6.00000E+03 N REF100 ! PHASE SI4TI5 % 2 4 5 ! CONSTITUENT SI4TI5 :SI : TI : ! PARAMETER G(SI4TI5,SI:TI;0) 2.98150E+02 -711000+22.37355*T+4*GHSERSI# +5*GHSERTI#; 6.00000E+03 N REF123 ! PHASE SI4Y5 % 2 4 5 ! CONSTITUENT SI4Y5 :SI : Y : ! PARAMETER G(SI4Y5,SI:Y;0) 2.98150E+02 -697950+86.72688*T+4*GHSERSI# +5*GHSERY#; 6.00000E+03 N REF66 ! PHASE SI4ZR5 % 2 4 5 ! CONSTITUENT SI4ZR5 :SI : ZR : ! PARAMETER G(SI4ZR5,SI:ZR;0) 2.98150E+02 -880743.11+1433.658*T -240.256*T*LN(T)-.0109481*T**2+6.59118333E-07*T**3+2006425*T**(-1); 6.00000E+03 N REF100 ! PHASE SI5V6 % 2 5 6 ! CONSTITUENT SI5V6 :SI : V : ! PARAMETER G(SI5V6,SI:V;0) 2.98150E+02 -641675+1665.98*T-280.28*T*LN(T) -.013915*T**2+2310000*T**(-1); 6.00000E+03 N REF117 ! PHASE SI5Y3_H % 2 5 3 ! CONSTITUENT SI5Y3_H :SI : Y : ! PARAMETER G(SI5Y3_H,SI:Y;0) 2.98150E+02 -601572+76*T+5*GHSERSI# +3*GHSERY#; 6.00000E+03 N REF66 ! PHASE SI5Y3_R % 2 5 3 ! CONSTITUENT SI5Y3_R :SI : Y : ! PARAMETER G(SI5Y3_R,SI:Y;0) 2.98150E+02 -607356+84*T+5*GHSERSI# +3*GHSERY#; 6.00000E+03 N REF66 ! PHASE SIGMA % 3 8 4 18 ! CONSTITUENT SIGMA :MN : CR : CR,MN : ! PARAMETER G(SIGMA,MN:CR:CR;0) 2.98150E+02 +65859.5+8*GFCCMN# +22*GHSERCR#; 6.00000E+03 N REF2 ! PARAMETER G(SIGMA,MN:CR:MN;0) 2.98150E+02 -172946+69.0245*T+8*GFCCMN# +4*GHSERCR#+18*GBCCMN#; 6.00000E+03 N REF2 ! PARAMETER G(SIGMA,MN:CR:CR,MN;0) 2.98150E+02 -1095771+862.0312*T; 6.00000E+03 N REF2 ! PHASE SI1TI1 % 2 1 1 ! CONSTITUENT SI1TI1 :SI : TI : ! PARAMETER G(SI1TI1,SI:TI;0) 2.98150E+02 -155061.7+7.6345*T+GHSERSI# +GHSERTI#; 6.00000E+03 N REF123 ! PHASE SITI3 % 2 1 3 ! CONSTITUENT SITI3 :SI : TI : ! PARAMETER G(SITI3,SI:TI;0) 2.98150E+02 -200000+3.19924*T+GHSERSI# +3*GHSERTI#; 6.00000E+03 N REF123 ! PHASE SIV3 % 2 1 3 ! CONSTITUENT SIV3 :SI%,V : SI,V% : ! PARAMETER G(SIV3,SI:SI;0) 2.98150E+02 +208000-80*T+4*GHSERSI#; 6.00000E+03 N REF117 ! PARAMETER G(SIV3,V:SI;0) 2.98150E+02 +166000-60*T+3*GHSERSI#+GHSERV#; 6.00000E+03 N REF117 ! PARAMETER G(SIV3,SI:V;0) 2.98150E+02 -216397+516.532*T-90.44*T*LN(T) -.008346*T**2+358000*T**(-1); 6.00000E+03 N REF117 ! PARAMETER G(SIV3,V:V;0) 2.98150E+02 +18000+10*T+4*GHSERV#; 6.00000E+03 N REF117 ! PARAMETER G(SIV3,SI,V:SI;0) 2.98150E+02 +9794.5-21.8*T; 3.00000E+03 N REF117 ! PARAMETER G(SIV3,SI:SI,V;0) 2.98150E+02 -150000; 3.00000E+03 N REF117 ! PARAMETER G(SIV3,V:SI,V;0) 2.98150E+02 0.0 ; 3.00000E+03 N REF117 ! PARAMETER G(SIV3,SI,V:V;0) 2.98150E+02 +9794.5-21.8*T; 3.00000E+03 N REF117 ! PHASE SIY % 2 1 1 ! CONSTITUENT SIY :SI : Y : ! PARAMETER G(SIY,SI:Y;0) 2.98150E+02 -160700+19.8*T+GHSERSI#+GHSERY#; 6.00000E+03 N REF66 ! PHASE SI1ZR1 % 2 1 1 ! CONSTITUENT SI1ZR1 :SI : ZR : ! PARAMETER G(SI1ZR1,SI:ZR;0) 2.98150E+02 -182203.4+258.51454*T -45.18631*T*LN(T)-.004393865*T**2+5.49699E-11*T**3+148517.5*T**(-1); 6.00000E+03 N REF100 ! PHASE SIZR2 % 2 1 2 ! CONSTITUENT SIZR2 :SI : ZR : ! PARAMETER G(SIZR2,SI:ZR;0) 2.98150E+02 -255317.83+411.76673*T -72.43244*T*LN(T)-.00546177*T**2-4.0442633E-09*T**3+306730.45*T**(-1); 6.00000E+03 N REF100 ! PHASE SIZR3 % 2 1 3 ! CONSTITUENT SIZR3 :SI : ZR : ! PARAMETER G(SIZR3,SI:ZR;0) 2.98150E+02 -270398.16+457.33*T -82.328*T*LN(T)-.0263963*T**2+1.54326E-06*T**3-34700*T**(-1); 6.00000E+03 N REF100 ! PHASE SN3TI5 % 2 3 5 ! CONSTITUENT SN3TI5 :SN : TI : ! PARAMETER G(SN3TI5,SN:TI;0) 2.98150E+02 -398000+64.8*T+3*GLIQSN# +5*GLIQTI#; 3.00000E+03 N REF39 ! PHASE SN5TI6 % 2 5 6 ! CONSTITUENT SN5TI6 :SN : TI : ! PARAMETER G(SN5TI6,SN:TI;0) 2.98150E+02 -525800+77*T+5*GLIQSN# +6*GLIQTI#; 3.00000E+03 N REF39 ! PHASE SNTI2 % 2 1 2 ! CONSTITUENT SNTI2 :SN : TI : ! PARAMETER G(SNTI2,SN:TI;0) 2.98150E+02 -152700+26.80539*T+GLIQSN# +2*GLIQTI#; 3.00000E+03 N REF39 ! PHASE SNTI3 % 2 1 3 ! CONSTITUENT SNTI3 :SN,TI% : SN%,TI : ! PARAMETER G(SNTI3,SN:SN;0) 2.98150E+02 +4*GHSERSN#+5; 3.00000E+03 N REF39 ! PARAMETER G(SNTI3,TI:SN;0) 2.98150E+02 +300000-200*T+3*GLIQSN#+GLIQTI#; 3.00000E+03 N REF39 ! PARAMETER G(SNTI3,SN:TI;0) 2.98150E+02 -193466.8+35.74052*T+GLIQSN# +3*GLIQTI#; 3.00000E+03 N REF39 ! PARAMETER G(SNTI3,TI:TI;0) 2.98150E+02 +4*GHSERTI#; 3.00000E+03 N REF39 ! PARAMETER G(SNTI3,SN,TI:SN;0) 2.98150E+02 +400000; 3.00000E+03 N REF39 ! PARAMETER G(SNTI3,SN:SN,TI;0) 2.98150E+02 +400000-40*T; 3.00000E+03 N REF39 ! PARAMETER G(SNTI3,TI:SN,TI;0) 2.98150E+02 +600000+40*T; 3.00000E+03 N REF39 ! PARAMETER G(SNTI3,SN,TI:TI;0) 2.98150E+02 +200000-108*T; 3.00000E+03 N REF39 ! PHASE TI2N % 2 2 1 ! CONSTITUENT TI2N :TI : C,N : ! PARAMETER G(TI2N,TI:C;0) 2.98150E+02 -17349+GHSERTI#+GHSERTIC#; 6.00000E+03 N REF111 ! PARAMETER G(TI2N,TI:N;0) 2.98150E+02 -63220.14+22.42085*T+GHSERTI# +GHSERTIN#; 6.00000E+03 N REF111 ! LIST_OF_REFERENCES NUMBER SOURCE REF1 'S.G.T.E., solution data-base (1991), unaries' REF13 'N. Saunders, Rep. Univ. of Surrey, (1990), Al-Ti, Al-V, Ti-V ' REF8 'N. Saunders and V.G. Rivlin, Z. f\"{u}r Metallkde, 78, 11, 795-801 (1987), Al-Cr ' REF76 'M. Seiersten, private communication, Al-Fe ' REF23 'A. Jansson, Trita-Mac-0462, Materials Research Center, The Royal Institute of Technology, Stockholm (1991), Al-Mn ' REF103 'G. Cacciamani, private communication, Al-Ce, Ce-Mg ' REF80 'G. Cacciamani, G. Borzone, R. Ferro, L. Battezzati, and M. Baricco, Calphad XXII - Salou, 15-21/5/93, poster (1993), Al-Nd ' REF105 'T.G. Chart, private communication, Al-Li-Mg ' REF11 'N. Saunders, Calphad, 14, 1, 61-70, (1990), Al-Mg, Mg-Li ' REF121 'M. Seiersten, private communication, Al-Fe-Si ' REF52 'H.L. Lukas 1992, private communication, Al-Y' REF74 'N. Saunders, private communication, Al-Cu, Al-Zr, Cu-Li, Li-Zr ' REF46 'H.L. Lukas 1992, private communication, Al-C' REF115 'P. Kolby, private communication, Al-Mn-Si' REF109 'A. Jansson, private communication, Al-Fe-Mn ' REF29 'J. Tibballs, private communication, Fe-Mg Mg-Mn Mn-Si' REF44 'H.L. Lukas 1992, private communication, Al-B' REF119 'N. Saunders, private communication, Al-Cu-Li ' REF72 'N. Saunders, Rep. ThermoTech, (1992), Cr-Ti, Mn-Ti ' REF126 'U Nknown, Al-Mg-Mn' REF48 'H.L. Lukas 1992, private communication, Al-N ' REF89 'C. Baetzner, Thesis, M.P.I. Stuttgart (1994), B-Ti ' REF58 'H.L. Lukas 1992, private communication, B-Si' REF54 'H.L. Lukas 1992, private communication, B-C' REF111 'S. Jonsson, private communication, C-Ti N-Ti ' REF70 'Marek, and P. Spencer, private communication, Cu-Zn ' REF26 'J. Lacaze, and B. Sundman, Met. Trans., 22A, 10, 2211-2223 (1991), Fe-Si ' REF56 'H.L. Lukas 1992, private communication, B-N' REF2 'B Lee, KTH Cr-Mn' REF91 'C.A. Coughnanowr, I. Ansara, and H.L. Lukas, Calphad, 18, 2, 125-140 (1994). Cr-Si ' REF83 'I. Ansara, private communication, Cr-Mg ' REF60 'H.L. Lukas 1992, private communication, C-Si' REF125 'U Nknown, Cu-Zr' REF94 'M. Jacobs, Cost507 Final Report (1994) Cu-Si, Si-Sn, Si-Zn, Al-Si-Zn, Cu-Mg-Ni ' REF20 'C.A. Coughnanowr, I. Ansara, R. Luoma, M. Hamalainen, and H.L. Lukas, Zeit. fur Metallkde., 82, 7, 574-581 (1991), Cu-Mg ' REF129 'I Ansara, added to make phase unstable' REF98 'K. Zeng, M. Hamalainen, and I. Ansara, Cr-Zr ' REF64 'H.L. Lukas 1992, private communication, Mg-Y ' REF62 'H.L. Lukas 1992, private communication, Mg-Si' REF33 'R. Agarwal, S.G. Fries, H.L. Lukas, G. Petzow, F. Sommer, T.G. Chart, G. Effenberg, Zeit. fur Metallkde., 83, 4, 216-223 (1992), Mg-Zn' REF123 'H. Seiffert, Thesis, MPI, Stuttgart, (1994), Si-Ti ' REF117 'M.H. Rand, private communication, Si-V ' REF66 'H.L. Lukas 1992, private communication, Si-Y' REF100 'C. Gueneau, C. Servant, I. Ansara, and N. Dupin, Calphad, 18, 3 319-328 (1994), Si-Zr ' REF39 'F. Hayes, private communication, Sn-Ti ' REF50 'H.L. Lukas 1992, private communication, Al-Si' REF15 'N. Chakraborti, G. Effenberg, S. G.-Fries, S. Kuang, H.L. Lukas, and H.L. Petzow, Vortr. Poster Symp. Materialforsch., 1991, 2nd, 3, 2692-2693 (1991). Al-Sn ' REF78 'S. an Mey, Zeit. fur Metallkde, 84, (7), 451-455 (1993), Al-Zn ' REF96 'K. Zeng, M. Hamalainen, private communication, Cr-Cu ' REF85 'I. Ansara, A. Jansson, Trita-Mac-0533, Materials Research Center, The Royal Institute of Technology, Stockholm (Sweden) (1993), Cu-Fe ' REF31 'S. an Mey, Calphad, 16, 3, 255-260 (1992), Cu-Ni ' REF6 'W Huang, KTH Fe-Mn ' REF68 'M. Hamalainen, private communication, Mg-Zr ' REF107 'M. Jacobs, private communication, Al-Sn-Zn ' REF113 'H.L. Lukas, private communication, Al-Mg-Si ' REF127 'F Hayes, Al-Ti-V' 93AKE 'Å Jansson, KTH 1993' BO2021 'B Sundman, Same excess as liquid to prevent HCP to be stable, 2021' REF0 'Not assessed' ! ================================================ FILE: examples/macros/cslaf-excess.TDB ================================================ $ CSLAF FROM DAT WITH SPLIT REFERENCE ENERGEIS ELEMENT CS SER 132.9 0 0 0 ! ELEMENT F GAS 18.9984 0 0 0 ! ELEMENT LA SER 138.9055 0 0 0 ! SPECIES CSF CSF ! SPECIES LAF3 LAF3 ! SPECIES LA/F LA/F 6.0 2.0 2.4 ! SPECIES CS/F CS/F 6.0 6.0 2.4 ! SPECIES LACS/F LA,CS/F 9.0 6.0 4.0 ! FUNCTION GLIQLAF 298.15 -1674170.0+806.53663*T-135*T*LN(T); 2500 N! FUNCTION GLIQCSF 298.15 -565946.80+405.89131*T-74.057*T*LN(T); 2000 N! $ FUNCTION GLIQLAF 298.15 0; 2500 N ! $ FUNCTION GLIQCSF 298.15 0; 2500 N ! TYPE_DEFINITION % SEQ * ! DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! PHASE LIQUID:Q % 1 1.0 ! $ bond fractions as in order of sublattice species CONST LIQUID:Q : LA/F-Q CS/F-Q LACS/F-Q : ! $ LA1/6 F1/2 is 2/3+2/2= 1/3 mole LaF3 PARAMETER G(LIQUID,LA/F-Q) 298.15 0.33333333*GLIQLAF; 6000 N 08Ben ! $ PARAMETER G(LIQUID,LA/F-Q) 298.15 GLIQLAF; 6000 N 08Ben ! $ Cs1/6 F1/6 is 2/6+2/6= 1/3 mole CsF PARAMETER G(LIQUID,CS/F-Q) 298.15 0.3333333*GLIQCSF; 6000 N 08Ben ! $ PARAMETER G(LIQUID,CS/F-Q) 298.15 GLIQCSF; 6000 N 08Ben ! $ NO REFERENCE STATE addded as that is calculated using the FNN $ The DAT file has twice this value $ 0 0 -21625.146 0.00000000 0.00000000 0.00000000 PARAMETER G(LIQUID,LACS/F-Q) 298.15 -10812.573; 6000 N bo! $ THESE PARAMETERS SHOULD BE HALFED ALSO ... $ 0 0 -1398.2896 -14.232842 0.00000000 0.00000000 $ 0 0 -2977.6120 4.9256711 0.00000000 0.00000000 PARAMETER G(LIQUID,LACS/F-Q,CS/F-Q) 298.15 -699.1448-7.1164*T; 6000 N 08Ben! PARAMETER G(LIQUID,LACS/F-Q,LA/F-Q) 298.15 -1488.806+2.4628355*T; 6000 N 08Ben ! PHASE LAF3 % 2 1.0 3.0 ! CONST LAF3 :LA:F: ! PARAMETER G(LAF3,LA:F) 298.15 GLAF3; 2500 N 08Ben ! FUNCTION GLAF3 298.15 -1712105.5+715.96122*T-122.11880*T*LN(T) +0.11233700E-01*T**2+0.27182333E-05*T**3+1085690.0*T**(-1) -.23478833E-08*T**4; 2500.0000 N 08Ben ! PHASE CSF % 2 1.0 1.0 ! CONST CSF :CS:F: ! PARAMETER G(CSF,CS:F) 298.15 GCSF; 2000 N 08Ben ! FUNCTION GCSF 298.15 -569439.00+230.50900*T-46.810600*T*LN(T) -.87950000E-02*T**2+4110.7635*T**(-1); 2000.0000 N 08Ben ! PHASE CS3LAF6 % 3 3.0 1.0 6.0 ! CONST :CS:LA:F: ! PARAMETER G(CS3LAF6,CS:LA:F) 298.15 GCSLAF; 2000 N 08Ben ! FUNCTION GCSLAF 298.15 -3524425.5+1383.1064*T-262.7*T*LN(T) +0.75E-02*T**2; 2000.0000 N 08Ben! LIST_OF_REFERENCES NUMBER SOURCE 08Ben 'O Benes, R J M Konings, Calphad 32 (2008) 121-128' ! ================================================ FILE: examples/macros/cslaf-map.OCM ================================================ new Y set echo Y @$================================================================= @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ Testing CsLaF with reference states @$ @$================================================================= r t ./cslaf-excess @& set c t=1600 p=1e5 n(la)=.2 n(cs)+n(la)=1 ac(f)=1 c e l , 2 @& set ax 1 n(la) 0 1 .01 set ax 2 t 300 2000 10 map @& plot x(*,la) t pos left title Fig 1: CsF-LaF3 phase diagram extra axis-factor x 4 text .42 400 .9 0 n Note fraction scale multiplied by 4, compound composition not correct @& @$ No more for the moment @$========================================================================== @$ end of cslaf-map macro @$========================================================================== set inter ================================================ FILE: examples/macros/hogas.TDB ================================================ $ Database file written 2012- 5-31 $ From database: USER ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT H 1/2_MOLE_H2(GAS) 1.0079E+00 4.2340E+03 6.5285E+01! ELEMENT O 1/2_MOLE_O2(GAS) 1.5999E+01 4.3410E+03 1.0252E+02! SPECIES H1O1 H1O1! SPECIES H1O2 H1O2! SPECIES H2 H2! SPECIES H2O1 H2O1! SPECIES H2O2 H2O2! SPECIES O2 O2! SPECIES O3 O3! FUNCTION F10447T 2.98150E+02 +211801.621+24.4989816*T-20.78611*T*LN(T); 6.00000E+03 N ! FUNCTION F10666T 2.98150E+02 +30698.6898+15.9096451*T-29.97699*T*LN(T) +.001713168*T**2-6.799205E-07*T**3-25503.82*T**(-1); 1.00000E+03 Y +31735.5127-12.686636*T-25.42186*T*LN(T)-.003149545*T**2 +1.34404917E-07*T**3+116618.65*T**(-1); 3.00000E+03 Y +41016.0783-20.7343256*T-24.94216*T*LN(T)-.0023107985*T**2 +5.91863E-08*T**3-6415210*T**(-1); 8.60000E+03 Y -154907.953+370.326117*T-69.24542*T*LN(T)+.0019361405*T**2 -1.47539017E-08*T**3+1.4391015E+08*T**(-1); 1.80000E+04 Y +326722.277-65.0792741*T-24.2768*T*LN(T)+6.42189E-05*T**2 -1.30298483E-10*T**3-8.292415E+08*T**(-1); 2.00000E+04 N ! FUNCTION F10729T 2.98150E+02 +1075.64106-55.242048*T-24.45435*T*LN(T) -.018507875*T**2+2.36297E-06*T**3-29469.05*T**(-1); 8.00000E+02 Y -7932.99164+54.2016233*T-40.775*T*LN(T)-.00501027*T**2 +2.122915E-07*T**3+925845*T**(-1); 3.60000E+03 Y -67875.8961+275.406716*T-68.1173*T*LN(T)+6.12331E-04*T**2 -6.573855E-09*T**3+26048030*T**(-1); 6.00000E+03 N ! FUNCTION F10854T 2.98150E+02 -9522.97393+78.5273873*T-31.35707*T*LN(T) +.0027589925*T**2-7.46390667E-07*T**3+56582.3*T**(-1); 1.00000E+03 Y +180.10884-15.6128262*T-17.84857*T*LN(T)-.00584168*T**2 +3.14618667E-07*T**3-1280036*T**(-1); 2.10000E+03 Y -18840.1661+92.3120249*T-32.05082*T*LN(T)-.0010728235*T**2 +1.14281783E-08*T**3+3561002.5*T**(-1); 6.00000E+03 N ! FUNCTION F10963T 2.98150E+02 -250423.434+4.45470312*T-28.40916*T*LN(T) -.00623741*T**2-6.01526167E-08*T**3-64163.45*T**(-1); 1.10000E+03 Y -256145.879+30.1894682*T-31.43044*T*LN(T)-.007055445*T**2 +3.05535833E-07*T**3+1246309.5*T**(-1); 2.80000E+03 Y -268423.418+116.690197*T-42.96842*T*LN(T)-.003069987*T**2 +6.97594167E-08*T**3+2458230.5*T**(-1); 8.40000E+03 Y -489068.882+553.259882*T-92.4077*T*LN(T)+.0016703495*T**2 -1.32333233E-08*T**3+1.765625E+08*T**(-1); 1.80000E+04 Y -165728.771+239.645643*T-59.77872*T*LN(T)+2.213599E-04*T**2 -1.2921095E-09*T**3-4.1931655E+08*T**(-1); 2.00000E+04 N ! FUNCTION F10983T 2.98150E+02 -147258.971-37.1497212*T-26.10636*T*LN(T) -.036948065*T**2+6.659505E-06*T**3+65357.65*T**(-1); 7.00000E+02 Y -156470.505+120.191295*T-50.94271*T*LN(T)-.007931945*T**2 +4.29733833E-07*T**3+684985.5*T**(-1); 1.50000E+03 N ! FUNCTION F13469T 2.98150E+02 +243206.494-20.8612587*T-21.01555*T*LN(T) +1.2687055E-04*T**2-1.23131283E-08*T**3-42897.09*T**(-1); 2.95000E+03 Y +252301.423-52.0847285*T-17.21188*T*LN(T)-5.413565E-04*T**2 +7.64520667E-09*T**3-3973170.5*T**(-1); 6.00000E+03 N ! FUNCTION F13839T 2.98150E+02 -6960.69252-51.1831473*T-22.25862*T*LN(T) -.01023867*T**2+1.339947E-06*T**3-76749.55*T**(-1); 9.00000E+02 Y -13136.0172+24.743296*T-33.55726*T*LN(T)-.0012348985*T**2 +1.66943333E-08*T**3+539886*T**(-1); 3.70000E+03 Y +14154.6461-51.4854586*T-24.47978*T*LN(T)-.002634759*T**2 +6.01544333E-08*T**3-15120935*T**(-1); 9.60000E+03 Y -314316.628+515.068037*T-87.56143*T*LN(T)+.0025787245*T**2 -1.878765E-08*T**3+2.9052515E+08*T**(-1); 1.85000E+04 Y -108797.175+288.483019*T-63.737*T*LN(T)+.0014375*T**2-9E-09*T**3 +.25153895*T**(-1); 2.00000E+04 N ! FUNCTION F14145T 2.98150E+02 +130696.944-37.9096651*T-27.58118*T*LN(T) -.02763076*T**2+4.60539333E-06*T**3+99530.45*T**(-1); 7.00000E+02 Y +114760.623+176.626736*T-60.10286*T*LN(T)+.00206456*T**2 -5.17486667E-07*T**3+1572175*T**(-1); 1.30000E+03 Y +49468.3958+710.094819*T-134.3696*T*LN(T)+.039707355*T**2 -4.10457667E-06*T**3+12362250*T**(-1); 2.10000E+03 Y +866367.075-3566.80563*T+421.2001*T*LN(T)-.1284109*T**2 +5.44768833E-06*T**3-2.1304835E+08*T**(-1); 2.80000E+03 Y +409416.384-1950.70834*T+223.4437*T*LN(T)-.0922361*T**2 +4.306855E-06*T**3-21589870*T**(-1); 3.50000E+03 Y -1866338.6+6101.13383*T-764.8435*T*LN(T)+.09852775*T**2 -2.59784667E-06*T**3+9.610855E+08*T**(-1); 4.90000E+03 Y +97590.0432+890.79836*T-149.9608*T*LN(T)+.01283575*T**2 -3.555105E-07*T**3-2.1699975E+08*T**(-1); 6.00000E+03 N ! FUNCTION F10952T 2.98150E+02 -332319.671+1078.59563*T-186.8669*T*LN(T) +.2320948*T**2-9.14296167E-05*T**3+978019*T**(-1); 5.00000E+02 Y -62418.8788-3288.18729*T+495.1304*T*LN(T)-.504926*T**2 +4.917665E-05*T**3-18523425*T**(-1); 5.40000E+02 Y -8528143.9+142414.45*T-22596.19*T*LN(T)+27.48508*T**2 -.00631160667*T**3+5.63356E+08*T**(-1); 6.00000E+02 Y -331037.282+741.178604*T-117.41*T*LN(T); 6.01000E+02 N ! FUNCTION F10981T 2.98150E+02 -214494.862+488.664597*T-89.3284*T*LN(T); 1.50000E+03 N ! FUNCTION UN_ASS 298.15 0; 300 N ! TYPE_DEFINITION % SEQ *! DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! PHASE GAS:G % 1 1.0 ! CONSTITUENT GAS:G :H,H2,H2O1,O,O2,O3 : ! $ CONSTITUENT GAS:G :H,H1O1,H1O2,H2,H2O1,H2O2,O,O2,O3 : ! PARAMETER G(GAS,H;0) 2.98150E+02 +F10447T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF86 ! $ PARAMETER G(GAS,H1O1;0) 2.98150E+02 +F10666T#+R#*T*LN(1E-05*P); $ 6.00000E+03 N REF93 ! $ PARAMETER G(GAS,H1O2;0) 2.98150E+02 +F10729T#+R#*T*LN(1E-05*P); $ 6.00000E+03 N REF94 ! PARAMETER G(GAS,H2;0) 2.98150E+02 +F10854T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF95 ! PARAMETER G(GAS,H2O1;0) 2.98150E+02 +F10963T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF101 ! $ PARAMETER G(GAS,H2O2;0) 2.98150E+02 +F10983T#+R#*T*LN(1E-05*P); $ 6.00000E+03 N REF102 ! PARAMETER G(GAS,O;0) 2.98150E+02 +F13469T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF116 ! PARAMETER G(GAS,O2;0) 2.98150E+02 +F13839T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF117 ! PARAMETER G(GAS,O3;0) 2.98150E+02 +F14145T#+R#*T*LN(1E-05*P); 6.00000E+03 N REF118 ! LIST_OF_REFERENCES NUMBER SOURCE REF86 'H1 JANAF 1982; ASSESSMENT DATED 3/77 SGTE ** HYDROGEN < MONATOMIC GAS>' REF93 'H1O1 T.C.R.A.S. Class: 1' REF94 'H1O2 T.C.R.A.S. Class: 4' REF95 'H2 JANAF THERMOCHEMICAL TABLES SGTE ** HYDROGEN STANDARD STATE FROM CODATA KEY VALUES. CP FROM JANAF PUB. 3/61' REF101 'H2O1 T.C.R.A.S. Class: 1 WATER ' REF102 'H2O2 JANAF SECOND EDIT SGTE HYDROGEN PEROXIDE ' REF116 'O1 JANAF 1982; ASSESSMENT DATED 3/77 SGTE OXYGEN ' REF117 'O2 T.C.R.A.S. Class: 1 OXYGEN ' REF118 'O3 T.C.R.A.S. Class: 4 OZONE ' REF128 'H2O1 T.C.R.A.S. Class: 4 WATER T.C.R.A.S. Class: 4 modified by atd 12/9/94' REF129 'H2O2 THERMODATA 01/93 HYDROGEN PEROXIDE 28/01/93' ! ================================================ FILE: examples/macros/iron4cd.TDB ================================================ $ $ Database for cast iron (Fe-Cr-Cu-Mg-Mn-Mo-Nb-Ni-Si-Ti-V-C-N), $ Version 4c. $ Compiled by Bengt Hallstedt, July 2020, (version 04b in December 2017, $ 04a in October 2017, 03 in June 2017, 02b in February 2017, $ 02a in August 2015, 01c in May 2008). $ $ ------------------------------------------------------------------------------ $ $ This database is open access under the CC BY license. $ https://creativecommons.org/licenses/by/4.0/ $ $ For comments and questions please contact: $ $ Dr. Bengt Hallstedt $ Institute for Materials Applications in Mechanical Engineering (IWM) $ RWTH Aachen University, Aachen, Germany $ b.hallstedt@iwm.rwth-aachen.de $ $ To cite the database, please use: $ $ B. Hallstedt, A thermodynamic database for cast iron, Calphad XLVI, $ June 11-16, 2017, Saint-Malo, France. $ $ ------------------------------------------------------------------------------ $ $ Open issues: $ Cr-Ni: C14_LAVES parameters $ Cr-Si: B2_BCC parameters $ $ Version information $ =================== $ $ Changes from version 04a to 04c: $ $ Modifications by Bo Sundman for use with OpenCalphad. $ $-------------------------------------------------- $ Modification for use by OC 2020-07-28:/BoS $ Moved DEFAULT section before PHASES to have TYPE_DEFS defined $ Changed phase CU4TI to CU4TI1 as ambiguous with CU4TI3 $ Changed phase FENBSI to FENBSI1 as ambiguous with FENBSI2 $ Changed phase NI2V to NI2V1 as ambigous with NI2V7_A15 $ Changed property Identifier BM to BMAG $ $ 2020.07.28: Modified for use with GES6. $ $ Changes from version 04a to 04b: $ $ Cr-Fe-Si: Estimated ternary fcc interaction. $ $ Changes from version 03 to 04a: $ $ Mostly checks and modifications in ternary systems. $ $ Cu-C: New parameters for FCC_A1 and BCC_A2. $ Ni-Si: 12Yua changed back to 99Du, except fcc ordering parameters. $ Cr-Mo-Ni: Modified sigma and P-phase parameters. $ Cr-Ni-Si: Acceptable, but would need more work. $ Cr-V-C: Modified liquid interaction. $ Cu-Fe-C: Added from Hallstedt 2017. $ Cu-Fe-Nb: Added from Wang 2000. $ Fe-Nb-Ti: Added from Hallstedt 2017. $ Mo-Nb-C: Added from Zhang 2015. $ Ti-V-C: Updated from 08Mar to 15Zha. $ $ 2017.07.07: Error in the parameters for FE2SI and FESI2_L corrected. $ $ Changes from version 02b to 03: $ $ This is a major rebuild, using more modern datasets for several systems. $ In particular all relevant systems from mpea-2 and PrecHiMn-4 were included. $ Note that Fe-Si-C in PrecHiMn-4 uses an unfortunate combination of Si-C and $ ternary liquid interaction (which is not used here). $ $ Ordering models for fcc (FCC_4SL) and bcc (B2_BCC) are now included. They $ are deactivated by default and have to be activated when needed. $ They are needed for FeNi3 (L1_2), FeSi (B2), FeTi (B2), MnNi (B2, L1_0), $ MnNi3 (L1_2), NiTi (B2). $ $ Only the 10:4:16 model is included for sigma and high-sigma. The old 8:4:18 $ model is not included. $ $ Cr-C: Modified from Lee 1992 to Khvan 2012. $ Cr-Nb: Updated from Costa Neto 1993 to Schmetterer 2014. $ Cr-Ni: Updated from Lee 1992 to Tang 2016. $ Cr-Ti: Updated from 98Sau to 10Pav. $ Cu-Mg: Updated from Coughanowr 1998 to Hallstedt 2016. $ Cu-Si: Updated from Yan 2000 to Hallstedt 2016. $ Fe-C: Cementite modified. $ Fe-Mo: New model for MU_D85, modified models for SIGMA_D8B and C14_LAVES. $ Fe-Mn: HCP_A3 interaction slightly modified. $ Fe-Nb: Updated from Lee 2001 to Liu 2012/Khvan 2013/Jacob 2016. $ Fe-Ni: Updated from Xing 1985 to Dupin 2003. $ Fe-Ti: Updated from Dumitrescu 1998 to Bo 2012. $ Mg-Mn: Updated from Tibballs 1998 to Groebner 2005. $ Mg-N: Added from Hallstedt 2015. $ Mg-Nb: Added from Hallstedt 2015. $ Mg-Si: Updated from Kevorkov 2004 to Liang 2016. $ Mg-Ti: Added from Murray 1986. $ Mg-V: Added from Hallstedt 2015. $ Mn-C: Updated from Huang 1990 to Djurovic 2010. $ Mn-Nb: Added from Liu 2012. $ Mn-Ni: Updated from Guo 2005 to Franke 2007. $ Mo-Nb: Added from Xiong 2004. $ Nb-C: Bcc modified. $ Nb-N: Updated from Huang 1996 to Khvan 2013. $ Nb-Ni: Updated from Bolcavage 1996 to Chen 2006 with modified MU_D85. $ Nb-Si: Updated from Fernandes 2002 to Geng 2009. $ Cr-Fe-C: Updated from Lee 1992 to Khvan 2014. $ Cr-Fe-Mn: New model for SIGMA_D8B and HIGH_SIGMA. $ Cr-Fe-Mo: New model for MU_D85 and SIGMA_D8B, modified model for C14_LAVES. $ Cr-Fe-Nb: Added from Jacob 2016. $ Cr-Fe-Ni: New model for SIGMA_D8B. $ Cr-Fe-Si: New model for SIGMA_D8B. $ Cr-Fe-V: New model for SIGMA_D8B. $ Cr-Mn-Ni: Added from Hallstedt 2016. $ Cr-Nb-C: Added from Khvan 2012. $ Fe-Mn-C: Updated from Huang 1990 to Djurovic 2011. $ Fe-Mn-Nb: Added from Khvan 2013. $ Fe-Mo-Ni: New model for MU_D85 and SIGMA_D8B, modified model for C14_LAVES. $ Fe-Mo-Ti: New model for MU_D85, modified model for C14_LAVES. $ Fe-Nb-C: Updated from Lee 2001 to Khvan 2013. $ Fe-Nb-N: Updated from Lee 2001 to Khvan 2013. $ Fe-Nb-Si: Added from Jacob 2016. $ Fe-Nb-V: Added from Khvan 2013. $ Fe-Ti-C: Changed from Lee 2001 to Dumitrescu 1999. $ Fe-Ti-N: Modified. $ Mn-Nb-C: Added from Khvan 2012. $ Mn-Nb-N: Added from Khvan 2013. $ Nb-C-N: Updated from Lee 2001 to Khvan 2013. $ $ Changes from version 02a to 02b: $ $ Si is included in M6C. M6C is found to form in Mo containing casts. $ The calculated Si content in M6C is considerably higher than measured, $ but similar to TCFE7/TCFE8. $ Si-C is changed from 96Gro to 91Lac in order to reproduce Fe-Si-C $ from J. Miettinen 1998. $ $ Changes from version 01c to 02a: $ $ Nb, Ti, V and N are added to the database. $ Most of the data concerning Nb, V and N are taken from PrecHiMn-01 and $ most of the data concerning Ti are taken from PrecHiMn-04. $ Several Fe-systems in PrecHiMn-04 are not compatible with iron-01c. $ $ ------------------------------------------------------------------------------ DATABASE_INFO ' Welcome to version 4c of the iron database for alloyed and unalloyed' cast iron.'' Created by Bengt Hallstedt in May 2008, updated in August 2015,' February 2017, March 2017 and September 2017.'' The database contains the elements Fe, Cr, Cu, Mg, Mn, Mo, Nb, Ni, Si,' Ti, V, C and N.''' A few notes on phases in the database:'' FCC_A1 is both austenite and cubic (Nb,Ti,V)(C,N).' HCP_A3 is both the epsilon-phase (epsilon-martensite) and the M2X' hexagonal carbide/nitride.'' At high contents of Si the BCC_A2 phase (ferrite) may order.' This is described by the B2_BCC phase, which is deactivated by default.' To activate it, the following commands are needed in the database module:' RESTORE PHASE A2_BCC B2_BCC' REJECT PHASE BCC_A2' All equilibria with BCC_A2 will be reproduced as before, but the phase' name will now be B2_BCC.'' If you suspend the GRAPHITE to calculate equilibria with CEMENTITE,' you should also suspend DIAMOND. Otherwise DIAMOND may become more stable' than CEMENTITE at low temperature.'' The GAS phase is deactivated by default, so if you need it activate it' in the database module: RESTORE PHASE GAS'' The database contains quite a large number of phases that will be of' little interest in most cases. For calculations with several elements' it is recommended to suspend all phases except those actually needed' in order to speed up the calculations.''' All binary systems are included in the database, except Mg-Mo.' The ternary systems' Cr-Cu-Fe, Cr-Fe-C, Cr-Fe-Mn, Cr-Fe-Mo, Cr-Fe-N, Cr-Fe-Nb, Cr-Fe-Ni,' Cr-Fe-Si, Cr-Fe-V, Cr-Mn-C, Cr-Mn-Ni, Cr-Mo-C, Cr-Mo-Ni, Cr-Nb-C, Cr-Ni-C,' Cr-Ni-Si, Cr-Si-C, Cr-V-C, Cu-Fe-C, Cu-Fe-Mn, Cu-Fe-Mo, Cu-Fe-Nb, Cu-Fe-Ni,' Cu-Fe-Si, Fe-C-N, Fe-Mn-C, Fe-Mn-N, Fe-Mn-Nb, Fe-Mn-Ni, Fe-Mn-Si, Fe-Mn-V,' Fe-Mo-C, Fe-Mo-N, Fe-Mo-Ni, Fe-Mo-Ti, Fe-Nb-C, Fe-Nb-N, Fe-Nb-Si, Fe-Nb-Ti,' Fe-Nb-V, Fe-Ni-C, Fe-Ni-N, Fe-Ni-Si, Fe-Si-C, Fe-Ti-C, Fe-Ti-N, Fe-V-C,' Fe-V-N, Mn-Nb-C, Mn-Nb-N, Mn-V-C, Mo-Nb-C, Mo-Ti-C, Mo-V-C, Nb-C-N, Nb-Ti-C,' Nb-Ti-N, Nb-V-C, Ni-Si-C, Ni-V-C, Ti-C-N, Ti-V-C, Ti-V-N and V-C-N' are included.'' ! $ $ ------------------------------------------------------------------------------ TEMP-LIM 298.15 6000.00 ! $ $ELEMENT NAME REF. STATE ATOMIC MASS H298-H0 S298 ! $ ELEMENT VA VACUUM 0.0 0.0 0.0 ! ELEMENT C GRAPHITE_A9 12.011 1054.0 5.7423 ! ELEMENT CR BCC_A2 51.996 4050.0 23.5429 ! ELEMENT CU FCC_A1 63.546 5004. 33.15 ! ELEMENT FE BCC_A2 55.847 4489.0 27.2797 ! ELEMENT MG HCP_A3 24.305 4998. 32.671 ! ELEMENT MN CBCC_A12 54.9380 4995.696 32.2206 ! ELEMENT MO BCC_A2 95.94 4589.0 28.56 ! ELEMENT N 1/2_MOLE_N2(G) 14.007 4335.0 95.751 ! ELEMENT NB BCC_A2 92.9064 5220.0 36.27 ! ELEMENT NI FCC_A1 58.69 4787.0 29.7955 ! ELEMENT SI DIAMOND_A4 28.0855 3217. 18.81 ! ELEMENT TI HCP_A3 47.88 4824. 30.72 ! ELEMENT V BCC_A2 50.9415 4507.0 30.89 ! $ ------------------------------------------------------------------------------ $ Species $ SPECIE FE2 FE2 ! SPECIE MG2 MG2 ! SPECIE N2 N2 ! SPECIE N3 N3 ! SPECIE SI2 SI2 ! SPECIE SI3 SI3 ! SPECIE SIN SI1N1 ! SPECIE SI2N SI2N1 ! $ ------------------------------------------------------------------------------ $ Defaults and TYPE_DEF $ DEFINE-SYSTEM-DEFAULT ELEMENT 2 ! DEFAULT-COM DEFINE_SYSTEM_ELEMENT VA ! $ $ with the default reject no ordering in FCC and BCC DEFAULT-COM REJECT_PHASE A1_FCC FCC_4SL A2_BCC B2_BCC GAS ! $ with this default reject include ordering in BCC and FCC $DEFAULT-COM REJECT_PHASE FCC_A1 BCC_A2 GAS ! $ TYPE-DEF % SEQ * ! TYPE-DEF A GES AMEND_PHASE_DESCRIPTION @ MAGNETIC -3 0.28 ! TYPE-DEF B GES AMEND_PHASE_DESCRIPTION @ MAGNETIC -1 0.4 ! TYPE-DEF O GES AMEND_PHASE_DESCRIPTION B2_BCC DIS_PART A2_BCC ! TYPE-DEF Y GES AMEND_PHASE_DESCRIPTION FCC_4SL DIS_PART A1_FCC ! TYPE-DEF S IF((NB OR TI OR V) AND (C OR N)) THEN GES AMEND_PHASE_DESCRIPTION @ COMP-SETS,, NB TI V : C N : ! FUNCTION ZERO 298.15 0; 6000 N ! FUNCTION UN_ASS 298.15 0; 6000 N ! FUNCTION R 298.15 +8.31451; 6000 N ! FUNCTION RTLNP 298.15 +8.31451*T*LN(1E-05*P); 6000 N ! $ ------------------------------------------------------------------------------ $ Phase definitions $ PHASE LIQUID:L % 1 1 ! CONST LIQUID:L : C CR CU FE MG MN MO N NB NI SI TI V : ! $ $ Fcc (cF4, Fm-3m) and MeX (cF8, Fm-3m) $ PHASE FCC_A1 %AS 2 1 1 ! CONST FCC_A1 : CR CU% FE% MG MN% MO NB NI% SI TI V : C N VA% : ! $ $ Disordered part of FCC_4SL, identical to FCC_A1 $ PHASE A1_FCC %A 2 1 1 ! CONST A1_FCC : CR CU% FE% MG MN% MO NB NI% SI TI V : C N VA% : ! $ $ Prototype AuCu3 (cP4, Pm-3m, L1_2) and AuCu (tP4, P4/mmm, L1_0) $ PHASE FCC_4SL:F %AY 5 0.25 0.25 0.25 0.25 1 ! CONST FCC_4SL:F : CR CU FE MG MN MO NB NI SI TI V : CR CU FE MG MN MO NB NI SI TI V : CR CU FE MG MN MO NB NI SI TI V : CR CU FE MG MN MO NB NI SI TI V : C N VA% : ! $ $ Bcc (cI2, Im-3m) $ PHASE BCC_A2 %B 2 1 3 ! CONST BCC_A2 : CR% CU FE% MG MN MO% NB% NI SI TI% V% : C N VA% : ! $ $ Disordered part of B2_BCC, identical to BCC_A2 $ PHASE A2_BCC %B 2 1 3 ! CONST A2_BCC : CR% CU FE% MG MN MO% NB% NI SI TI% V% : C N VA% : ! $ $ Prototype CsCl (cP2, Pm-3m) $ PHASE B2_BCC %BO 3 0.5 0.5 3 ! CONST B2_BCC : CR CU FE MG MN MO NB NI SI TI V : CR CU FE MG MN MO NB NI SI TI V : C N VA% : ! $ $ Hcp (hP2, P6_3/mmc) and Me2X (NiAs-type, hP4, P6_3/mmc, B8_1) $ PHASE HCP_A3 %A 2 1 0.5 ! CONST HCP_A3 : CR CU FE MG% MN MO NB NI SI TI% V : C N VA% : ! $ $ Prototype alpha-Mn (cI58, I-43m) $ PHASE CBCC_A12 %A 2 1 1 ! CONST CBCC_A12 : CR CU FE MG MN% MO NB NI SI TI V : C N VA% : ! $ $ Prototype beta-Mn (cP20, P4_132) $ PHASE CUB_A13 % 2 1 1 ! CONST CUB_A13 : CR CU FE MG MN% MO NB NI SI TI V : C N VA% : ! $ $ Prototype C (cF8, Fd-3m) $ PHASE DIAMOND_A4 % 1 1 ! CONST DIAMOND_A4 : C MG SI% : ! $ $ Prototype C (hP4, P6_3/mmc) $ PHASE GRAPHITE_A9 % 1 1 ! CONST GRAPHITE_A9 : C : ! $ $ Prototype Fe3C (oP16, Pnma) $ PHASE CEMENTITE_D011 %A 2 3 1 ! CONST CEMENTITE_D011 : CR FE MN MO NB NI V : C N : ! $ $ Prototype alpha-Mn (cI58, I-43m) $ PHASE CHI_A12 % 3 24 10 24 ! CONST CHI_A12 : CR FE NI : CR MO : CR FE MO NI : ! $ $ Prototype Cr3C2 (oP20, Pnma) $ PHASE CR3C2_D510 % 2 3 2 ! CONST CR3C2_D510 : CR MO V : C : ! $ $ Similar to alpha-Mn (cI58, I-43m) $ PHASE CR3MN5 % 2 3 5 ! CONST CR3MN5 : CR : MN : ! $ $ Prototype MoPt2 (oP6, Immm, ordered fcc) $ PHASE CRNI2_C11B % 2 1 2 ! CONST CRNI2_C11B : CR MO : MO NI% : ! $ $ Prototype AlAu4 (cP20, P2_13) also pi $ PHASE CR3NI5SI2 % 3 3 5 2 ! CONST CR3NI5SI2 : CR : NI : SI : ! $ $ Unknown structure $ PHASE CR5NI5SI3 % 3 5 5 3 ! CONST CR5NI5SI3 : CR : NI : SI : ! $ $ Prototype Cr3Si (cP8, Pm-3n) $ PHASE CR3SI_A15 % 3 3 1 3 ! CONST CR3SI_A15 : CR% FE% NI SI : CR SI% : C VA% : ! $ $ Prototype W5Si3 (tI32, I4/mcm) $ PHASE CR5SI3_D8M % 2 5 3 ! CONST CR5SI3_D8M : CR% FE : SI : ! $ $ Prototype CrSi2 (hP9, P6_222) $ PHASE CRSI2_C40 % 2 1 2 ! CONST CRSI2_C40 : CR% SI : CR SI% : ! $ $ Prototype Cr2VC2 (oC20, Cmcm) $ PHASE CR2VC2 % 3 2 1 2 ! CONST CR2VC2 : CR : V : C : ! $ $ Prototype CuMg2 (oF48, Fddd) $ PHASE CUMG2_CB % 2 1 2 ! CONST CUMG2_CB : CU : MG : ! $ $ Prototype beta-Mn (cP20, P4_132), gamma $ PHASE CU33SI7_A13 % 2 33 7 ! CONST CU33SI7_A13 : CU : SI : ! $ $ Pearson tP* or hP* (delta) $ PHASE CU33SI7_HT % 2 33 7 ! CONST CU33SI7_HT : CU : SI : ! $ $ Prototype Cu15Si4 (cI76, I-43d), epsilon $ PHASE CU15SI4_D86 % 2 15 4 ! CONST CU15SI4_D86 : CU : SI : ! $ $ Pearson hR* (R-3m), distorted bcc?, eta $ PHASE CU3SI_LT % 2 0.77 0.23 ! CONST CU3SI_LT : CU : SI : ! $ $ Prototype Cu3Si (it) (hR9, R-3), eta-prime $ PHASE CU3SI_MT % 2 0.765 0.235 ! CONST CU3SI_MT : CU : SI : ! $ $ Long-period superlattice, Pearson oC*, eta-doubleprime $ PHASE CU3SI_HT % 2 0.76 0.24 ! CONST CU3SI_HT : CU : SI : ! $ $ Prototype Au4Zr (oP20, Pnma); beta-Cu4Ti? $ According to LB, alpha-Cu4Ti has prototype MoNi4 (tI10, I4/m, D1_a) $ Only Au4Zr is in the Pauling file. $ PHASE CU4TI1 % 2 4 1 ! CONST CU4TI1 : CU% TI : CU TI% : ! $ $ Prototype Au2V (oC12, Cmcm) $ PHASE CU2TI % 2 2 1 ! CONST CU2TI : CU : TI : ! $ $ Prototype Cu3Ti2 (tP10, P4/nmm) $ PHASE CU3TI2 % 2 3 2 ! CONST CU3TI2 : CU : TI : ! $ $ Prototype Cu4Ti3 (tI14, I4/mmm) $ PHASE CU4TI3 % 2 4 3 ! CONST CU4TI3 : CU : TI : ! $ $ Prototype gamma-CuTi (tP4, P4/nmm) $ PHASE CUTI_B11 % 2 1 1 ! CONST CUTI_B11 : CU% TI : CU TI% : ! $ $ Prototype MoSi2 (tI6, I4/mmm) $ PHASE CUTI2_C11B % 2 1 2 ! CONST CUTI2_C11B : CU : TI : ! $ $ Prototype Mn5C2 (mC28, C2/c), Haegg carbide, chi $ Should probably be modelled as M5C2 $ PHASE FECN_CHI % 2 5 2 ! CONST FECN_CHI : FE : C N : ! $ $ Prototype Fe4N (cP5, Pm-3m, L'1) $ PHASE FE4N_L1 % 2 4 1 ! CONST FE4N_L1 : CR FE MN NI : C N VA : ! $ $ Prototype CrSi2Zr (oP48, Pbam) $ PHASE FENBSI2 % 3 1 1 2 ! CONST FENBSI2 : FE : NB : SI : ! $ $ Prototype Co4Ge7Zr4 (tI60, I4/mmm) $ PHASE FE4NB4SI7 % 3 4 4 7 ! CONST FE4NB4SI7 : FE : NB : SI : ! $ $ Prototype NiSiTi (oP12, Pnma) $ PHASE FENBSI1 % 3 1 1 1 ! CONST FENBSI1 : FE : NB : SI : ! $ $ Prototype FeNb2Si2 (tP198, P4_2/mcm) $ PHASE FENB2SI2 % 3 1 2 2 ! CONST FENB2SI2 : FE : NB : SI : ! $ $ Prototype MgZn2 (hP12, P63/mmc), low-T $ Prototype Fe3Nb4Si5 (oP72, Pmn2_1), high-T $ PHASE FE3NB4SI5 % 3 3 4 5 ! CONST FE3NB4SI5 : FE : NB : SI : ! $ $ Prototype CoNb4Si (tP12, P4/mcc) $ PHASE FENB4SI % 3 1 4 1 ! CONST FENB4SI : FE : NB : SI : ! $ $ Prototype AlNi2 (hP6, P-3m1) $ PHASE FE2SI % 2 2 1 ! CONST FE2SI : FE : SI : ! $ $ Prototype FeSi2-h (oC48, Cmca) $ PHASE FESI2_H % 2 0.3 0.7 ! CONST FESI2_H : FE : SI : ! $ $ Prototype FeSi2-l (tP3, P4/mmm) $ PHASE FESI2_L % 2 1 2 ! CONST FESI2_L : FE : SI : ! $ $ Prototype Mn8Si2C3 (aP*, P1) $ PHASE FE8SI2C % 3 8 2 1 ! CONST FE8SI2C : FE : SI : C : ! $ $ Prototype Fe11Mo6C5 (mC44, C2/m) $ PHASE KSI_CARBIDE % 2 3 1 ! CONST KSI_CARBIDE : CR FE MO : C : ! $ $ Prototype MgZn2 (hP12, P6_3/mmc) $ PHASE C14_LAVES % 2 2 1 ! CONST C14_LAVES : CR% FE% MN% MO NB NI% SI% TI V% : CR FE MN MO% NB% NI SI TI% V : ! $ $ Prototype Cu2Mg (cF24, Fd-3m) $ PHASE C15_LAVES % 2 2 1 ! CONST C15_LAVES : CR% CU% FE MG NB SI TI : CR CU FE MG% NB% SI TI% : ! $ $ Prototype MgNi2 (hP24, P6_3/mmc) $ PHASE C36_LAVES % 2 2 1 ! CONST C36_LAVES : CR% MG NI% TI : CR MG% NI TI% : ! $ $ Prototype TiP (hP8, P6_3/mmc, SB: Bi) $ PHASE MC_ETA % 2 1 1 ! CONST MC_ETA : MO NB TI V : C% VA : ! $ $ Prototype WC (hP2, P-6m2, SB: Bh) $ PHASE MC_SHP % 2 1 1 ! CONST MC_SHP : MO : C N : ! $ $ Prototype Mn5C2 (mC28, C2/c) $ PHASE M5C2 % 2 5 2 ! CONST M5C2 : FE MN NB V : C : ! $ $ Prototype Fe3W3C (cF112, Fd-3m) $ PHASE M6C_E93 % 4 2 2 2 1 ! CONST M6C_E93 : FE : MO : CR FE MO SI : C : ! $ $ Prototype Cr7C3 (oP40, Pnma) $ PHASE M7C3_D101 % 2 7 3 ! CONST M7C3_D101 : CR FE MN MO NB NI V : C : ! $ $ Prototype Cr23C6 (cF116, Fm-3m) $ PHASE M23C6_D84 % 3 20 3 6 ! CONST M23C6_D84 : CR FE MN NI V : CR FE MN MO NB NI V : C : ! $ $ Prototype Mn5Si3 (hP16, P6_3/mcm) $ PHASE M5SI3_D88 % 3 5 3 1 ! CONST M5SI3_D88 : CR FE MN : SI : C VA% : ! $ $ Prototype Si3W5 (tI32, I4/mcm) alpha $ PHASE M5SI3_D8M % 2 5 3 ! CONST M5SI3_D8M : MO : SI : ! $ $ Unknown structure $ PHASE M4SI3 % 2 4 3 ! CONST M4SI3 : CR NI : SI : ! $ $ Prototype FeSi (cP8, P2_13) $ PHASE MSI_B20 % 2 1 1 ! CONST MSI_B20 : CR% FE% MN% NI : SI : ! $ $ Prototype Mg2C3 (oP10, Pnnm) $ PHASE MG2C3 % 2 2 3 ! CONST MG2C3 : MG : C : ! $ $ Prototype MgC2 (tP6, P4_2/mnm) $ PHASE MGC2 % 2 1 2 ! CONST MGC2 : MG : C : ! $ $ Prototype alpha-Mn2O3 (cI80, Ia-3) $ PHASE MG3N2_D53 % 2 3 2 ! CONST MG3N2_D53 : MG : N : ! $ $ Prototype Mg2Ni (hP18, P6_222) $ PHASE MG2NI % 2 2 1 ! CONST MG2NI : MG : NI : ! $ $ Prototype CaF2 (cF12, Fm-3m) $ PHASE MG2SI_C1 % 2 2 1 ! CONST MG2SI_C1 : MG : SI : ! $ $ Prototype Mn3N2 (tI10, I4/mmm) $ PHASE MN3N2 % 2 3 2 ! CONST MN3N2 : MN : N :! $ $ Prototype CoO (tI4, I4/mmm); distorted NaCl $ PHASE MN6N5 % 2 6 5 ! CONST MN6N5 : MN : N :! $ $ Prototype R-(Co,Cr,Mo) (hR53, R-3) or possibly Fe7W6 (hR13, R-3m) $ PHASE MN6SI % 2 17 3 ! CONST MN6SI : MN : SI : ! $ $ Prototype Mn9Si2 (oI186, Immm) $ PHASE MN9SI2 % 2 33 7 ! CONST MN9SI2 : MN : SI : ! $ $ The structure of alpha-Mn3Si is unknown. $ Beta-Mn3Si is D0_3 (prototype BiF3 (cF16, Fm-3m)), should be modelled $ as an ordered bcc-phase. The transformation is at 950 K. $ PHASE MN3SI % 2 3 1 ! CONST MN3SI : FE MN : SI : ! $ $ Prototype Mn11Si19 (tP120, P-4n2) $ PHASE MN11SI19 % 2 11 19 ! CONST MN11SI19 : MN : SI : ! $ $ Prototype R-(Co,Cr,Mo) (hR53, R-3) $ PHASE MN4TI % 2 0.815 0.185 ! CONST MN4TI : MN : TI : ! $ $ Pearson o** $ PHASE MN3TI % 2 3 1 ! CONST MN3TI : MN : TI : ! $ $ Prototype Re25Zr21 (hR92, R-3c) $ PHASE MNTI_ALPHA % 2 1 1 ! CONST MNTI_ALPHA : MN : TI : ! $ $ Unknown structure $ PHASE MNTI_BETA % 2 0.515 0.485 ! CONST MNTI_BETA : MN : TI : ! $ $ Prototype MoNi (oP56, P2_12_12_1) $ PHASE MONI % 3 6 5 3 ! CONST MONI : CR FE NI : CR FE MO NI : MO : ! $ $ Prototype MoSi2 (tI6, I4/mmm, ordered fcc) $ PHASE MOSI2_C11B % 2 1 2 ! CONST MOSI2_C11B : MO : SI : ! $ $ Prototype Cr3Si (cP8, Pm-3n) $ PHASE MO3SI_A15 % 2 3 1 ! CONST MO3SI_A15 : MO : SI : ! $ $ Prototype Fe7W6 (hR13, R-3m) $ PHASE MU_D85 % 4 1 4 2 6 ! CONST MU_D85 : CR FE% MN% NB NI% SI V : MO% NB% TI : CR FE MO% NB% NI SI TI V : CR FE% MN% MO NB NI% SI V : ! $ $ Prototype Fe7W6 (hR13, R-3m) $ $PHASE MU_D85 % 3 7 2 4 ! $CONST MU_D85 : CR FE MN NI% : MO NB TI : CR FE MO% NB% NI TI : ! $ $ Unknown structure $ PHASE NBNI8 % 2 1 8 ! CONST NBNI8 : NB : NI : ! $ $ Prototype Cu3Ti (oP8, Pmmn) $ PHASE NBNI3_D0A % 2 1 3 ! CONST NBNI3_D0A : NB% NI : NB NI% : ! $ $ Prototype Ti3P (tP32, P4_2/n) $ PHASE NB3SI % 2 3 1 ! CONST NB3SI : NB : SI : ! $ $ Prototype Cr5B3 (tI32, I4/mcm), alpha-Nb5Si3 $ PHASE NB5SI3_D8L % 2 5 3 ! CONST NB5SI3_D8L : NB% SI : SI : ! $ $ Prototype W5Si3 (tI32, I4/mcm), beta-Nb5Si3 $ PHASE NB5SI3_D8M % 3 4 1 3 ! CONST NB5SI3_D8M : NB : NB SI : SI : ! $ $ Prototype CrSi2 (hP9, P6_222) $ PHASE NBSI2_C40 % 2 1 2 ! CONST NBSI2_C40 : NB% SI : SI : ! $ $ Prototype Ge9Pd25 (hP34, P-3), also beta-2 $ PHASE NI3SI_M % 2 3 1 ! CONST NI3SI_M : NI : SI : ! $ $ Prototype CsCl (cP2, Pm-3m, B2) or BiF3 (cF16, Fm-3m, D0_3), also beta-3 $ PHASE NI3SI_H % 2 3 1 ! CONST NI3SI_H : NI : SI : ! $ $ Prototype Ni31Si12 (hP43, P321), also gamma $ PHASE NI5SI2 % 2 5 2 ! CONST NI5SI2 : CR NI% : SI : ! $ $ Prototype Co2Si (oP12, Pnma), also delta $ PHASE NI2SI_C37 % 2 2 1 ! CONST NI2SI_C37 : CR NI% : SI : ! $ $ Prototype Ni2Si (hP6, P6_322) $ PHASE NI2SI_THETA % 3 1 1 1 ! CONST NI2SI_THETA : NI : NI% VA : SI : ! $ $ Prototype Ni3Si2 (oC80, Cmc2_1), also epsilon $ PHASE NI3SI2 % 2 3 2 ! CONST NI3SI2 : NI : SI : ! $ $ Prototype MnP (oP8, Pnma) $ PHASE NISI_B31 % 2 1 1 ! CONST NISI_B31 : NI : SI : ! $ $ Prototype CaF2 (cF12, Fm-3m) $ PHASE NISI2_C1 % 2 1 2 ! CONST NISI2_C1 : NI : SI : ! $ $ Prototype Ni3Ti (hP16, P6_3/mmc) $ PHASE NI3TI_D024 % 2 0.75 0.25 ! CONST NI3TI_D024 : NI% : NI TI% : ! $ $ Prototype NiTi2 (cF96, Fd-3m) $ PHASE NITI2 % 2 1 2 ! CONST NITI2 : NI% TI : NI TI% : ! $ $ Prototype Al3Ti (tI8, I4/mmm) $ PHASE NI3V_D022 % 2 3 1 ! CONST NI3V_D022 : NI : V : ! $ $ Prototype MoPt2 (oI6, Immm) $ PHASE NI2V1 % 2 2 1 ! CONST NI2V1 : NI : V : ! $ $ Prototype Cr3Si (cP8, Pm-3n) $ PHASE NI2V7_A15 % 2 2 7 ! CONST NI2V7_A15 : NI : V : ! $ $ Prototype beta-Cu3Ti (oP8, Pmmn) $ PHASE NI3X_D0A % 2 3 1 ! CONST NI3X_D0A : NI : MO : ! $ $ Prototype MoNi4 (tI10, I4/m) $ PHASE NI4X_D1A % 2 4 1 ! CONST NI4X_D1A : NI : MO : ! $ $ Prototype Cr9Mo21Ni20 (oP56, Pnma) $ PHASE P_PHASE % 3 24 20 12 ! CONST P_PHASE : CR FE NI : CR FE MO NI : MO : ! $ $ Prototype Al2Mo3C (cP24, P4_132) $ Proper model would be Cr3(Fe,Ni)2N $ PHASE PI_CRFENIN % 3 12.8 7.2 4 ! CONST PI_CRFENIN : CR : FE : N : ! $ $ Prototype R-(Co,Cr,Mo) (hR159, R-3, also appears as Fe3Mo2) $ PHASE R_PHASE % 3 27 14 12 ! CONST R_PHASE : CR FE MN NI : MO : CR FE MN MO NI : ! $ $ Prototype ZnS (cF8, F-43m) $ PHASE SIC_B3 % 2 1 1 ! CONST SIC_B3 : SI : C : ! $ $ Prototype CrFe (tP30, P4_2/mnm) $ Cr on first sublattice added by Schuster and Du (00Sch). $ They also removed Ni on the third sublattice. $ PHASE SIGMA_D8B % 3 10 4 16 ! CONST SIGMA_D8B : FE% MN% MO NI% V : CR MO NB TI V : CR FE MN MO NB NI SI TI V : ! $ $ Prototype CrFe (tP30, P4_2/mnm, D8_b) Sigma in TCFE 2000 and SSOL V4 $ $PHASE SIGMA_OLD % 3 8 4 18 ! $CONST SIGMA_OLD : FE MN NI : CR MO NB TI V : CR% FE MN MO NB NI SI TI V : ! $ $ Prototype CrFe (tP30, P4_2/mnm, D8_b) $ PHASE HIGH_SIGMA % 3 10 4 16 ! CONST HIGH_SIGMA : FE MN NI V : CR MO NB V : CR FE MN MO NB NI SI V : ! $ $ Prototype Si3N4; alpha: (hP28, p31c), beta: (hP14, P6_3) $ PHASE SI3N4 % 2 3 4 ! CONST SI3N4 : SI : N : ! $ $ Prototype Si2Ti (oF24, Fddd) $ PHASE SI2TI_C54 % 2 2 1 ! CONST SI2TI_C54 : SI : TI : ! $ $ Prototype FeB (oP8, Pnma) $ PHASE SITI_B27 % 2 1 1 ! CONST SITI_B27 : SI : TI : ! $ $ Prototype Si4Zr5 (tP36, P4_12_12) $ PHASE SI4TI5 % 2 4 5 ! CONST SI4TI5 : SI : TI : ! $ $ Prototype Mn5Si3 (hP16, P6_3/mcm) $ PHASE SI3TI5_D88 % 3 2 3 3 ! CONST SI3TI5_D88 : SI TI : SI TI : TI : ! $ $ Prototype Ti3P (tP32, P4_2/n) $ PHASE SITI3 % 2 1 3 ! CONST SITI3 : SI : TI : ! $ $ Prototype CrSi2 (hP9, P6_222) $ PHASE SI2V_C40 % 2 2 1 ! CONST SI2V_C40 : SI : V : ! $ $ Prototype W5Si3 (tI32, I4/mcm) $ PHASE SI3V5_D8M % 2 3 5 ! CONST SI3V5_D8M : SI : V : ! $ $ Prototype Si5V6 (oI44, Ibam) $ PHASE SI5V6 % 2 5 6 ! CONST SI5V6 : SI : V : ! $ $ Prototype Cr3Si (cP8, Pm-3n) $ PHASE SIV3_A15 % 2 1 3 ! CONST SIV3_A15 : SI% V : SI V% : ! $ $ Prototype TiO2 (tP6, P4_2/mnm) $ PHASE TI2N_C4 % 2 2 1 ! CONST TI2N_C4 : TI V : C N% : ! $ $ Unknown structure $ PHASE TI3N2 % 2 0.71 0.29 ! CONST TI3N2 : TI : N : ! $ $ Unknown structure $ PHASE TI4N3 % 2 0.685 0.315 ! CONST TI4N3 : TI : N : ! $ $ Prototype Sc2Te3 (hR24, R-3m), zeta-carbide $ (Prototype V4C3 (hR20, R-3m) seems to be obsolete) $ PHASE V3C2 % 2 3 2 ! CONST V3C2 : FE MN V : C : ! $ PHASE N2GAS % 1 1 ! CONST N2GAS : N2 : ! $ PHASE GAS:G % 1 1 ! CONST GAS:G : FE FE2 MG MG2 MN N N2 N3 SI SI2 SI3 SIN SI2N : ! $ ------------------------------------------------------------------------------ $ Element data $ ------------------------------------------------------------------------------ $ C $ PAR G(GRAPHITE_A9,C),, +GHSERCC;,, N 91Din ! PAR G(DIAMOND_A4,C),, +GDIACC;,, N 91Din ! PAR G(LIQUID,C),, +GHSERCC+117369-24.63*T;,, N 91Din ! $ FUNCTION GHSERCC 298.15 -17368.441+170.73*T-24.3*T*LN(T) -4.723E-04*T**2+2562600*T**(-1)-2.643E+08*T**(-2)+1.2E+10*T**(-3); 6000.00 N ! FUNCTION GDIACC 298.15 -16359.441+175.61*T-24.31*T*LN(T) -4.723E-04*T**2+2698000*T**(-1)-2.61E+08*T**(-2)+1.11E+10*T**(-3); 6000.00 N ! $ ------------------------------------------------------------------------------ $ Cr $ PAR G(BCC_A2,CR:VA),, +GHSERCR;,, N 91Din ! PAR TC(BCC_A2,CR:VA),, -311.50;,, N 91Din ! PAR BMAG(BCC_A2,CR:VA),, -0.008;,, N 91Din ! PAR G(A2_BCC,CR:VA),, +GHSERCR;,, N 91Din ! PAR TC(A2_BCC,CR:VA),, -311.50;,, N 91Din ! PAR BMAG(A2_BCC,CR:VA),, -0.008;,, N 91Din ! PAR G(FCC_A1,CR:VA),, +GHSERCR+7284+0.163*T;,, N 91Din ! PAR TC(FCC_A1,CR:VA),, -1109.00;,, N 91Din ! PAR BMAG(FCC_A1,CR:VA),, -2.46;,, N 91Din ! PAR G(A1_FCC,CR:VA),, +GHSERCR+7284+0.163*T;,, N 91Din ! PAR TC(A1_FCC,CR:VA),, -1109.00;,, N 91Din ! PAR BMAG(A1_FCC,CR:VA),, -2.46;,, N 91Din ! PAR G(HCP_A3,CR:VA),, +GHSERCR+4438;,, N 91Din ! PAR TC(HCP_A3,CR:VA),, -1109.00;,, N 91Din ! PAR BMAG(HCP_A3,CR:VA),, -2.46;,, N 91Din ! PAR G(CBCC_A12,CR:VA),, +GHSERCR+11087+2.7196*T;,, N 91Din ! PAR G(CUB_A13,CR:VA),, +GHSERCR+15899+0.6276*T;,, N 91Din ! PAR G(LIQUID,CR),, +GLIQCR;,, N 91Din ! $ PAR G(CHI_A12,CR:CR:CR),, +48*GFCCCR+10*GHSERCR +109000+123*T;,, N 88Gus4 ! PAR G(CR3SI_A15,CR:CR:VA),, +4*GHSERCR+20000+10*T;,, N 94Cou ! PAR G(CRSI2_C40,CR:CR),, +3*GHSERCR+10000-T;,, N 94Cou ! PAR G(FE4N_L1,CR:VA),, +4*GFCCCR;,, N 17Hal12 ! PAR G(C14_LAVES,CR:CR),, +3*GHSERCR+82440;,, N 16Jac1 ! PAR G(C15_LAVES,CR:CR),, +3*GHSERCR+79200;,, N 06Slu ! PAR G(C36_LAVES,CR:CR),, +3*GHSERCR+75600;,, N 13Slu ! $ FUNCTION GHSERCR 298.15 -8856.94+157.48*T-26.908*T*LN(T) +0.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2180.00 Y -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6000.00 N ! FUNCTION GLIQCR 298.15 +24339.955-11.420225*T+GHSERCR+2.37615E-21*T**7; 2180.00 Y -16459.984+335.616316*T-50*T*LN(T); 6000.00 N ! FUNCTION GFCCCR 298.15 +GHSERCR+7284+0.163*T; 6000 N ! $ ------------------------------------------------------------------------------ $ Cu $ $ BCT_A5 from 00Moo not included in unary $ CBCC_A12 and CUB_A13 not included in unary $ PAR G(FCC_A1,CU:VA),, +GHSERCU; 3200 N 91Din ! PAR G(A1_FCC,CU:VA),, +GHSERCU; 3200 N 91Din ! PAR G(BCC_A2,CU:VA),, +GHSERCU+4017-1.255*T; 3200 N 91Din ! PAR G(A2_BCC,CU:VA),, +GHSERCU+4017-1.255*T; 3200 N 91Din ! PAR G(HCP_A3,CU:VA),, +GHSERCU+600+0.2*T; 3200 N 91Din ! $PAR G(BCT_A5,CU),, +GHSERCU+4184; 3200 N 00Moo ! PAR G(CBCC_A12,CU:VA),, +GHSERCU+3556; 2000 N 03Mie2 ! PAR G(CUB_A13,CU:VA),, +GHSERCU+2092; 2000 N 03Mie2 ! PAR G(LIQUID,CU),, +GLIQCU; 3200 N 91Din ! $ PAR G(CU4TI1,CU:CU),, +5*GHSERCU+25000;,, N 96Har2 ! PAR G(CUTI_B11,CU:CU),, +2*GHSERCU+10000;,, N 96Har2 ! PAR G(C15_LAVES,CU:CU),, +3*GHSERCU+15000;,, N REFLAV ! $ FUNCTION GHSERCU 298.15 -7770.458+130.485235*T-24.112392*T*LN(T) -0.00265684*T**2+1.29223E-07*T**3+52478*T**(-1); 1357.77 Y -13542.026+183.803828*T-31.38*T*LN(T)+3.64167E+29*T**(-9); 3200.00 N ! FUNCTION GLIQCU 298.15 +12964.735-9.511904*T+GHSERCU-5.8489E-21*T**7; 1357.77 Y -46.545+173.881484*T-31.38*T*LN(T); 3200.00 N ! FUNCTION GBCCCU 298.15 +GHSERCU+4017-1.255*T; 3200 N ! $ ------------------------------------------------------------------------------ $ Fe $ $ ORTHORHOMBIC_A20 and TETRAGONAL_U added im unary 4.1 $ PAR G(BCC_A2,FE:VA),, +GHSERFE;,, N 91Din ! PAR TC(BCC_A2,FE:VA),, 1043.00;,, N 91Din ! PAR BMAG(BCC_A2,FE:VA),, 2.22;,, N 91Din ! PAR G(A2_BCC,FE:VA),, +GHSERFE;,, N 91Din ! PAR TC(A2_BCC,FE:VA),, 1043.00;,, N 91Din ! PAR BMAG(A2_BCC,FE:VA),, 2.22;,, N 91Din ! PAR G(FCC_A1,FE:VA),, +GFCCFE;,, N 91Din ! PAR TC(FCC_A1,FE:VA),, -201.00;,, N 91Din ! PAR BMAG(FCC_A1,FE:VA),, -2.10;,, N 91Din ! PAR G(A1_FCC,FE:VA),, +GFCCFE;,, N 91Din ! PAR TC(A1_FCC,FE:VA),, -201.00;,, N 91Din ! PAR BMAG(A1_FCC,FE:VA),, -2.10;,, N 91Din ! PAR G(HCP_A3,FE:VA),, +GHCPFE;,, N 91Din ! PAR G(CBCC_A12,FE:VA),, +GHSERFE+4745;,, N 91Din ! PAR G(CUB_A13,FE:VA),, +GHSERFE+3745;,, N 91Din ! $PAR G(ORTHORHOMBIC_A20,FE),, +GHSERFE+5000;,, N 99SGUN ! $PAR G(TETRAGONAL_U,FE),, +GHSERFE+5000;,, N 99SGUN ! PAR G(LIQUID,FE),, +GLIQFE;,, N 91Din ! $ PAR G(GAS,FE),, +F9886T+RTLNP;,, N 97SUB ! PAR G(GAS,FE2),, +F10090T+RTLNP;,, N 97SUB ! $ PAR G(FE4N_L1,FE:VA),, +4*GFCCFE+20000;,, N 17Hal12 ! PAR G(C14_LAVES,FE:FE),, +3*GHSERFE+44130;,, N 12Liu ! PAR G(C15_LAVES,FE:FE),, +3*GHSERFE+110290;,, N 16Jac1 ! $ FUNCTION GHSERFE 298.15 +1225.7+124.134*T-23.5143*T*LN(T) -0.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1811.00 Y -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6000.00 N ! FUNCTION GFCCFE 298.15 -1462.4+8.282*T-1.15*T*LN(T) +6.4E-04*T**2+GHSERFE; 1811.00 Y -1713.815+0.940009*T+GHSERFE+4.9251E+30*T**(-9); 6000.00 N ! FUNCTION GHCPFE 298.15 -3705.78+12.591*T-1.15*T*LN(T) +6.4E-04*T**2+GHSERFE; 1811.00 Y -3957.195+5.249009*T+GHSERFE+4.9251E+30*T**(-9); 6000.00 N ! FUNCTION GLIQFE 298.15 +12040.17-6.55843*T+GHSERFE-3.67516E-21*T**7; 1811.00 Y -10838.83+291.302*T-46*T*LN(T); 6000.00 N ! $ Fe(g) FUNCTION F9886T 298.15 +405563.032+35.536443*T-32.8261*T*LN(T) +0.00908265*T**2-1.34845667E-06*T**3+108791.4*T**(-1); 900.00 Y +414134.539-53.8401478*T-19.84276*T*LN(T) +6.959445E-05*T**2-1.30682983E-07*T**3-976411.5*T**(-1); 2400.00 Y +410389.799-49.3269727*T-20.12513*T*LN(T) -5.66549E-04*T**2-5.290265E-08*T**3+887592*T**(-1); 5500.00 Y +521855.538-375.147472*T+18.70844*T*LN(T) -0.00634452*T**2+1.038655E-07*T**3-55487750*T**(-1); 10000.00 N ! $ Fe2(g) FUNCTION F10090T 298.15 +704549.823+89.2549323*T-50.743*T*LN(T) +0.00803125*T**2-2.18098667E-06*T**3+169270*T**(-1); 800.00 Y +717674.096-87.8134515*T-23.957*T*LN(T) -0.0157846*T**2+1.723485E-06*T**3-1006505*T**(-1); 1700.00 Y +655211.274+352.671354*T-83.82001*T*LN(T) +0.0095931*T**2-2.85336667E-07*T**3+11147285*T**(-1); 4500.00 Y +780963.168-41.3623277*T-36.245*T*LN(T) +0.00155795*T**2-3.05716667E-08*T**3-51729450*T**(-1); 6000.00 N ! $ ------------------------------------------------------------------------------ $ Mg $ $ DHCP from 04Guo (included in SGSOL 5.0; this value is not particularly good) $ DIAMOND_A4 from 16Lia not included in unary $ PAR G(HCP_A3,MG:VA),, +GHSERMG; 3000 N 91Din ! PAR G(FCC_A1,MG:VA),, +GHSERMG+2600-0.9*T; 3000 N 91Din ! PAR G(A1_FCC,MG:VA),, +GHSERMG+2600-0.9*T; 3000 N 91Din ! PAR G(BCC_A2,MG:VA),, +GHSERMG+3100-2.1*T; 3000 N 91Din ! PAR G(A2_BCC,MG:VA),, +GHSERMG+3100-2.1*T; 3000 N 91Din ! $PAR G(DHCP,MG),, +GHSERMG+5000; 3000 N 04Guo ! PAR G(DIAMOND_A4,MG),, +GHSERMG+74780; 3000 N 16Lia ! PAR G(CBCC_A12,MG:VA),, +GHSERMG +4602.4-3.011*T; 3000 N 91Din ! PAR G(CUB_A13,MG:VA),, +GHSERMG+5000-3*T; 3000 N 91Din ! PAR G(LIQUID,MG),, +GLIQMG; 3000 N 91Din ! $ PAR G(C15_LAVES,MG:MG),, +3*GHSERMG+15000;,, N REFLAV ! PAR G(C36_LAVES,MG:MG),, +3*GHSERMG+15000;,, N REFLAV ! $ PAR G(GAS,MG),, +F12309T+RTLNP;,, N 97SUB ! PAR G(GAS,MG2),, +F12397T+RTLNP;,, N 97SUB ! $ FUNCTION GHSERMG 298.15 -8367.34+143.675547*T-26.1849782*T*LN(T) +4.858E-04*T**2-1.393669E-06*T**3+78950*T**(-1); 923.00 Y -14130.185+204.716215*T-34.3088*T*LN(T)+1.038192E+28*T**(-9); 3000.00 N ! FUNCTION GLIQMG 298.15 +8202.243-8.83693*T+GHSERMG-8.0176E-20*T**7; 923.00 Y -5439.869+195.324057*T-34.3088*T*LN(T); 3000.00 N ! $ Mg(g) FUNCTION F12309T 298.15 +140825.883-8.26177982*T-20.96302*T*LN(T) +1.331861E-04*T**2-1.51554617E-08*T**3+5221.91*T**(-1); 2900.00 Y +141959.02+20.1923541*T-25.1271*T*LN(T) +0.002179723*T**2-1.502275E-07*T**3-3744678*T**(-1); 5400.00 Y +458455.469-794.05688*T+70.54811*T*LN(T) -0.010649025*T**2+1.716475E-07*T**3-1.996814E+08*T**(-1); 9200.00 Y -315972.848+423.179252*T-63.73726*T*LN(T) -2.847232E-04*T**2+2.15099667E-08*T**3+6.39436E+08*T**(-1); 10000.00 N ! $ Mg2(g) FUNCTION F12397T 298.15 +281408.793-104.38489*T-20.63169*T*LN(T) -6.14869E-05*T**2+4.25457833E-09*T**3-156733.25*T**(-1); 3000.00 N ! $ ------------------------------------------------------------------------------ $ Mn $ $ RHOMB_C19 from 09Wan not included in unary $ PAR G(CBCC_A12,MN:VA),, +GHSERMN; 2000 N 91Din ! PAR TC(CBCC_A12,MN:VA),, -285.00; 2000 N 91Din ! PAR BMAG(CBCC_A12,MN:VA),, -0.66; 2000 N 91Din ! PAR G(CUB_A13,MN:VA),, +GCUBMN; 2000 N 91Din ! PAR G(FCC_A1,MN:VA),, +GFCCMN; 2000 N 91Din ! PAR TC(FCC_A1,MN:VA),, -1620.00; 2000 N 91Din ! PAR BMAG(FCC_A1,MN:VA),, -1.86; 2000 N 91Din ! PAR G(A1_FCC,MN:VA),, +GFCCMN; 2000 N 91Din ! PAR TC(A1_FCC,MN:VA),, -1620.00; 2000 N 91Din ! PAR BMAG(A1_FCC,MN:VA),, -1.86; 2000 N 91Din ! PAR G(BCC_A2,MN:VA),, +GBCCMN; 2000 N 91Din ! PAR TC(BCC_A2,MN:VA),, -580.00; 2000 N 91Din ! PAR BMAG(BCC_A2,MN:VA),, -0.27; 2000 N 91Din ! PAR G(A2_BCC,MN:VA),, +GBCCMN; 2000 N 91Din ! PAR TC(A2_BCC,MN:VA),, -580.00; 2000 N 91Din ! PAR BMAG(A2_BCC,MN:VA),, -0.27; 2000 N 91Din ! PAR G(HCP_A3,MN:VA),, +GHCPMN; 2000 N 91Din ! PAR TC(HCP_A3,MN:VA),, -1620.00; 2000 N 91Din ! PAR BMAG(HCP_A3,MN:VA),, -1.86; 2000 N 91Din ! $PAR G(RHOMB_C19,MN),, +GHSERMN+1000; 2100 N 09Wan ! PAR G(LIQUID,MN),, +GLIQMN; 2000 N 91Din ! $ PAR G(GAS,MN),, +F12439T+RTLNP;,, N 97SUB ! $ PAR G(C14_LAVES,MN:MN),, +3*GHSERMN+20700;,, N 12Liu ! PAR G(FE4N_L1,MN:VA),, +4*GFCCMN+20000;,, N 17Hal12 ! $ FUNCTION GHSERMN 298.15 -8115.28+130.059*T-23.4582*T*LN(T) -0.00734768*T**2+69827*T**(-1); 1519.00 Y -28733.41+312.2648*T-48*T*LN(T)+1.656847E+30*T**(-9); 2000.00 N ! FUNCTION GCUBMN 298.15 -5800.4+135.995*T-24.8785*T*LN(T) -0.00583359*T**2+70269*T**(-1); 1519.00 Y +442.65-0.9715*T+GHSERMN+2.310723E+30*T**(-9); 2000.00 N ! FUNCTION GFCCMN 298.15 -3439.3+131.884*T-24.5177*T*LN(T) -0.006*T**2+69600*T**(-1); 1519.00 Y +2663.31-2.5984*T+GHSERMN+2.205113E+30*T**(-9); 2000.00 N ! FUNCTION GBCCMN 298.15 -3235.3+127.85*T-23.7*T*LN(T) -0.00744271*T**2+60000*T**(-1); 1519.00 Y +5544.58-4.5605*T+GHSERMN-3.91695E+29*T**(-9); 2000.00 N ! FUNCTION GHCPMN 298.15 -4439.3+133.007*T-24.5177*T*LN(T) -0.006*T**2+69600*T**(-1); 1519.00 Y +1663.31-1.4754*T+GHSERMN+2.205113E+30*T**(-9); 2000.00 N ! FUNCTION GLIQMN 298.15 +17859.91-12.6208*T+GHSERMN-4.41929E-21*T**7; 1519.00 Y -9993.9+299.036*T-48*T*LN(T); 2000.00 N ! $ Mn(g) FUNCTION F12439T 298.15 +276164.054-34.4987547*T-20.786*T*LN(T); 1575.00 Y +275547.585-29.2480566*T-21.52064*T*LN(T) +3.819474E-04*T**2-3.66030333E-08*T**3+95180.95*T**(-1); 2100.00 Y +274521.741-16.3844926*T-23.35302*T*LN(T) +0.0013469965*T**2-1.18903067E-07*T**3; 2400.00 N ! $ ------------------------------------------------------------------------------ $ Mo $ $ CBCC_A12 and CUB_A13 from unknown source not included in unary $ PAR G(BCC_A2,MO:VA),, +GHSERMO; 5000 N 91Din ! PAR G(A2_BCC,MO:VA),, +GHSERMO; 5000 N 91Din ! PAR G(FCC_A1,MO:VA),, +GHSERMO+15200+0.63*T; 5000 N 91Din ! PAR G(A1_FCC,MO:VA),, +GHSERMO+15200+0.63*T; 5000 N 91Din ! PAR G(HCP_A3,MO:VA),, +GHSERMO+11550; 5000 N 91Din ! PAR G(CBCC_A12,MO:VA),, +GHSERMO+11087+2.7196*T;,, N Null ! PAR G(CUB_A13,MO:VA),, +GHSERMO+15899+0.6276*T;,, N Null ! PAR G(LIQUID,MO),, +GLIQMO; 5000 N 91Din ! $ PAR G(CRNI2_C11B,MO:MO),, +ZERO;,, N 06Tur ! PAR G(C14_LAVES,MO:MO),, +3*GHSERMO+109200;,, N 06Slu ! PAR G(MC_ETA,MO:VA),, +GHSERMO+15200+0.63*T;,, N 88And1 ! PAR G(SIGMA_D8B,MO:MO:MO),, +30*GHSERMO+552000;,, N 06Slu ! $ FUNCTION GHSERMO 298.15 -7746.302+131.9197*T-23.56414*T*LN(T) -0.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)-1.30927E-10*T**4; 2896.00 Y -30556.41+283.559746*T-42.63829*T*LN(T)-4.849315E+33*T**(-9); 5000.00 N ! FUNCTION GLIQMO 298.15 +41831.347-14.694912*T+GHSERMO+4.24519E-22*T**7; 2896.00 Y +3538.963+271.6697*T-42.63829*T*LN(T); 5000.00 N ! FUNCTION GFCCMO 298.15 +GHSERMO+15200+0.63*T; 6000 N ! $ ------------------------------------------------------------------------------ $ N $ $ There is a small change in G(GAS,N) from SGSUB 1992 to 1994 $ G(GAS,N2) has a completely different expression in SGSUB 1994 and 1997 $ compared to the unary database. $ G(GAS,N3) is considerably changed from SGSUB 1992 to 1994. $ PAR G(N2GAS,N2),, +2*GHSERNN+RTLNP;,, N 91Din ! PAR G(LIQUID,N),, +GHSERNN+29950+59.02*T;,, N 91Din ! $ PAR G(GAS,N),, +F12658T+RTLNP;,, N 97SUB ! PAR G(GAS,N2),, +2*GHSERNN+RTLNP;,, N 91Din ! PAR G(GAS,N3),, +F12909T+RTLNP;,, N 97SUB ! $ FUNCTION GHSERNN 298.15 -3750.675-9.45425*T-12.7819*T*LN(T) -0.00176686*T**2+2.681E-09*T**3-32374*T**(-1); 950.00 Y -7358.85+17.2003*T-16.3699*T*LN(T) -6.5107E-04*T**2+3.0097E-08*T**3+563070*T**(-1); 3350.00 Y -16392.8+50.26*T-20.4695*T*LN(T) +2.39754E-04*T**2-8.333E-09*T**3+4596375*T**(-1); 6000.00 N ! $ N(g) FUNCTION F12658T 298.15 +466446.153-13.3752574*T-20.89393*T*LN(T) +8.45521E-05*T**2-1.0018685E-08*T**3+2788.7865*T**(-1); 2950.00 Y +481259.035-52.5441353*T-16.37613*T*LN(T) -2.283738E-04*T**2-2.78997167E-08*T**3-7559105*T**(-1); 6000.00 N ! $ N2(g) from SGSUB 1997 FUNCTION F12845T 298.15 -8000.12556-8.81620364*T-27.22332*T*LN(T) -0.0012599175*T**2-5.39381E-07*T**3-38326.695*T**(-1); 800.00 Y -10569.6463+2.77534156*T-28.42384*T*LN(T) -0.003189275*T**2+2.06638E-07*T**3+416969.05*T**(-1); 2200.00 Y -22468.6305+71.8176271*T-37.55014*T*LN(T) -6.158995E-06*T**2-4.22547E-09*T**3+3427512*T**(-1); 6000.00 N ! $ N3(g) FUNCTION F12909T 298.15 +426260.222-44.8788468*T-24.40177*T*LN(T) -0.02510581*T**2+3.41313667E-06*T**3+61652.95*T**(-1); 800.00 Y +409926.892+144.323862*T-52.34995*T*LN(T) -0.0035522355*T**2+2.39819667E-07*T**3+1869491.5*T**(-1); 2200.00 Y +398090.062+216.588607*T-61.96494*T*LN(T) -5.55378E-05*T**2+1.47712917E-09*T**3+4654831*T**(-1); 6000.00 N ! $ ------------------------------------------------------------------------------ $ Nb $ $ CBCC_A12 and CUB_A13 from 06Slu not included in unary $ PAR G(BCC_A2,NB:VA),, +GHSERNB;,, N 91Din ! PAR G(A2_BCC,NB:VA),, +GHSERNB;,, N 91Din ! PAR G(FCC_A1,NB:VA),, +GHSERNB+13500+1.7*T;,, N 91Din ! PAR G(A1_FCC,NB:VA),, +GHSERNB+13500+1.7*T;,, N 91Din ! PAR G(HCP_A3,NB:VA),, +GHSERNB+10000+2.4*T;,, N 91Din ! PAR G(CBCC_A12,NB:VA),, +GHSERNB+17600;,, N 06Slu ! PAR G(CUB_A13,NB:VA),, +GHSERNB+22000;,, N 06Slu ! PAR G(LIQUID,NB),, +GLIQNB;,, N 91Din ! $ PAR G(C14_LAVES,NB:NB),, +3*GHSERNB+49620;,, N 12Liu ! PAR G(C15_LAVES,NB:NB),, +3*GHSERNB+48600;,, N 06Slu ! PAR G(MC_ETA,NB:VA),, +GHSERNB+15200+0.63*T;,, N 15Zha1 ! PAR G(MU_D85,NB:NB:NB:NB),, +13*GHSERNB+227500;,, N 12Liu ! PAR G(NBNI3_D0A,NB:NB),, +4*GHSERNB+20000;,, N 96Bol ! $PAR G(OMEGA_C32,NB),, +GHSERNB+15000+2.4*T;,, N 01Zha ! $ FUNCTION GHSERNB 298.15 -8519.353+142.045475*T-26.4711*T*LN(T) +2.03475E-04*T**2-3.5012E-07*T**3+93399*T**(-1); 2750.00 Y -37669.3+271.720843*T-41.77*T*LN(T)+1.528238E+32*T**(-9); 6000.00 N ! FUNCTION GLIQNB 298.15 +29781.555-10.816418*T+GHSERNB-3.06098E-23*T**7; 2750.00 Y -7499.398+260.756148*T-41.77*T*LN(T); 6000.00 N ! FUNCTION GFCCNB 298.15 +GHSERNB+13500+1.7*T; 6000 N ! $ ------------------------------------------------------------------------------ $ Ni $ $ FCC_A1 and LIQUID modified in unary 5.0 (slight change in upper T interval) $ BCT_A5 added in unary 5.0 $ PAR G(FCC_A1,NI:VA),, +GHSERNI; 3000 N 91Din ! PAR TC(FCC_A1,NI:VA),, 633.00; 3000 N 91Din ! PAR BMAG(FCC_A1,NI:VA),, 0.52; 3000 N 91Din ! PAR G(A1_FCC,NI:VA),, +GHSERNI; 3000 N 91Din ! PAR TC(A1_FCC,NI:VA),, 633.00; 3000 N 91Din ! PAR BMAG(A1_FCC,NI:VA),, 0.52; 3000 N 91Din ! PAR G(BCC_A2,NI:VA),, +GHSERNI +8715.084-3.556*T; 3000 N 91Din ! PAR TC(BCC_A2,NI:VA),, 575.00; 3000 N 91Din ! PAR BMAG(BCC_A2,NI:VA),, 0.85; 3000 N 91Din ! PAR G(A2_BCC,NI:VA),, +GHSERNI +8715.084-3.556*T; 3000 N 91Din ! PAR TC(A2_BCC,NI:VA),, 575.00; 3000 N 91Din ! PAR BMAG(A2_BCC,NI:VA),, 0.85; 3000 N 91Din ! PAR G(HCP_A3,NI:VA),, +GHSERNI+1046+1.255*T; 3000 N 91Din ! $PAR G(BCT_A5,NI),, +GHSERNI+10023-4.556*T; 3000 N 99Gho ! PAR G(CUB_A13,NI:VA),, +GHSERNI+2092; 3000 N 91Din ! PAR G(CBCC_A12,NI:VA),, +GHSERNI+3556; 3000 N 91Din ! PAR G(LIQUID,NI),, +GLIQNI; 3000 N 91Din ! $ PAR G(FE4N_L1,NI:VA),, +4*GHSERNI+20000;,, N 17Hal12 ! PAR G(C14_LAVES,NI:NI),, +3*GHSERNI+56700;,, N 06Slu ! PAR G(C36_LAVES,NI:NI),, +ZERO;,, N 98Jac2 ! PAR G(NBNI3_D0A,NI:NI),, +4*GHSERNI+20000;,, N 96Bol ! PAR G(NI3TI_D024,NI:NI),, +GHCPNI;,, N 91Din ! PAR G(NITI2,NI:NI),, +3*GHSERNI+15000;,, N 99Dup2 ! $ FUNCTION GHSERNI 298.15 -5179.159+117.854*T-22.096*T*LN(T)-0.0048407*T**2; 1728.00 Y -27840.62+279.134977*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 3000.00 N ! FUNCTION GLIQNI 298.15 +16414.686-9.397*T+GHSERNI-3.82318E-21*T**7; 1728.00 Y -9549.817+268.597977*T-43.1*T*LN(T); 3000.00 N ! FUNCTION GBCCNI 298.15 +GHSERNI+8715.084-3.556*T; 6000 N ! FUNCTION GHCPNI 298.15 +GHSERNI+1046+1.255*T; 6000 N ! $ ------------------------------------------------------------------------------ $ Si $ PAR G(DIAMOND_A4,SI),, +GHSERSI; 3600 N 91Din ! PAR G(FCC_A1,SI:VA),, +GHSERSI+51000-21.8*T; 3600 N 91Din ! PAR G(A1_FCC,SI:VA),, +GHSERSI+51000-21.8*T; 3600 N 91Din ! PAR G(BCC_A2,SI:VA),, +GHSERSI+47000-22.5*T; 3600 N 91Din ! PAR G(A2_BCC,SI:VA),, +GHSERSI+47000-22.5*T; 3600 N 91Din ! PAR G(HCP_A3,SI:VA),, +GHSERSI+49200-20.8*T; 3600 N 91Din ! PAR G(CBCC_A12,SI:VA),, +GHSERSI+50208-20.377*T; 3600 N 91Din ! PAR G(CUB_A13,SI:VA),, +GHSERSI+47279-20.377*T; 3600 N 91Din ! PAR G(LIQUID,SI),, +GLIQSI; 3600 N 91Din ! $ PAR G(GAS,SI),, +F8197T+RTLNP;,, N 90SUB ! PAR G(GAS,SI2),, +F8227T+RTLNP;,, N 90SUB ! PAR G(GAS,SI3),, +F8245T+RTLNP;,, N 90SUB ! $ $PAR G(CR3SI_A15,SI:SI:VA),, +4*GHSERSI+24543.3+4*T;,, N 91Ans ! PAR G(CR3SI_A15,SI:SI:VA),, +4*GHSERSI+208000-80*T;,, N 94Cou ! PAR G(CRSI2_C40,SI:SI),, +3*GHSERSI +82389.75-24.68504*T;,, N 00Du1 ! PAR G(C14_LAVES,SI:SI),, +3*GHSERSI+142380;,, N 17Jac ! PAR G(C15_LAVES,SI:SI),, +3*GHSERSI+15000;,, N REFLAV ! PAR G(NB5SI3_D8L,SI:SI),, +8*GHSERSI+40000;,, N 09Gen ! PAR G(NBSI2_C40,SI:SI),, +3*GHSERSI+15000;,, N 09Gen ! PAR G(SIV3_A15,SI:SI),, +4*GHSERSI+208000-80*T;,, N 98Ran ! $ FUNCTION GHSERSI 298.15 -8162.609+137.236859*T-22.8317533*T*LN(T) -0.001912904*T**2-3.552E-09*T**3+176667*T**(-1); 1687.00 Y -9457.642+167.281367*T-27.196*T*LN(T)-4.20369E+30*T**(-9); 3600.00 N ! FUNCTION GLIQSI 298.15 +50696.36-30.099439*T+GHSERSI+2.09307E-21*T**7; 1687.00 Y +40370.523+137.722298*T-27.196*T*LN(T); 3600.00 N ! FUNCTION GBCCSI 298.15 +GHSERSI+47000-22.5*T; 3600 N 91Din ! FUNCTION GFCCSI 298.15 +GHSERSI+51000-21.8*T; 3600 N 91Din ! $ Si(g) FUNCTION F8197T 298.15 +444772.786-60709.2124*T**(-1)-27.6547439*T -21.0681554*T*LN(T)+3.99285396E-04*T**2-9.9554096E-08*T**3; 2000.00 Y +444116.957+762762.028*T**(-1)-38.3214094*T -19.3609998*T*LN(T)-9.76258996E-04*T**2+4.14151845E-08*T**3; 4000.00 Y +400678.285+22825602.8*T**(-1)+96.3062503*T -35.5990619*T*LN(T)+0.00175586581*T**2-4.58426236E-08*T**3; 6000.00 N ! $ Si2(g) FUNCTION F8227T 298.15 +580605.171-8227.81508*T**(-1)-31.8482492*T -28.7155033*T*LN(T)-0.0094705886*T**2+1.76928808E-07*T**3; 600.00 Y +576928.698+444960.032*T**(-1)-3.54867845*T -32.2831164*T*LN(T)-0.0114310436*T**2+1.75212671E-06*T**3; 1200.00 Y +565230.011+1453776.82*T**(-1)+139.106857*T -53.3225696*T*LN(T)+0.00393279264*T**2-2.42637831E-07*T**3; 2600.00 Y +583134.867-3023002.76*T**(-1)+39.6531838*T -40.3154759*T*LN(T)-1.64330156E-04*T**2-5.40281315E-09*T**3; 6000.00 N ! $ Si3(g) FUNCTION F8245T 298.15 +616635.909+234142.916*T**(-1)+129.920395*T -58.7282976*T*LN(T)-0.00312912992*T**2+5.00836655E-07*T**3; 1000.00 Y +614516.828+384664.408*T**(-1)+160.460124*T -63.3670984*T*LN(T)+9.95168584E-04*T**2-1.50930827E-07*T**3; 2900.00 Y +630336.932-1798745.53*T**(-1)+58.7146891*T -49.9352032*T*LN(T)-0.00334104952*T**2+9.15842733E-08*T**3; 6000.00 N ! $ ------------------------------------------------------------------------------ $ Ti $ $ BCT_A5 added in unary 3.0 $ PAR G(HCP_A3,TI:VA),, +GHSERTI; 4000 N 91Din ! PAR G(BCC_A2,TI:VA),, +GBCCTI; 4000 N 91Din ! PAR G(A2_BCC,TI:VA),, +GBCCTI; 4000 N 91Din ! PAR G(FCC_A1,TI:VA),, +GHSERTI+6000-0.1*T; 4000 N 91Din ! PAR G(A1_FCC,TI:VA),, +GHSERTI+6000-0.1*T; 4000 N 91Din ! $PAR G(DIAMOND_A4,TI),, +GHSERTI+25000; 4000 N 91Din ! $PAR G(BCT_A5,TI),, +GHSERTI+4602.2; 3000 N SGCOST ! PAR G(CBCC_A12,TI:VA),, +GHSERTI+4602.2; 4000 N 91Din ! PAR G(CUB_A13,TI:VA),, +GHSERTI+7531.2; 4000 N 91Din ! PAR G(LIQUID,TI),, +GLIQTI; 4000 N 91Din ! $ PAR G(CU4TI1,TI:TI),, +5*GHSERTI+25000;,, N 96Har2 ! PAR G(CUTI_B11,TI:TI),, +2*GHSERTI+10000;,, N 96Har2 ! $PAR G(C14_LAVES,TI:TI),, +3*GFCCTI+57600;,, N 06Slu ! $PAR G(C15_LAVES,TI:TI),, +3*GFCCTI+60900;,, N 06Slu ! $PAR G(C36_LAVES,TI:TI),, +3*GFCCTI+59100;,, N 13Slu ! PAR G(C14_LAVES,TI:TI),, +3*GHSERTI+45000;,, N 17Hal2 ! PAR G(C15_LAVES,TI:TI),, +3*GHSERTI+48300;,, N 17Hal2 ! PAR G(C36_LAVES,TI:TI),, +3*GHSERTI+46500;,, N 17Hal2 ! PAR G(MC_ETA,TI:VA),, +GHSERTI+20000; 4000 N 96Shi ! PAR G(NITI2,TI:TI),, +3*GHSERTI+15000;,, N 99Dup2 ! $PAR G(OMEGA_C32,TI),, +GHSERTI+1886.7-0.1561*T;,, N 01Zha ! PAR G(SI3TI5_D88,TI:TI:TI),, +8*GHSERTI+40000+20*T;,, N 96Sei ! $ FUNCTION GHSERTI 298.15 -8059.921+133.615208*T-23.9933*T*LN(T) -0.004777975*T**2+1.06716E-07*T**3+72636*T**(-1); 900.00 Y -7811.815+132.988068*T-23.9887*T*LN(T) -0.0042033*T**2-9.0876E-08*T**3+42680*T**(-1); 1155.00 Y +908.837+66.976538*T-14.9466*T*LN(T) -0.0081465*T**2+2.02715E-07*T**3-1477660*T**(-1); 1941.00 Y -124526.786+638.806871*T-87.2182461*T*LN(T) +0.008204849*T**2-3.04747E-07*T**3+36699805*T**(-1); 4000.00 N ! FUNCTION GBCCTI 298.15 -1272.064+134.71418*T-25.5768*T*LN(T) -6.63845E-04*T**2-2.78803E-07*T**3+7208*T**(-1); 1155.00 Y +6667.385+105.366379*T-22.3771*T*LN(T) +0.00121707*T**2-8.4534E-07*T**3-2002750*T**(-1); 1941.00 Y +26483.26-182.426471*T+19.0900905*T*LN(T) -0.02200832*T**2+1.228863E-06*T**3+1400501*T**(-1); 4000.00 N ! FUNCTION GLIQTI 298.15 +12194.415-6.980938*T+GHSERTI; 1300.00 Y +369519.198-2554.0225*T+342.059267*T*LN(T) -0.163409355*T**2+1.2457117E-05*T**3-67034516*T**(-1); 1941.00 Y -19887.066+298.7367*T-46.29*T*LN(T); 4000.00 N ! FUNCTION GFCCTI 298.15 +GHSERTI+6000-0.1*T; 4000 N ! $ ------------------------------------------------------------------------------ $ V $ PAR G(BCC_A2,V:VA),, +GHSERVV; 4000 N 91Din ! PAR G(A2_BCC,V:VA),, +GHSERVV; 4000 N 91Din ! PAR G(FCC_A1,V:VA),, +GHSERVV+7500+1.7*T; 4000 N 91Din ! PAR G(A1_FCC,V:VA),, +GHSERVV+7500+1.7*T; 4000 N 91Din ! PAR G(HCP_A3,V:VA),, +GHSERVV+4000+2.4*T; 4000 N 91Din ! PAR G(CBCC_A12,V:VA),, +GHSERVV+9000; 4000 N 91Din ! PAR G(CUB_A13,V:VA),, +GHSERVV+10000; 4000 N 91Din ! PAR G(LIQUID,V),, +GLIQVV; 4000 N 91Din ! $ PAR G(C14_LAVES,V:V),, +3*GHSERVV+36983;,, N 13Khv2 ! PAR G(MC_ETA,V:VA),, +GHSERVV+4000+2.4*T;,, N 02Bra ! PAR G(SIGMA_D8B,V:V:V),, +30*GHSERVV+100000;,, N 02Sun ! PAR G(SIV3_A15,V:V),, +4*GHSERVV+18000+10*T;,, N 98Ran ! $ FUNCTION GHSERVV 298.15 -7930.43+133.346053*T-24.134*T*LN(T) -0.003098*T**2+1.2175E-07*T**3+69460*T**(-1); 790.00 Y -7967.842+143.291093*T-25.9*T*LN(T) +6.25E-05*T**2-6.8E-07*T**3; 2183.00 Y -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); 4000.00 N ! FUNCTION GLIQVV 298.15 +20764.117-9.455552*T+GHSERVV-5.19136E-22*T**7; 2183.00 Y -19617.51+311.055983*T-47.43*T*LN(T); 4000.00 N ! FUNCTION GFCCVV 298.15 +GHSERVV+7500+1.7*T; 6000 N ! $ ------------------------------------------------------------------------------ $ Binary systems $ ------------------------------------------------------------------------------ $ C-N $ $ No parameters for this system. $ $ ------------------------------------------------------------------------------ $ Cr-C $ $ A.V. Khvan, B. Hallstedt, K. Chang, Calphad, 39, 54-61(2012). $ $ Checked against paper. Checked at 6000 K. $ $ The liquid interaction has been changed compared to 92Lee. $ There is still very nearly a stable miscibility gap on the C-rich side. $ $ M7C3 and CR3C2 become stable again above 9000K. This is a result of the $ T**2 terms and is not important. $ $ The enthalpies and Gibbs energies of formation compare well with recent $ data from Kleykamp (J. Alloys Compd., 321, 138-45(2001)) and $ Meschel and Kleppa on Cr7C3 (J. Alloys Compd., 257, 227-33(1997)). $ The standard entropies and cp at 298K are not quite as good as they $ could (or should) be, but it doesn't motivate a reassessment. $ $ It would probably be desirable to use the G(FCC_A1,CR:C) parameter from 04Bra, $ but in order to do that it may be necessary to adjust L(FCC_A1,CR:C,VA) and $ ternary fcc parameters in the systems Cr-Fe-C, Cr-Mn-C, Cr-Ni-C and Co-Cr-C. $ PAR L(LIQUID,C,CR;0),, -69245-35*T;,, N 12Khv1 ! PAR L(LIQUID,C,CR;1),, +83242;,, N 12Khv1 ! PAR L(LIQUID,C,CR;2),, +88000;,, N 12Khv1 ! $ PAR G(BCC_A2,CR:C),, +GHSERCR+3*GHSERCC+416000;,, N 87And2 ! PAR TC(BCC_A2,CR:C),, -311.50;,, N 90Kaj ! PAR BMAG(BCC_A2,CR:C),, -0.008;,, N 90Kaj ! PAR L(BCC_A2,CR:C,VA;0),, -190*T;,, N 87And2 ! $ PAR G(A2_BCC,CR:C),, +GHSERCR+3*GHSERCC+416000;,, N 87And2 ! PAR TC(A2_BCC,CR:C),, -311.50;,, N 90Kaj ! PAR BMAG(A2_BCC,CR:C),, -0.008;,, N 90Kaj ! PAR L(A2_BCC,CR:C,VA;0),, -190*T;,, N 87And2 ! $ PAR G(M23C6_D84,CR:CR:C),, +GCR23C6;,, N 87And2 ! PAR G(CR3C2_D510,CR:C),, -100823.8+530.66989*T -89.6694*T*LN(T)-0.0301188*T**2;,, N 92Lee1 ! PAR G(M7C3_D101,CR:C),, -201690+1103.128*T -190.177*T*LN(T)-0.0578207*T**2;,, N 92Lee1 ! $ $ metastable $ PAR G(FCC_A1,CR:C),, +GHSERCR+GHSERCC +1200-1.94*T;,, N 92Lee1 ! $ The parameter below gives a formation energy considerably more negative $ than the previous from 92Lee1 and is consistent with data in 92Fer. $PAR G(FCC_A1,CR:C),, -32690+248.42*T $ -41.678*T*LN(T)-0.00301955*T**2;,, N 04Bra ! PAR L(FCC_A1,CR:C,VA;0),, -11977+6.8194*T;,, N 92Lee1 ! $ PAR G(A1_FCC,CR:C),, +GHSERCR+GHSERCC +1200-1.94*T;,, N 92Lee1 ! PAR L(A1_FCC,CR:C,VA;0),, -11977+6.8194*T;,, N 92Lee1 ! $ PAR G(HCP_A3,CR:C),, +GHSERCR+0.5*GHSERCC -18504+9.4173*T-2.4997*T*LN(T)+0.001386*T**2;,, N 92Lee1 ! PAR L(HCP_A3,CR:C,VA;0),, +4165;,, N 88Gus5 ! $ PAR G(CBCC_A12,CR:C),, +GHSERCR+GHSERCC+5000;,, N 93Lee2 ! PAR G(CUB_A13,CR:C),, +GHSERCR+GHSERCC+5000;,, N 93Lee2 ! $ PAR G(CEMENTITE_D011,CR:C),, +3*GHSERCR+GHSERCC -48000-9.2888*T;,, N 92Fer ! $ PAR G(CR3SI_A15,CR:CR:C),, +4*GHSERCR+3*GHSERCC;,, N 00Du2 ! $ PAR G(FE4N_L1,CR:C),, +UN_ASS;,, N ! $ PAR G(KSI_CARBIDE,CR:C),, +3*GHSERCR+GHSERCC +114060-47.2519*T;,, N 92Qiu2 ! $ FUNCTION GCR23C6 298.15 -521983+3622.24*T-620.965*T*LN(T)-0.126431*T**2; 6000.00 N ! $ ------------------------------------------------------------------------------ $ Cr-Cu $ $ M. Hamalainen, K. Jaaskelainen, R. Luoma, M. Nuotio, P. Taskinen, O. Teppo, $ Calphad, 14, 125-37(1990). $ $ Checked against paper. Checked at 6000 K. $ $ This version seems more reasonable than the later version from 98Zen2, which $ is included in LB Vol. 3. $ PAR L(LIQUID,CR,CU;0),, +62797.75-18.95186*T;,, N 90Ham ! PAR L(LIQUID,CR,CU;1),, -1183.91;,, N 90Ham ! $ PAR L(BCC_A2,CR,CU:VA;0),, +77107.48;,, N 90Ham ! PAR L(A2_BCC,CR,CU:VA;0),, +77107.48;,, N 90Ham ! $ PAR L(FCC_A1,CR,CU:VA;0),, +53195.87-3.31182*T;,, N 90Ham ! PAR L(A1_FCC,CR,CU:VA;0),, +53195.87-3.31182*T;,, N 90Ham ! $ $ metastable $ PAR L(HCP_A3,CR,CU:VA;0),, +60000;,, N 98Zen2 ! PAR L(CBCC_A12,CR,CU:VA;0),, +60000;,, N Same ! PAR L(CUB_A13,CR,CU:VA;0),, +60000;,, N Same ! $ ------------------------------------------------------------------------------ $ Cr-Fe $ $ From J.-O. Andersson and B. Sundman 1987 (included in LB Vol. 2) $ Liquid changed by B.-J. Lee 1993 $ $ J.-O. Andersson, B. Sundman, Calphad, 11, 83-92(1987). $ $ Checked against LB and paper. Checked at 6000 K. $ $ Wrong sign for L(FCC_A1,CR,FE:VA;0) in the paper. $ $ The SIGMA_D8B and SIGMA_OLD phase fields are very similar. $ $PAR L(LIQUID,CR,FE;0),, -14550+6.65*T;,, N 87And1 ! PAR L(LIQUID,CR,FE;0),, -17737+7.996546*T;,, N 93Lee1 ! PAR L(LIQUID,CR,FE;1),, -1331;,, N 93Lee1 ! $ PAR L(BCC_A2,CR,FE:VA;0),, +20500-9.68*T;,, N 87And1 ! PAR BMAG(BCC_A2,CR,FE:VA;0),, -0.85;,, N 87And1 ! PAR TC(BCC_A2,CR,FE:VA;0),, +1650;,, N 87And1 ! PAR TC(BCC_A2,CR,FE:VA;1),, +550;,, N 87And1 ! $ PAR L(A2_BCC,CR,FE:VA;0),, +20500-9.68*T;,, N 87And1 ! PAR BMAG(A2_BCC,CR,FE:VA;0),, -0.85;,, N 87And1 ! PAR TC(A2_BCC,CR,FE:VA;0),, +1650;,, N 87And1 ! PAR TC(A2_BCC,CR,FE:VA;1),, +550;,, N 87And1 ! $ PAR G(B2_BCC,CR:FE:VA),, +3000;,, N 97Lin ! PAR G(B2_BCC,FE:CR:VA),, +3000;,, N 97Lin ! $ PAR L(FCC_A1,CR,FE:VA;0),, +10833-7.477*T;,, N 87And1 ! PAR L(FCC_A1,CR,FE:VA;1),, +1410;,, N 87And1 ! $ PAR L(A1_FCC,CR,FE:VA;0),, +10833-7.477*T;,, N 87And1 ! PAR L(A1_FCC,CR,FE:VA;1),, +1410;,, N 87And1 ! $ PAR G(SIGMA_D8B,FE:CR:CR),, +10*GFCCFE+20*GHSERCR +83844-111.32*T;,, N 00Wes ! PAR G(SIGMA_D8B,FE:CR:FE),, +10*GFCCFE+4*GHSERCR +16*GHSERFE+140515-111.32*T;,, N 00Wes ! $ $ metastable $ PAR L(HCP_A3,CR,FE:VA;0),, +10833-7.477*T;,, N 90Fri1 ! $ PAR G(CHI_A12,CR:CR:FE),, +24*GFCCCR+10*GHSERCR +24*GFCCFE+500000;,, N 88Gus4 ! PAR G(CHI_A12,FE:CR:CR),, +24*GFCCFE+10*GHSERCR +24*GFCCCR+18300-100*T;,, N 88And4 ! PAR G(CHI_A12,FE:CR:FE),, +48*GFCCFE+10*GHSERCR +57300-100*T;,, N 88And4 ! $ PAR G(CR3SI_A15,FE:CR:VA),, +3*GHSERFE+GHSERCR+8000;,, N 97Lin ! $ PAR G(C14_LAVES,CR:FE),, +2*GHSERCR+GHSERFE+86733;,, N 16Jac1 ! PAR G(C14_LAVES,FE:CR),, +2*GHSERFE+GHSERCR+66547;,, N 16Jac1 ! $ PAR G(C15_LAVES,CR:FE),, +2*GHSERCR+GHSERFE+80893;,, N 16Jac1 ! PAR G(C15_LAVES,FE:CR),, +2*GHSERFE+GHSERCR+50467;,, N 16Jac1 ! $ $ Added 100 J to SIGMA_D8B PAR G(HIGH_SIGMA,FE:CR:CR),, +10*GFCCFE+20*GHSERCR +83944-111.32*T;,, N 00Wes ! PAR G(HIGH_SIGMA,FE:CR:FE),, +10*GFCCFE+4*GHSERCR +16*GHSERFE+140615-111.32*T;,, N 00Wes ! $ ------------------------------------------------------------------------------ $ Cr-Mg $ $ From I. Ansara 1998 (included in LB Vol. 2) $ $ I. Ansara, COST 507, Final report round 2, 1998. $ $ Checked against LB and COST. $ PAR L(LIQUID,CR,MG;0),, +94500;,, N 98Ans ! PAR L(LIQUID,CR,MG;1),, +12500;,, N 98Ans ! $ PAR L(BCC_A2,CR,MG:VA;0),, +80*T;,, N 98Ans ! PAR L(A2_BCC,CR,MG:VA;0),, +80*T;,, N 98Ans ! PAR L(HCP_A3,CR,MG:VA;0),, +80*T;,, N 98Ans ! $ $ metastable $ PAR L(FCC_A1,CR,MG:VA;0),, +80*T;,, N Same ! PAR L(A1_FCC,CR,MG:VA;0),, +80*T;,, N Same ! PAR L(CBCC_A12,CR,MG:VA;0),, +80*T;,, N Same ! PAR L(CUB_A13,CR,MG:VA;0),, +80*T;,, N Same ! $ ------------------------------------------------------------------------------ $ Cr-Mn $ $ From B.-J. Lee 1993 (Included in LB Vol. 2) $ $ B.-J. Lee, Metall. Trans. A, 24A, 1919-33(1993). $ $ Checked against LB and paper. Checked at 6000 K. $ $ HIGH-SIGMA with 10:4:16 model added by B. Hallstedt, 2016. $ $ The phase field of HIGH_SIGMA with 10:4:16 is slightly more narrow. $ Invariant temperatures are very nearly unchanged. $ $ The CBCC_A12 interaction referred to as 98Lee is an old parameter from 1991. $ It is used by mistake in COST and LB. $ $ L(FCC_4SL,CR,MN:*:*:*:VA;0) added for the Cr-Fe-Mn system. $ PAR L(LIQUID,CR,MN;0),, -15009+13.6587*T;,, N 93Lee3 ! PAR L(LIQUID,CR,MN;1),, +504+0.9479*T;,, N 93Lee3 ! $ PAR L(FCC_A1,CR,MN:VA;0),, -19088+17.5423*T;,, N 93Lee3 ! PAR L(A1_FCC,CR,MN:VA;0),, -19088+17.5423*T;,, N 93Lee3 ! $ PAR L(FCC_4SL,CR,MN:*:*:*:VA;0),, +2000;,, N 16Hal7 ! $ PAR L(BCC_A2,CR,MN:VA;0),, -20328+18.7339*T;,, N 93Lee3 ! PAR L(BCC_A2,CR,MN:VA;1),, -9162+4.4183*T;,, N 93Lee3 ! PAR TC(BCC_A2,CR,MN:VA;0),, -1325;,, N 93Lee3 ! PAR TC(BCC_A2,CR,MN:VA;2),, -1133;,, N 93Lee3 ! PAR TC(BCC_A2,CR,MN:VA;4),, -10294;,, N 93Lee3 ! PAR TC(BCC_A2,CR,MN:VA;6),, +26706;,, N 93Lee3 ! PAR TC(BCC_A2,CR,MN:VA;8),, -28117;,, N 93Lee3 ! PAR BMAG(BCC_A2,CR,MN:VA;0),, +0.48643;,, N 93Lee3 ! PAR BMAG(BCC_A2,CR,MN:VA;2),, -0.72035;,, N 93Lee3 ! PAR BMAG(BCC_A2,CR,MN:VA;4),, -1.93265;,, N 93Lee3 ! $ PAR L(A2_BCC,CR,MN:VA;0),, -20328+18.7339*T;,, N 93Lee3 ! PAR L(A2_BCC,CR,MN:VA;1),, -9162+4.4183*T;,, N 93Lee3 ! PAR TC(A2_BCC,CR,MN:VA;0),, -1325;,, N 93Lee3 ! PAR TC(A2_BCC,CR,MN:VA;2),, -1133;,, N 93Lee3 ! PAR TC(A2_BCC,CR,MN:VA;4),, -10294;,, N 93Lee3 ! PAR TC(A2_BCC,CR,MN:VA;6),, +26706;,, N 93Lee3 ! PAR TC(A2_BCC,CR,MN:VA;8),, -28117;,, N 93Lee3 ! PAR BMAG(A2_BCC,CR,MN:VA;0),, +0.48643;,, N 93Lee3 ! PAR BMAG(A2_BCC,CR,MN:VA;2),, -0.72035;,, N 93Lee3 ! PAR BMAG(A2_BCC,CR,MN:VA;4),, -1.93265;,, N 93Lee3 ! $ PAR L(CBCC_A12,CR,MN:VA;0),, -38349+22.6925*T;,, N 93Lee3 ! $PAR L(CBCC_A12,CR,MN:VA;0),, -36796+20.385*T;,, N 98Lee ! PAR L(CUB_A13,CR,MN:VA;0),, -31260+16.4919*T;,, N 93Lee3 ! $ PAR G(SIGMA_D8B,MN:CR:CR),, +10*GFCCMN+20*GHSERCR +10000;,, N 16Hal6 ! PAR G(SIGMA_D8B,MN:CR:MN),, +10*GFCCMN+4*GHSERCR +16*GBCCMN-168613+65.6*T;,, N 16Hal6 ! PAR L(SIGMA_D8B,MN:CR:CR,MN;0),, -947617+762.6*T;,, N 16Hal6 ! $ PAR G(HIGH_SIGMA,MN:CR:CR),, +10*GFCCMN+20*GHSERCR -105987+105*T;,, N 16Hal6 ! PAR G(HIGH_SIGMA,MN:CR:MN),, +10*GFCCMN+4*GHSERCR +16*GBCCMN-73252-10*T;,, N 16Hal6 ! $ PAR G(CR3MN5,CR:MN),, +3*GHSERCR+5*GHSERMN -72550+21.1732*T;,, N 93Lee3 ! $ $ Metastable $ $PAR L(HCP_A3,CR,MN:VA;0),, +60000;,, N 93Lee3 ! PAR L(HCP_A3,CR,MN:VA;0),, -19088+17.5423*T;,, N 93Fri ! $ PAR G(C14_LAVES,CR:MN),, +2*GHSERCR+GHSERMN+61860;,, N Lin ! PAR G(C14_LAVES,MN:CR),, +2*GHSERMN+GHSERCR+41280;,, N Lin ! $ ------------------------------------------------------------------------------ $ Cr-Mo $ $ From K. Frisk and P. Gustafson 1988 (Included in LB Vol. 2) $ $ K. Frisk, P. Gustafson, Calphad, 12, 247-254(1988). $ $ Checked against LB and paper. $ PAR L(LIQUID,CR,MO;0),, +15810-6.714*T;,, N 88Fri ! PAR L(LIQUID,CR,MO;1),, -6220;,, N 88Fri ! $ PAR L(BCC_A2,CR,MO:VA;0),, +28890-7.962*T;,, N 88Fri ! PAR L(BCC_A2,CR,MO:VA;1),, +5974-2.428*T;,, N 88Fri ! $ PAR L(A2_BCC,CR,MO:VA;0),, +28890-7.962*T;,, N 88Fri ! PAR L(A2_BCC,CR,MO:VA;1),, +5974-2.428*T;,, N 88Fri ! $ $ Metastable $ $ Same as bcc PAR L(FCC_A1,CR,MO:VA;0),, +28890-7.962*T;,, N 92Qiu1 ! PAR L(FCC_A1,CR,MO:VA;1),, +5974-2.428*T;,, N 92Qiu1 ! $ PAR L(A1_FCC,CR,MO:VA;0),, +28890-7.962*T;,, N 92Qiu1 ! PAR L(A1_FCC,CR,MO:VA;1),, +5974-2.428*T;,, N 92Qiu1 ! $ $ Same as bcc PAR L(HCP_A3,CR,MO:VA;0),, +28890-7.962*T;,, N NIST ! PAR L(HCP_A3,CR,MO:VA;1),, +5974-2.428*T;,, N NIST ! $ $ Same as bcc PAR L(CBCC_A12,CR,MO:VA;0),, +28890-7.962*T;,, N 95Lee ! PAR L(CBCC_A12,CR,MO:VA;1),, +5974-2.428*T;,, N 95Lee ! $ $ Same as bcc PAR L(CUB_A13,CR,MO:VA;0),, +28890-7.962*T;,, N 95Lee ! PAR L(CUB_A13,CR,MO:VA;1),, +5974-2.428*T;,, N 95Lee ! $ PAR G(CHI_A12,CR:CR:MO),, +24*GFCCCR+10*GHSERCR+24*GFCCMO +500000;,, N 88Gus4 ! PAR G(CHI_A12,CR:MO:MO),, +24*GFCCCR+10*GHSERMO+24*GFCCMO +500000;,, N 88Gus4 ! PAR G(CHI_A12,CR:MO:CR),, +48*GFCCCR+10*GHSERMO +500000;,, N 88Gus4 ! $ Parameter below from TCFE-99 $PAR G(CHI_A12,CR:MO:CR),, +48*GFCCCR+10*GHSERMO $ -26000;,, N Null ! $ PAR G(CRNI2_C11B,CR:MO),, +ZERO;,, N 06Tur ! $ PAR G(C14_LAVES,CR:MO),, +2*GFCCCR+GHSERMO-8000-6*T;,, N 87Gus2 ! PAR G(C14_LAVES,MO:CR),, +2*GHSERMO+GHSERCR+190000;,, N 17Hal5 ! $PAR L(C14_LAVES,CR,MO:*;0),, +60000;,, N 99Lee ! $PAR L(C14_LAVES,*:CR,MO;0),, +30000;,, N 99Lee ! $ PAR G(MU_D85,CR:MO:CR:CR),, +7*GFCCCR+2*GHSERCR +4*GHSERMO;,, N Lin ! PAR G(MU_D85,CR:MO:CR:MO),, +3*GHSERCR+4*GHSERMO +6*GFCCMO;,, N Lin ! PAR G(MU_D85,CR:MO:MO:CR),, +7*GFCCCR+6*GHSERMO;,, N Lin ! PAR G(MU_D85,CR:MO:MO:MO),, +GHSERCR+6*GHSERMO +6*GFCCMO;,, N Lin ! $ PAR G(MONI,CR:CR:MO),, +6*GFCCCR+5*GHSERCR+3*GHSERMO +12500;,, N 90Fri3 ! PAR G(MONI,CR:MO:MO),, +6*GFCCCR+8*GHSERMO+25000;,, N 90Fri3 ! $ PAR G(P_PHASE,CR:CR:MO),, +24*GFCCCR+20*GHSERCR+12*GHSERMO +252300-100*T;,, N 90Fri3 ! PAR G(P_PHASE,CR:MO:MO),, +24*GFCCCR+32*GHSERMO +265000-200*T;,, N 17Hal11 ! $ PAR G(R_PHASE,CR:MO:CR),, +27*GFCCCR+12*GHSERCR+14*GHSERMO -20000;,, N 88And4 ! PAR G(R_PHASE,CR:MO:MO),, +27*GFCCCR+26*GHSERMO -20000;,, N 88And4 ! $ PAR G(SIGMA_D8B,MO:CR:CR),, +10*GFCCMO+20*GHSERCR +150000;,, N 17Hal6 ! PAR G(SIGMA_D8B,MO:CR:MO),, +10*GFCCMO+4*GHSERCR +16*GHSERMO;,, N 17Hal6 ! PAR G(SIGMA_D8B,MO:MO:CR),, +10*GFCCMO+4*GHSERMO +16*GHSERCR-150000;,, N 17Hal6 ! $ ------------------------------------------------------------------------------ $ Cr-N $ $ From K. Frisk 1991 (included in LB Vol. 2) $ $ K. Frisk, Calphad, 15, 79-106(1991). $ $ Checked against LB and paper. $ $ BCC_A2 has a gigantic stability region above 2500 K. $ PAR L(LIQUID,CR,N;0),, -161800-16.11*T;,, N 91Fri1 ! PAR L(LIQUID,CR,N;1),, +65508;,, N 91Fri1 ! $ PAR G(FCC_A1,CR:N),, +GHSERCR+GHSERNN -124460+142.16*T-8.5*T*LN(T);,, N 91Fri1 ! PAR L(FCC_A1,CR:N,VA;0),, +20000;,, N 91Fri1 ! $ PAR G(A1_FCC,CR:N),, +GHSERCR+GHSERNN -124460+142.16*T-8.5*T*LN(T);,, N 91Fri1 ! PAR L(A1_FCC,CR:N,VA;0),, +20000;,, N 91Fri1 ! $ PAR G(BCC_A2,CR:N),, +GHSERCR+3*GHSERNN +311870+29.12*T;,, N 91Fri1 ! PAR TC(BCC_A2,CR:N),, -311.5;,, N 91Fri1 ! PAR BMAG(BCC_A2,CR:N),, -0.008;,, N 91Fri1 ! PAR L(BCC_A2,CR:N,VA;0),, -200000;,, N 91Fri1 ! $ PAR G(A2_BCC,CR:N),, +GHSERCR+3*GHSERNN +311870+29.12*T;,, N 91Fri1 ! PAR TC(A2_BCC,CR:N),, -311.5;,, N 91Fri1 ! PAR BMAG(A2_BCC,CR:N),, -0.008;,, N 91Fri1 ! PAR L(A2_BCC,CR:N,VA;0),, -200000;,, N 91Fri1 ! $ PAR G(HCP_A3,CR:N),, +GHSERCR+0.5*GHSERNN -65760+64.69*T-3.93*T*LN(T);,, N 91Fri1 ! PAR L(HCP_A3,CR:N,VA;0),, +21120-10.61*T;,, N 91Fri1 ! PAR L(HCP_A3,CR:N,VA;1),, -6204;,, N 91Fri1 ! $ $ metastable $ PAR G(CEMENTITE_D011,CR:N),, +3*GHSERCR+GHSERNN+40000;,, N Null ! PAR G(FE4N_L1,CR:N),, -135240+717.87*T-127.18*T*LN(T) -0.002899*T**2-1.0968E-06*T**3+450231*T**(-1);,, N 93Fri ! $ ------------------------------------------------------------------------------ $ Cr-Nb $ $ C. Schmetterer, A. Khvan, A. Jacob, B. Hallstedt, T. Markus $ J. Phase Equilib. Diffus., 35, 434-44(2014). $ $ Checked against paper. Checked at 6000 K. $ PAR L(LIQUID,CR,NB;0),, -10856;,, N 14Sch ! PAR L(LIQUID,CR,NB;1),, -5056;,, N 14Sch ! PAR L(LIQUID,CR,NB;2),, -2520;,, N 14Sch ! $ PAR L(BCC_A2,CR,NB:VA;0),, +61904-23.12*T;,, N 14Sch ! PAR L(BCC_A2,CR,NB:VA;1),, +37791-19.31*T;,, N 14Sch ! $ PAR L(A2_BCC,CR,NB:VA;0),, +61904-23.12*T;,, N 14Sch ! PAR L(A2_BCC,CR,NB:VA;1),, +37791-19.31*T;,, N 14Sch ! $ PAR G(C15_LAVES,CR:NB),, +2*GHSERCR+GHSERNB -6976-10.46*T;,, N 14Sch ! PAR G(C15_LAVES,NB:CR),, +GHSERCR+2*GHSERNB+222090;,, N 14Sch ! PAR L(C15_LAVES,CR,NB:CR;0),, +35896;,, N 14Sch ! PAR L(C15_LAVES,CR,NB:NB;0),, +35896;,, N 14Sch ! PAR L(C15_LAVES,CR:CR,NB;0),, -55035;,, N 14Sch ! PAR L(C15_LAVES,NB:CR,NB;0),, -55035;,, N 14Sch ! $ $ metastable $ PAR L(FCC_A1,CR,NB:VA;0),, +61904-23.12*T;,, N Same ! PAR L(FCC_A1,CR,NB:VA;1),, +37791-19.31*T;,, N Same ! $ PAR L(A1_FCC,CR,NB:VA;0),, +61904-23.12*T;,, N Same ! PAR L(A1_FCC,CR,NB:VA;1),, +37791-19.31*T;,, N Same ! $ PAR L(HCP_A3,CR,NB:VA;0),, +61904-23.12*T;,, N Same ! PAR L(HCP_A3,CR,NB:VA;1),, +37791-19.31*T;,, N Same ! $ PAR G(C14_LAVES,CR:NB),, +2*GHSERCR+GHSERNB -5600-10.46*T;,, N 16Jac1 ! PAR G(C14_LAVES,NB:CR),, +GHSERCR+2*GHSERNB+227160;,, N 16Jac1 ! PAR L(C14_LAVES,CR,NB:CR;0),, +35896;,, N 16Jac1 ! PAR L(C14_LAVES,CR,NB:NB;0),, +35896;,, N 16Jac1 ! PAR L(C14_LAVES,CR:CR,NB;0),, -55035;,, N 16Jac1 ! PAR L(C14_LAVES,NB:CR,NB;0),, -55035;,, N 16Jac1 ! $ PAR G(MU_D85,CR:NB:CR:CR),, +9*GHSERCR+4*GHSERNB+47060;,, N 16Jac1 ! PAR G(MU_D85,CR:NB:CR:NB),, +3*GHSERCR+10*GHSERNB +359580;,, N 16Jac1 ! PAR G(MU_D85,CR:NB:NB:CR),, +7*GHSERCR+6*GHSERNB+10140;,, N 16Jac1 ! PAR G(MU_D85,CR:NB:NB:NB),, +GHSERCR+12*GHSERNB+214240;,, N 16Jac1 ! PAR G(MU_D85,NB:NB:CR:CR),, +8*GHSERCR+5*GHSERNB +135200;,, N 16Jac1 ! PAR G(MU_D85,NB:NB:CR:NB),, +2*GHSERCR+11*GHSERNB +378690;,, N 16Jac1 ! PAR G(MU_D85,NB:NB:NB:CR),, +6*GHSERCR+7*GHSERNB+75660;,, N 16Jac1 ! $ ------------------------------------------------------------------------------ $ Cr-Ni $ $ F. Tang, B. Hallstedt, Calphad, 55, 260-69(2016). $ $ Checked against paper. Checked at 6000 K. $ $ Metastable ordering in fcc and bcc from N. Dupin. Changed to a 4SL fcc $ model with option F. Adding a reciprocal term makes CrNi3 (the only $ ordered state) less stable; max T decreases from 450 K to 235 K. $ $ The hcp interaction is set 2kJ more positive than the fcc interaction $ to avoid having hcp stable in Cr-Ni-C. $ PAR L(LIQUID,CR,NI;0),, -13300+2.7*T;,, N 16Tan ! PAR L(LIQUID,CR,NI;1),, +2900+1*T;,, N 16Tan ! $ PAR L(FCC_A1,CR,NI:VA;0),, +4300-8.9*T;,, N 16Tan ! PAR L(FCC_A1,CR,NI:VA;1),, +27000-13.8*T;,, N 16Tan ! PAR TC(FCC_A1,CR,NI:VA;0),, -3605;,, N 86Din ! PAR BMAG(FCC_A1,CR,NI:VA;0),, -1.91;,, N 86Din ! $ PAR L(A1_FCC,CR,NI:VA;0),, +4300-8.9*T;,, N 16Tan ! PAR L(A1_FCC,CR,NI:VA;1),, +27000-13.8*T;,, N 16Tan ! PAR TC(A1_FCC,CR,NI:VA;0),, -3605;,, N 86Din ! PAR BMAG(A1_FCC,CR,NI:VA;0),, -1.91;,, N 86Din ! $ PAR G(FCC_4SL,CR:CR:CR:NI:VA),, +GFCR3NI;,, N 01Dup ! PAR G(FCC_4SL,CR:CR:NI:NI:VA),, +GFCR2NI2;,, N 01Dup ! PAR G(FCC_4SL,CR:NI:NI:NI:VA),, +GFCRNI3;,, N 01Dup ! $PAR L(FCC_4SL,CR,NI:CR,NI:*:*:VA),, +SFCRNI;,, N 16Hal3 ! $ PAR L(BCC_A2,CR,NI:VA;0),, +14500-9*T;,, N 16Tan ! PAR L(BCC_A2,CR,NI:VA;1),, +27500-7.6*T;,, N 16Tan ! PAR TC(BCC_A2,CR,NI:VA;0),, +2373;,, N 86Din ! PAR TC(BCC_A2,CR,NI:VA;1),, +617;,, N 86Din ! PAR BMAG(BCC_A2,CR,NI:VA;0),, +4;,, N 86Din ! $ PAR L(A2_BCC,CR,NI:VA;0),, +14500-9*T;,, N 16Tan ! PAR L(A2_BCC,CR,NI:VA;1),, +27500-7.6*T;,, N 16Tan ! PAR TC(A2_BCC,CR,NI:VA;0),, +2373;,, N 86Din ! PAR TC(A2_BCC,CR,NI:VA;1),, +617;,, N 86Din ! PAR BMAG(A2_BCC,CR,NI:VA;0),, +4;,, N 86Din ! $ PAR G(B2_BCC,CR:NI:VA),, +4000;,, N 01Dup ! PAR G(B2_BCC,NI:CR:VA),, +4000;,, N 01Dup ! $ PAR G(CRNI2_C11B,CR:NI),, +GHSERCR+2*GHSERNI -6000-6.8*T;,, N 16Tan ! $ $ Metastable $ PAR L(HCP_A3,CR,NI:VA;0),, +6300-8.9*T;,, N Same ! PAR L(HCP_A3,CR,NI:VA;1),, +27000-13.8*T;,, N Same ! $PAR L(HCP_A3,CR,NI:VA;0),, +50000;,, N 95Dup ! PAR TC(HCP_A3,CR,NI:VA;0),, -3605;,, N Same ! PAR BMAG(HCP_A3,CR,NI:VA;0),, -1.91;,, N Same ! $ PAR G(CHI_A12,CR:CR:NI),, +24*GFCCCR+10*GHSERCR +24*GHSERNI;,, N Lin ! PAR G(CHI_A12,NI:CR:CR),, +24*GHSERNI+10*GHSERCR +24*GFCCCR;,, N Lin ! PAR G(CHI_A12,NI:CR:NI),, +48*GHSERNI+10*GHSERCR;,, N Lin ! $ PAR G(CR3SI_A15,NI:CR:VA),, +3*GHSERNI+GHSERCR+20000;,, N 00Sch ! $ PAR G(C14_LAVES,CR:NI),, +2*GHSERCR+GHSERNI+15000;,, N REFLAV ! PAR G(C14_LAVES,NI:CR),, +2*GHSERNI+GHSERCR+15000;,, N REFLAV ! $ $PAR G(SIGMA_D8B,NI:CR:CR),, +10*GHSERNI+20*GHSERCR $ +258130-254.715*T;,, N 93Lee4 ! PAR G(SIGMA_D8B,NI:CR:CR),, +10*GHSERNI+20*GHSERCR +240000-254.715*T;,, N 16Hal4 ! PAR G(SIGMA_D8B,NI:CR:NI),, +10*GHSERNI+4*GHSERCR+16*GBCCNI +175400;,, N 88Gus6 ! $ PAR G(HIGH_SIGMA,NI:CR:CR),, +10*GHSERNI+20*GHSERCR +240000-254.715*T;,, N 16Hal4 ! PAR G(HIGH_SIGMA,NI:CR:NI),, +10*GHSERNI+4*GHSERCR+16*GBCCNI +175400;,, N 88Gus6 ! $ FUNCTION U1FCRNI 298.15 -1980; 6000 N ! FUNCTION SFCRNI 298.15 +U1FCRNI; 6000 N ! FUNCTION GFCRNI3 298.15 +3*U1FCRNI; 6000 N ! FUNCTION GFCR2NI2 298.15 +4*U1FCRNI; 6000 N ! FUNCTION GFCR3NI 298.15 +3*U1FCRNI; 6000 N ! $ ------------------------------------------------------------------------------ $ Cr-Si $ $ Y. Du, J.C. Schuster, J. Phase Equilib., 21, 281-86(2000). $ $ Checked against paper. Checked at 6000 K. $ $ The parameter G(CR3SI_A15,SI:SI:VA) should probably be changed. $ Modified M5SI3_D88 to be stoichiometric for combination with e.g. Fe-Si. $ The temperature dependence of G(M4SI3,CR:SI) has the wrong sign in 00Sch. $ $ Stoichiometric version of M5SI3_D88 is used here. $ PAR L(LIQUID,CR,SI;0),, -126112.28+19.92557*T;,, N 00Du1 ! PAR L(LIQUID,CR,SI;1),, -48048.45+11.38497*T;,, N 00Du1 ! $ PAR L(BCC_A2,CR,SI:VA;0),, -83007.82-1.35928*T;,, N 00Du1 ! PAR L(BCC_A2,CR,SI:VA;1),, -48048.45+11.38497*T;,, N 00Du1 ! $ PAR L(A2_BCC,CR,SI:VA;0),, -83007.82-1.35928*T;,, N 00Du1 ! PAR L(A2_BCC,CR,SI:VA;1),, -48048.45+11.38497*T;,, N 00Du1 ! $ PAR G(B2_BCC,CR:SI:VA),, -20000;,, N 97Lin ! PAR G(B2_BCC,SI:CR:VA),, -20000;,, N 97Lin ! $ PAR G(CR3SI_A15,CR:SI:VA),, +3*GHSERCR+GHSERSI -115442.82-1.40036*T;,, N 00Du1 ! PAR G(CR3SI_A15,SI:CR:VA),, +GHSERCR+3*GHSERSI +316999.96-68.59964*T;,, N 00Du1 ! PAR L(CR3SI_A15,CR,SI:CR:VA;0),, -9661.46;,, N 00Du1 ! PAR L(CR3SI_A15,CR,SI:SI:VA;0),, -9661.46;,, N 00Du1 ! PAR L(CR3SI_A15,CR:CR,SI:VA;0),, -16781.4;,, N 00Du1 ! PAR L(CR3SI_A15,SI:CR,SI:VA;0),, -16781.4;,, N 00Du1 ! $ PAR G(CR5SI3_D8M,CR:SI),, +GCR5SI3;,, N 00Du1 ! $ PAR G(M5SI3_D88,CR:SI:VA),, +GCR5SI3 +19359-10.89*T;,, N 07Hal1 ! $ PAR G(MSI_B20,CR:SI),, -79273.09+312.40316*T -51.62865*T*LN(T)-0.00447355*T**2 +391330*T**(-1);,, N 00Du1 ! $ PAR G(CRSI2_C40,CR:SI),, -100352.65+336.777*T -57.855747*T*LN(T)-0.0132277*T**2 -4.3203E-07*T**3;,, N 00Du1 ! PAR G(CRSI2_C40,SI:CR),, +2*GHSERCR+GHSERSI +174006-27.21105*T;,, N 00Du1 ! PAR L(CRSI2_C40,CR,SI:CR;0),, +1435.7;,, N 00Du1 ! PAR L(CRSI2_C40,CR,SI:SI;0),, +1435.7;,, N 00Du1 ! PAR L(CRSI2_C40,CR:CR,SI;0),, +ZERO;,, N 00Du1 ! PAR L(CRSI2_C40,SI:CR,SI;0),, +ZERO;,, N 00Du1 ! $ $ metastable $ PAR L(FCC_A1,CR,SI:VA;0),, -83007.82-1.35928*T;,, N Same ! PAR L(FCC_A1,CR,SI:VA;1),, -48048.45+11.38497*T;,, N Same ! $ PAR L(A1_FCC,CR,SI:VA;0),, -83007.82-1.35928*T;,, N Same ! PAR L(A1_FCC,CR,SI:VA;1),, -48048.45+11.38497*T;,, N Same ! $ PAR L(HCP_A3,CR,SI:VA;0),, -83007.82-1.35928*T;,, N Same ! PAR L(HCP_A3,CR,SI:VA;1),, -48048.45+11.38497*T;,, N Same ! $ PAR L(CBCC_A12,CR,SI:VA;0),, -83007.82-1.35928*T;,, N Same ! PAR L(CBCC_A12,CR,SI:VA;1),, -48048.45+11.38497*T;,, N Same ! $ PAR L(CUB_A13,CR,SI:VA;0),, -83007.82-1.35928*T;,, N Same ! PAR L(CUB_A13,CR,SI:VA;1),, -48048.45+11.38497*T;,, N Same ! $ PAR G(C14_LAVES,CR:SI),, +2*GHSERCR+GHSERSI+100000;,, N 17Hal10 ! PAR G(C14_LAVES,SI:CR),, +2*GHSERSI+GHSERCR+100000;,, N 17Hal10 ! $ PAR G(M4SI3,CR:SI),, +4*GHSERCR+3*GHSERSI -213260.3-1.74503*T;,, N 00Sch ! PAR G(NI5SI2,CR:SI),, +5*GHSERCR+2*GHSERSI -23370.86-78.25748*T;,, N 00Sch ! PAR G(NI2SI_C37,CR:SI),, +2*GHSERCR+GHSERSI -40923.29-23.21742*T;,, N 00Sch ! $ FUNCTION GCR5SI3 298.15 -316886.2+1067.97713*T-182.578184*T*LN(T) -0.023919688*T**2-2.31728E-06*T**3; 6000.00 N ! $ ------------------------------------------------------------------------------ $ Cr-Ti $ $ J. Pavlu, J. Vrestal, M. Sob, Calphad, 34, 215-21(2010). $ $ Both 2-SL and 3-SL models are included for the C14_LAVES and C36_LAVES phases. $ This dataset includes the 2-SL models. $ $ Checked against paper. Checked at 6000 K. $ $ There are two models for Cr2Ti included. CR2TI_C14 etc are the original from $ 10Pav. C14_LAVES etc include new end-member values and refitted interactions. $ Incorrect values for G(C14_LAVES,TI:TI), G(C15_LAVES,TI:TI) and $ G(C36_LAVES,TI:TI) were used in a previous version. $ When using the correct value for C14_LAVES from 06Slu it was not possible to $ refit the Mn-Ti phase diagram without using excessive interaction parameters. $ Therefore a value for G(C14_LAVES,TI:TI) was selected that produces moderate $ interaction parameters. $ The Ti solubility in the Laves phases increases somewhat and invariant $ temperatures change by up to about 7 K. $ PAR L(LIQUID,CR,TI;0),, -992;,, N 00Zhu ! PAR L(LIQUID,CR,TI;1),, +1811;,, N 00Zhu ! $ PAR L(BCC_A2,CR,TI:VA;0),, +11824;,, N 00Zhu ! PAR L(BCC_A2,CR,TI:VA;1),, +5012;,, N 00Zhu ! $ PAR L(A2_BCC,CR,TI:VA;0),, +11824;,, N 00Zhu ! PAR L(A2_BCC,CR,TI:VA;1),, +5012;,, N 00Zhu ! $ PAR L(HCP_A3,CR,TI:VA;0),, +25500;,, N 00Zhu ! $ PAR G(C14_LAVES,CR:TI),, +2*GHSERCR+GHSERTI -25401-0.788*T+0.788*T*LN(T);,, N 10Pav ! PAR G(C14_LAVES,TI:CR),, +2*GHSERTI+GHSERCR +154157;,, N 10Pav ! PAR L(C14_LAVES,CR,TI:TI;0),, +10000;,, N 17Hal2 ! $ PAR G(C15_LAVES,CR:TI),, +2*GHSERCR+GHSERTI -30486-1.414*T+1.414*T*LN(T);,, N 10Pav ! PAR G(C15_LAVES,TI:CR),, +2*GHSERTI+GHSERCR +171806;,, N 10Pav ! PAR L(C15_LAVES,CR,TI:TI;0),, -7500;,, N 17Hal2 ! $ PAR G(C36_LAVES,CR:TI),, +2*GHSERCR+GHSERTI -28534-1.107*T+1.107*T*LN(T);,, N 10Pav ! PAR G(C36_LAVES,TI:CR),, +2*GHSERTI+GHSERCR +160581;,, N 10Pav ! PAR L(C36_LAVES,CR,TI:TI;0),, +8000;,, N 17Hal2 ! $ $ metastable $ $PAR L(FCC_A1,CR,TI:VA;0),, +32000;,, N 95Dup ! PAR L(FCC_A1,CR,TI:VA;0),, +15791.59;,, N Null ! PAR L(A1_FCC,CR,TI:VA;0),, +15791.59;,, N Null ! $ PAR G(MU_D85,CR:TI:TI:CR),, +7*GFCCCR+6*GBCCTI;,, N Lin ! PAR G(MU_D85,CR:TI:CR:CR),, +7*GFCCCR+4*GBCCTI +2*GHSERCR;,, N Lin ! $ ------------------------------------------------------------------------------ $ Cr-V $ $ From B.-J. Lee 1992 (Included in LB Vol. 2) $ $ B.-J. Lee, Z. Metallkd., 83, 292-99(1992). $ $ Checked against LB and paper. Checked at 6000 K. $ PAR L(LIQUID,CR,V;0),, -9874-2.6964*T;,, N 92Lee3 ! PAR L(LIQUID,CR,V;1),, -1720-2.5237*T;,, N 92Lee3 ! $ PAR L(BCC_A2,CR,V:VA;0),, -9874-2.6964*T;,, N 92Lee3 ! PAR L(BCC_A2,CR,V:VA;1),, -1720-2.5237*T;,, N 92Lee3 ! $ PAR L(A2_BCC,CR,V:VA;0),, -9874-2.6964*T;,, N 92Lee3 ! PAR L(A2_BCC,CR,V:VA;1),, -1720-2.5237*T;,, N 92Lee3 ! $ $ Metastable $ PAR L(FCC_A1,CR,V:VA;0),, -9874-2.6964*T;,, N 92Lee3 ! PAR L(FCC_A1,CR,V:VA;1),, -1720-2.5237*T;,, N 92Lee3 ! $ PAR L(A1_FCC,CR,V:VA;0),, -9874-2.6964*T;,, N 92Lee3 ! PAR L(A1_FCC,CR,V:VA;1),, -1720-2.5237*T;,, N 92Lee3 ! $ PAR L(HCP_A3,CR,V:VA;0),, -9874-2.6964*T;,, N Same ! PAR L(HCP_A3,CR,V:VA;1),, -1720-2.5237*T;,, N Same ! $ PAR G(C14_LAVES,CR:V),, +2*GHSERCR+GHSERVV+67290;,, N Lin ! PAR G(C14_LAVES,V:CR),, +2*GHSERVV+GHSERCR+52140;,, N Lin ! $ PAR G(SIGMA_D8B,V:CR:CR),, +10*GFCCVV+20*GHSERCR;,, N Lin ! PAR G(SIGMA_D8B,V:CR:V),, +10*GFCCVV+4*GHSERCR +16*GHSERVV;,, N Lin ! PAR G(SIGMA_D8B,V:V:CR),, +10*GFCCVV+4*GHSERVV +16*GHSERCR;,, N Lin ! $ ------------------------------------------------------------------------------ $ Cu-C $ $ From A.T. Dinsdale 2004 (included in LB Vol. 2) $ $ A.T. Dinsdale, unpublished, 2004. $ $ Checked against LB. $ $ The calculated diagram using the fcc interaction from LBall-v7+fun.tdb $ is not in agreement with the text in LB. According to the text the max C $ C solubility in fcc-Cu is 0.04 at%. The calculated solubility is 3e-6 at%. $ $ L(FCC_A1,CU:C,VA;0) was fitted to solubility data from R.B. McLellan, $ Scripta Metall., 3, 389-92(1989), which is roughly in agreement with the $ text in LB. $ $ There are new data on the C solubility in fcc-Cu from Lopez and Mittemeijer $ (Scripta Mater., 51, 1-5(2004)). These indicate a much lower solubility $ of 7.4e-4 at.% at 1293 K. These data were used by 14Shu and their parameters $ are used here. $ $ The liquid solubility is in agreement with data from L.L. Oden and $ N.A. Gokcen, Metall. Trans. B, 23B, 453-58(1992), which were also used $ by 14Shu. $ $ The BCC_A2 parameters suggested by 14Shu are questionable, but it is not $ clear if the 87Cha parameters are any better. The BCC_A2 parameters were $ selected here for a G-curve approximately parallel to the FCC_A1 curve $ at 1373 K. $ $ PAR L(LIQUID,C,CU;0),, +123650-24.5461*T;,, N 04Din ! $ $PAR G(FCC_A1,CU:C),, +GHSERCU+GHSERCC $ +138490-14.64*T;,, N 87Cha ! PAR G(FCC_A1,CU:C),, +GHSERCU+GHSERCC+127000;,, N 14Shu ! $PAR L(FCC_A1,CU:C,VA;0),, +75000;,, N 04Din ! $PAR L(FCC_A1,CU:C,VA;0),, -91200+45.8*T;,, N 08Hal2 ! PAR L(FCC_A1,CU:C,VA;0),, +ZERO;,, N 14Shu ! $ PAR G(A1_FCC,CU:C),, +GHSERCU+GHSERCC+127000;,, N 14Shu ! PAR L(A1_FCC,CU:C,VA;0),, +ZERO;,, N 14Shu ! $ $ metastable $ $PAR G(BCC_A2,CU:C),, +GHSERCU+3*GHSERCC+127000;,, N 14Shu ! $PAR L(BCC_A2,CU:C,VA;0),, +ZERO;,, N 14Shu ! $PAR G(BCC_A2,CU:C),, +GHSERCU+3*GHSERCC $ +146858-14.64*T;,, N 87Cha ! $PAR L(BCC_A2,CU:C,VA;0),, +120000;,, N 87Cha ! PAR G(BCC_A2,CU:C),, +GHSERCU+3*GHSERCC+440000;,, N 17Hal15 ! PAR L(BCC_A2,CU:C,VA;0),, +ZERO;,, N 17Hal15 ! $ PAR G(A2_BCC,CU:C),, +GHSERCU+3*GHSERCC+440000;,, N 17Hal15 ! PAR L(A2_BCC,CU:C,VA;0),, +ZERO;,, N 17Hal15 ! $ PAR G(HCP_A3,CU:C),, +UN_ASS;,, N ! $ ------------------------------------------------------------------------------ $ Cu-Fe $ $ Q. Chen, Z.P. Jin, Metall. Mater. Trans. A, 26A, 417-26(1995). $ $ Checked against paper. Checked at 6000 K. $ PAR L(LIQUID,CU,FE;0),, +35625.8-2.19045*T;,, N 95Che ! PAR L(LIQUID,CU,FE;1),, -1529.8+1.15291*T;,, N 95Che ! PAR L(LIQUID,CU,FE;2),, +12714.4-5.18624*T;,, N 95Che ! PAR L(LIQUID,CU,FE;3),, +1177.1;,, N 95Che ! $ PAR L(FCC_A1,CU,FE:VA;0),, +43319.6-6.94445*T;,, N 95Che ! PAR L(FCC_A1,CU,FE:VA;1),, +6068.8-2.83662*T;,, N 95Che ! PAR L(FCC_A1,CU,FE:VA;2),, +3629.4;,, N 95Che ! $ PAR L(A1_FCC,CU,FE:VA;0),, +43319.6-6.94445*T;,, N 95Che ! PAR L(A1_FCC,CU,FE:VA;1),, +6068.8-2.83662*T;,, N 95Che ! PAR L(A1_FCC,CU,FE:VA;2),, +3629.4;,, N 95Che ! $ PAR L(BCC_A2,CU,FE:VA;0),, +39676-4.73222*T;,, N 95Che ! PAR TC(BCC_A2,CU,FE:VA;0),, -41.40;,, N 95Che ! $ PAR L(A2_BCC,CU,FE:VA;0),, +39676-4.73222*T;,, N 95Che ! PAR TC(A2_BCC,CU,FE:VA;0),, -41.40;,, N 95Che ! $ $ metastable $ PAR L(HCP_A3,CU,FE:VA;0),, +43319.6-6.94445*T;,, N Same ! PAR L(HCP_A3,CU,FE:VA;1),, +6068.8-2.83662*T;,, N Same ! PAR L(HCP_A3,CU,FE:VA;2),, +3629.4;,, N Same ! $ PAR L(CBCC_A12,CU,FE:VA;0),, +50000;,, N 03Mie3 ! PAR L(CUB_A13,CU,FE:VA;0),, +50000;,, N 03Mie3 ! $ ------------------------------------------------------------------------------ $ Cu-Mg $ $ B. Hallstedt, unpublished, 2016. $ $ Checked at 6000 K. $ $ Based on the assessment from P. Liang et al. 1998 with modified Gibbs $ energies from S.H. Zhou et al. 2007. This was necessary because the heat $ capacity of Cu2Mg (C15) from 98Lia2 increases too rapidly and makes Cu2Mg $ stable again above 2800 K. $ $ The Gibbs energy functions from 07Zho for C15_LAVES and CUMG2_CB are $ discontinuous across the temperature interval limit. This was corrected by $ adjusting the functions for the upper temperature interval. The other Laves $ phase and CuMg2 parameters were reoptimised to reproduce the invariant $ equilibria from 98Lia (and to some extent 07Zho). $ $ The hcp interaction is very different from the fcc interaction. The fcc $ interaction can be considered reasonably well determined since it is $ based on a relatively well determined solubility of Mg in Cu. The current $ hcp interaction gives a Cu solubility in Mg at the eutectic temperature $ of 0.049 at.% Cu. The measured solubility is smaller (0.01 to 0.02 at.% Cu). $ There are several measurements cited in Nayeb-Hashemi and Clark, $ BAPD, 5(1), 36-43(1984), but they are all very old; 1931 or earlier. $ Thus, the hcp interaction seems uncertain and the value from 98Lia seems a $ reasonable compromise. The hcp interaction from 07Zho results in an even $ lower solubility than measured and should not be used. $ $ The parameters for the metastable C14 and C36 phases are modified to keep $ the same Delta-G relative to C15. $ PAR L(LIQUID,CU,MG;0),, -36962.71+4.74394*T;,, N 98Lia2 ! PAR L(LIQUID,CU,MG;1),, -8182.19;,, N 98Lia2 ! $ PAR L(FCC_A1,CU,MG:VA;0),, -22059.61+5.63232*T;,, N 98Lia2 ! PAR L(A1_FCC,CU,MG:VA;0),, -22059.61+5.63232*T;,, N 98Lia2 ! $ PAR L(HCP_A3,CU,MG:VA;0),, +22500-3*T;,, N 98Lia2 ! $ PAR G(C15_LAVES,CU:MG),, +GC15CUMG;,, N 16Hal9 ! PAR G(C15_LAVES,MG:CU),, +GHSERCU+2*GHSERMG +104970.96-16.46448*T;,, N 98Lia2 ! PAR L(C15_LAVES,CU,MG:CU;0),, +13011.35;,, N 98Lia2 ! PAR L(C15_LAVES,CU,MG:MG;0),, +13011.35;,, N 98Lia2 ! PAR L(C15_LAVES,CU:CU,MG;0),, +6599.45;,, N 98Lia2 ! PAR L(C15_LAVES,MG:CU,MG;0),, +6599.45;,, N 98Lia2 ! $ PAR G(CUMG2_CB,CU:MG),, +GCBCUMG;,, N 16Hal9 ! $ $ Metastable $ PAR L(BCC_A2,CU,MG:VA;0),, -6500;,, N 98Lia2 ! PAR L(A2_BCC,CU,MG:VA;0),, -6500;,, N 98Lia2 ! $ $PAR G(C14_LAVES,CU:MG),, +GC15CUMG+30000;,, N 98Lia2 ! $PAR G(C14_LAVES,MG:CU),, +GHSERCU+2*GHSERMG $ +74970.96-16.46448*T;,, N 98Lia2 ! $PAR L(C14_LAVES,CU,MG:CU;0),, +13011.35;,, N 98Lia2 ! $PAR L(C14_LAVES,CU,MG:MG;0),, +13011.35;,, N 98Lia2 ! $PAR L(C14_LAVES,CU:CU,MG;0),, +6599.45;,, N 98Lia2 ! $PAR L(C14_LAVES,MG:CU,MG;0),, +6599.45;,, N 98Lia2 ! $ $PAR G(C36_LAVES,CU:MG),, +GC15CUMG+20000;,, N 98Lia2 ! $PAR G(C36_LAVES,MG:CU),, +GHSERCU+2*GHSERMG $ +84970.96-16.46448*T;,, N 98Lia2 ! $PAR L(C36_LAVES,CU,MG:CU;0),, +13011.35;,, N 98Lia2 ! $PAR L(C36_LAVES,CU,MG:MG;0),, +13011.35;,, N 98Lia2 ! $PAR L(C36_LAVES,CU:CU,MG;0),, +6599.45;,, N 98Lia2 ! $PAR L(C36_LAVES,MG:CU,MG;0),, +6599.45;,, N 98Lia2 ! $ FUNCTION GC15CUMG 298.15 -54854+408.17*T-76.1*T*LN(T) -9.9E-04*T**2-1.35E-06*T**3+183906*T**(-1); 1070.00 Y -61915.6682+489.549872*T-87.17102875*T*LN(T); 6000.00 N ! FUNCTION GCBCUMG 298.15 -50415+423.34*T-77.9913484*T*LN(T) +0.00231*T**2-2.72115E-06*T**3+190378*T**(-1); 850.00 Y -54534.6038+477.968452*T-85.33353573*T*LN(T); 6000.00 N ! $ ------------------------------------------------------------------------------ $ Cu-Mn $ $ From J. Miettinen 2003 (Included in LB Vol. 3) $ $ J. Miettinen, Calphad, 27, 103-14(2003). $ $ Checked against LB and paper. Checked at 6000 K. $ PAR L(LIQUID,CU,MN;0),, +1800-2.28*T;,, N 96Vre ! PAR L(LIQUID,CU,MN;1),, -6500-2.91*T;,, N 96Vre ! $ PAR L(BCC_A2,CU,MN:VA;0),, +11190-6*T;,, N 03Mie2 ! PAR L(BCC_A2,CU,MN:VA;1),, -9865;,, N 03Mie2 ! $ PAR L(A2_BCC,CU,MN:VA;0),, +11190-6*T;,, N 03Mie2 ! PAR L(A2_BCC,CU,MN:VA;1),, -9865;,, N 03Mie2 ! $ PAR L(FCC_A1,CU,MN:VA;0),, +11820-2.3*T;,, N 03Mie2 ! PAR L(FCC_A1,CU,MN:VA;1),, -10600+3*T;,, N 03Mie2 ! PAR L(FCC_A1,CU,MN:VA;2),, +ZERO;,, N 03Mie2 ! PAR L(FCC_A1,CU,MN:VA;3),, -4850+3.5*T;,, N 03Mie2 ! $ PAR L(A1_FCC,CU,MN:VA;0),, +11820-2.3*T;,, N 03Mie2 ! PAR L(A1_FCC,CU,MN:VA;1),, -10600+3*T;,, N 03Mie2 ! PAR L(A1_FCC,CU,MN:VA;2),, +ZERO;,, N 03Mie2 ! PAR L(A1_FCC,CU,MN:VA;3),, -4850+3.5*T;,, N 03Mie2 ! $ PAR L(CBCC_A12,CU,MN:VA;0),, +35000;,, N 03Mie2 ! PAR L(CUB_A13,CU,MN:VA;0),, +35000;,, N 03Mie2 ! $ $ metastable $ PAR L(HCP_A3,CU,MN:VA;0),, +11820-2.3*T;,, N Same ! PAR L(HCP_A3,CU,MN:VA;1),, -10600+3*T;,, N Same ! PAR L(HCP_A3,CU,MN:VA;2),, +ZERO;,, N Same ! PAR L(HCP_A3,CU,MN:VA;3),, -4850+3.5*T;,, N Same ! $ ------------------------------------------------------------------------------ $ Cu-Mo $ $ C.P. Wang, X.J. Liu, I. Ohnuma, R. Kainuma, S.M. Hao, K. Ishida, $ J. Phase Equilib., 21, 54-62(2000). $ $ Checked against paper. Checked at 6000 K. $ PAR L(LIQUID,CU,MO;0),, +57285.4+2*T;,, N 00Wan ! PAR L(LIQUID,CU,MO;1),, -1200;,, N 00Wan ! $ PAR L(BCC_A2,CU,MO:VA;0),, +82313;,, N 80Bre ! PAR L(A2_BCC,CU,MO:VA;0),, +82313;,, N 80Bre ! $ PAR L(FCC_A1,CU,MO:VA;0),, +83144;,, N 80Bre ! PAR L(A1_FCC,CU,MO:VA;0),, +83144;,, N 80Bre ! $ $ metastable $ PAR L(HCP_A3,CU,MO:VA;0),, +83144;,, N Same ! PAR L(CBCC_A12,CU,MO:VA;0),, +83144;,, N Same ! PAR L(CUB_A13,CU,MO:VA;0),, +83144;,, N Same ! $ ------------------------------------------------------------------------------ $ Cu-N $ $ K. Frisk, Report IM-2929, 1991. $ $ The solubility of N in fcc-Cu is extremely small. Results without the gas $ included are not reasonable; there is then a large bcc region in the center. $ $ The bcc phase is far too stable. $ PAR L(LIQUID,CU,N;0),, +33115;,, N 91Fri4 ! $ PAR G(FCC_A1,CU:N),, +GHSERCU+GHSERNN+374805;,, N 91Fri4 ! PAR G(A1_FCC,CU:N),, +GHSERCU+GHSERNN+374805;,, N 91Fri4 ! $ $ metastable $ PAR G(BCC_A2,CU:N),, +GHSERCU+3*GHSERNN +100000+200*T;,, N 91Fri4 ! PAR G(A2_BCC,CU:N),, +GHSERCU+3*GHSERNN +100000+200*T;,, N 91Fri4 ! PAR G(HCP_A3,CU:N),, +GHSERCU+0.5*GHSERNN +300000;,, N 91Fri4 ! $ ------------------------------------------------------------------------------ $ Cu-Nb $ $ From Hämäläinen et al. 1990 (Included in LB Vol. 3) $ $ M. Hamalainen, K. Jaaskelainen, R. Luoma, M. Nuotio, P. Taskinen, $ O. Teppo, Calphad, 14, 125-37(1990). $ $ Checked against LB and paper. Checked at 6000 K. $ $ The temperature dependence of the liquid interaction is ridiculous. $ PAR L(LIQUID,CU,NB;0),, +204361.19-89.93141*T;,, N 90Ham ! PAR L(LIQUID,CU,NB;1),, -105148.17+57.81653*T;,, N 90Ham ! $ PAR L(FCC_A1,CU,NB:VA;0),, +45699.84-5.22785*T;,, N 90Ham ! PAR L(A1_FCC,CU,NB:VA;0),, +45699.84-5.22785*T;,, N 90Ham ! $ PAR L(BCC_A2,CU,NB:VA;0),, +49480.18;,, N 90Ham ! PAR L(A2_BCC,CU,NB:VA;0),, +49480.18;,, N 90Ham ! $ $ metastable $ PAR L(HCP_A3,CU,NB:VA;0),, +45699.84-5.22785*T;,, N Same ! $ ------------------------------------------------------------------------------ $ Cu-Ni $ $ From S. an Mey 1992 (Included in LB Vol. 3) $ $ S. an Mey, Calphad 16, 255-60(1992). $ $ Checked against LB and paper. Checked at 6000 K. $ $ The COST 507 database has different parameters for BMAG(FCC_A1,CU,NI:VA). $ Probable error in the COST 507 database. $ $ TCFE2000 uses L(BCC_A2,CU,NI:VA;0)=-20000 to stabilize BCC in 2% Cu steel. $ PAR L(LIQUID,CU,NI;0),, +12048.61+1.29893*T;,, N 92Mey ! PAR L(LIQUID,CU,NI;1),, -1861.61+0.94201*T;,, N 92Mey ! $ PAR L(FCC_A1,CU,NI:VA;0),, +8047.72+3.42217*T;,, N 92Mey ! PAR L(FCC_A1,CU,NI:VA;1),, -2041.3+0.99714*T;,, N 92Mey ! PAR TC(FCC_A1,CU,NI:VA;0),, -935.5;,, N 87Jan ! PAR TC(FCC_A1,CU,NI:VA;1),, -594.9;,, N 87Jan ! PAR BMAG(FCC_A1,CU,NI:VA;0),, -0.7316;,, N 87Jan ! PAR BMAG(FCC_A1,CU,NI:VA;1),, -0.3174;,, N 87Jan ! $ PAR L(A1_FCC,CU,NI:VA;0),, +8047.72+3.42217*T;,, N 92Mey ! PAR L(A1_FCC,CU,NI:VA;1),, -2041.3+0.99714*T;,, N 92Mey ! PAR TC(A1_FCC,CU,NI:VA;0),, -935.5;,, N 87Jan ! PAR TC(A1_FCC,CU,NI:VA;1),, -594.9;,, N 87Jan ! PAR BMAG(A1_FCC,CU,NI:VA;0),, -0.7316;,, N 87Jan ! PAR BMAG(A1_FCC,CU,NI:VA;1),, -0.3174;,, N 87Jan ! $ $ Metastable $ PAR L(BCC_A2,CU,NI:VA;0),, +8366+2.802*T;,, N 87Jan ! PAR L(BCC_A2,CU,NI:VA;1),, -4359.6+1.812*T;,, N 87Jan ! $ PAR L(A2_BCC,CU,NI:VA;0),, +8366+2.802*T;,, N 87Jan ! PAR L(A2_BCC,CU,NI:VA;1),, -4359.6+1.812*T;,, N 87Jan ! $ PAR L(HCP_A3,CU,NI:VA;0),, +8047.72+3.42217*T;,, N 92Mey ! PAR L(HCP_A3,CU,NI:VA;1),, -2041.3+0.99714*T;,, N 92Mey ! $ PAR L(CBCC_A12,CU,NI:VA;0),, +8047.72+3.42217*T;,, N Same ! PAR L(CBCC_A12,CU,NI:VA;1),, -2041.3+0.99714*T;,, N Same ! $ PAR L(CUB_A13,CU,NI:VA;0),, +8047.72+3.42217*T;,, N Same ! PAR L(CUB_A13,CU,NI:VA;1),, -2041.3+0.99714*T;,, N Same ! $ ------------------------------------------------------------------------------ $ Cu-Si $ $ B. Hallstedt, J. Groebner, M. Hampl, R. Schmid-Fetzer, $ Calphad, 53, 25-38(2016). $ $ BCC_A2 is stable as beta at about CU85SI15 and HCP_A3 is stable as $ kappa at about CU87SI13. $ PAR L(LIQUID,CU,SI;0),, -37776+3.47*T;,, N 16Hal10 ! PAR L(LIQUID,CU,SI;1),, -44866+14.53*T;,, N 16Hal10 ! PAR L(LIQUID,CU,SI;2),, -40866+8.62*T;,, N 16Hal10 ! PAR L(LIQUID,CU,SI;3),, -10060;,, N 16Hal10 ! PAR L(LIQUID,CU,SI;4),, +17550;,, N 16Hal10 ! $ PAR L(FCC_A1,CU,SI:VA;0),, -32244+20*T;,, N 16Hal10 ! PAR L(FCC_A1,CU,SI:VA;1),, -43581-28.5*T;,, N 16Hal10 ! $ PAR L(A1_FCC,CU,SI:VA;0),, -32244+20*T;,, N 16Hal10 ! PAR L(A1_FCC,CU,SI:VA;1),, -43581-28.5*T;,, N 16Hal10 ! $ PAR L(HCP_A3,CU,SI:VA;0),, -26218+11*T;,, N 16Hal10 ! PAR L(HCP_A3,CU,SI:VA;1),, -60756-15.4*T;,, N 16Hal10 ! $ PAR L(BCC_A2,CU,SI:VA;0),, -19744+11*T;,, N 16Hal10 ! PAR L(BCC_A2,CU,SI:VA;1),, -88450-9*T;,, N 16Hal10 ! $ PAR L(A2_BCC,CU,SI:VA;0),, -19744+11*T;,, N 16Hal10 ! PAR L(A2_BCC,CU,SI:VA;1),, -88450-9*T;,, N 16Hal10 ! $ $PAR G(DIAMOND_A4,SI:CU),, +GHSERSI+GHSERCU+100000;,, N 16Hal10 ! $PAR L(DIAMOND_A4,SI:CU,VA;0),, +47230-30.23*T;,, N 16Hal10 ! $ PAR G(CU33SI7_A13,CU:SI),, +33*GHSERCU+7*GHSERSI -156240-163.2*T;,, N 16Hal10 ! PAR G(CU33SI7_HT,CU:SI),, +33*GHSERCU+7*GHSERSI -90160-228.8*T;,, N 16Hal10 ! PAR G(CU15SI4_D86,CU:SI),, +15*GHSERCU+4*GHSERSI -88065-77.9*T;,, N 16Hal10 ! PAR G(CU3SI_LT,CU:SI),, +0.77*GHSERCU+0.23*GHSERSI -4770-4*T;,, N 16Hal10 ! PAR G(CU3SI_MT,CU:SI),, +0.765*GHSERCU+0.235*GHSERSI -4060-4.88*T;,, N 16Hal10 ! PAR G(CU3SI_HT,CU:SI),, +0.76*GHSERCU+0.24*GHSERSI -2885-6.23*T;,, N 16Hal10 ! $ $ metastable $ PAR L(CBCC_A12,CU,SI:VA;0),, -32244+20*T;,, N Same ! PAR L(CBCC_A12,CU,SI:VA;1),, -43581-28.5*T;,, N Same ! $ PAR L(CUB_A13,CU,SI:VA;0),, -32244+20*T;,, N Same ! PAR L(CUB_A13,CU,SI:VA;1),, -43581-28.5*T;,, N Same ! $ ------------------------------------------------------------------------------ $ Cu-Ti $ $ J. Wang, C. Liu, C. Leinenbach, U.E. Klotz, P.J. Uggowitzer, J.F. Loeffler, $ Calphad, 35, 82-94(2011). $ $ Modified from Hari Kumar et al. 1996. Gibbs energy of CuTi2 was changed for $ use in the Cu-Sn-Ti system. It is also used in the Cu-Ni-Ti system. $ $ Checked against paper. Checked at 6000 K. $ PAR L(LIQUID,CU,TI;0),, -19330+7.651*T;,, N 96Har2 ! PAR L(LIQUID,CU,TI;2),, +9382-5.448*T;,, N 96Har2 ! $ PAR L(FCC_A1,CU,TI:VA;0),, -9882;,, N 96Har2 ! PAR L(FCC_A1,CU,TI:VA;1),, +15777;,, N 96Har2 ! $ PAR L(A1_FCC,CU,TI:VA;0),, -9882;,, N 96Har2 ! PAR L(A1_FCC,CU,TI:VA;1),, +15777;,, N 96Har2 ! $ PAR L(BCC_A2,CU,TI:VA;0),, +3389;,, N 96Har2 ! PAR L(A2_BCC,CU,TI:VA;0),, +3389;,, N 96Har2 ! $ PAR L(HCP_A3,CU,TI:VA;0),, +16334;,, N 96Har2 ! $ PAR G(CU4TI1,CU:TI),, +4*GHSERCU+GHSERTI -30055+11.695*T;,, N 96Har2 ! PAR G(CU4TI1,TI:CU),, +4*GHSERTI+GHSERCU +80055-11.695*T;,, N 96Har2 ! PAR L(CU4TI1,CU,TI:CU;0),, +17089;,, N 96Har2 ! PAR L(CU4TI1,CU,TI:TI;0),, +17089;,, N 96Har2 ! PAR L(CU4TI1,CU:CU,TI;0),, -15767;,, N 96Har2 ! PAR L(CU4TI1,TI:CU,TI;0),, -15767;,, N 96Har2 ! $ PAR G(CU2TI,CU:TI),, +2*GHSERCU+GHSERTI-17628;,, N 96Har2 ! PAR G(CU3TI2,CU:TI),, +3*GHSERCU+2*GHSERTI -46245+10.86*T;,, N 96Har2 ! PAR G(CU4TI3,CU:TI),, +4*GHSERCU+3*GHSERTI -68236+15.946*T;,, N 96Har2 ! $ PAR G(CUTI_B11,CU:TI),, +GHSERCU+GHSERTI -22412+6.544*T;,, N 96Har2 ! PAR G(CUTI_B11,TI:CU),, +GHSERTI+GHSERCU +42412-6.544*T;,, N 96Har2 ! PAR L(CUTI_B11,CU,TI:CU;0),, +15419;,, N 96Har2 ! PAR L(CUTI_B11,CU,TI:TI;0),, +15419;,, N 96Har2 ! PAR L(CUTI_B11,CU:CU,TI;0),, +15578;,, N 96Har2 ! PAR L(CUTI_B11,TI:CU,TI;0),, +15578;,, N 96Har2 ! $ $PAR G(CUTI2_C11B,CU:TI),, +GHSERCU+2*GHSERTI $ -36393+14.064*T;,, N 96Har2 ! PAR G(CUTI2_C11B,CU:TI),, +GHSERCU+2*GHSERTI -27000+6.6*T;,, N 11Wan ! $ $ Metastable $ $PAR L(BCT_A5,CU,TI;0),, +20000;,, N 11Wan ! $ ------------------------------------------------------------------------------ $ Cu-V $ $ J. Zhao, Y. Du, L.Zhang, H. Xu, Calphad, 32, 252-55(2008). $ $ Checked against paper. Checked at 6000 K. $ PAR L(LIQUID,CU,V;0),, +37900;,, N 08Zha1 ! PAR L(LIQUID,CU,V;1),, +18500;,, N 08Zha1 ! $ PAR L(FCC_A1,CU,V:VA;0),, +53650;,, N 08Zha1 ! PAR L(A1_FCC,CU,V:VA;0),, +53650;,, N 08Zha1 ! $ PAR L(BCC_A2,CU,V:VA;0),, +42377.8;,, N 08Zha1 ! PAR L(A2_BCC,CU,V:VA;0),, +42377.8;,, N 08Zha1 ! $ $ metastable $ PAR L(HCP_A3,CU,V:VA;0),, +53650;,, N Same ! PAR L(CBCC_A12,CU,V:VA;0),, +53650;,, N Same ! PAR L(CUB_A13,CU,V:VA;0),, +53650;,, N Same ! $ ------------------------------------------------------------------------------ $ Fe-C $ $ From P. Gustafson 1985 (included in LB Vol. 3) $ $ P. Gustafson, Scand. J. Metall., 14, 259-67(1985). $ $ Checked against paper and LB. All numbers are exactly reproduced, except $ for a rounding error in the paper of the temperature of the FCC + LIQ + CEM $ equilibrium (1421 K in the paper, 1421.51 K calculated). $ $ Cementite changed to 10Hal. $ The eutectoid (bcc+fcc+cem) temperature changed from 999.78 to 999.68 K. $ The eutectic (fcc+liq+cem) temperature changed from 1421.51 to 1421.31 K. $ The congruent melting point of cementite changed from 1497.8 to 1497.1 K. $ $ BCC_A2 is stable above 4000 K around x(C)=0.33. $ There is an inverse miscibility gap in the liquid with a minimum at $ 5559 K and x(C)=0.53. $ $ According to ab initio calculations by Joerg van Appen from 2008 is the $ energy of NM and AFM FeC (fcc) nearly the same. The AFM state has a BM of $ 0.9 per metal atom. $ $ The value of TC(FCC_A1,FE:C,VA) was adjusted to match the measured influence $ of C on the Neel temperature in the Fe-Mn-C system. It could even be $ increased further to possibly 6000 or 7000. $ PAR L(LIQUID,C,FE;0),, -124320+28.5*T;,, N 85Gus ! PAR L(LIQUID,C,FE;1),, +19300;,, N 85Gus ! PAR L(LIQUID,C,FE;2),, +49260-19*T;,, N 85Gus ! $ PAR G(BCC_A2,FE:C),, +GHSERFE+3*GHSERCC +322050+75.667*T;,, N 85Gus ! PAR TC(BCC_A2,FE:C),, 1043.00;,, N 85Gus ! PAR BMAG(BCC_A2,FE:C),, 2.22;,, N 85Gus ! PAR L(BCC_A2,FE:C,VA;0),, -190*T;,, N 85Gus ! $ PAR G(A2_BCC,FE:C),, +GHSERFE+3*GHSERCC +322050+75.667*T;,, N 85Gus ! PAR TC(A2_BCC,FE:C),, 1043.00;,, N 85Gus ! PAR BMAG(A2_BCC,FE:C),, 2.22;,, N 85Gus ! PAR L(A2_BCC,FE:C,VA;0),, -190*T;,, N 85Gus ! $ PAR G(FCC_A1,FE:C),, +GFCCFE+GHSERCC +77207-15.877*T;,, N 85Gus ! $PAR TC(FCC_A1,FE:C),, -201.00;,, N 85Gus ! $PAR BMAG(FCC_A1,FE:C),, -2.10;,, N 85Gus ! PAR L(FCC_A1,FE:C,VA;0),, -34671;,, N 85Gus ! PAR TC(FCC_A1,FE:C,VA),, +5000;,, N 12Hal ! $ PAR G(A1_FCC,FE:C),, +GFCCFE+GHSERCC +77207-15.877*T;,, N 85Gus ! $PAR TC(A1_FCC,FE:C),, -201.00;,, N 85Gus ! $PAR BMAG(A1_FCC,FE:C),, -2.10;,, N 85Gus ! PAR L(A1_FCC,FE:C,VA;0),, -34671;,, N 85Gus ! PAR TC(A1_FCC,FE:C,VA),, +5000;,, N 12Hal ! $ PAR G(CEMENTITE_D011,FE:C) 0.01 +GFECEM;,, N 10Hal ! PAR TC(CEMENTITE_D011,FE:C) 0.01 485.00;,, N 10Hal ! PAR BMAG(CEMENTITE_D011,FE:C) 0.01 1.008;,, N 10Hal ! $ $ metastable $ PAR G(HCP_A3,FE:C),, +GFCCFE+0.5*GHSERCC +52905-11.9075*T;,, N 88And2 ! PAR L(HCP_A3,FE:C,VA;0),, -17335;,, N 88And2 ! $PAR L(HCP_A3,FE:C,VA;0),, -22126;,, N 93Du ! $ PAR G(CBCC_A12,FE:C),, +GHSERFE+GHSERCC+80000;,, N 90Hua2 ! PAR L(CBCC_A12,FE:C,VA;0),, -34671;,, N 90Hua2 ! $ PAR G(CUB_A13,FE:C),, +GHSERFE+GHSERCC+90000;,, N 90Hua2 ! PAR L(CUB_A13,FE:C,VA;0),, -34671;,, N 90Hua2 ! $ PAR G(M7C3_D101,FE:C),, +2.333333*GFECEM +0.666667*GHSERCC+13200;,, N 11Dju ! PAR G(M23C6_D84,FE:FE:C),, +GFE23C6;,, N 11Dju ! PAR G(M5C2,FE:C),, +1.666667*GFECEM +0.333333*GHSERCC+6200;,, N 11Dju ! PAR G(FE4N_L1,FE:C),, +4*GHSERFE+GHSERCC+15965;,, N 93Du ! PAR G(FECN_CHI,FE:C),, -11287.4+1013.78*T -176.412*T*LN(T)+810869*T**(-1);,, N 93Du ! PAR G(KSI_CARBIDE,FE:C),, +3*GHSERFE+GHSERCC +14540+20*T;,, N 88And2 ! PAR G(V3C2,FE:C),, +7250+741.566*T -125.833*T*LN(T)+779485*T**(-1);,, N 91Hua4 ! $ FUNCTION GFECEM 0.01 +11369.937746-5.641259263*T-8.333E-6*T**4; 43.00 Y +11622.647246-59.537709263*T+15.74232*T*LN(T) -0.27565*T**2; 163.00 Y -10195.860754+690.949887637*T-118.47637*T*LN(T) -0.0007*T**2+590527*T**(-1); 6000.00 N ! FUNCTION GFE23C6 298.15 +7.666667*GFECEM-1.666667*GHSERCC+15000; 6000 N ! $ ------------------------------------------------------------------------------ $ Fe-Mg $ $ From J. Tibballs 1998 (included in LB Vol. 3) $ $ J. Tibballs, COST 507, Final report round 2, 1998. $ $ Checked against LB and COST. Checked at 6000 K. $ PAR L(LIQUID,FE,MG;0),, +61343+1.5*T;,, N 98Tib ! PAR L(LIQUID,FE,MG;1),, -2700;,, N 98Tib ! $ PAR L(FCC_A1,FE,MG:VA;0),, +65200;,, N 98Tib ! PAR L(A1_FCC,FE,MG:VA;0),, +65200;,, N 98Tib ! PAR L(BCC_A2,FE,MG:VA;0),, +65700;,, N 98Tib ! PAR L(A2_BCC,FE,MG:VA;0),, +65700;,, N 98Tib ! PAR L(HCP_A3,FE,MG:VA;0),, +92400;,, N 98Tib ! $ $ metastable $ PAR L(CBCC_A12,FE,MG:VA;0),, +70000;,, N Same ! PAR L(CUB_A13,FE,MG:VA;0),, +70000;,, N Same ! $ ------------------------------------------------------------------------------ $ Fe-Mn $ $ From W. Huang 1989 (included in LB Vol. 3) $ $ W. Huang, Calphad, 13, 243-52(1989). $ $ Checked against LB and paper. Checked at 6000 K. $ $ HCP_A3 interaction slightly modified by 11Dju. $ $ The Neel temperature (fcc) is well described, but there is an uncertainty $ concerning the magnetic moments. A value BMAG(CC_A1,FE,MN:VA;0)=1 seems to $ fit M_s data best. $ $ Fcc ordering energies (approximately) from Alexey Dick 2008. $ PAR L(LIQUID,FE,MN;0),, -3950+0.489*T;,, N 89Hua2 ! PAR L(LIQUID,FE,MN;1),, +1145;,, N 89Hua2 ! $ PAR L(FCC_A1,FE,MN:VA;0),, -7762+3.865*T;,, N 89Hua2 ! PAR L(FCC_A1,FE,MN:VA;1),, -259;,, N 89Hua2 ! PAR TC(FCC_A1,FE,MN:VA;0),, -2282;,, N 89Hua2 ! PAR TC(FCC_A1,FE,MN:VA;1),, -2068;,, N 89Hua2 ! $ New value below (old value was zero) PAR BMAG(FCC_A1,FE,MN:VA;0),, +1;,, N 12Hal ! $ PAR L(A1_FCC,FE,MN:VA;0),, -7762+3.865*T;,, N 89Hua2 ! PAR L(A1_FCC,FE,MN:VA;1),, -259;,, N 89Hua2 ! PAR TC(A1_FCC,FE,MN:VA;0),, -2282;,, N 89Hua2 ! PAR TC(A1_FCC,FE,MN:VA;1),, -2068;,, N 89Hua2 ! PAR BMAG(A1_FCC,FE,MN:VA;0),, +1;,, N 12Hal ! $ PAR G(FCC_4SL,FE:FE:FE:MN:VA),, +GFFE3MN;,, N 08Hal3 ! PAR G(FCC_4SL,FE:FE:MN:MN:VA),, +GFFE2MN2;,, N 08Hal3 ! PAR G(FCC_4SL,FE:MN:MN:MN:VA),, +GFFEMN3;,, N 08Hal3 ! PAR L(FCC_4SL,FE,MN:FE,MN:*:*:VA;0),, +SFFEMN;,, N 08Hal3 ! $ PAR L(BCC_A2,FE,MN:VA;0),, -2759+1.237*T;,, N 89Hua2 ! PAR TC(BCC_A2,FE,MN:VA;0),, +123;,, N 89Hua2 ! $ PAR L(A2_BCC,FE,MN:VA;0),, -2759+1.237*T;,, N 89Hua2 ! PAR TC(A2_BCC,FE,MN:VA;0),, +123;,, N 89Hua2 ! $ PAR L(HCP_A3,FE,MN:VA;0),, -5748+3.865*T;,, N 11Dju ! PAR L(HCP_A3,FE,MN:VA;1),, +273;,, N 11Dju ! $PAR L(HCP_A3,FE,MN:VA;0),, -5582+3.865*T;,, N 89Hua2 ! $PAR L(HCP_A3,FE,MN:VA;1),, +273;,, N 89Hua2 ! $ PAR L(CBCC_A12,FE,MN:VA;0),, -10184;,, N 89Hua2 ! PAR L(CUB_A13,FE,MN:VA;0),, -11518+2.819*T;,, N 89Hua2 ! $ $ Metastable $ PAR G(C14_LAVES,FE:MN),, +2*GHSERFE+GHSERMN+36320;,, N 12Liu ! PAR G(C14_LAVES,MN:FE),, +2*GHSERMN+GHSERFE+28510;,, N 12Liu ! $ FUNCTION U1FFEMN 298.15 -700; 6000 N ! FUNCTION GFFE3MN 298.15 +3*U1FFEMN-90; 6000 N ! FUNCTION GFFE2MN2 298.15 +4*U1FFEMN; 6000 N ! FUNCTION GFFEMN3 298.15 +3*U1FFEMN+90; 6000 N ! FUNCTION SFFEMN 298.15 +U1FFEMN; 6000 N ! $ ------------------------------------------------------------------------------ $ Fe-Mo $ $ From J.-O. Andersson 1988 (included in LB Vol. 3) $ $ J.-O. Andersson, Calphad, 12, 9-23(1988). $ Completely revised from the original Fernandez Guillermet 1982 version. $ $ Checked against LB (SIGMA_D8B) and paper (SIGMA_OLD). Checked at 6000 K. $ $ There are small differences (up to 2K) for the invariant temperatures $ compared to the paper. $ $ In LB FE2MO_C14 is described as a stoichiometric compound. The upper $ stability limit of FE2MO_C14 is 4K lower in LB. $ $ The SIGMA_OLD and SIGMA_D8B phase fields are rather similar. They have $ somewhat different solubility limits, in particular on the Mo-rich side. $ $ There are two models for Fe2Mo included. FE2MO_C14 is the original from 88And. $ C14_LAVES includes new end-member values and refitted interactions. $ The max temperature for C14_LAVES is 1192 K instead of 1177 K previously, $ which is closer to 82Gui where it is 1200 K. $ $ The change of model for MU_D85 results in a somewhat wider phase field $ with preserved invariant temperatures. $ $ Mo was added on the first sublattice of SIGMA_D8B. This was necessary in $ order to use the 10:4:16 model in the Cr-Fe-Mo system. Otherwise the $ experimentally determined Mo content in sigma cannot be reached. The previous $ SIGMA_D8B phase field is closely reproduced and invariant temperatures $ differ by less than 2-3 K. $ PAR L(LIQUID,FE,MO;0),, -6973-0.37*T;,, N 88And2 ! PAR L(LIQUID,FE,MO;1),, -9424+4.502*T;,, N 88And2 ! $ PAR L(FCC_A1,FE,MO:VA;0),, +28347-17.691*T;,, N 88And2 ! PAR L(A1_FCC,FE,MO:VA;0),, +28347-17.691*T;,, N 88And2 ! $ PAR L(BCC_A2,FE,MO:VA;0),, +36818-9.141*T;,, N 88And2 ! PAR L(BCC_A2,FE,MO:VA;1),, -362-5.724*T;,, N 88And2 ! PAR TC(BCC_A2,FE,MO:VA;0),, +335;,, N 82Fer ! PAR TC(BCC_A2,FE,MO:VA;1),, +526;,, N 82Fer ! $ PAR L(A2_BCC,FE,MO:VA;0),, +36818-9.141*T;,, N 88And2 ! PAR L(A2_BCC,FE,MO:VA;1),, -362-5.724*T;,, N 88And2 ! PAR TC(A2_BCC,FE,MO:VA;0),, +335;,, N 82Fer ! PAR TC(A2_BCC,FE,MO:VA;1),, +526;,, N 82Fer ! $ PAR G(C14_LAVES,FE:MO),, +2*GFCCFE+GHSERMO -10798-0.132*T;,, N 88And2 ! PAR G(C14_LAVES,MO:FE),, +2*GHSERMO+3*GHSERFE-2*GFCCFE +153330+10798+0.132*T;,, N ! $ PAR G(MU_D85,FE:MO:FE:FE),, +7*GFCCFE+4*GHSERMO+2*GHSERFE -14320-18.9*T;,, N 17Hal4 ! PAR G(MU_D85,FE:MO:FE:MO),, +3*GHSERFE+10*GHSERMO +445950;,, N 14Raj ! PAR G(MU_D85,FE:MO:MO:FE),, +7*GFCCFE+6*GHSERMO -46663-5.891*T;,, N 88And2 ! PAR G(MU_D85,FE:MO:MO:MO),, +GHSERFE+12*GHSERMO +340960;,, N 14Raj ! PAR L(MU_D85,FE:MO:FE,MO:FE;0),, +17780;,, N 17Hal4 ! $ PAR G(R_PHASE,FE:MO:FE),, +27*GFCCFE+14*GHSERMO +12*GHSERFE-77487-50.486*T;,, N 88And2 ! PAR G(R_PHASE,FE:MO:MO),, +27*GFCCFE+26*GHSERMO +313474-289.472*T;,, N 88And2 ! $ PAR G(SIGMA_D8B,FE:MO:FE),, +10*GFCCFE+16*GHSERFE +4*GHSERMO+65550-62.2*T;,, N 17Hal6 ! PAR G(SIGMA_D8B,FE:MO:MO),, +10*GFCCFE+20*GHSERMO +40000-62.2*T;,, N 17Hal6 ! PAR G(SIGMA_D8B,MO:MO:FE),, +10*GFCCMO+16*GHSERFE +4*GHSERMO+150000;,, N 17Hal6 ! PAR L(SIGMA_D8B,FE:MO:FE,MO;0),, +220253;,, N 00Wes ! $ $ metastable $ PAR L(HCP_A3,FE,MO:VA;0),, +28347-17.691*T;,, N 88And2 ! $ PAR G(CHI_A12,FE:MO:FE),, +48*GFCCFE+10*GHSERMO +305210-270*T;,, N 88And4 ! $ Parameter below in TCFE-99 $PAR G(CHI_A12,FE:MO:FE),, +48*GFCCFE+10*GHSERMO $ +156437-169*T;,, N 95Lee ! PAR G(CHI_A12,FE:MO:MO),, +24*GFCCFE+10*GHSERMO +24*GFCCMO+97300-100*T;,, N 88And4 ! $ PAR G(MONI,FE:FE:MO),, +6*GFCCFE+5*GHSERFE +3*GHSERMO+25000;,, N 92Fri1 ! PAR G(MONI,FE:MO:MO),, +6*GFCCFE+8*GHSERMO+25000;,, N 92Fri1 ! $ PAR G(P_PHASE,FE:FE:MO),, +24*GFCCFE+20*GHSERFE +12*GHSERMO+111361;,, N 92Fri1 ! PAR G(P_PHASE,FE:MO:MO),, +24*GFCCFE+32*GHSERMO +362525-332.7*T;,, N 92Fri1 ! $ ------------------------------------------------------------------------------ $ Fe-N $ $ H. Du, J. Phase Equilib., 14, 682-93(1993). $ $ Checked against paper. Checked at 6000 K. $ $ FE4N_L1 modified to avoid Fe4N to become stable in e.g. Cr-Fe. The Fe4N $ phase field is slightly changed and the fcc+hcp+Fe4N equilibrium decreases $ from 923 to 920 K. $ $ The FeN (FCC_A1) phase still seems somewhat too stable at low temperature. $ PAR L(LIQUID,FE,N;0),, -19930-12.01*T;,, N 91Fri1 ! $ PAR G(FCC_A1,FE:N),, +GHSERFE+GHSERNN -20277+245.3931*T-21.2984*T*LN(T);,, N 93Du ! PAR L(FCC_A1,FE:N,VA;0),, -26150;,, N 91Fri1 ! $ PAR G(A1_FCC,FE:N),, +GHSERFE+GHSERNN -20277+245.3931*T-21.2984*T*LN(T);,, N 93Du ! PAR L(A1_FCC,FE:N,VA;0),, -26150;,, N 91Fri1 ! $ PAR G(BCC_A2,FE:N),, +GHSERFE+3*GHSERNN +93562+165.07*T;,, N 91Fri1 ! PAR TC(BCC_A2,FE:N),, 1043;,, N 91Fri1 ! PAR BMAG(BCC_A2,FE:N),, 2.22;,, N 91Fri1 ! $ PAR G(A2_BCC,FE:N),, +GHSERFE+3*GHSERNN +93562+165.07*T;,, N 91Fri1 ! PAR TC(A2_BCC,FE:N),, 1043;,, N 91Fri1 ! PAR BMAG(A2_BCC,FE:N),, 2.22;,, N 91Fri1 ! $ PAR G(HCP_A3,FE:N),, +GHSERFE+0.5*GHSERNN -13863+40.2123*T;,, N 93Du ! PAR L(HCP_A3,FE:N,VA;0),, +10012-19.9853*T;,, N 93Du ! PAR L(HCP_A3,FE:N,VA;1),, -9446+9.3472*T;,, N 93Du ! $ PAR G(FE4N_L1,FE:N),, +4*GHSERFE+GHSERNN -37514+72.6235*T;,, N 93Du ! $PAR L(FE4N_L1,FE:N,VA;0),, +64679-21.9574*T;,, N 93Du ! PAR L(FE4N_L1,FE:N,VA;0),, +44679-21.9574*T;,, N 17Hal12 ! PAR L(FE4N_L1,FE:N,VA;1),, -27905-3.409*T;,, N 93Du ! $ $ metastable $ PAR G(CBCC_A12,FE:N),, +GHSERFE+GHSERNN -30766+375.42*T-37.6*T*LN(T);,, N 93Qiu2 ! PAR L(CBCC_A12,FE:N,VA;0),, -26150;,, N 93Qiu2 ! $ PAR G(CUB_A13,FE:N),, +GHSERFE+GHSERNN -32216+375.42*T-37.6*T*LN(T);,, N 93Qiu2 ! PAR L(CUB_A13,FE:N,VA;0),, -26150;,, N 93Qiu2 ! $ PAR G(CEMENTITE_D011,FE:N),, -20060+538.7902*T -99.7371*T*LN(T)+226735*T**(-1);,, N 93Du ! PAR G(FECN_CHI,FE:N),, -55838+952.0774*T -174.5248*T*LN(T)+438672*T**(-1);,, N 93Du ! $ ------------------------------------------------------------------------------ $ Fe-Nb $ $ A. Jacob, C. Schmetterer, A. Khvan, A. Kondratiev, D. Ivanov, B. Hallstedt, $ Calphad, 54, 1-15(2016). $ $ Checked against paper. Checked at 6000 K. $ $ Modified from the description by A.V. Khvan and B. Hallstedt 2013. $ It was necessary to reduce the stability of the mu phase to model Cr-Fe-Nb. $ $ B2 ordering added to have a reasonable extension of FeTi-B2 in Fe-Nb-Ti. $ PAR L(LIQUID,FE,NB;0),, -74257+99.67*T-10*T*LN(T);,, N 13Khv1 ! PAR L(LIQUID,FE,NB;1),, +17624-10.805*T;,, N 13Khv1 ! $ PAR L(FCC_A1,FE,NB:VA;0),, -6176-2.04*T;,, N 13Khv1 ! PAR L(A1_FCC,FE,NB:VA;0),, -6176-2.04*T;,, N 13Khv1 ! $ PAR L(BCC_A2,FE,NB:VA;0),, -10893+10.288*T;,, N 13Khv1 ! PAR L(BCC_A2,FE,NB:VA;1),, +4674-5.776*T;,, N 13Khv1 ! $ PAR L(A2_BCC,FE,NB:VA;0),, -10893+10.288*T;,, N 13Khv1 ! PAR L(A2_BCC,FE,NB:VA;1),, +4674-5.776*T;,, N 13Khv1 ! $ PAR G(B2_BCC,FE:NB:VA),, -10000;,, N 17Hal17 ! PAR G(B2_BCC,NB:FE:VA),, -10000;,, N 17Hal17 ! $ PAR G(C14_LAVES,FE:NB),, +2*GHSERFE+GHSERNB -67223+13.971*T;,, N 13Khv1 ! PAR G(C14_LAVES,NB:FE),, +2*GHSERNB+GHSERFE+180030;,, N 12Liu ! PAR L(C14_LAVES,FE,NB:FE;0),, +ZERO;,, N 12Liu ! PAR L(C14_LAVES,FE,NB:NB;0),, +ZERO;,, N 12Liu ! PAR L(C14_LAVES,FE:FE,NB;0),, -33816;,, N 13Khv1 ! PAR L(C14_LAVES,NB:FE,NB;0),, -33816;,, N 13Khv1 ! $ PAR G(MU_D85,FE:NB:FE:FE),, +9*GHSERFE+4*GHSERNB -100230;,, N 12Liu ! PAR G(MU_D85,FE:NB:FE:NB),, +3*GHSERFE+10*GHSERNB +426530;,, N 12Liu ! PAR G(MU_D85,FE:NB:NB:FE),, +7*GHSERFE+6*GHSERNB -266116+56*T;,, N 16Jac1 ! PAR G(MU_D85,FE:NB:NB:NB),, +GHSERFE+12*GHSERNB+176020;,, N 12Liu ! PAR G(MU_D85,NB:NB:FE:FE),, +8*GHSERFE+5*GHSERNB-27430;,, N 12Liu ! PAR G(MU_D85,NB:NB:FE:NB),, +2*GHSERFE+11*GHSERNB +499200;,, N 12Liu ! PAR G(MU_D85,NB:NB:NB:FE),, +6*GHSERFE+7*GHSERNB -131400;,, N 12Liu ! $ $ Metastable $ PAR L(HCP_A3,FE,NB:VA;0),, -6176-2.04*T;,, N Same ! $ PAR G(C15_LAVES,FE:NB),, +2*GHSERFE+GHSERNB -50000+13.971*T;,, N 16Jac1 ! PAR G(C15_LAVES,NB:FE),, +2*GHSERNB+GHSERFE+178263;,, N 16Jac1 ! PAR L(C15_LAVES,FE,NB:FE;0),, +ZERO;,, N 16Jac1 ! PAR L(C15_LAVES,FE,NB:NB;0),, +ZERO;,, N 16Jac1 ! PAR L(C15_LAVES,FE:FE,NB;0),, -33816;,, N 16Jac1 ! PAR L(C15_LAVES,NB:FE,NB;0),, -33816;,, N 16Jac1 ! $ PAR G(SIGMA_D8B,FE:NB:FE),, +26*GHSERFE+4*GHSERNB +57084;,, N 13Khv2 ! PAR G(SIGMA_D8B,FE:NB:NB),, +10*GHSERFE+20*GHSERNB +497885;,, N 13Khv2 ! $ ------------------------------------------------------------------------------ $ Fe-Ni $ $ N. Dupin, B. Sundman, March 2003 at JEEP. $ $ Checked against LB. Checked at 6000 K. $ $ This dataset is modified from the LB dataset by changing the ordering $ parameter to have a much weaker temperature dependence. A strongly positive $ ordering contribution causes ordering at high temperature (in this case) $ in the Cr-Fe-Ni and Fe-Mn-Ni systems. Compared to the LB dataset the critical $ temperature for ordering (FeNi3) is the same, but the FeNi3 phase field $ becomes wider at lower temperature and the bcc+fcc+FeNi3 equilibrium $ temperature decreases. $ $ There are several different descriptions of the fcc ordering floating around. $ All are referred to I. Ansara. This one is taken from LBall-v7+fun.tdb and $ cited there as I. Ansara 1995. However, the description in FeNi-95Ans-CK.tdb $ is different. Therefore I assume that the complete present description $ (and not just the SRO contribution) is from N. Dupin 2003. $ $ Bcc ordering added by B. Sundman 2003 $ Liquid changed by B.-J. Lee 1993 $ U1FFENI changed by B. Hallstedt 2016 $ $ I have not seen the original 85Xin report, but it is consistently cited $ by both AFG and B.-J. Lee, so I believe it is correctly cited. $ $ The diagram in LB is calculated using the original 85Xin parameters for $ the liquid. $ $PAR L(LIQUID,FE,NI;0),, -18378.86+6.03912*T;,, N 85Xin ! $PAR L(LIQUID,FE,NI;1),, +9228.1-3.54642*T;,, N 85Xin ! PAR L(LIQUID,FE,NI;0),, -16911+5.1622*T;,, N 93Lee1 ! PAR L(LIQUID,FE,NI;1),, +10180-4.146656*T;,, N 93Lee1 ! $ PAR L(FCC_A1,FE,NI:VA;0),, -12054.355+3.27413*T;,, N 85Xin ! PAR L(FCC_A1,FE,NI:VA;1),, +11082.1315-4.45077*T;,, N 85Xin ! PAR L(FCC_A1,FE,NI:VA;2),, -725.805174;,, N 85Xin ! PAR TC(FCC_A1,FE,NI:VA;0),, +2133;,, N 85Xin ! PAR TC(FCC_A1,FE,NI:VA;1),, -682;,, N 85Xin ! PAR BMAG(FCC_A1,FE,NI:VA;0),, +9.55;,, N 85Xin ! PAR BMAG(FCC_A1,FE,NI:VA;1),, +7.23;,, N 85Xin ! PAR BMAG(FCC_A1,FE,NI:VA;2),, +5.93;,, N 85Xin ! PAR BMAG(FCC_A1,FE,NI:VA;3),, +6.18;,, N 85Xin ! $ PAR L(A1_FCC,FE,NI:VA;0),, -12054.355+3.27413*T;,, N 85Xin ! PAR L(A1_FCC,FE,NI:VA;1),, +11082.1315-4.45077*T;,, N 85Xin ! PAR L(A1_FCC,FE,NI:VA;2),, -725.805174;,, N 85Xin ! PAR TC(A1_FCC,FE,NI:VA;0),, +2133;,, N 85Xin ! PAR TC(A1_FCC,FE,NI:VA;1),, -682;,, N 85Xin ! PAR BMAG(A1_FCC,FE,NI:VA;0),, +9.55;,, N 85Xin ! PAR BMAG(A1_FCC,FE,NI:VA;1),, +7.23;,, N 85Xin ! PAR BMAG(A1_FCC,FE,NI:VA;2),, +5.93;,, N 85Xin ! PAR BMAG(A1_FCC,FE,NI:VA;3),, +6.18;,, N 85Xin ! $ PAR G(FCC_4SL,FE:FE:FE:NI:VA),, +GFFE3NI;,, N 16Hal5 ! PAR G(FCC_4SL,FE:FE:NI:NI:VA),, +GFFE2NI2;,, N 16Hal5 ! PAR G(FCC_4SL,FE:NI:NI:NI:VA),, +GFFENI3;,, N 16Hal5 ! PAR L(FCC_4SL,FE,NI:*:*:*:VA;0),, +U3FFENI;,, N 03Dup ! PAR L(FCC_4SL,FE,NI:FE,NI:*:*:VA;0),, +SFFENI;,, N 16Hal5 ! $ PAR L(BCC_A2,FE,NI:VA;0),, -956.63-1.28726*T;,, N 85Xin ! PAR L(BCC_A2,FE,NI:VA;1),, +1789.03-1.92912*T;,, N 85Xin ! $ PAR L(A2_BCC,FE,NI:VA;0),, -956.63-1.28726*T;,, N 85Xin ! PAR L(A2_BCC,FE,NI:VA;1),, +1789.03-1.92912*T;,, N 85Xin ! $ PAR G(B2_BCC,FE:NI:VA),, -2000;,, N 07Zha ! PAR G(B2_BCC,NI:FE:VA),, -2000;,, N 07Zha ! $ $ metastable $ PAR L(HCP_A3,FE,NI:VA;0),, -12054.355+3.27413*T;,, N 85Xin ! PAR L(HCP_A3,FE,NI:VA;1),, +11082-4.45077*T;,, N 85Xin ! PAR L(HCP_A3,FE,NI:VA;2),, -725.8;,, N 85Xin ! $ PAR L(CBCC_A12,FE,NI:VA;0),, +ZERO;,, N 09Zha ! PAR L(CUB_A13,FE,NI:VA;0),, -7000;,, N 09Zha ! $ PAR G(C14_LAVES,FE:NI),, +2*GHSERFE+GHSERNI+48320;,, N 17Hal8 ! PAR G(C14_LAVES,NI:FE),, +2*GHSERNI+GHSERFE+52510;,, N 17Hal8 ! $ $ Function below from 03Dup $FUNCTION U1FFENI 298.15 -7500+13.7*T; 6000 N ! $ Half T dependence (below) is not sufficient. $FUNCTION U1FFENI 298.15 -1906+6.5*T; 6000 N ! FUNCTION U1FFENI 298.15 +814+3*T; 6000 N ! FUNCTION SFFENI 298.15 +U1FFENI; 6000 N ! FUNCTION U3FFENI 298.15 +1200; 6000 N ! FUNCTION GFFENI3 298.15 +3*U1FFENI-6315; 6000 N ! FUNCTION GFFE3NI 298.15 +3*U1FFENI+6000; 6000 N ! FUNCTION GFFE2NI2 298.15 +4*U1FFENI; 6000 N ! $ ------------------------------------------------------------------------------ $ Fe-Si $ $ From J. Lacaze and B. Sundman 1991 (included in LB Vol. 3) $ $ J. Lacaze, B. Sundman, Metall. Mater. Trans. A, 22A, 2211-23(1991). $ $ Checked against LB and paper. Checked at 6000 K. $ $ tcfe99 has a different liquid interaction (from Miettinen 1998) $ 91Lac: Inverse miscibility gap with min at 2170K, x(Si)=0.87 $ 98Mie: Inverse miscibility gap with min at 2740K, x(Si)=0.76 $ $ The modification of the liquid changes invariant temperatures less than 1 K. $ PAR L(LIQUID,FE,SI;0),, -164435+41.977*T;,, N 91Lac ! PAR L(LIQUID,FE,SI;1),, -21.523*T;,, N 91Lac ! $PAR L(LIQUID,FE,SI;2),, -18821+22.07*T;,, N 91Lac ! $PAR L(LIQUID,FE,SI;3),, +9696;,, N 91Lac ! PAR L(LIQUID,FE,SI;2),, +5220+5.726*T;,, N 98Mie ! PAR L(LIQUID,FE,SI;3),, -28955+26.275*T;,, N 98Mie ! $ PAR L(FCC_A1,FE,SI:VA;0),, -125248+41.116*T;,, N 91Lac ! PAR L(FCC_A1,FE,SI:VA;1),, -142708;,, N 91Lac ! PAR L(FCC_A1,FE,SI:VA;2),, +89907;,, N 91Lac ! $ PAR L(A1_FCC,FE,SI:VA;0),, -125248+41.116*T;,, N 91Lac ! PAR L(A1_FCC,FE,SI:VA;1),, -142708;,, N 91Lac ! PAR L(A1_FCC,FE,SI:VA;2),, +89907;,, N 91Lac ! $ PAR L(BCC_A2,FE,SI:VA;0),, +4*L0BCC-4*FESIW1;,, N 91Lac ! PAR L(BCC_A2,FE,SI:VA;1),, +8*L1BCC;,, N 91Lac ! PAR L(BCC_A2,FE,SI:VA;2),, +16*L2BCC;,, N 91Lac ! PAR TC(BCC_A2,FE,SI:VA;1),, +8*ETCFESI;,, N 91Lac ! $ PAR L(A2_BCC,FE,SI:VA;0),, +4*L0BCC-4*FESIW1;,, N 91Lac ! PAR L(A2_BCC,FE,SI:VA;1),, +8*L1BCC;,, N 91Lac ! PAR L(A2_BCC,FE,SI:VA;2),, +16*L2BCC;,, N 91Lac ! PAR TC(A2_BCC,FE,SI:VA;1),, +8*ETCFESI;,, N 91Lac ! $ PAR G(B2_BCC,SI:FE:VA),, -2*FESIW1;,, N 91Lac ! PAR G(B2_BCC,FE:SI:VA),, -2*FESIW1;,, N 91Lac ! $ PAR G(FE2SI,FE:SI),, +2*GHSERFE+GHSERSI -71256-10.62*T;,, N 91Lac ! PAR G(FESI2_H,FE:SI),, +0.3*GHSERFE+0.7*GHSERSI -19649-0.92*T;,, N 91Lac ! PAR G(FESI2_L,FE:SI),, +GHSERFE+2*GHSERSI -82149+10.44*T;,, N 91Lac ! PAR G(MSI_B20,FE:SI),, +GHSERFE+GHSERSI -72762+4.44*T;,, N 91Lac ! PAR G(M5SI3_D88,FE:SI:VA),, +5*GHSERFE+3*GHSERSI -241144+2.16*T;,, N 91Lac ! $ $ Metastable $ PAR L(HCP_A3,FE,SI:VA;0),, -123468+41.116*T;,, N 93For ! PAR L(HCP_A3,FE,SI:VA;1),, -142708;,, N 93For ! PAR L(HCP_A3,FE,SI:VA;2),, +89907;,, N 93For ! $ PAR L(CBCC_A12,FE,SI:VA;0),, -153141+46.48*T;,, N 93For ! PAR L(CBCC_A12,FE,SI:VA;1),, -92352;,, N 93For ! PAR L(CBCC_A12,FE,SI:VA;2),, +62240;,, N 93For ! $ PAR L(CUB_A13,FE,SI:VA;0),, -153141+46.48*T;,, N 93For ! PAR L(CUB_A13,FE,SI:VA;1),, -92352;,, N 93For ! PAR L(CUB_A13,FE,SI:VA;2),, +62240;,, N 93For ! $ PAR G(CR3SI_A15,FE:SI:VA),, +3*GHSERFE+GHSERSI -75000+8*T;,, N 97Lin ! $PAR G(CR5SI3_D8M,FE:SI),, +5*GHSERFE+3*GHSERSI $ -180000;,, N 97Lin ! PAR G(CR5SI3_D8M,FE:SI),, +5*GHSERFE+3*GHSERSI -140000;,, N 97Lin ! $ PAR G(MN3SI,FE:SI),, +3*GHSERFE+GHSERSI -94274-3.56*T;,, N 93For ! $ PAR G(C14_LAVES,FE:SI),, +2*GHSERFE+GHSERSI+25770;,, N 16Jac2 ! PAR G(C14_LAVES,SI:FE),, +2*GHSERSI+GHSERFE+80090;,, N 16Jac2 ! PAR L(C14_LAVES,FE,SI:FE;0),, -380000;,, N 16Jac2 ! $ FUNCTION FESIW1 298.15 +1260*R; 6000 N ! FUNCTION L0BCC 298.15 -27809+11.62*T; 6000 N ! FUNCTION L1BCC 298.15 -11544; 6000 N ! FUNCTION L2BCC 298.15 +3890; 6000 N ! FUNCTION ETCFESI 298.15 +63; 6000 N ! $ ------------------------------------------------------------------------------ $ Fe-Ti $ $ H. Bo, J. Wang, L. Duarte, C. Leinenbach, L. Liu, H. Liu, Z. Jin, $ Trans. Nonferrous Met. Soc. China, 22, 2204-11(2012). $ $ Checked against paper. Checked at 6000 K. $ $ The hcp phase is not sufficiently stable. $ $ There are two models for Fe2Ti included. FE2TI_C14 is the original from 12Bo. $ C14_LAVES includes new end-member values and refitted interactions. $ An incorrect value for G(C14_LAVES,TI:TI) was used in a previous version. $ When using the correct value from 06Slu it was not possible to refit the $ Mn-Ti phase diagram without using excessive interaction parameters. Therefore $ a value for G(C14_LAVES,TI:TI) was selected that produces moderate interaction $ parameters. $ The invariant temperatures are preserved, but the C14_LAVES phase shows lower $ Fe solubility. $ PAR L(LIQUID,FE,TI;0),, -74300+17.839*T;,, N 12Bo ! PAR L(LIQUID,FE,TI;1),, +8299.849-6.101*T;,, N 12Bo ! $ PAR L(FCC_A1,FE,TI:VA;0),, -52149.856+9.265*T;,, N 12Bo ! PAR L(FCC_A1,FE,TI:VA;1),, +4755.9-4.982*T;,, N 12Bo ! PAR L(FCC_A1,FE,TI:VA;2),, +29205.228-11.046*T;,, N 12Bo ! $ PAR L(A1_FCC,FE,TI:VA;0),, -52149.856+9.265*T;,, N 12Bo ! PAR L(A1_FCC,FE,TI:VA;1),, +4755.9-4.982*T;,, N 12Bo ! PAR L(A1_FCC,FE,TI:VA;2),, +29205.228-11.046*T;,, N 12Bo ! $ PAR L(BCC_A2,FE,TI:VA;0),, -69241.924+25.246*T +1E-04*T**2+120000*T**(-1);,, N 12Bo ! PAR L(BCC_A2,FE,TI:VA;1),, +5018.986-4.992*T;,, N 12Bo ! PAR L(BCC_A2,FE,TI:VA;2),, +23028.241-13.11*T;,, N 12Bo ! PAR TC(BCC_A2,FE,TI:VA;0),, -2000.00;,, N 12Bo ! $ PAR L(A2_BCC,FE,TI:VA;0),, -69241.924+25.246*T +1E-04*T**2+120000*T**(-1);,, N 12Bo ! PAR L(A2_BCC,FE,TI:VA;1),, +5018.986-4.992*T;,, N 12Bo ! PAR L(A2_BCC,FE,TI:VA;2),, +23028.241-13.11*T;,, N 12Bo ! PAR TC(A2_BCC,FE,TI:VA;0),, -2000.00;,, N 12Bo ! $ PAR G(B2_BCC,FE:TI:VA),, -30028.003+4.495*T;,, N 12Bo ! PAR G(B2_BCC,TI:FE:VA),, -30028.003+4.495*T;,, N 12Bo ! PAR L(B2_BCC,FE,TI:FE:VA;1),, -5001.5;,, N 12Bo ! PAR L(B2_BCC,FE:FE,TI:VA;1),, -5001.5;,, N 12Bo ! PAR L(B2_BCC,FE,TI:TI:VA;1),, +11000;,, N 12Bo ! PAR L(B2_BCC,TI:FE,TI:VA;1),, +11000;,, N 12Bo ! $ PAR L(HCP_A3,FE,TI:VA;0),, -25000+35.004*T;,, N 12Bo ! $ PAR G(C14_LAVES,FE:TI),, +GFE2TI;,, N 12Bo ! PAR G(C14_LAVES,TI:FE),, +3*GHSERFE+3*GHSERTI+89130 -GFE2TI;,, N 17Hal2 ! PAR L(C14_LAVES,FE,TI:FE;0),, -35000;,, N 17Hal2 ! PAR L(C14_LAVES,FE,TI:TI;0),, -35000;,, N 17Hal2 ! PAR L(C14_LAVES,FE:FE,TI;0),, -35000;,, N 17Hal2 ! PAR L(C14_LAVES,TI:FE,TI;0),, -35000;,, N 17Hal2 ! $ $ Metastable $ PAR G(MU_D85,FE:TI:FE:FE),, +7*GFCCFE+4*GBCCTI +2*GHSERFE;,, N Lin ! PAR G(MU_D85,FE:TI:TI:FE),, +7*GFCCFE+6*GBCCTI-200000;,, N 17Hal17 ! $ PAR G(SIGMA_D8B,FE:TI:FE),, +10*GFCCFE+4*GBCCTI +16*GHSERFE;,, N Lin ! PAR G(SIGMA_D8B,FE:TI:TI),, +10*GFCCFE+20*GBCCTI;,, N Lin ! $ FUNCTION GFE2TI 298.15 -85500+410.041*T-73.553*T*LN(T) -0.01017*T**2+124212.42*T**(-1); 6000.00 N ! $ ------------------------------------------------------------------------------ $ Fe-V $ $ From W. Huang 1991 (Included in LB Vol. 3) $ $ W. Huang, Z. Metallkd., 82, 391-401(1991). $ $ Checked against LB and paper. Checked at 6000K. $ $ W. Huang used the 8:4:18 model for the sigma phase (SIGMA_OLD). This was $ changed to 10:4:16 (SIGMA_D8B) for LB. The change of model shifts $ the maximum to higher V content. Max at x(V)=0.485 for SIGMA_OLD $ and x(V)=0.517 for SIGMA_D8B. $ PAR L(LIQUID,FE,V;0),, -34679+1.895*T;,, N 91Hua2 ! PAR L(LIQUID,FE,V;1),, +10209;,, N 91Hua2 ! $ PAR L(FCC_A1,FE,V:VA;0),, -15291-4.138*T;,, N 91Hua2 ! PAR L(A1_FCC,FE,V:VA;0),, -15291-4.138*T;,, N 91Hua2 ! $ PAR L(BCC_A2,FE,V:VA;0),, -23674+0.465*T;,, N 91Hua2 ! PAR L(BCC_A2,FE,V:VA;1),, +8283;,, N 91Hua2 ! PAR TC(BCC_A2,FE,V:VA;0),, -110;,, N 83And ! PAR TC(BCC_A2,FE,V:VA;1),, +3075;,, N 83And ! PAR TC(BCC_A2,FE,V:VA;2),, +808;,, N 83And ! PAR TC(BCC_A2,FE,V:VA;3),, -2169;,, N 83And ! PAR BMAG(BCC_A2,FE,V:VA;0),, -2.26;,, N 83And ! $ PAR L(A2_BCC,FE,V:VA;0),, -23674+0.465*T;,, N 91Hua2 ! PAR L(A2_BCC,FE,V:VA;1),, +8283;,, N 91Hua2 ! PAR TC(A2_BCC,FE,V:VA;0),, -110;,, N 83And ! PAR TC(A2_BCC,FE,V:VA;1),, +3075;,, N 83And ! PAR TC(A2_BCC,FE,V:VA;2),, +808;,, N 83And ! PAR TC(A2_BCC,FE,V:VA;3),, -2169;,, N 83And ! PAR BMAG(A2_BCC,FE,V:VA;0),, -2.26;,, N 83And ! $ PAR G(SIGMA_D8B,FE:V:FE),, +10*GFCCFE+4*GHSERVV +16*GHSERFE-174619+78.27*T;,, N 00Wes ! PAR G(SIGMA_D8B,FE:V:V),, +10*GFCCFE+20*GHSERVV -249118-68.64*T;,, N 00Wes ! PAR G(SIGMA_D8B,V:V:FE),, +14*GHSERVV+16*GHSERFE +100000;,, N 02Sun ! PAR L(SIGMA_D8B,FE:V:FE,V;0),, -200000;,, N 02Sun ! $ $ Metastable $ PAR L(HCP_A3,FE,V:VA;0),, -15291-4.138*T;,, N 91Hua2 ! $ PAR L(CBCC_A12,FE,V:VA;0),, -10000;,, N 91Hua3 ! PAR L(CUB_A13,FE,V:VA;0),, -10000;,, N 91Hua3 ! $ PAR G(C14_LAVES,FE:V),, +2*GHSERFE+GHSERVV+75611;,, N 13Khv2 ! PAR G(C14_LAVES,V:FE),, +2*GHSERVV+GHSERFE+124858;,, N 13Khv2 ! $ ------------------------------------------------------------------------------ $ Mg-C $ $ From B. Hallstedt 2006 $ $ This is a very preliminary description based on the limited information $ from A.A. Nayeb-Hashemi and J.B. Clark in ASM Handbook of binary phase $ diagrams 1996. Gas phase and carbides are taken from SGSUB 1997. $ $ G(HCP_A3,MG:C) set to give approximately the same C solubility in hcp as $ in the liquid, which is treated as ideal, at the melting temperature of Mg. $ $ The carbides Mg2C3 and MgC2 do not appear to be stable. $ The only important gas species is Mg1. $ PAR G(HCP_A3,MG:C),, +GHSERMG+0.5*GHSERCC+45000;,, N 06Hal4 ! $ PAR G(MG2C3,MG:C),, +31041.1756+712.136068*T -118.7419*T*LN(T)-0.00535552*T**2+1251016*T**(-1);,, N 97SUB ! PAR G(MGC2,MG:C),, +61324.7987+432.693209*T -71.17821*T*LN(T)-0.003231094*T**2+6.56084E-10*T**3 +749881.5*T**(-1);,, N 97SUB ! $ $ Metastable $ PAR G(BCC_A2,MG:C),, +GHSERMG+3*GHSERCC+320000;,, N 15Hal2 ! PAR G(A2_BCC,MG:C),, +GHSERMG+3*GHSERCC+320000;,, N 15Hal2 ! $ ------------------------------------------------------------------------------ $ Mg-Mn $ $ J. Groebner, D. Mirkovic, M. Ohno, R. Schmid-Fetzer, $ J. Phase Equilib. Diffus., 26, 234-39(2005). $ $ Checked against paper. Checked at 6000 K. $ $ The shape of the liquid miscibility gap is more reasonable than in 98Tib. $ $ Solid interactions except HCP_A3 should probably be changed. $ PAR L(LIQUID,MG,MN;0),, +25922.4+9.0357*T;,, N 05Gro ! PAR L(LIQUID,MG,MN;1),, -3470.8;,, N 05Gro ! $ PAR L(FCC_A1,MG,MN:VA;0),, +85000;,, N 05Gro ! PAR L(A1_FCC,MG,MN:VA;0),, +85000;,, N 05Gro ! PAR L(BCC_A2,MG,MN:VA;0),, +85000;,, N 05Gro ! PAR L(A2_BCC,MG,MN:VA;0),, +85000;,, N 05Gro ! PAR L(HCP_A3,MG,MN:VA;0),, +37148.1-1.8103*T;,, N 05Gro ! PAR L(CBCC_A12,MG,MN:VA;0),, +85000;,, N 05Gro ! PAR L(CUB_A13,MG,MN:VA;0),, +85000;,, N 05Gro ! $ ------------------------------------------------------------------------------ $ Mg-Mo $ ------------------------------------------------------------------------------ $ Mg-N $ $ B. Hallstedt, unpublished, 2015. $ $ Checked at 6000K. $ $ This is just a dummy until reasonable interactions have been determined. $ Interactions should be determined from a suitable ternary system. $ $ There is a stable nitride, Mg3N2. Its enthalpy of formation is taken from $ LB IV/5 (Predel). No further parameters are included. $ PAR L(LIQUID,MG,N;0),, +ZERO;,, N 15Hal3 ! $ PAR L(HCP_A3,MG:N;0),, +ZERO;,, N 15Hal3 ! $ PAR G(MG3N2_D53,MG:N),, +3*GHSERMG+2*GHSERNN -461000;,, N 15Hal3 ! $ ------------------------------------------------------------------------------ $ Mg-Nb $ $ B. Hallstedt, unpublished, 2015. $ $ Checked at 6000K. $ $ This is just a dummy until reasonable interactions have been determined. $ Interactions should be determined from a suitable ternary system and/or $ SQS calculations. $ $ There are no intermetallic compounds and the terminal solubilities are small $ (LB IV/5; Predel). $ PAR L(LIQUID,MG,NB;0),, +100000;,, N 15Hal4 ! $ PAR L(BCC_A2,MG,NB:VA;0),, +100000;,, N 15Hal4 ! PAR L(A2_BCC,MG,NB:VA;0),, +100000;,, N 15Hal4 ! $ PAR L(HCP_A3,MG,NB:VA;0),, +100000;,, N 15Hal4 ! $ $ Metastable $ PAR L(FCC_A1,MG,NB:VA;0),, +100000;,, N 15Hal4 ! PAR L(A1_FCC,MG,NB:VA;0),, +100000;,, N 15Hal4 ! PAR L(CBCC_A12,MG,NB:VA;0),, +100000;,, N 15Hal4 ! PAR L(CUB_A13,MG,NB:VA;0),, +100000;,, N 15Hal4 ! $ ------------------------------------------------------------------------------ $ Mg-Ni $ $ From M.H.G. Jacobs and P.J. Spencer 1998 (Included in LB Vol. 3) $ $ M.H.G. Jacobs, P.J. Spencer, COST 507, Final report round 2, 1998. $ $ Checked against LB and COST. Checked at 6000 K. $ $ This version is quite different from the version published in Calphad, $ which seems quite reasonable with the exception of an inverse liquid $ miscibility gap and probably too positive solid interactions. $ $ Solid interactions should be changed. Ni endpoint of C36_LAVES should be $ changed. Mg2Ni has a constant heat capacity. $ PAR L(LIQUID,MG,NI;0),, -42304.49+7.45704*T;,, N 98Jac2 ! PAR L(LIQUID,MG,NI;1),, -15611.66+9.11885*T;,, N 98Jac2 ! $ PAR L(FCC_A1,MG,NI:VA;0),, +80*T;,, N 98Jac2 ! PAR L(A1_FCC,MG,NI:VA;0),, +80*T;,, N 98Jac2 ! PAR L(HCP_A3,MG,NI:VA;0),, +80*T;,, N 98Jac2 ! $ PAR G(C36_LAVES,MG:NI),, +104136-293.9216*T +54.35385*T*LN(T)+0.0333*T**2+99*T**(-1) -5.14203E-06*T**3;,, N 98Jac2 ! PAR G(C36_LAVES,NI:MG),, -74136+293.9216*T -54.35385*T*LN(T)-0.0333*T**2-99*T**(-1) +5.14203E-06*T**3;,, N 98Jac2 ! PAR L(C36_LAVES,MG,NI:MG;0),, +50000;,, N 98Jac2 ! PAR L(C36_LAVES,MG,NI:NI;0),, +50000;,, N 98Jac2 ! PAR L(C36_LAVES,MG:MG,NI;0),, +50000;,, N 98Jac2 ! PAR L(C36_LAVES,NI:MG,NI;0),, +50000;,, N 98Jac2 ! $ PAR G(MG2NI,MG:NI),, -82211.2+571.0183*T -95.992*T*LN(T);,, N 98Jac2 ! $ $ Metastable $ PAR L(BCC_A2,MG,NI:VA;0),, +80*T;,, N 98Jac2 ! PAR L(A2_BCC,MG,NI:VA;0),, +80*T;,, N 98Jac2 ! $ ------------------------------------------------------------------------------ $ Mg-Si $ $ S.-M. Liang, P. Wang, R. Schmid-Fetzer, Calphad, 54, 82-96(2016). $ $ Checked against paper. Checked at 6000 K. $ $ Includes new model for the T-dependence of the liquid interaction. $ PAR L(LIQUID,MG,SI;0),, -59907.1*FET+10*T*FET;,, N 16Lia ! PAR L(LIQUID,MG,SI;1),, -20810.1*FET+12.2428*T*FET;,, N 16Lia ! PAR L(LIQUID,MG,SI;2),, +26078.6*FET-14*T*FET;,, N 16Lia ! $ PAR L(HCP_A3,MG,SI:VA;0),, -5330;,, N 16Lia ! PAR L(DIAMOND_A4,MG,SI;0),, +40618-38*T;,, N 16Lia ! $ PAR G(MG2SI_C1,MG:SI),, +GMG2SI;,, N 16Lia ! $ $ metastable $ PAR L(FCC_A1,MG,SI:VA;0),, -5330;,, N Same ! PAR L(A1_FCC,MG,SI:VA;0),, -5330;,, N Same ! PAR L(BCC_A2,MG,SI:VA;0),, -5330;,, N Same ! PAR L(A2_BCC,MG,SI:VA;0),, -5330;,, N Same ! PAR L(CBCC_A12,MG,SI:VA;0),, -5330;,, N Same ! PAR L(CUB_A13,MG,SI:VA;0),, -5330;,, N Same ! $ PAR G(C15_LAVES,MG:SI),, +2*GHSERMG+GHSERSI +104970.96-16.46448*T;,, N 98Luk ! PAR G(C15_LAVES,SI:MG),, +2*GHSERSI+GHSERMG +41039+6.25*T;,, N 98Luk ! PAR L(C15_LAVES,SI,MG:SI;0),, +15000;,, N 98Luk ! PAR L(C15_LAVES,SI:SI,MG;0),, +8000;,, N 98Luk ! PAR L(C15_LAVES,MG:MG,SI;0),, +8000;,, N 98Luk ! PAR L(C15_LAVES,MG,SI:MG;0),, +15000;,, N 98Luk ! $ FUNCTION EXP1 298.15 +EXP(-1.25E-07*T**2); 6000 N ! FUNCTION EXP2 298.15 +EXP(1.25E-04*T); 6000 N ! FUNCTION FET 298.15 +0.96923*EXP1*EXP2; 6000 N ! FUNCTION GMG2SI 1.00 -75335.76-5.205E-03*T**2+1.25E-07*T**4; 17.00 Y -75321.86-0.4894*T-0.40121*T*LN(T) +0.074176*T**2-1.04634E-03*T**3-68.8*T**(-1); 50.00 Y -73998.13-160.5303*T+40.92023*T*LN(T) -0.498235*T**2+4.38333E-04*T**3-8007*T**(-1); 120.00 Y -79151.48+145.3746*T-22.83914*T*LN(T) -0.1476684*T**2+7.69627E-05*T**3+70083*T**(-1); 250.00 Y -86546.8+410.4926*T-71.661*T*LN(T) -0.00561*T**2+278010*T**(-1); 1400.00 Y -96748.07+521.8042*T-87.0853*T*LN(T); 3600.00 N ! $ ------------------------------------------------------------------------------ $ Mg-Ti $ $ J.L. Murray, Bull. Alloy Phase Diagrams, 7, 245-48(1986). $ $ Checked against paper. Checked at 6000K. $ $ The match is reasonable considering that pre-SGTE lattice stabilities were $ used in 86Mur. $ PAR L(LIQUID,MG,TI;0),, +77020;,, N 86Mur ! $ PAR L(BCC_A2,MG,TI:VA;0),, +33608;,, N 86Mur ! PAR L(A2_BCC,MG,TI:VA;0),, +33608;,, N 86Mur ! $ PAR L(HCP_A3,MG,TI:VA;0),, +21779+22.165*T;,, N 86Mur ! PAR L(HCP_A3,MG,TI:VA;1),, +9467;,, N 86Mur ! $ $ Metastable $ PAR L(FCC_A1,MG,TI:VA;0),, +21779+22.165*T;,, N Same ! PAR L(FCC_A1,MG,TI:VA;1),, +9467;,, N Same ! $ PAR L(A1_FCC,MG,TI:VA;0),, +21779+22.165*T;,, N Same ! PAR L(A1_FCC,MG,TI:VA;1),, +9467;,, N Same ! $ PAR L(CBCC_A12,MG,TI:VA;0),, +21779+22.165*T;,, N Same ! PAR L(CBCC_A12,MG,TI:VA;1),, +9467;,, N Same ! $ PAR L(CUB_A13,MG,TI:VA;0),, +21779+22.165*T;,, N Same ! PAR L(CUB_A13,MG,TI:VA;1),, +9467;,, N Same ! $ ------------------------------------------------------------------------------ $ Mg-V $ $ B. Hallstedt, unpublished, 2015. $ $ Checked at 6000K. $ $ This is just a dummy until reasonable interactions have been determined. $ Interactions should be determined from a suitable ternary system and/or $ SQS calculations. $ $ There are no intermetallic compounds and the terminal solubilities are small $ (LB IV/5; Predel). $ $ There is also a dataset from 08GTT. In contrast to 08GTT I do not assume $ ideal mixing in the liquid. The interactions are also larger here than in $ 08GTT. $ PAR L(LIQUID,MG,V;0),, +100000;,, N 15Hal5 ! $ PAR L(BCC_A2,MG,V:VA;0),, +100000;,, N 15Hal5 ! PAR L(A2_BCC,MG,V:VA;0),, +100000;,, N 15Hal5 ! $ PAR L(HCP_A3,MG,V:VA;0),, +100000;,, N 15Hal5 ! $ $ Metastable $ PAR L(FCC_A1,MG,V:VA;0),, +100000;,, N 15Hal5 ! PAR L(A1_FCC,MG,V:VA;0),, +100000;,, N 15Hal5 ! $ PAR L(CBCC_A12,MG,V:VA;0),, +100000;,, N Same ! PAR L(CUB_A13,MG,V:VA;0),, +100000;,, N Same ! $ ------------------------------------------------------------------------------ $ Mn-C $ $ D. Djurovic, B. Hallstedt, J. von Appen, R. Dronskowski, $ Calphad, 34, 279-85(2010). $ $ Checked against paper. Checked at 6000 K. $ PAR L(LIQUID,C,MN;0),, -179183+43.8449*T;,, N 10Dju ! PAR L(LIQUID,C,MN;1),, +6313;,, N 10Dju ! PAR L(LIQUID,C,MN;2),, +23281;,, N 10Dju ! $ PAR G(FCC_A1,MN:C),, +GHSERMN+GHSERCC+13.659*T;,, N 10Dju ! PAR L(FCC_A1,MN:C,VA;0),, -41333;,, N 10Dju ! $ PAR G(A1_FCC,MN:C),, +GHSERMN+GHSERCC+13.659*T;,, N 10Dju ! PAR L(A1_FCC,MN:C,VA;0),, -41333;,, N 10Dju ! $ PAR G(BCC_A2,MN:C),, +GHSERMN+3*GHSERCC +10000+30*T;,, N 90Hua1 ! PAR G(A2_BCC,MN:C),, +GHSERMN+3*GHSERCC +10000+30*T;,, N 90Hua1 ! $ PAR G(HCP_A3,MN:C),, +GHSERMN+0.5*GHSERCC -9000-1.0651*T;,, N 10Dju ! PAR L(HCP_A3,MN:C,VA;0),, -5006;,, N 10Dju ! $ PAR G(CBCC_A12,MN:C),, +GHSERMN+GHSERCC +27.46525*T;,, N 10Dju ! PAR L(CBCC_A12,MN:C,VA;0),, -52204;,, N 10Dju ! $ PAR G(CUB_A13,MN:C),, +GHSERMN+GHSERCC+2607;,, N 10Dju ! PAR L(CUB_A13,MN:C,VA;0),, -10175;,, N 10Dju ! $ PAR G(M23C6_D84,MN:MN:C),, +GMN23C6;,, N 10Dju ! PAR G(CEMENTITE_D011,MN:C),, +GMN3C;,, N 10Dju ! PAR G(M5C2,MN:C),, +GMN5C2;,, N 10Dju ! PAR G(M7C3_D101,MN:C),, +GMN7C3;,, N 10Dju ! $ $ metastable $ PAR G(V3C2,MN:C),, -76135+750.415*T -125.589*T*LN(T)+922711*T**(-1);,, N 91Fer2 ! $ FUNCTION GMN23C6 298.15 +23*GHSERMN+6*GHSERCC-310473+53.86*T; 6000 N ! FUNCTION GMN3C 298.15 +3*GHSERMN+GHSERCC-39644+3.04*T; 6000 N ! FUNCTION GMN5C2 298.15 +5*GHSERMN+2*GHSERCC-73954+6.36*T; 6000 N ! FUNCTION GMN7C3 298.15 +7*GHSERMN+3*GHSERCC-106695+9.36*T; 6000 N ! $ ------------------------------------------------------------------------------ $ Mn-Mo $ $ From from B.-J. Lee 1995 (Included in LB Vol. 4) $ $ B.-J. Lee, unpublished research, 1995. $ $ Checked against previous datasets. Checked at 6000 K. $ $ Modified from the dataset by 95Lee. $ $ Model for MU_D85 changed from 7:2:4 to 1:4:2:6 and extended. $ Mo added on the 1st SL in SIGMA_D8B. This was necessary in the Cr-Fe-Mo $ system. $ $ MU_D85 becomes unstable below 445 K. $ $ New model for MU_D85: The MU_D85 phase has a narrow homogeneity range and $ is shifted somewhat towards Mo at high temperature. The SIGMA_D8B parameters $ were changed to approximately keep the composition and invarient temperatures $ of the original version. $ PAR L(LIQUID,MN,MO;0),, -22275+13.6587*T;,, N 95Lee ! PAR L(LIQUID,MN,MO;1),, +23500-10.7493*T;,, N 95Lee ! $ PAR L(FCC_A1,MN,MO:VA;0),, +11174;,, N 95Lee ! PAR L(A1_FCC,MN,MO:VA;0),, +11174;,, N 95Lee ! $ PAR L(BCC_A2,MN,MO:VA;0),, +49770-14.2564*T;,, N 95Lee ! PAR L(BCC_A2,MN,MO:VA;1),, -7260;,, N 95Lee ! $ PAR L(A2_BCC,MN,MO:VA;0),, +49770-14.2564*T;,, N 95Lee ! PAR L(A2_BCC,MN,MO:VA;1),, -7260;,, N 95Lee ! $ PAR L(CBCC_A12,MN,MO:VA;0),, +646;,, N 95Lee ! $ PAR L(CUB_A13,MN,MO:VA;0),, +5626;,, N 95Lee ! $ PAR G(MU_D85,MN:MO:MO:MN),, +7*GFCCMN+6*GHSERMO -7638-27*T;,, N 17Hal4 ! PAR G(MU_D85,MN:MO:MO:MO),, +GFCCMN+6*GHSERMO +6*GFCCMO+100000;,, N 17Hal4 ! $ PAR G(SIGMA_D8B,MN:MO:MN),, +10*GFCCMN+4*GHSERMO +16*GBCCMN+30000;,, N 17Hal6 ! PAR G(SIGMA_D8B,MN:MO:MO),, +10*GFCCMN+20*GHSERMO +83000-30*T;,, N 17Hal6 ! PAR G(SIGMA_D8B,MO:MO:MN),, +10*GFCCMO+4*GHSERMO +16*GBCCMN+300000;,, N 17Hal6 ! $ $ Metastable $ PAR L(HCP_A3,MN,MO:VA;0),, +11174;,, N Same ! $ PAR G(C14_LAVES,MN:MO),, +2*GHSERMN+GHSERMO;,, N Lin ! PAR G(C14_LAVES,MO:MN),, +2*GHSERMO+GHSERMN+79700;,, N Lin ! $ PAR G(R_PHASE,MN:MO:MN),, +27*GFCCMN+14*GHSERMO +12*GBCCMN;,, N 95Lee ! PAR G(R_PHASE,MN:MO:MO),, +27*GFCCMN+26*GHSERMO;,, N 95Lee ! $ ------------------------------------------------------------------------------ $ Mn-N $ $ From C. Qiu and AFG (Included in LB Vol. 4) $ $ C. Qiu, A. Fernandez Guillermet, Z. Metallkd., 84, 11-22(1993). $ $ Checked against LB and paper. Checked at 6000 K. $ $ There are no strange features when the gas is not included. $ $ MN6N5 appears to have a distorted NaCl structure. It should possibly be $ modelled as FCC_A1. $ $ Va added on the second sublattice of FE4N_L1 to be compatible with $ Fe-N from 93Du. This adds a narrow solubility range for FE4N_L1 and $ invariant equilibria on the Mn-rich side of FE4N_L1 increase by about 10 K. $ PAR L(LIQUID,MN,N;0),, -142308+6.0759*T;,, N 93Qiu1 ! PAR L(LIQUID,MN,N;1),, +32906;,, N 93Qiu1 ! $ PAR G(BCC_A2,MN:N),, -55600+606.648*T -100.41*T*LN(T)+844897*T**(-1);,, N 93Qiu1 ! PAR L(BCC_A2,MN:N,VA;0),, -185000;,, N 93Qiu1 ! $ PAR G(A2_BCC,MN:N),, -55600+606.648*T -100.41*T*LN(T)+844897*T**(-1);,, N 93Qiu1 ! PAR L(A2_BCC,MN:N,VA;0),, -185000;,, N 93Qiu1 ! $ PAR G(FCC_A1,MN:N),, -75940+292.226*T -50.294*T*LN(T)+265051*T**(-1);,, N 93Qiu1 ! PAR L(FCC_A1,MN:N,VA;0),, -69698+11.5845*T;,, N 93Qiu1 ! $ PAR G(A1_FCC,MN:N),, -75940+292.226*T -50.294*T*LN(T)+265051*T**(-1);,, N 93Qiu1 ! PAR L(A1_FCC,MN:N,VA;0),, -69698+11.5845*T;,, N 93Qiu1 ! $ PAR G(HCP_A3,MN:N),, -60607+211.1804*T -37.7331*T*LN(T)+129442*T**(-1);,, N 93Qiu1 ! PAR L(HCP_A3,MN:N,VA;0),, -7194-5.2075*T;,, N 93Qiu1 ! PAR L(HCP_A3,MN:N,VA;1),, -11810+6.9538*T;,, N 93Qiu1 ! $ PAR G(CBCC_A12,MN:N),, -53114+299.266*T -50.216*T*LN(T)+358309*T**(-1);,, N 93Qiu1 ! PAR L(CBCC_A12,MN:N,VA;0),, -58869;,, N 93Qiu1 ! $ PAR G(CUB_A13,MN:N),, -67484+299.266*T -50.216*T*LN(T)+358309*T**(-1);,, N 93Qiu1 ! PAR L(CUB_A13,MN:N,VA;0),, -58869;,, N 93Qiu1 ! $ PAR G(FE4N_L1,MN:N),, -155790+691.0638*T -126.9328*T*LN(T)+307417*T**(-1);,, N 93Qiu1 ! PAR G(MN3N2,MN:N),, -232807+714.166*T -125.6685*T*LN(T)+513949*T**(-1);,, N 93Qiu1 ! PAR G(MN6N5,MN:N),, -546880+1591.607*T -276.668*T*LN(T)+1297983*T**(-1);,, N 93Qiu1 ! $ $ Metastable $ PAR G(CEMENTITE_D011,MN:N),, +3*GHSERMN+GHSERNN+40000;,, N 99Lee ! $ ------------------------------------------------------------------------------ $ Mn-Nb $ $ S. Liu, B. Hallstedt, D. Music, Y. Du, Calphad, 38, 43-58(2012). $ $ Checked against paper. Checked at 6000 K. $ PAR L(LIQUID,MN,NB;0),, -15322.786;,, N 12Liu ! PAR L(LIQUID,MN,NB;1),, +12376.04;,, N 12Liu ! $ PAR L(FCC_A1,MN,NB:VA;0),, +6305.5;,, N 12Liu ! PAR L(A1_FCC,MN,NB:VA;0),, +6305.5;,, N 12Liu ! $ PAR L(BCC_A2,MN,NB:VA;0),, +16895.03;,, N 12Liu ! PAR L(A2_BCC,MN,NB:VA;0),, +16895.03;,, N 12Liu ! $ PAR L(CBCC_A12,MN,NB:VA;0),, -10485.26;,, N 12Liu ! PAR L(CUB_A13,MN,NB:VA;0),, -10485.26;,, N 12Liu ! $ PAR G(C14_LAVES,MN:NB),, +2*GHSERMN+GHSERNB -32983.815;,, N 12Liu ! PAR G(C14_LAVES,NB:MN),, +2*GHSERNB+GHSERMN+160800;,, N 12Liu ! PAR G(C14_LAVES,MN,NB:MN;0),, +5249.5;,, N 12Liu ! PAR G(C14_LAVES,MN,NB:NB;0),, +5249.5;,, N 12Liu ! PAR G(C14_LAVES,MN:MN,NB;0),, +ZERO;,, N 12Liu ! PAR G(C14_LAVES,NB:MN,NB;0),, +ZERO;,, N 12Liu ! $ PAR G(MU_D85,MN:NB:NB:MN),, +7*GHSERMN+6*GHSERNB -119340;,, N 12Liu ! PAR G(MU_D85,MN:NB:NB:NB),, +GHSERMN+12*GHSERNB +181220;,, N 12Liu ! PAR G(MU_D85,NB:NB:NB:MN),, +6*GHSERMN+7*GHSERNB -47450;,, N 12Liu ! $ $ Metastable $ PAR L(HCP_A3,MN,NB:VA;0),, +6305.5;,, N Same ! $ PAR G(SIGMA_D8B,MN:NB:MN),, +10*GFCCMN+4*GHSERNB +16*GHSERMN;,, N Lin ! PAR G(SIGMA_D8B,MN:NB:NB),, +10*GFCCMN+20*GHSERNB;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mn-Ni $ $ P. Franke, Int. J. Mater. Res., 98, 954-60(2007). $ $ Checked against paper. Checked at 6000 K. $ $ 4SL model for fcc using option F. $ $ The parameters for the disordered phases (except bcc) are kept from $ Guo and Du 2005. $ $ There seems to be a magnetic miscibility gap (with Nishizawa horn) in the $ fcc phase on the Ni-rich side below about 500 K. For some reason it $ continues as a very thin miscibility gap up to the solidus. $ PAR L(LIQUID,MN,NI;0),, -45032.1+2.7764*T;,, N 05Guo ! PAR L(LIQUID,MN,NI;1),, +11665.5-7.6061*T;,, N 05Guo ! $ PAR L(FCC_A1,MN,NI:VA;0),, -27996.5-1.2275*T;,, N 05Guo ! PAR L(FCC_A1,MN,NI:VA;1),, +19266.4-12.2853*T;,, N 05Guo ! PAR TC(FCC_A1,MN,NI:VA;0),, -3171.20;,, N 05Guo ! PAR TC(FCC_A1,MN,NI:VA;1),, -4317.73;,, N 05Guo ! PAR BMAG(FCC_A1,MN,NI:VA;0),, -1.3947;,, N 05Guo ! PAR BMAG(FCC_A1,MN,NI:VA;1),, +3.9050;,, N 05Guo ! $ PAR L(A1_FCC,MN,NI:VA;0),, -27996.5-1.2275*T;,, N 05Guo ! PAR L(A1_FCC,MN,NI:VA;1),, +19266.4-12.2853*T;,, N 05Guo ! PAR TC(A1_FCC,MN,NI:VA;0),, -3171.20;,, N 05Guo ! PAR TC(A1_FCC,MN,NI:VA;1),, -4317.73;,, N 05Guo ! PAR BMAG(A1_FCC,MN,NI:VA;0),, -1.3947;,, N 05Guo ! PAR BMAG(A1_FCC,MN,NI:VA;1),, +3.9050;,, N 05Guo ! $ PAR G(FCC_4SL,MN:MN:MN:NI:VA),, +GFMN3NI;,, N 07Fra ! PAR G(FCC_4SL,MN:MN:NI:NI:VA),, +GFMN2NI2;,, N 07Fra ! PAR G(FCC_4SL,MN:NI:NI:NI:VA),, +GFMNNI3;,, N 07Fra ! PAR G(FCC_4SL,MN,NI:MN,NI:*:*:VA;0),, +SFMNNI;,, N 07Fra ! $ PAR L(BCC_A2,MN,NI:VA;0),, -11466-14*T;,, N 07Fra ! PAR L(A2_BCC,MN,NI:VA;0),, -11466-14*T;,, N 07Fra ! $ PAR G(B2_BCC,MN:NI:VA),, -23774+4.5*T;,, N 07Fra ! PAR G(B2_BCC,NI:MN:VA),, -23774+4.5*T;,, N 07Fra ! $ PAR L(CBCC_A12,MN,NI:VA;0),, -27797.3-0.4267*T;,, N 05Guo ! PAR L(CBCC_A12,MN,NI:VA;1),, +36529.6-30.5162*T;,, N 05Guo ! $ PAR L(CUB_A13,MN,NI:VA;0),, -28815.2+0.1795*T;,, N 05Guo ! PAR L(CUB_A13,MN,NI:VA;1),, +24317.8-16.8271*T;,, N 05Guo ! $ $ metastable $ PAR L(HCP_A3,MN,NI:VA;0),, -27996.5-1.2275*T;,, N Same ! PAR L(HCP_A3,MN,NI:VA;1),, +19266.4-12.2853*T;,, N Same ! $ PAR G(C14_LAVES,MN:NI),, +2*GHSERMN+GHSERNI+32700;,, N Lin ! PAR G(C14_LAVES,NI:MN),, +2*GHSERNI+GHSERMN+44700;,, N Lin ! $ FUNCTION U1FMNNI 298.15 -7050; 6000 N ! FUNCTION SFMNNI 298.15 -5500; 6000 N ! FUNCTION GFMN3NI 298.15 +3*U1FMNNI+2200; 6000 N ! FUNCTION GFMN2NI2 298.15 +4*U1FMNNI; 6000 N ! FUNCTION GFMNNI3 298.15 +3*U1FMNNI+1550; 6000 N ! $ ------------------------------------------------------------------------------ $ Mn-Si $ $ From J.E. Tibballs 1991 (included in LB Vol. 4) $ $ J.E. Tibballs, SI-report 890221-5, 1991 (also COST 507 report, 1998). $ $ Checked against LB and COST report. Checked at 6000 K. $ $ There are some differences in the invariant equilibria between LB and the $ COST report, possibly because of rounding errors. This dataset reproduces $ the LB version correctly. $ $ Mn6Si is stable above 5500 K and there is an inverse miscibility gap with $ a minimum at 5800 K and x(Si)=0.58. $ PAR L(LIQUID,MN,SI;0),, -139817.4+29.86137*T;,, N 91Tib ! PAR L(LIQUID,MN,SI;1),, -34917.2+3.20488*T;,, N 91Tib ! PAR L(LIQUID,MN,SI;2),, +46782.4-18.18969*T;,, N 91Tib ! PAR L(LIQUID,MN,SI;3),, +16168.2;,, N 91Tib ! $ PAR L(FCC_A1,MN,SI:VA;0),, -95600+2.94097*T;,, N 91Tib ! PAR L(FCC_A1,MN,SI:VA;1),, -7500;,, N 91Tib ! $ PAR L(A1_FCC,MN,SI:VA;0),, -95600+2.94097*T;,, N 91Tib ! PAR L(A1_FCC,MN,SI:VA;1),, -7500;,, N 91Tib ! $ PAR L(BCC_A2,MN,SI:VA;0),, -89620.7+2.94097*T;,, N 91Tib ! PAR L(BCC_A2,MN,SI:VA;1),, -7500;,, N 91Tib ! $ PAR L(A2_BCC,MN,SI:VA;0),, -89620.7+2.94097*T;,, N 91Tib ! PAR L(A2_BCC,MN,SI:VA;1),, -7500;,, N 91Tib ! $ PAR L(CBCC_A12,MN,SI:VA;0),, -142743.62+22.3961*T;,, N 91Tib ! PAR L(CBCC_A12,MN,SI:VA;1),, +16440.608-3.5300332*T;,, N 91Tib ! $ PAR L(CUB_A13,MN,SI:VA;0),, -142343.62+21.89261*T;,, N 91Tib ! PAR L(CUB_A13,MN,SI:VA;1),, +16440.608-3.5300332*T;,, N 91Tib ! $ PAR G(MN6SI,MN:SI),, +20*GMN17SI3;,, N 91Tib ! PAR G(MN9SI2,MN:SI),, +40*GMN33SI7;,, N 91Tib ! PAR G(MN3SI,MN:SI),, +4*GMN3SI;,, N 91Tib ! PAR G(M5SI3_D88,MN:SI:VA),, +GMN5SI3;,, N 91Tib ! PAR G(MSI_B20,MN:SI),, +2*GMNSI;,, N 91Tib ! PAR G(MN11SI19,MN:SI),, +GMN11SI1;,, N 91Tib ! $ $ metastable $ PAR L(HCP_A3,MN,SI:VA;0),, -86775+2.94*T;,, N 93For ! PAR L(HCP_A3,MN,SI:VA;1),, -7500;,, N 93For ! $ PAR G(C14_LAVES,MN:SI),, +2*GHSERMN+GHSERSI+61260;,, N Lin ! PAR G(C14_LAVES,SI:MN),, +2*GHSERSI+GHSERMN+101820;,, N Lin ! $ FUNCTION GMN17SI3 298.15 +0.85*GHSERMN+0.15*GHSERSI-12509.03+4.24222*T -0.6038776*T*LN(T)-0.001652606*T**2+375.7*T**(-1); 1519.00 Y +0.85*GHSERMN+0.15*GHSERSI-14100.43-1.629152*T +0.6033774*T*LN(T)-0.0029395827*T**2+1.964114E+30*T**(-9); 6000.00 N ! FUNCTION GMN33SI7 298.15 +0.825*GHSERMN+0.175*GHSERSI-14455.21+9.53235*T -1.421747*T*LN(T)-0.001250875*T**2+364.65*T**(-1); 1519.00 Y +0.825*GHSERMN+0.175*GHSERSI-15999.8+3.833662*T -0.25*T*LN(T)-0.0025*T**2+1.906346E+30*T**(-9); 6000.00 N ! FUNCTION GMN3SI 298.15 -31047.468+195.60933*T-32.920521*T*LN(T) -0.0019425154*T**2+414300.232*T**(-1); 950.00 Y -29935.151+194.43847*T-32.920521*T*LN(T) -0.0019425154*T**2+414300.232*T**(-1); 6000.00 N ! FUNCTION GMN5SI3 298.15 -261930.32+1170.7779*T-211.15016*T*LN(T) -0.01529344*T**2-149263.11*T**(-1); 6000.00 N ! FUNCTION GMNSI 298.15 -39067.572+154.1244*T-26.210608*T*LN(T) -0.0034516778*T**2+438221.48*T**(-1); 6000.00 N ! FUNCTION GMN11SI1 298.15 -636300.49+1624.9288*T-378.69397*T*LN(T) -0.16391259*T**2-15432618*T**(-1); 6000.00 N ! $ ------------------------------------------------------------------------------ $ Mn-Ti $ $ From N. Saunders 1998 (included in LB Vol. 4) $ $ N. Saunders, COST 507, Final report round 2, 1998. $ $ Checked against LB and COST report. Checked at 6000 K. $ $ REFLAV not used for G(MN2TI_C14,MN:MN). $ -4*T term missing for G(MNTI_ALPHA,MN:TI)in the COST report. $ $ There are two models for Mn2Ti included. MN2TI_C14 is the original from 98Sau. $ C14_LAVES includes new end-member values and refitted interactions. $ An incorrect value for G(C14_LAVES,TI:TI) was used in a previous version. $ When using the correct value from 06Slu it was not possible to refit the $ phase diagram without using excessive interaction parameters. Therefore $ a value for G(C14_LAVES,TI:TI) was selected that produces moderate interaction $ parameters. The interaction parameters were selected so that the invariant $ temperatures involving the liquid change minimally. The C14_LAVES phase field $ is more narrow and the invariant temperatures involving C14_LAVES change $ somewhat. The minimum temperature of beta-MnTi increases by 10 K. Other $ equilibria change less. $ PAR L(LIQUID,MN,TI;0),, -34000+21.5*T;,, N 98Sau2 ! PAR L(LIQUID,MN,TI;1),, +1400;,, N 98Sau2 ! $ PAR L(FCC_A1,MN,TI:VA;0),, -26200+20*T;,, N 98Sau2 ! PAR L(A1_FCC,MN,TI:VA;0),, -26200+20*T;,, N 98Sau2 ! $ PAR L(BCC_A2,MN,TI:VA;0),, -23200+20*T;,, N 98Sau2 ! PAR L(BCC_A2,MN,TI:VA;1),, -1000;,, N 98Sau2 ! $ PAR L(A2_BCC,MN,TI:VA;0),, -23200+20*T;,, N 98Sau2 ! PAR L(A2_BCC,MN,TI:VA;1),, -1000;,, N 98Sau2 ! $ PAR L(HCP_A3,MN,TI:VA;0),, +22100;,, N 98Sau2 ! $ PAR L(CBCC_A12,MN,TI:VA;0),, -29500+20*T;,, N 98Sau2 ! PAR L(CBCC_A12,MN,TI:VA;1),, -3635-5*T;,, N 98Sau2 ! $ PAR L(CUB_A13,MN,TI:VA;0),, -34000+20*T;,, N 98Sau2 ! $ PAR G(C14_LAVES,MN:TI),, +2*GHSERMN+GHSERTI-26400;,, N 98Sau2 ! PAR G(C14_LAVES,TI:MN),, +GHSERMN+2*GHSERTI+92100;,, N 17Hal2 ! PAR L(C14_LAVES,MN,TI:MN;0),, -6500;,, N 17Hal2 ! PAR L(C14_LAVES,MN,TI:TI;0),, -6500;,, N 17Hal2 ! PAR L(C14_LAVES,MN:MN,TI;0),, -5500;,, N 17Hal2 ! PAR L(C14_LAVES,TI:MN,TI;0),, -5500;,, N 17Hal2 ! $ PAR G(MN3TI,MN:TI),, +3*GHSERMN+GHSERTI -18552-9.12*T;,, N 98Sau2 ! PAR G(MN4TI,MN:TI),, +0.815*GHSERMN+0.185*GHSERTI -2445-2.9*T;,, N 98Sau2 ! PAR G(MNTI_ALPHA,MN:TI),, +GHSERMN+GHSERTI -11478-4*T;,, N 98Sau2 ! PAR G(MNTI_BETA,MN:TI),, +0.515*GHSERMN+0.485*GHSERTI -5540-2.29*T;,, N 98Sau2 ! $ $ metastable $ PAR G(MU_D85,MN:TI:TI:MN),, +7*GFCCMN+6*GBCCTI;,, N Lin ! $ PAR G(SIGMA_D8B,MN:TI:MN),, +10*GFCCMN+4*GBCCTI +16*GBCCMN;,, N Lin ! PAR G(SIGMA_D8B,MN:TI:TI),, +10*GFCCMN+20*GBCCTI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mn-V $ $ From W. Huang 1991 (Included in LB Vol. 4) $ $ W. Huang, Calphad, 15, 195-208(1991). $ $ Checked against LB and paper. Checked at 6000K. $ $ W. Huang used the 8:4:18 model for the sigma phase (SIGMA_OLD). This was $ changed to 10:4:16 (SIGMA_D8B) for LB. The change of model only slightly $ changes the V-rich side of the sigma phase field. $ PAR L(LIQUID,MN,V;0),, -11399;,, N 91Hua3 ! $ PAR L(FCC_A1,MN,V:VA;0),, -11820;,, N 91Hua3 ! PAR L(A1_FCC,MN,V:VA;0),, -11820;,, N 91Hua3 ! PAR L(BCC_A2,MN,V:VA;0),, -10000;,, N 91Hua3 ! PAR L(A2_BCC,MN,V:VA;0),, -10000;,, N 91Hua3 ! PAR L(CBCC_A12,MN,V:VA;0),, -22225;,, N 91Hua3 ! PAR L(CUB_A13,MN,V:VA;0),, -17724;,, N 91Hua3 ! $ PAR G(SIGMA_D8B,MN:V:MN),, +10*GFCCMN+4*GHSERVV +16*GBCCMN-225273+57.82*T;,, N 00Wes ! PAR G(SIGMA_D8B,MN:V:V),, +10*GFCCMN+20*GHSERVV -52083-60.39*T;,, N 00Wes ! PAR G(SIGMA_D8B,V:V:MN),, +14*GHSERVV+16*GBCCMN +100000;,, N 02Sun ! $ $ Metastable $ PAR L(HCP_A3,MN,V:VA;0),, -11820;,, N 91Hua4 ! $ PAR G(C14_LAVES,MN:V),, +2*GHSERMN+GHSERVV+26130;,, N Lin ! PAR G(C14_LAVES,V:MN),, +2*GHSERVV+GHSERMN+31560;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mo-C $ $ From J.-O. Andersson 1988 (included in LB Vol. 2) $ $ J.-O. Andersson, Calphad, 12, 1-8(1988). $ $ Checked against LB and paper. Checked at 6000 K. $ $ BCC_A2 is stable above 5400 K at x(C) about 0.55. There is no inverse $ miscibility gap in the liquid. $ $ Shim et al. 1996 claim that a negative L(BCC_A2,MO:C,VA;0) is necessary $ in order to describe Mo-Ti-C, but this brings the C-solubility in bcc-Mo $ far beyond all experimental data. This parameter is in TCFE, but not in LB. $ $ CEMENTITE_D011 is stable above 3100K. $ PAR L(LIQUID,C,MO;0),, -217800+38.41*T;,, N 88And1 ! PAR L(LIQUID,C,MO;1),, +30000;,, N 88And1 ! PAR L(LIQUID,C,MO;2),, +47000;,, N 88And1 ! $ PAR G(BCC_A2,MO:C),, +GHSERMO+3*GHSERCC +331000-75*T;,, N 88And1 ! PAR L(BCC_A2,MO:C,VA;0),, -20000;,, N 15Hal1 ! PAR G(A2_BCC,MO:C),, +GHSERMO+3*GHSERCC +331000-75*T;,, N 88And1 ! PAR L(A2_BCC,MO:C,VA;0),, -20000;,, N 15Hal1 ! $PAR L(BCC_A2,MO:C,VA;0),, -50000;,, N 96Shi ! $ PAR G(FCC_A1,MO:C),, +GHSERMO+GHSERCC -7500-8.3*T-750000*T**(-1);,, N 88And1 ! PAR L(FCC_A1,MO:C,VA;0),, -41300;,, N 88And1 ! $ PAR G(A1_FCC,MO:C),, +GHSERMO+GHSERCC -7500-8.3*T-750000*T**(-1);,, N 88And1 ! PAR L(A1_FCC,MO:C,VA;0),, -41300;,, N 88And1 ! $ PAR G(HCP_A3,MO:C),, +GHSERMO+0.5*GHSERCC -24150-3.625*T-163000*T**(-1);,, N 88And1 ! PAR L(HCP_A3,MO:C,VA;0),, +4150;,, N 88And1 ! $ PAR G(MC_ETA,MO:C),, +GHSERMO+GHSERCC -9100-5.35*T-750000*T**(-1);,, N 88And1 ! PAR L(MC_ETA,MO:C,VA;0),, -59500;,, N 88And1 ! $ PAR G(MC_SHP,MO:C),, +GHSERMO+GHSERCC -32983+2.5*T;,, N 88And1 ! $ $ metastable $ PAR G(CBCC_A12,MO:C),, +UN_ASS;,, N ! PAR G(CUB_A13,MO:C),, +UN_ASS;,, N ! PAR G(CEMENTITE_D011,MO:C),, +3*GHSERMO+GHSERCC +77000-57.4*T;,, N 88And2 ! PAR G(M7C3_D101,MO:C),, +7*GHSERMO+3*GHSERCC -140415+24.24*T;,, N 92Qiu2 ! PAR G(CR3C2_D510,MO:C),, +3*GHSERMO+2*GHSERCC+27183;,, N 92Qiu2 ! PAR G(KSI_CARBIDE,MO:C),, +3*GHSERMO+GHSERCC +167009-33*T;,, N 88And2 ! $ ------------------------------------------------------------------------------ $ Mo-N $ $ From K. Frisk 1991 (included in LB Vol. 4) $ $ K. Frisk, Calphad, 15, 79-106(1991). $ $ Checked against LB and paper. Checked at 6000 K. $ $ BCC_A2 has a gigantic stability region above 3000 K. $ There is no inverse miscibility gap below 6000 K in the liquid. $ PAR L(LIQUID,MO,N;0),, -198280+37.49*T;,, N 91Fri1 ! $ PAR G(FCC_A1,MO:N),, +GHSERMO+GHSERNN -65344+149.7*T-9.78*T*LN(T);,, N 91Fri1 ! PAR L(FCC_A1,MO:N,VA;0),, -52565;,, N 91Fri1 ! $ PAR G(A1_FCC,MO:N),, +GHSERMO+GHSERNN -65344+149.7*T-9.78*T*LN(T);,, N 91Fri1 ! PAR L(A1_FCC,MO:N,VA;0),, -52565;,, N 91Fri1 ! $ PAR G(BCC_A2,MO:N),, +GHSERMO+3*GHSERNN +299700+79.73*T;,, N 91Fri1 ! PAR G(A2_BCC,MO:N),, +GHSERMO+3*GHSERNN +299700+79.73*T;,, N 91Fri1 ! $ PAR G(HCP_A3,MO:N),, +GHSERMO+0.5*GHSERNN -29450+28.7*T;,, N 91Fri1 ! $ $ metastable $ PAR G(CEMENTITE_D011,MO:N),, +UN_ASS;,, N ! $ PAR G(MC_SHP,MO:N),, -65897+276.75741*T -45.6523426*T*LN(T)-0.00302837129*T**2 +450481*T**(-1);,, N 96Fri ! $ ------------------------------------------------------------------------------ $ Mo-Nb $ $ W. Xiong, Y. Du, Y. Liu, B.Y. Huang, H.H. Xu, H.L. Chen, Z. Pan, $ Calphad, 28, 133-40(2004). $ $ Checked against paper. Checked at 6000 K. $ $ The very large negative enthalpy of mixing for the bcc phase seems very $ improbable. The 80Che version also has a large negative enthalpy of mixing, $ but not as large by far as here. This casts some doubt on the experimental $ chemical potential data in Fig. 5 in 04Xio. Both solid and liquid should be $ expected to be nearly ideal. $ PAR L(LIQUID,MO,NB;0),, +15253.7;,, N 04Xio ! PAR L(LIQUID,MO,NB;1),, +10594.2;,, N 04Xio ! $ PAR L(BCC_A2,MO,NB:VA;0),, -68202.6+29.85596*T;,, N 04Xio ! PAR L(BCC_A2,MO,NB:VA;1),, +8201.3;,, N 04Xio ! $ PAR L(A2_BCC,MO,NB:VA;0),, -68202.6+29.85596*T;,, N 04Xio ! PAR L(A2_BCC,MO,NB:VA;1),, +8201.3;,, N 04Xio ! $ $ Metastable $ PAR L(FCC_A1,MO,NB:VA;0),, +ZERO;,, N 15Zha1 ! PAR L(A1_FCC,MO,NB:VA;0),, +ZERO;,, N 15Zha1 ! $ PAR L(HCP_A3,MO,NB:VA;0),, +ZERO;,, N 15Zha1 ! $ PAR G(C14_LAVES,MO:NB),, +2*GHSERMO+GHSERNB+89340;,, N Lin ! PAR G(C14_LAVES,NB:MO),, +2*GHSERNB+GHSERMO+69480;,, N Lin ! $ PAR G(MU_D85,NB:MO:MO:MO),, +GFCCNB+6*GHSERMO+6*GFCCMO;,, N Lin ! PAR G(MU_D85,NB:MO:MO:NB),, +7*GFCCNB+6*GHSERMO;,, N Lin ! PAR G(MU_D85,NB:MO:NB:MO),, +GFCCNB+4*GHSERMO+2*GHSERNB +6*GFCCMO;,, N Lin ! PAR G(MU_D85,NB:MO:NB:NB),, +7*GFCCNB+4*GHSERMO +2*GHSERNB;,, N Lin ! PAR G(MU_D85,NB:NB:MO:MO),, +GFCCNB+4*GHSERNB+2*GHSERMO +6*GFCCMO;,, N Lin ! PAR G(MU_D85,NB:NB:MO:NB),, +7*GFCCNB+4*GHSERNB +2*GHSERMO;,, N Lin ! PAR G(MU_D85,NB:NB:NB:MO),, +GFCCNB+6*GHSERNB+6*GFCCMO;,, N Lin ! $ PAR G(SIGMA_D8B,MO:MO:NB),, +10*GFCCMO+4*GHSERMO +16*GHSERNB;,, N Lin ! PAR G(SIGMA_D8B,MO:NB:MO),, +10*GFCCMO+4*GHSERNB +16*GHSERMO;,, N Lin ! PAR G(SIGMA_D8B,MO:NB:NB),, +10*GFCCMO+20*GHSERNB;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mo-Ni $ $ K. Frisk, Calphad, 14, 371-380(1990). $ $ Checked against paper. Checked at 6000 K. $ $ Presently calculated invariant equilibria are up to 3 K higher than in $ the paper. $ $ Included in NIST superalloys database 23-Sep-2002 and SSOL V4. $ $ D1A_NI4X is not stable below 317 K. $ $ MONI changes to Mo-rich at low T without any apparent reason. $ The parameters for MONI seem strange. $ PAR L(LIQUID,MO,NI;0),, -46540+19.53*T;,, N 90Fri2 ! PAR L(LIQUID,MO,NI;1),, +2915;,, N 90Fri2 ! $ PAR L(FCC_A1,MO,NI:VA;0),, +4803.7-5.96*T;,, N 90Fri2 ! PAR L(FCC_A1,MO,NI:VA;1),, +10880;,, N 90Fri2 ! $ PAR L(A1_FCC,MO,NI:VA;0),, +4803.7-5.96*T;,, N 90Fri2 ! PAR L(A1_FCC,MO,NI:VA;1),, +10880;,, N 90Fri2 ! $ PAR L(BCC_A2,MO,NI:VA;0),, +46422;,, N 90Fri2 ! PAR L(A2_BCC,MO,NI:VA;0),, +46422;,, N 90Fri2 ! $ PAR G(NI3X_D0A,NI:MO),, +GHSERMO+3*GHSERNI -4199-7.00*T;,, N 90Fri2 ! $ PAR G(NI4X_D1A,NI:MO),, +GHSERMO+4*GHSERNI -4330-9.21*T;,, N 90Fri2 ! $ PAR G(MONI,NI:NI:MO),, +6*GHSERNI+5*GBCCNI+3*GHSERMO -257.5-23.375*T+3.375*T*LN(T);,, N 90Fri2 ! PAR G(MONI,NI:MO:MO),, +6*GHSERNI+8*GHSERMO -53025+272.25*T-35.5*T*LN(T);,, N 90Fri2 ! $ $ Metastable $ $ Same as fcc (zero in TCFE 1999) PAR L(HCP_A3,MO,NI:VA;0),, +4803.7-5.96*T;,, N NIST ! PAR L(HCP_A3,MO,NI:VA;1),, +10880;,, N NIST ! $ PAR G(CHI_A12,NI:MO:MO),, +24*GHSERNI+10*GHSERMO +24*GFCCMO;,, N Lin ! PAR G(CHI_A12,NI:MO:NI),, +48*GHSERNI+10*GHSERMO;,, N Lin ! $ PAR G(CRNI2_C11B,MO:NI),, +GHSERMO+2*GHSERNI +1000;,, N 06Tur ! $ PAR G(C14_LAVES,MO:NI),, +2*GHSERMO+GHSERNI+91700;,, N 17Hal8 ! PAR G(C14_LAVES,NI:MO),, +2*GHSERNI+GHSERMO;,, N Lin ! $ PAR G(MU_D85,NI:MO:NI:NI),, +7*GHSERNI+4*GHSERMO +2*GBCCNI;,, N Lin ! PAR G(MU_D85,NI:MO:NI:MO),, +3*GBCCNI+10*GHSERMO +200000;,, N 17Hal8 ! PAR G(MU_D85,NI:MO:MO:NI),, +7*GHSERNI+6*GHSERMO -20000;,, N 17Hal8 ! PAR G(MU_D85,NI:MO:MO:MO),, +GBCCNI+12*GHSERMO +200000;,, N 17Hal8 ! $ PAR G(SIGMA_D8B,NI:MO:MO),, +10*GHSERNI+20*GHSERMO +64295-65*T;,, N 17Hal8 ! PAR G(SIGMA_D8B,NI:MO:NI),, +10*GHSERNI+4*GHSERMO +16*GBCCNI+150000;,, N 17Hal8 ! PAR G(SIGMA_D8B,MO:MO:NI),, +10*GFCCMO+4*GHSERMO +16*GBCCNI+150000;,, N 17Hal8 ! $ PAR G(P_PHASE,NI:NI:MO;0),, +24*GHSERNI+20*GBCCNI+12*GHSERMO +208845-100*T;,, N 92Fri1 ! PAR G(P_PHASE,NI:MO:MO;0),, +24*GHSERNI+32*GHSERMO +26739-100*T;,, N 92Fri1 ! $ PAR G(R_PHASE,NI:MO:NI),, +27*GHSERNI+12*GBCCNI +14*GHSERMO+100000;,, N 92Fri1 ! PAR G(R_PHASE,NI:MO:MO),, +27*GHSERNI+26*GHSERMO -18000;,, N 92Fri1 ! $ ------------------------------------------------------------------------------ $ Mo-Si $ $ From from P.-Y. Chevalier and E. Fischer 2003 (Included in LB Vol. 4) $ $ P.-Y. Chevalier, E. Fischer, unpublished research, 2003. $ $ Checked against LB. Checked at 6000 K. $ $PAR L(LIQUID,MO,SI;0),, -135276.2+1.772195*T;,, N 89Vah ! $PAR L(LIQUID,MO,SI;1),, -47107.9+33.71028*T;,, N 89Vah ! $PAR L(LIQUID,MO,SI;2),, +75846.6-30.9*T;,, N 89Vah ! PAR L(LIQUID,MO,SI;0),, -137903.34+8.40536*T;,, N 03Che ! PAR L(LIQUID,MO,SI;1),, -42528.38;,, N 03Che ! PAR L(LIQUID,MO,SI;2),, +49284.19;,, N 03Che ! PAR L(LIQUID,MO,SI;3),, +48395.52;,, N 03Che ! $ $PAR L(BCC_A2,MO,SI:VA;0),, -70899.6;,, N 89Vah ! PAR L(BCC_A2,MO,SI:VA;0),, -75688.45;,, N 03Che ! PAR L(A2_BCC,MO,SI:VA;0),, -75688.45;,, N 03Che ! $ PAR G(MO3SI_A15,MO:SI),, +4*GMO3SI;,, N 03Che ! PAR G(MOSI2_C11B,MO:SI),, +3*GMOSI2;,, N 03Che ! PAR G(M5SI3_D8M,MO:SI),, +8*GMO5SI3;,, N 03Che ! $ $ Metastable $ PAR L(FCC_A1,MO,SI:VA;0),, -75688.45;,, N Same ! PAR L(A1_FCC,MO,SI:VA;0),, -75688.45;,, N Same ! PAR L(HCP_A3,MO,SI:VA;0),, -75688.45;,, N Same ! PAR L(CBCC_A12,MO,SI:VA;0),, -75688.45;,, N Same ! PAR L(CUB_A13,MO,SI:VA;0),, -75688.45;,, N Same ! $ PAR G(C14_LAVES,MO:SI),, +2*GHSERMO+GHSERSI+120260;,, N Lin ! PAR G(C14_LAVES,SI:MO),, +2*GHSERSI+GHSERMO;,, N Lin ! $ PAR G(MU_D85,SI:MO:MO:MO),, +GFCCSI+6*GHSERMO+6*GFCCMO;,, N Lin ! PAR G(MU_D85,SI:MO:MO:SI),, +7*GFCCSI+6*GHSERMO;,, N Lin ! PAR G(MU_D85,SI:MO:SI:MO),, +GFCCSI+4*GHSERMO+2*GBCCSI +6*GFCCMO;,, N Lin ! PAR G(MU_D85,SI:MO:SI:SI),, +7*GFCCSI+4*GHSERMO +2*GBCCSI;,, N Lin ! $ PAR G(SIGMA_D8B,MO:MO:SI),, +10*GFCCMO+4*GHSERMO +16*GBCCSI;,, N Lin ! $ FUNCTION GMO3SI 298.15 -39940.78+150.83071*T-26.260529*T*LN(T) +0.5380211E-3*T**2-0.457131E-6*T**3+159265*T**(-1); 6000.00 N ! FUNCTION GMO5SI3 298.15 -48230.28+148.34434*T-26.078027*T*LN(T) +0.3235301E-3*T**2-0.396771E-6*T**3+174382*T**(-1); 6000.00 N ! FUNCTION GMOSI2 298.15 -52358.28+146.62405*T-24.788623*T*LN(T) -0.6491781E-3*T**2-0.216351E-6*T**3+180226*T**(-1); 6000.00 N ! $ ------------------------------------------------------------------------------ $ Mo-Ti $ $ From N. Saunders 1998 (included in LB Vol. 4) $ $ N. Saunders, COST 507, Final report round 2, 1998. $ $ Checked against LB and COST. Checked at 6000 K. $ PAR L(LIQUID,MO,TI;0),, -9000+2*T;,, N 98Sau3 ! $ PAR L(BCC_A2,MO,TI:VA;0),, +2000;,, N 98Sau3 ! PAR L(BCC_A2,MO,TI:VA;1),, -2000;,, N 98Sau3 ! $ PAR L(A2_BCC,MO,TI:VA;0),, +2000;,, N 98Sau3 ! PAR L(A2_BCC,MO,TI:VA;1),, -2000;,, N 98Sau3 ! $ PAR L(HCP_A3,MO,TI:VA;0),, +22760-6*T;,, N 98Sau3 ! $ $ Metastable $ PAR L(FCC_A1,MO,TI:VA;0),, +16500;,, N 98Sau3 ! PAR L(A1_FCC,MO,TI:VA;0),, +16500;,, N 98Sau3 ! $ PAR G(C14_LAVES,MO:TI),, +2*GHSERMO+GHSERTI+87800;,, N Lin ! PAR G(C14_LAVES,TI:MO),, +2*GHSERTI+GHSERMO+66400;,, N Lin ! $ PAR G(SIGMA_D8B,MO:MO:TI),, +10*GFCCMO+4*GHSERMO +16*GBCCTI;,, N Lin ! PAR G(SIGMA_D8B,MO:TI:MO),, +10*GFCCMO+4*GBCCTI +16*GHSERMO;,, N Lin ! PAR G(SIGMA_D8B,MO:TI:TI),, +10*GFCCMO+20*GBCCTI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mo-V $ $ From J. Bratberg and K. Frisk 2002 (included in LB Vol. 5) $ $ J. Bratberg, K. Frisk, Calphad, 26, 459-76(2002). $ $ Checked against LB and paper. Checked at 6000 K. $ $ There is a miscibility gap in bcc below 1158 K, which is not experimentally $ verified. $ PAR L(LIQUID,MO,V;0),, +17784;,, N 02Bra ! $ PAR L(BCC_A2,MO,V:VA;0),, +19245;,, N 02Bra ! PAR L(A2_BCC,MO,V:VA;0),, +19245;,, N 02Bra ! $ $ metastable $ PAR L(FCC_A1,MO,V:VA;0),, +ZERO;,, N 02Bra ! PAR L(A1_FCC,MO,V:VA;0),, +ZERO;,, N 02Bra ! PAR L(HCP_A3,MO,V:VA;0),, +ZERO;,, N 02Bra ! PAR L(MC_ETA,MO,V:VA;0),, +ZERO;,, N 02Bra ! $ PAR G(C14_LAVES,MO:V),, +2*GHSERMO+GHSERVV+85130;,, N Lin ! PAR G(C14_LAVES,V:MO),, +2*GHSERVV+GHSERMO;,, N Lin ! $ PAR G(MU_D85,V:MO:MO:MO),, +GFCCVV+6*GHSERMO+6*GFCCMO;,, N Lin ! PAR G(MU_D85,V:MO:MO:V),, +7*GFCCVV+6*GHSERMO;,, N Lin ! PAR G(MU_D85,V:MO:V:MO),, +GFCCVV+4*GHSERMO+2*GHSERVV +6*GFCCMO;,, N Lin ! PAR G(MU_D85,V:MO:V:V),, +7*GFCCVV+4*GHSERMO +2*GHSERVV;,, N Lin ! $ PAR G(SIGMA_D8B,MO:MO:V),, +10*GFCCMO+4*GHSERMO +16*GHSERVV+100000;,, N Lin ! PAR G(SIGMA_D8B,MO:V:MO),, +10*GFCCMO+4*GHSERVV +16*GHSERMO+100000;,, N Lin ! PAR G(SIGMA_D8B,MO:V:V),, +10*GFCCMO+20*GHSERVV +100000;,, N Lin ! PAR G(SIGMA_D8B,V:MO:MO),, +10*GFCCVV+20*GHSERMO +100000;,, N Lin ! PAR G(SIGMA_D8B,V:MO:V),, +10*GFCCVV+4*GHSERMO +16*GHSERVV+100000;,, N Lin ! PAR G(SIGMA_D8B,V:V:MO),, +10*GFCCVV+4*GHSERVV +16*GHSERMO+100000;,, N Lin ! $ ------------------------------------------------------------------------------ $ Nb-C $ $ From B.-J. Lee 2001 (Included in TCFE 1999) $ $ B.-J. Lee, Metall. Mater. Trans. A, 32A, 2423-39(2001). $ $ Checked against paper. Checked at 6000K. $ $ The congruent melting temperature of NbC is 2 K lower than in the paper. $ $ The BCC_A2 phase was modified by A.V. Khvan and B. Hallstedt to avoid an $ an inverse stability range for this phase. $ PAR L(LIQUID,C,NB;0),, -292831+31.2967*T;,, N 01Lee ! PAR L(LIQUID,C,NB;1),, +6091;,, N 01Lee ! PAR L(LIQUID,C,NB;2),, +41021;,, N 01Lee ! $ PAR G(FCC_A1,NB:C),, -156735+284.1689*T -46.34274*T*LN(T)-0.0029287*T**2+563374*T**(-1) -1.02788144E+09*T**(-3);,, N 01Lee ! PAR L(FCC_A1,NB:C,VA;0),, -94050+22.6993*T;,, N 01Lee ! PAR L(FCC_A1,NB:C,VA;2),, -65000+17.4391*T;,, N 01Lee ! $ PAR G(A1_FCC,NB:C),, -156735+284.1689*T -46.34274*T*LN(T)-0.0029287*T**2+563374*T**(-1) -1.02788144E+09*T**(-3);,, N 01Lee ! PAR L(A1_FCC,NB:C,VA;0),, -94050+22.6993*T;,, N 01Lee ! PAR L(A1_FCC,NB:C,VA;2),, -65000+17.4391*T;,, N 01Lee ! $ PAR G(BCC_A2,NB:C),, +GHSERNB+3*GHSERCC +446349;,, N 13Khv1 ! PAR L(BCC_A2,NB:C,VA;0),, -510296-70*T;,, N 13Khv1 ! $PAR G(BCC_A2,NB:C),, +GHSERNB+3*GHSERCC $ +446349-70*T;,, N 01Lee ! $PAR L(BCC_A2,NB:C,VA;0),, -510296;,, N 01Lee ! $ PAR G(A2_BCC,NB:C),, +GHSERNB+3*GHSERCC +446349;,, N 13Khv1 ! PAR L(A2_BCC,NB:C,VA;0),, -510296-70*T;,, N 13Khv1 ! $ PAR G(HCP_A3,NB:C),, -103175+206.3004*T -34.986618*T*LN(T)-0.002897*T**2+252376*T**(-1) -58298590*T**(-3);,, N 01Lee ! PAR L(HCP_A3,NB:C,VA;0),, +4735;,, N 01Lee ! $ $ Metastable $ $PAR G(CEMENTITE_D011,NB:C),, +3*GHSERNB+GHSERCC-86000;,, N 90Hua3 ! PAR G(CEMENTITE_D011,NB:C),, +3*GHSERNB+GHSERCC+137491;,, N 12Khv1! PAR G(M7C3_D101,NB:C),, +7*GHSERNB+3*GHSERCC +151964;,, N 12Khv1! PAR G(M5C2,NB:C),, +5*GHSERNB+2*GHSERCC -110958;,, N 12Khv1! $PAR G(M23C6_D84,NB:NB:C),, +UN_ASS;,, N ! PAR G(MC_ETA,NB:C),, +GHSERNB+GHSERCC+15000;,, N 15Zha1 ! $ ------------------------------------------------------------------------------ $ Nb-N $ $ A.V. Khvan, B. Hallstedt, Calphad, 40, 10-15(2013). $ $ Checked against paper. Checked at 6000 K. $ $ Modified from W. Huang 1996. The bcc stability problem was solved by using $ ugly parameters. However, the bcc phase is still stable above 4000 K around $ x(N)=0.5 (when gas is not included). $ PAR L(LIQUID,N,NB;0),, -292101;,, N 96Hua ! PAR L(LIQUID,N,NB;1),, -105406;,, N 96Hua ! $ PAR G(FCC_A1,NB:N),, +GHSERNB+GHSERNN -227779+120.567*T-4*T*LN(T);,, N 96Hua ! PAR L(FCC_A1,NB:N,VA;0),, -65218;,, N 96Hua ! $ PAR G(A1_FCC,NB:N),, +GHSERNB+GHSERNN -227779+120.567*T-4*T*LN(T);,, N 96Hua ! PAR L(A1_FCC,NB:N,VA;0),, -65218;,, N 96Hua ! $ PAR G(BCC_A2,NB:N),, +GHSERNB+3*GHSERNN +4273902-324.302*T;,, N 13Khv1 ! PAR L(BCC_A2,NB:N,VA;0),, -6778349+577.778*T;,, N 13Khv1 ! PAR L(BCC_A2,NB:N,VA;1),, -1917408;,, N 13Khv1 ! $ PAR G(A2_BCC,NB:N),, +GHSERNB+3*GHSERNN +4273902-324.302*T;,, N 13Khv1 ! PAR L(A2_BCC,NB:N,VA;0),, -6778349+577.778*T;,, N 13Khv1 ! PAR L(A2_BCC,NB:N,VA;1),, -1917408;,, N 13Khv1 ! $ PAR G(HCP_A3,NB:N),, +GHSERNB+0.5*GHSERNN -135568+59.295*T-2*T*LN(T);,, N 96Hua ! PAR L(HCP_A3,NB:N,VA;0),, +ZERO;,, N 96Hua ! $ ------------------------------------------------------------------------------ $ Nb-Ni $ $ H. Chen, Y. Du, Calphad, 30, 308-15(2006). $ $ Checked against paper. Checked at 6000K. $ $ Changed lattice stability G(MU_D85,NB:NB:NB:NB). $ There is a slight change in the shape of the MU_D85 phase field $ on the Nb-rich side and a slightly higher peritectic temperature (1572 K $ instead of 1564 K). $ PAR L(LIQUID,NB,NI;0),, -74555-12.00495*T;,, N 06Che ! PAR L(LIQUID,NB,NI;1),, +31039+19*T;,, N 06Che ! PAR L(LIQUID,NB,NI;2),, +42510-28.68081*T;,, N 06Che ! $ PAR L(FCC_A1,NB,NI:VA;0),, -36499-15.24689*T;,, N 06Che ! PAR L(FCC_A1,NB,NI:VA;1),, +94812;,, N 06Che ! PAR TC(FCC_A1,NB,NI:VA;0),, -1200;,, N 96Bol ! PAR TC(FCC_A1,NB,NI:VA;1),, +760;,, N 96Bol ! $ PAR L(A1_FCC,NB,NI:VA;0),, -36499-15.24689*T;,, N 06Che ! PAR L(A1_FCC,NB,NI:VA;1),, +94812;,, N 06Che ! PAR TC(A1_FCC,NB,NI:VA;0),, -1200;,, N 96Bol ! PAR TC(A1_FCC,NB,NI:VA;1),, +760;,, N 96Bol ! $ PAR L(BCC_A2,NB,NI:VA;0),, -22463+4.89296*T;,, N 06Che ! PAR L(A2_BCC,NB,NI:VA;0),, -22463+4.89296*T;,, N 06Che ! $ PAR G(MU_D85,NB:NB:NB:NI),, +7*GHSERNB+6*GHSERNI -285506;,, N 06Che ! PAR G(MU_D85,NB:NB:NI:NB),, +11*GHSERNB+2*GHSERNI +517348;,, N 06Che ! PAR G(MU_D85,NB:NB:NI:NI),, +5*GHSERNB+8*GHSERNI +166842;,, N 06Che ! PAR G(MU_D85,NI:NB:NB:NB),, +12*GHSERNB+GHSERNI+269698;,, N 06Che ! PAR G(MU_D85,NI:NB:NB:NI),, +6*GHSERNB+7*GHSERNI -80808;,, N 06Che ! PAR G(MU_D85,NI:NB:NI:NB),, +10*GHSERNB+3*GHSERNI +722046;,, N 06Che ! PAR G(MU_D85,NI:NB:NI:NI),, +4*GHSERNB+9*GHSERNI +371540;,, N 06Che ! PAR L(MU_D85,NB,NI:NB:NB:NB;0),, -286806;,, N 06Che ! PAR L(MU_D85,NB,NI:NB:NB:NI;0),, -286806;,, N 06Che ! PAR L(MU_D85,NB,NI:NB:NI:NB;0),, -286806;,, N 06Che ! PAR L(MU_D85,NB,NI:NB:NI:NI;0),, -286806;,, N 06Che ! PAR L(MU_D85,NB:NB:NB,NI:NB;0),, -545207;,, N 06Che ! PAR L(MU_D85,NB:NB:NB,NI:NI;0),, -545207;,, N 06Che ! PAR L(MU_D85,NI:NB:NB,NI:NB;0),, -545207;,, N 06Che ! PAR L(MU_D85,NI:NB:NB,NI:NI;0),, -545207;,, N 06Che ! PAR L(MU_D85,NB:NB:NB:NB,NI;0),, -50000;,, N 17Hal7 ! PAR L(MU_D85,NB:NB:NI:NB,NI;0),, -50000;,, N 17Hal7 ! PAR L(MU_D85,NI:NB:NB:NB,NI;0),, -50000;,, N 17Hal7 ! PAR L(MU_D85,NI:NB:NI:NB,NI;0),, -50000;,, N 17Hal7 ! $ PAR G(NBNI3_D0A,NB:NI),, +GHSERNB+3*GHSERNI -123184+5.8664*T;,, N 06Che ! PAR G(NBNI3_D0A,NI:NB),, +GHSERNI+3*GHSERNB +163184-5.8664*T;,, N 06Che ! PAR L(NBNI3_D0A,NB,NI:NB;0),, -2480;,, N 06Che ! PAR L(NBNI3_D0A,NB,NI:NI;0),, -2480;,, N 06Che ! PAR L(NBNI3_D0A,NB:NB,NI;0),, +64712;,, N 06Che ! PAR L(NBNI3_D0A,NI:NB,NI;0),, +64712;,, N 06Che ! $ PAR G(NBNI8,NB:NI),, +GHSERNB+8*GHSERNI -128556+4.54104*T;,, N 06Che ! $ $ Metastable $ PAR L(HCP_A3,NB,NI:VA;0),, -36499-15.24689*T;,, N Same ! PAR L(HCP_A3,NB,NI:VA;1),, +94812;,, N Same ! $ PAR G(C14_LAVES,NB:NI),, +2*GHSERNB+GHSERNI+51980;,, N Lin ! PAR G(C14_LAVES,NI:NB),, +2*GHSERNI+GHSERNB;,, N Lin ! $ PAR G(SIGMA_D8B,NI:NB:NB),, +10*GHSERNI+20*GHSERNB;,, N Lin ! PAR G(SIGMA_D8B,NI:NB:NI),, +10*GHSERNI+4*GHSERNB +16*GBCCNI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Nb-Si $ $ T. Geng, C. Li, J. Bao, X. Zhao, Z. Du, C. Guo, $ Intermetallics, 17, 343-57(2009). $ $ Checked against paper. Checked at 6000K. $ $ Parameters are very similar to those of 02Fer. $ PAR L(LIQUID,NB,SI;0),, -199000;,, N 09Gen ! PAR L(LIQUID,NB,SI;1),, -18800;,, N 09Gen ! PAR L(LIQUID,NB,SI;2),, +50000;,, N 09Gen ! $ PAR L(BCC_A2,NB,SI:VA;0),, -151178;,, N 09Gen ! PAR L(BCC_A2,NB,SI:VA;1),, -15915;,, N 09Gen ! PAR L(BCC_A2,NB,SI:VA;2),, +40000;,, N 09Gen ! $ PAR L(A2_BCC,NB,SI:VA;0),, -151178;,, N 09Gen ! PAR L(A2_BCC,NB,SI:VA;1),, -15915;,, N 09Gen ! PAR L(A2_BCC,NB,SI:VA;2),, +40000;,, N 09Gen ! $ PAR G(NB3SI,NB:SI),, +3*GHSERNB+GHSERSI -133428-25.8*T;,, N 09Gen ! $ PAR G(NB5SI3_D8L,NB:SI),, +5*GHSERNB+3*GHSERSI -504010.8-23.2*T;,, N 09Gen ! PAR L(NB5SI3_D8L,NB,SI:SI;0),, -97808;,, N 09Gen ! $ PAR G(NB5SI3_D8M,NB:NB:SI),, +5*GHSERNB+3*GHSERSI -405092-68*T;,, N 09Gen ! PAR G(NB5SI3_D8M,NB:SI:SI),, +4*GHSERNB+4*GHSERSI -146496-122.2688*T;,, N 09Gen ! PAR L(NB5SI3_D8M,NB:NB,SI:SI;0),, -194544;,, N 09Gen ! $ PAR G(NBSI2_C40,NB:SI),, +GHSERNB+2*GHSERSI -153600-15*T;,, N 09Gen ! PAR L(NBSI2_C40,NB,SI:SI;0),, +38757+12.7986*T;,, N 09Gen ! $ $ Metastable $ PAR L(FCC_A1,NB,SI:VA;0),, -151178;,, N Same ! PAR L(FCC_A1,NB,SI:VA;1),, -15915;,, N Same ! PAR L(FCC_A1,NB,SI:VA;2),, +40000;,, N Same ! $ PAR L(A1_FCC,NB,SI:VA;0),, -151178;,, N Same ! PAR L(A1_FCC,NB,SI:VA;1),, -15915;,, N Same ! PAR L(A1_FCC,NB,SI:VA;2),, +40000;,, N Same ! $ PAR L(HCP_A3,NB,SI:VA;0),, -151178;,, N Same ! PAR L(HCP_A3,NB,SI:VA;1),, -15915;,, N Same ! PAR L(HCP_A3,NB,SI:VA;2),, +40000;,, N Same ! $ PAR G(C14_LAVES,NB:SI),, +2*GHSERNB+GHSERSI+121144;,, N 17Jac ! $PAR G(C14_LAVES,SI:NB),, +2*GHSERSI+GHSERNB $ +3400+35*T;,, N 17Jac ! PAR G(C14_LAVES,SI:NB),, +2*GHSERSI+GHSERNB-18510;,, N 16Jac2 ! $ PAR G(MU_D85,NB:NB:NB:SI),, +7*GHSERNB+6*GHSERSI -424026;,, N 16Jac2 ! PAR G(MU_D85,NB:NB:SI:NB),, +11*GHSERNB+2*GHSERSI +112710;,, N 16Jac2 ! PAR G(MU_D85,NB:NB:SI:SI),, +5*GHSERNB+8*GHSERSI -214240;,, N 16Jac2 ! PAR G(MU_D85,SI:NB:NB:NB),, +12*GHSERNB+GHSERSI +61326;,, N 16Jac2 ! PAR G(MU_D85,SI:NB:NB:SI),, +6*GHSERNB+7*GHSERSI -290703;,, N 16Jac2 ! PAR G(MU_D85,SI:NB:SI:NB),, +10*GHSERNB+3*GHSERSI -16640;,, N 16Jac2 ! PAR G(MU_D85,SI:NB:SI:SI),, +4*GHSERNB+9*GHSERSI -27040;,, N 16Jac2 ! $ ------------------------------------------------------------------------------ $ Nb-Ti $ $ From Y. Zhang et al. 2001 (Included in LB Vol. 4) $ $ Y. Zhang, H. Liu, Z. Jin, Calphad, 25, 305-17(2001). $ $ Checked against LB. Checked at 6000K. $ $ Original dataset includes the metastable (at normal pressure) omega phase. $ PAR L(LIQUID,NB,TI;0),, +7406.1;,, N 01Zha ! $ PAR L(BCC_A2,NB,TI:VA;0),, +13045.3;,, N 01Zha ! PAR L(A2_BCC,NB,TI:VA;0),, +13045.3;,, N 01Zha ! $ PAR L(HCP_A3,NB,TI:VA;0),, +11742.4;,, N 01Zha ! $ $PAR L(OMEGA_C32,NB,TI;0),, -3775.9;,, N 01Zha ! $ $ Metastable $ PAR L(FCC_A1,NB,TI:VA;0),, +11742.4;,, N Same ! PAR L(A1_FCC,NB,TI:VA;0),, +11742.4;,, N Same ! $ PAR G(C14_LAVES,NB:TI),, +2*GHSERNB+GHSERTI+48080;,, N Lin ! PAR G(C14_LAVES,TI:NB),, +2*GHSERTI+GHSERNB+46540;,, N Lin ! $ PAR G(MU_D85,NB:NB:TI:NB),, +7*GFCCNB+4*GHSERNB +2*GBCCTI;,, N Lin ! PAR G(MU_D85,NB:TI:NB:NB),, +7*GFCCNB+4*GBCCTI +2*GHSERNB;,, N Lin ! PAR G(MU_D85,NB:TI:TI:NB),, +7*GFCCNB+6*GBCCTI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Nb-V $ $ From K.C. Hari Kumar et al. 1994 (Included in LB Vol. 4) $ $ K.C. Hari Kumar, P. Wollants, L. Delaey, Calphad, 18, 71-79(1994). $ $ Checked against paper and LB. Checked at 6000K. $ PAR L(LIQUID,NB,V;0),, -1875;,, N 94Har ! $ PAR L(BCC_A2,NB,V:VA;0),, +9080;,, N 94Har ! PAR L(A2_BCC,NB,V:VA;0),, +9080;,, N 94Har ! $ $ Metastable $ PAR L(FCC_A1,NB,V:VA;0),, +9080;,, N Same ! PAR L(A1_FCC,NB,V:VA;0),, +9080;,, N Same ! $ PAR L(HCP_A3,NB,V:VA;0),, +9080;,, N 94Har ! $ PAR G(C14_LAVES,NB:V),, +2*GHSERNB+GHSERVV+147190;,, N 13Khv2 ! PAR G(C14_LAVES,V:NB),, +2*GHSERVV+GHSERNB +29427-17.627*T;,, N 13Khv2 ! $ PAR G(MU_D85,NB:NB:NB:V),, +7*GHSERNB+6*GHSERVV +103339;,, N 13Khv2 ! PAR G(MU_D85,NB:NB:V:NB),, +11*GHSERNB+2*GHSERVV +438296;,, N 13Khv2 ! PAR G(MU_D85,NB:NB:V:V),, +5*GHSERNB+8*GHSERVV +157578;,, N 13Khv2 ! PAR G(MU_D85,V:NB:NB:NB),, +12*GHSERNB+GHSERVV +395871;,, N 13Khv2 ! PAR G(MU_D85,V:NB:NB:V),, +6*GHSERNB+7*GHSERVV +834518;,, N 13Khv2 ! PAR G(MU_D85,V:NB:V:NB),, +10*GHSERNB+3*GHSERVV +502985;,, N 13Khv2 ! PAR G(MU_D85,V:NB:V:V),, +4*GHSERNB+9*GHSERVV +154133;,, N 13Khv2 ! $ PAR G(SIGMA_D8B,V:NB:NB),, +20*GHSERNB+10*GHSERVV +830734;,, N 13Khv2 ! PAR G(SIGMA_D8B,V:NB:V),, +4*GHSERNB+26*GHSERVV +313770;,, N 13Khv2 ! PAR G(SIGMA_D8B,V:V:NB),, +14*GHSERVV+16*GHSERNB +812161;,, N 13Khv2 ! $ ------------------------------------------------------------------------------ $ Ni-C $ $ B. Hallstedt, unpublished, 2006 $ $ Checked at 6000 K. $ $ Liquid interaction adjusted to exp. data from Oden and Gokcen 1997. $ $ The parameter G(BCC_A2,NI:C) was set temperature independent to $ avoid inverse stability of bcc (equal to 87Gab at about 1273K). $ PAR L(LIQUID,C,NI;0),, -93450+24*T;,, N 06Hal2 ! $ PAR G(FCC_A1,NI:C),, +GHSERNI+GHSERCC +62000-7.6*T;,, N 92Fer ! PAR TC(FCC_A1,NI:C),, 633.00;,, N 87Gab ! PAR BMAG(FCC_A1,NI:C),, 0.52;,, N 87Gab ! PAR L(FCC_A1,NI:C,VA;0),, -14902+7.5*T;,, N 92Lee1 ! $ PAR G(A1_FCC,NI:C),, +GHSERNI+GHSERCC +62000-7.6*T;,, N 92Fer ! PAR TC(A1_FCC,NI:C),, 633.00;,, N 87Gab ! PAR BMAG(A1_FCC,NI:C),, 0.52;,, N 87Gab ! PAR L(A1_FCC,NI:C,VA;0),, -14902+7.5*T;,, N 92Lee1 ! $ $ Metastable $ PAR G(BCC_A2,NI:C),, +GHSERNI+3*GHSERCC +270000;,, N 06Hal2 ! PAR TC(BCC_A2,NI:C),, 575.00;,, N 87Gab ! PAR BMAG(BCC_A2,NI:C),, 0.85;,, N 87Gab ! $ PAR G(A2_BCC,NI:C),, +GHSERNI+3*GHSERCC +270000;,, N 06Hal2 ! PAR TC(A2_BCC,NI:C),, 575.00;,, N 87Gab ! PAR BMAG(A2_BCC,NI:C),, 0.85;,, N 87Gab ! $ PAR G(HCP_A3,NI:C),, +GHSERNI+0.5*GHSERCC +34796+2.665*T;,, N 88Fer3 ! PAR TC(HCP_A3,NI:C),, 633.00;,, N 88Fer3 ! PAR BMAG(HCP_A3,NI:C),, 0.52;,, N 88Fer3 ! $ PAR G(CEMENTITE_D011,NI:C),, +3*GHSERNI+GHSERCC +34700-20*T;,, N 87Gab ! PAR G(M7C3_D101,NI:C),, +7*GHSERNI+3*GHSERCC +198000-37*T;,, N 06Hal3 ! PAR G(M23C6_D84,NI:NI:C),, +GNI23C6;,, N 06Hal3 ! $ FUNCTION GNI23C6 298.15 +23*GHSERNI+6*GHSERCC+350000-85*T; 6000 N ! $ ------------------------------------------------------------------------------ $ Ni-N $ $ From A. Fernandez Guillermet and K. Frisk 1991 (included in LB Vol. 4) $ $ A. Fernandez Guillermet, K. Frisk, Int. J. Thermophys., 12, 417-31(1991). $ $ Checked against LB and paper. Checked at 6000 K. $ $ In LB this dataset is incorrectly attributed to 91Fri2. $ PAR L(LIQUID,N,NI;0),, +14981;,, N 91Fer1 ! $ PAR G(FCC_A1,NI:N),, +GHSERNI+GHSERNN +38680+143.09*T-10.9*T*LN(T)+0.00438*T**2;,, N 91Fer1 ! $ PAR G(A1_FCC,NI:N),, +GHSERNI+GHSERNN +38680+143.09*T-10.9*T*LN(T)+0.00438*T**2;,, N 91Fer1 ! $ PAR G(HCP_A3,NI:N),, +GHSERNI+0.5*GHSERNN -4409.6+72.93*T-7.36*T*LN(T)+0.00614*T**2;,, N 91Fer1 ! $ $ metastable $ PAR G(BCC_A2,NI:N),, +GHSERNI+3*GHSERNN +200000+200*T;,, N 91Fri2 ! PAR TC(BCC_A2,NI:N),, +575;,, N 91Fri2 ! PAR BMAG(BCC_A2,NI:N),, +0.85;,, N 91Fri2 ! $ PAR G(A2_BCC,NI:N),, +GHSERNI+3*GHSERNN +200000+200*T;,, N 91Fri2 ! PAR TC(A2_BCC,NI:N),, +575;,, N 91Fri2 ! PAR BMAG(A2_BCC,NI:N),, +0.85;,, N 91Fri2 ! $ PAR G(FE4N_L1,NI:N),, +4*GHSERNI+GHSERNN -5393+142.97*T-15.65*T*LN(T)+0.0154*T**2;,, N 91Fer1 ! $ ------------------------------------------------------------------------------ $ Ni-Si $ $ Y. Du, J.C. Schuster, Metall. Mater. Trans. A, 30A, 2409-18(1999). $ $ Checked against paper, checked at 6000 K. $ $ There two! inverse miscibility gaps; one at x(Si)=0.35, T>5600 K, $ another at x(Si)=0.92, T>2900 $ $ Misprint in paper: their L(LIQUID,NI,SI;2) is L(LIQUID,NI,SI;3) $ $ There are up to 3 K differences in invariant equilibria involving $ Ni2Si-theta. $ $ The L12_FCC model cannot be converted to FCC_4SL without changing parameter $ values. With the current parameters L10 becomes a stable phase. If the $ parameters from 12Yua for NiSi_L10 and NiSi3_L12 are used Ni3Si_L12 is far $ too stable. The 99Du parameters were adjusted. There is then a slight change $ in the Ni3Si_L12 phase field. $ PAR L(LIQUID,NI,SI;0),, -205176.85+33.40446*T;,, N 99Du ! PAR L(LIQUID,NI,SI;1),, -114240.82+20.34156*T;,, N 99Du ! PAR L(LIQUID,NI,SI;2),, +ZERO;,, N 99Du ! PAR L(LIQUID,NI,SI;3),, +116695.857-53.88609*T;,, N 99Du ! $ PAR L(FCC_A1,NI,SI:VA;0),, -204564.5+38.99204*T;,, N 99Du ! PAR L(FCC_A1,NI,SI:VA;1),, -82289.61;,, N 99Du ! $ PAR L(A1_FCC,NI,SI:VA;0),, -204564.5+38.99204*T;,, N 99Du ! PAR L(A1_FCC,NI,SI:VA;1),, -82289.61;,, N 99Du ! $ $PAR G(FCC_4SL,NI:NI:NI:SI:VA),, -35712+11.07*T;,, N 12Yua ! PAR G(FCC_4SL,NI:NI:NI:SI:VA),, -28245+6*T;,, N 17Hal13 ! PAR G(FCC_4SL,NI:NI:SI:SI:VA),, +7649.4;,, N 12Yua ! PAR G(FCC_4SL,NI:SI:SI:SI:VA),, +37790.1;,, N 12Yua ! PAR L(FCC_4SL,NI,SI:*:*:*:VA;1),, -8886.4+3.6585*T;,, N 12Yua ! PAR L(FCC_4SL,NI,SI:NI,SI:*:*:VA;0),, -25458.8;,, N 12Yua ! $ PAR G(NI3SI_M,NI:SI),, +3*GHSERNI+GHSERSI -144506.1-9.63044*T;,, N 99Du ! PAR G(NI3SI_H,NI:SI),, +3*GHSERNI+GHSERSI -143815.8-10.12344*T;,, N 99Du ! PAR G(NI5SI2,NI:SI),, +5*GHSERNI+2*GHSERSI -303488.9+2.32414*T;,, N 99Du ! PAR G(NI2SI_C37,NI:SI),, +2*GHSERNI+GHSERSI -128241.1-5.47659*T;,, N 99Du ! $ PAR G(NI2SI_THETA,NI:NI:SI),, +2*GHSERNI+GHSERSI -124473.6-7.83186*T;,, N 99Du ! PAR G(NI2SI_THETA,NI:VA:SI),, +GHSERNI+GHSERSI -77347.09+1.49818*T;,, N 99Du ! PAR L(NI2SI_THETA,NI:NI,VA:SI;0),, +17973.42;,, N 99Du ! $ PAR G(NI3SI2,NI:SI),, +3*GHSERNI+2*GHSERSI -217858.8+3.90115*T;,, N 99Du ! PAR G(NISI_B31,NI:SI),, +GHSERNI+GHSERSI -76423.44-1.84188*T;,, N 99Du ! PAR G(NISI2_C1,NI:SI),, +GHSERNI+2*GHSERSI -94542.19+11.29221*T;,, N 99Du ! $ $ metastable $ PAR L(BCC_A2,NI,SI:VA;0),, -204564.5+38.99204*T;,, N Same ! PAR L(BCC_A2,NI,SI:VA;1),, -82289.61;,, N Same ! $ PAR L(A2_BCC,NI,SI:VA;0),, -204564.5+38.99204*T;,, N Same ! PAR L(A2_BCC,NI,SI:VA;1),, -82289.61;,, N Same ! $ PAR L(HCP_A3,NI,SI:VA;0),, -204564.5+38.99204*T;,, N Same ! PAR L(HCP_A3,NI,SI:VA;1),, -82289.61;,, N Same ! $ PAR L(CBCC_A12,NI,SI:VA;0),, -204564.5+38.99204*T;,, N Same ! PAR L(CBCC_A12,NI,SI:VA;1),, -82289.61;,, N Same ! $ PAR L(CUB_A13,NI,SI:VA;0),, -204564.5+38.99204*T;,, N Same ! PAR L(CUB_A13,NI,SI:VA;1),, -82289.61;,, N Same ! $ PAR G(C14_LAVES,NI:SI),, +2*GHSERNI+GHSERSI+85260;,, N Lin ! PAR G(C14_LAVES,SI:NI),, +2*GHSERSI+GHSERNI+113820;,, N Lin ! $ PAR G(CR3SI_A15,NI:SI:VA),, +3*GHSERNI+GHSERSI-30000;,, N 00Sch ! PAR G(M4SI3,NI:SI),, +4*GHSERNI+3*GHSERSI -285000+9.93391*T;,, N 00Sch ! PAR G(MSI_B20,NI:SI),, +GHSERNI+GHSERSI -74500+1.2949*T;,, N 00Sch ! $ ------------------------------------------------------------------------------ $ Ni-Ti $ $ From P. Bellen et al. 1996 (included in LB Vol. 4) $ $ P. Bellen, K.C. Hari Kumar, P. Wollants, Z. Metallkd., 87, 972-78(1996). $ $ Checked against LB and paper. Checked at 6000 K. $ $ Fcc and NiTi2 modified by N. Dupin (00Dup and 99Dup2). $ Ti removed from the first sublattice of NI3TI_D024. $ $ NI3TI_D024 reappears above 1916 K at x(Ti)=0.097. This covers an inverse $ miscibility gap in the liquid with a minimum at 4981 K and x(Ti)=0.41. $ $ The LB/00Dup version of the fcc-Ni solvus is quite different from the paper $ at low temperature with a much lower Ti solubility. At high temperature $ the differences are minimal. In the LB/00Dup version there is a metastable $ miscibility gap in fcc close to Ni with a maximum just below 600 K. $ The original fcc is considerably more well behaved. $ PAR L(LIQUID,NI,TI;0),, -153707+34.8594*T;,, N 96Bel ! PAR L(LIQUID,NI,TI;1),, -81824.8+25.8099*T;,, N 96Bel ! PAR L(LIQUID,NI,TI;2),, -10.0779*T;,, N 96Bel ! $ PAR L(FCC_A1,NI,TI:VA;0),, -125000+22.62*T;,, N 00Dup ! PAR L(FCC_A1,NI,TI:VA;1),, -84260+5.77*T;,, N 00Dup ! PAR L(FCC_A1,NI,TI:VA;2),, +95730-46.45*T;,, N 00Dup ! PAR TC(FCC_A1,NI,TI:VA;0),, -4670;,, N 96Bel ! $ Original fcc parameters from Bellen below $PAR L(FCC_A1,NI,TI:VA;0),, -99290.4+6.21142*T;,, N 96Bel ! $PAR L(FCC_A1,NI,TI:VA;1),, -59449.5;,, N 96Bel ! $ PAR L(A1_FCC,NI,TI:VA;0),, -125000+22.62*T;,, N 00Dup ! PAR L(A1_FCC,NI,TI:VA;1),, -84260+5.77*T;,, N 00Dup ! PAR L(A1_FCC,NI,TI:VA;2),, +95730-46.45*T;,, N 00Dup ! PAR TC(A1_FCC,NI,TI:VA;0),, -4670;,, N 96Bel ! $ PAR L(BCC_A2,NI,TI:VA;0),, -97427.4+12.112*T;,, N 96Bel ! PAR L(BCC_A2,NI,TI:VA;1),, -32315.3;,, N 96Bel ! $ PAR L(A2_BCC,NI,TI:VA;0),, -97427.4+12.112*T;,, N 96Bel ! PAR L(A2_BCC,NI,TI:VA;1),, -32315.3;,, N 96Bel ! $ PAR G(B2_BCC,NI:TI:VA;0),, -33193.7+10.284*T;,, N 96Bel ! PAR G(B2_BCC,TI:NI:VA;0),, -33193.7+10.284*T;,, N 96Bel ! PAR L(B2_BCC,NI,TI:NI:VA;0),, -55288.8+25.4416*T;,, N 96Bel ! PAR L(B2_BCC,NI,TI:NI:VA;2),, +6010.11+3.95974*T;,, N 96Bel ! PAR L(B2_BCC,NI:NI,TI:VA;0),, -55288.8+25.4416*T;,, N 96Bel ! PAR L(B2_BCC,NI:NI,TI:VA;2),, +6010.11+3.95974*T;,, N 96Bel ! PAR L(B2_BCC,TI:NI,TI:VA;0),, +60723.7-15.4024*T;,, N 96Bel ! PAR L(B2_BCC,NI,TI:TI:VA;0),, +60723.7-15.4024*T;,, N 96Bel ! $ PAR L(HCP_A3,NI,TI:VA;0),, -20000;,, N 96Bel ! $ PAR G(NI3TI_D024,NI:TI),, +0.75*GHCPNI+0.25*GHSERTI -39435.7+4.66357*T;,, N 96Bel ! PAR L(NI3TI_D024,NI:NI,TI;0),, +56040.9-41.6971*T;,, N 96Bel ! PAR L(NI3TI_D024,NI:NI,TI;1),, +56197.1-38.2252*T;,, N 96Bel ! $ PAR G(NITI2,NI:TI),, +3*GNITI2;,, N 96Bel ! PAR G(NITI2,TI:NI),, +3*GHSERNI+3*GHSERTI+30000 -3*GNITI2;,, N 99Dup2 ! PAR L(NITI2,NI,TI:NI;0),, +60000;,, N 99Dup2 ! PAR L(NITI2,NI,TI:TI;0),, +60000;,, N 99Dup2 ! PAR L(NITI2,NI:NI,TI;0),, +60000;,, N 99Dup2 ! PAR L(NITI2,TI:NI,TI;0),, +60000;,, N 99Dup2 ! $ $ metastable $ PAR G(C14_LAVES,NI:TI),, +2*GHSERNI+GHSERTI;,, N Lin ! PAR G(C14_LAVES,TI:NI),, +2*GHSERTI+GHSERNI+48900;,, N Lin ! $ PAR G(MU_D85,NI:TI:NI:NI),, +7*GHSERNI+4*GBCCTI +2*GBCCNI;,, N Lin ! PAR G(MU_D85,NI:TI:TI:NI),, +7*GHSERNI+6*GBCCTI;,, N Lin ! $ PAR G(SIGMA_D8B,NI:TI:NI),, +10*GHSERNI+4*GBCCTI +16*GBCCNI;,, N Lin ! PAR G(SIGMA_D8B,NI:TI:TI),, +10*GHSERNI+20*GBCCTI;,, N Lin ! $ FUNCTION GNITI2 298.15 +0.333333*GHSERNI+0.666667*GHSERTI -27514.2+2.85345*T; 6000.00 N ! $ ------------------------------------------------------------------------------ $ Ni-V $ $ From J. Korb and K. Hack 1998 (included in LB Vol. 4) $ $ J. Korb, K. Hack, COST 507, Final report round 2, 1998. $ $ Checked against LB and COST. Checked at 6000 K. $ $ The model change for the sigma phase in LB leads to quite large shifts of $ the phase boundaries, in particular on the V-rich side. $ Invariant equilibria listed in COST are reproduced when SIGMA_OLD is used. $ $ NI3V_D022 is not stable below 386 K. $ PAR L(LIQUID,NI,V;0),, -51927+14.99*T;,, N 98Kor ! $ PAR L(BCC_A2,NI,V:VA;0),, -30513.8+12.6138*T;,, N 98Kor ! PAR L(A2_BCC,NI,V:VA;0),, -30513.8+12.6138*T;,, N 98Kor ! $ PAR L(FCC_A1,NI,V:VA;0),, -36365.6+3.75677*T;,, N 98Kor ! PAR L(FCC_A1,NI,V:VA;1),, +11860.7-9.0302*T;,, N 98Kor ! PAR L(FCC_A1,NI,V:VA;2),, -10647.5+7.00954*T;,, N 98Kor ! $ PAR L(A1_FCC,NI,V:VA;0),, -36365.6+3.75677*T;,, N 98Kor ! PAR L(A1_FCC,NI,V:VA;1),, +11860.7-9.0302*T;,, N 98Kor ! PAR L(A1_FCC,NI,V:VA;2),, -10647.5+7.00954*T;,, N 98Kor ! $ PAR G(NI3V_D022,NI:V),, -45524.96+529.01852*T -99.74166*T*LOG(T)-0.00824*T**2-13753.332*T**(-1);,, N 98Kor ! PAR G(NI2V1,NI:V),, -38032.065+337.2614*T -64.6973*T*LOG(T)-0.01512*T**2-13.75326*T**(-1);,, N 98Kor ! PAR G(NI2V7_A15,NI:V),, -190634.14+1333.90548*T -233.55668*T*LOG(T)-0.00482*T**2-5.196308E-06*T**3 +844557.21*T**(-1);,, N 98Kor ! $ PAR G(SIGMA_D8B,NI:V:NI),, +26*GHSERNI+4*GHSERVV +79717-127.17*T;,, N 02Sun ! PAR G(SIGMA_D8B,NI:V:V),, +10*GHSERNI+20*GHSERVV -450217+137.12*T;,, N 02Sun ! PAR G(SIGMA_D8B,V:V:NI),, +16*GHSERNI+14*GHSERVV +100000;,, N 02Sun ! $ $ metastable $ PAR L(HCP_A3,NI,V:VA;0),, -36365.6+3.75677*T;,, N Same ! PAR L(HCP_A3,NI,V:VA;1),, +11860.7-9.0302*T;,, N Same ! PAR L(HCP_A3,NI,V:VA;2),, -10647.5+7.00954*T;,, N Same ! $ PAR G(C14_LAVES,NI:V),, +2*GHSERNI+GHSERVV+50130;,, N Lin ! PAR G(C14_LAVES,V:NI),, +2*GHSERVV+GHSERNI+43560;,, N Lin ! $ ------------------------------------------------------------------------------ $ Si-C $ $ From J. Lacaze and B. Sundman 1991 (included in SGSOL V4.3) $ $ J. Lacaze, B. Sundman, Metall. Mater. Trans. A, 22A, 2211-23(1991). $ $ Checked against paper. Checked at 6000 K. $ $ In the paper reference is given to unpublished work by I. Ansara, 1989. $ $ If BCC_A2 is included, it is stable above 3900 K at about SiC composition. $ $ No phase diagram is shown in the paper. $ $ CBCC_A12 and CUB_A13 parameters should probably be removed. $ PAR L(LIQUID,C,SI;0),, -133000+30.97*T;,, N 91Lac ! $ PAR L(DIAMOND_A4,C,SI;0),, +ZERO;,, N 91Lac ! $ PAR G(SIC_B3,SI:C),, +GSIC;,, N 91Lac ! $ $ Metastable $ PAR G(FCC_A1,SI:C),, +GHSERSI+GHSERCC -20510+38.7*T;,, N 91Lac ! PAR L(FCC_A1,SI:C,VA;0),, +ZERO;,, N 91Lac ! $ PAR G(A1_FCC,SI:C),, +GHSERSI+GHSERCC -20510+38.7*T;,, N 91Lac ! PAR L(A1_FCC,SI:C,VA;0),, +ZERO;,, N 91Lac ! $ PAR G(BCC_A2,SI:C),, +GBCCSI+3*GHSERCC +322050-75.667*T;,, N 91Lac ! PAR L(BCC_A2,SI:C,VA;0),, +ZERO;,, N 91Lac ! $ PAR G(A2_BCC,SI:C),, +GBCCSI+3*GHSERCC +322050-75.667*T;,, N 91Lac ! PAR L(A2_BCC,SI:C,VA;0),, +ZERO;,, N 91Lac ! $ PAR G(HCP_A3,SI:C),, +GHSERSI+0.5*GHSERCC +UN_ASS;,, N ! PAR G(CBCC_A12,SI:C),, +1000000+566.0326*T -85.955678*T*LN(T)-0.007814909*T**2+3.7239E-07*T**3 +1688653*T**(-1);,, N 89NPL ! PAR G(CUB_A13,SI:C),, +1000000+566.0326*T -85.955678*T*LN(T)-0.007814909*T**2+3.7239E-07*T**3 +1688653*T**(-1);,, N 89NPL ! PAR G(CR3SI_A15,SI:SI:C),, +4*GHSERSI+3*GHSERCC;,, N 00Du2 ! $ FUNCTION GSIC 298.15 -85572.264+173.2005*T-25.856*T*LN(T) -0.02107*T**2+3.2153E-06*T**3+438415*T**(-1); 700.00 Y -95145.902+300.346*T-45.093*T*LN(T) -0.00367*T**2+2.2E-07*T**3+1341065*T**(-1); 2100.00 Y -105007.971+360.309*T-53.073*T*LN(T) -7.4525E-04*T**2+1.73167E-08*T**3+3693345*T**(-1); 6000.00 N ! $ ------------------------------------------------------------------------------ $ Si-N $ $ From X. Ma et al. 2003 (included in LB Vol. 5) $ $ X. Ma, C. Li, F. Wang, W. Zhang, Calphad, 27, 383-88(2003). $ $ Checked against LB and paper. Checked at 6000 K. $ $ Alpha- and beta-Si3N4 are assumed to have the same Gibbs energy. $ PAR L(LIQUID,N,SI;0),, -87631.311+22.359*T;,, N 03Ma ! $ PAR G(SI3N4,SI:N),, -788513.009+733.225*T -121.79*T*LN(T)-0.02065*T**2+6.9938E-07*T**3 +1666886.4*T**(-1);,, N 03Ma ! $ PAR G(GAS,SIN),, +F12915T+RTLNP;,, N 00SUB ! PAR G(GAS,SI2N),, +F12921T+RTLNP;,, N 00SUB ! $ $ SiN(g) FUNCTION F12915T 298.15 +373690.147-126.773849*T-11.48813*T*LN(T) -0.02760032*T**2+4.14460833E-06*T**3-201121*T**(-1); 900.00 Y +345651.105+184.200439*T-57.02462*T*LN(T) +0.005212695*T**2-2.80815333E-07*T**3+3030993*T**(-1); 3000.00 Y +401766.122-30.0990737*T-30.3733*T*LN(T) -6.13755E-04*T**2-3.30314167E-08*T**3-19797170*T**(-1); 5800.00 Y +397720.711-70.2315921*T-24.95975*T*LN(T) -0.0020519915*T**2+1.71382167E-08*T**3-543722*T**(-1); 6000.00 N ! $ Si2N(g) FUNCTION F12921T 298.15 +367551.162+68.9613567*T-47.11477*T*LN(T) -0.01410916*T**2+2.51869833E-06*T**3+190945.2*T**(-1); 800.00 Y +360363.442+166.768467*T-61.99726*T*LN(T) -8.395595E-05*T**2+2.98128167E-09*T**3+863651*T**(-1); 3400.00 Y +358195.746+179.731995*T-63.68676*T*LN(T) +4.0735635E-04*T**2-2.15632833E-08*T**3+1158715*T**(-1); 6000.00 N ! $ ------------------------------------------------------------------------------ $ Si-Ti $ $ From H.J. Seifert et al. 1996 (Included in LB Vol. 4) $ $ H.J. Seifert, H.L. Lukas, G. Petzow, Z. Metallkd., 87, 2-13(1996). $ $ Checked against LB and paper. Checked at 6000 K. $ $ In the paper there is also a version with stoichiometric Si3Ti5 and $ another with ionic liquid. The ionic liquid seems to yield a good $ description, but I could not interpret the parameters presented in the paper. $ PAR L(LIQUID,SI,TI;0),, -255852.17+21.87411*T;,, N 96Sei ! PAR L(LIQUID,SI,TI;1),, +25025.35-2.00203*T;,, N 96Sei ! PAR L(LIQUID,SI,TI;2),, +83940.65-6.71526*T;,, N 96Sei ! $ PAR L(BCC_A2,SI,TI:VA;0),, -275629.1+42.5094*T;,, N 96Sei ! PAR L(BCC_A2,SI,TI:VA;1),, +25025.35-2.00203*T;,, N 96Sei ! PAR L(BCC_A2,SI,TI:VA;2),, +83940.65-6.71526*T;,, N 96Sei ! $ PAR L(A2_BCC,SI,TI:VA;0),, -275629.1+42.5094*T;,, N 96Sei ! PAR L(A2_BCC,SI,TI:VA;1),, +25025.35-2.00203*T;,, N 96Sei ! PAR L(A2_BCC,SI,TI:VA;2),, +83940.65-6.71526*T;,, N 96Sei ! $ PAR L(HCP_A3,SI,TI:VA;0),, -302731.04+69.08469*T;,, N 96Sei ! PAR L(HCP_A3,SI,TI:VA;1),, +25025.35-2.00203*T;,, N 96Sei ! PAR L(HCP_A3,SI,TI:VA;2),, +83940.65-6.71526*T;,, N 96Sei ! $ PAR G(SI2TI_C54,SI:TI),, +GHSERTI+2*GHSERSI -175038.5+4.54797*T;,, N 96Sei ! PAR G(SITI_B27,SI:TI),, +GHSERSI+GHSERTI -155061.7+7.6345*T;,, N 96Sei ! PAR G(SI4TI5,SI:TI),, +4*GHSERSI+5*GHSERTI -711000+22.37355*T;,, N 96Sei ! $ PAR G(SI3TI5_D88,SI:SI:TI),, +5*GHSERSI+3*GHSERTI -206191.45+16.49531*T;,, N 96Sei ! PAR G(SI3TI5_D88,SI:TI:TI),, +2*GHSERSI+6*GHSERTI +417372.85+33.81017*T;,, N 96Sei ! PAR G(SI3TI5_D88,TI:SI:TI),, +5*GHSERTI+3*GHSERSI -583564.31+2.68514*T;,, N 96Sei ! PAR L(SI3TI5_D88,SI,TI:SI:TI;0),, -500000+40*T;,, N 96Sei ! PAR L(SI3TI5_D88,SI,TI:TI:TI;0),, -500000+40*T;,, N 96Sei ! PAR L(SI3TI5_D88,SI:SI,TI:TI;0),, +43024.29-3.44194*T;,, N 96Sei ! PAR L(SI3TI5_D88,TI:SI,TI:TI;0),, +43024.29-3.44194*T;,, N 96Sei ! $ PAR G(SITI3,SI:TI),, +GHSERSI+3*GHSERTI -200000+3.19924*T;,, N 96Sei ! $ $ Metastable $ PAR L(FCC_A1,SI,TI:VA;0),, -302731.04+69.08469*T;,, N Same ! PAR L(FCC_A1,SI,TI:VA;1),, +25025.35-2.00203*T;,, N Same ! PAR L(FCC_A1,SI,TI:VA;2),, +83940.65-6.71526*T;,, N Same ! $ PAR L(A1_FCC,SI,TI:VA;0),, -302731.04+69.08469*T;,, N Same ! PAR L(A1_FCC,SI,TI:VA;1),, +25025.35-2.00203*T;,, N Same ! PAR L(A1_FCC,SI,TI:VA;2),, +83940.65-6.71526*T;,, N Same ! $ PAR G(C14_LAVES,SI:TI),, +2*GHSERSI+GHSERTI;,, N Lin ! PAR G(C14_LAVES,TI:SI),, +2*GHSERTI+GHSERSI+77460;,, N Lin ! $ PAR G(MU_D85,SI:TI:SI:SI),, +7*GFCCSI+4*GBCCTI +2*GBCCSI;,, N Lin ! PAR G(MU_D85,SI:TI:TI:SI),, +7*GFCCSI+6*GBCCTI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Si-V $ $ From M.H. Rand and N. Saunders 1998 (Included in LB Vol. 4) $ $ M.H. Rand, N. Saunders, COST 507, Final report round 2, 1998. $ $ Checked against LB and COST. Checked at 6000K. $ PAR L(LIQUID,SI,V;0),, -180900+40*T;,, N 98Ran ! PAR L(LIQUID,SI,V;1),, +37000;,, N 98Ran ! PAR L(LIQUID,SI,V;2),, +20000;,, N 98Ran ! $ PAR L(BCC_A2,SI,V:VA;0),, -164505+30.1*T;,, N 98Ran ! PAR L(BCC_A2,SI,V:VA;1),, +37000;,, N 98Ran ! PAR L(BCC_A2,SI,V:VA;2),, +20000;,, N 98Ran ! $ PAR L(A2_BCC,SI,V:VA;0),, -164505+30.1*T;,, N 98Ran ! PAR L(A2_BCC,SI,V:VA;1),, +37000;,, N 98Ran ! PAR L(A2_BCC,SI,V:VA;2),, +20000;,, N 98Ran ! $ PAR G(SI2V_C40,SI:V),, -143160+401.98*T-67.8*T*LN(T) -0.0075*T**2+330000*T**(-1);,, N 98Ran ! PAR G(SI3V5_D8M,SI:V),, -504000+1259.03*T -211.04*T*LN(T)-0.00748*T**2+1680000*T**(-1);,, N 98Ran ! PAR G(SI5V6,SI:V),, -641675+1665.98*T -280.28*T*LN(T)-0.013915*T**2+2310000*T**(-1);,, N 98Ran ! $ PAR G(SIV3_A15,V:SI),, +3*GHSERSI+GHSERVV +166000-60*T;,, N 98Ran ! PAR G(SIV3_A15,SI:V),, -216397+516.532*T -90.44*T*LN(T)-0.008346*T**2+358000*T**(-1);,, N 98Ran ! PAR L(SIV3_A15,SI,V:SI;0),, +9794.5-21.8*T;,, N 98Ran ! PAR L(SIV3_A15,SI,V:V;0),, +9794.5-21.8*T;,, N 98Ran ! PAR L(SIV3_A15,SI:SI,V;0),, -150000;,, N 98Ran ! PAR L(SIV3_A15,V:SI,V;0),, +ZERO;,, N 98Ran ! $ $ Metastable $ PAR L(FCC_A1,SI,V:VA;0),, -164505+30.1*T;,, N Same ! PAR L(FCC_A1,SI,V:VA;1),, +37000;,, N Same ! PAR L(FCC_A1,SI,V:VA;2),, +20000;,, N Same ! $ PAR L(A1_FCC,SI,V:VA;0),, -164505+30.1*T;,, N Same ! PAR L(A1_FCC,SI,V:VA;1),, +37000;,, N Same ! PAR L(A1_FCC,SI,V:VA;2),, +20000;,, N Same ! $ PAR L(HCP_A3,SI,V:VA;0),, -164505+30.1*T;,, N Same ! PAR L(HCP_A3,SI,V:VA;1),, +37000;,, N Same ! PAR L(HCP_A3,SI,V:VA;2),, +20000;,, N Same ! $ PAR G(C14_LAVES,SI:V),, +2*GHSERSI+GHSERVV+107250;,, N Lin ! PAR G(C14_LAVES,V:SI),, +2*GHSERVV+GHSERSI+72120;,, N Lin ! $ PAR G(SIGMA_D8B,V:V:SI),, +10*GFCCVV+4*GHSERVV +16*GBCCSI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Ti-C $ $ From L.F.S. Dumitrescu et al. 1999 (Included in LB Vol. 2) $ $ L.F.S. Dumitrescu, M. Hillert, B. Sundman, Z. Metallkd., 90, 534-41(1999). $ $ Checked against LB and paper. Checked at 6000K. $ PAR L(LIQUID,C,TI;0),, -125409-44.4*T;,, N 99Dum1 ! $ PAR G(FCC_A1,TI:C),, +GTIC;,, N 99Dum1 ! PAR L(FCC_A1,TI:C,VA;0),, -52702-4.6*T;,, N 99Dum1 ! PAR L(FCC_A1,TI:C,VA;1),, -121367+31.5*T;,, N 99Dum1 ! $ PAR G(A1_FCC,TI:C),, +GTIC;,, N 99Dum1 ! PAR L(A1_FCC,TI:C,VA;0),, -52702-4.6*T;,, N 99Dum1 ! PAR L(A1_FCC,TI:C,VA;1),, -121367+31.5*T;,, N 99Dum1 ! $ PAR G(BCC_A2,TI:C),, +GTIC+2*GHSERCC+600000;,, N 99Dum1 ! PAR L(BCC_A2,TI:C,VA;0),, -881180+45.5*T;,, N 99Dum1 ! $ PAR G(A2_BCC,TI:C),, +GTIC+2*GHSERCC+600000;,, N 99Dum1 ! PAR L(A2_BCC,TI:C,VA;0),, -881180+45.5*T;,, N 99Dum1 ! $ PAR G(HCP_A3,TI:C),, +GHSERTI+0.5*GHSERCC -67577-8.6*T;,, N 99Dum1 ! PAR L(HCP_A3,TI:C,VA;0),, +ZERO;,, N 99Dum1 ! $ $ Metastable $ PAR G(MC_ETA,TI:C),, +GHSERTI+GHSERCC-110000;,, N 96Shi ! PAR G(TI2N_C4,TI:C),, +GHSERTI+GTIC-17349;,, N 99Dum1 ! $ FUNCTION GTIC 298.15 -168261.31+293.73187*T-48.0195*T*LN(T) -0.00272*T**2+819000*T**(-1)-2.03E+09*T**(-3); 6000.00 N ! $ ------------------------------------------------------------------------------ $ Ti-N $ $ K. Zeng, R. Schmid-Fetzer, Z. Metallkd., 87, 540-54(1996). $ $ Checked against paper. Checked at 6000K. $ PAR L(LIQUID,N,TI;0),, -376354.145;,, N 96Zen ! PAR L(LIQUID,N,TI;1),, -98242.2945;,, N 96Zen ! $ PAR G(FCC_A1,TI:N),, +GTIN;,, N 96Zen ! PAR L(FCC_A1,TI:N,VA;0),, -42704.41;,, N 96Zen ! PAR L(FCC_A1,TI:N,VA;1),, -13989.34;,, N 96Zen ! $ PAR G(A1_FCC,TI:N),, +GTIN;,, N 96Zen ! PAR L(A1_FCC,TI:N,VA;0),, -42704.41;,, N 96Zen ! PAR L(A1_FCC,TI:N,VA;1),, -13989.34;,, N 96Zen ! $ PAR G(BCC_A2,TI:N),, +GTIN+2*GHSERNN +2604201.62+118.04*T;,, N 96Zen ! PAR L(BCC_A2,TI:N,VA;0),, -3215338.17;,, N 96Zen ! $ PAR G(A2_BCC,TI:N),, +GTIN+2*GHSERNN +2604201.62+118.04*T;,, N 96Zen ! PAR L(A2_BCC,TI:N,VA;0),, -3215338.17;,, N 96Zen ! $ PAR G(HCP_A3,TI:N),, +0.5*GHSERTI+0.5*GTIN -6046.53-2.653*T;,, N 96Zen ! PAR L(HCP_A3,TI:N,VA;0),, -13501;,, N 96Zen ! $ PAR G(TI2N_C4,TI:N),, +GHSERTI+GTIN -67116+26.5395534*T;,, N 96Zen ! $ PAR G(TI3N2,TI:N),, +0.42*GHSERTI+0.29*GTIN -8190.33982-1.54816366*T;,, N 96Zen ! $ PAR G(TI4N3,TI:N),, +0.37*GHSERTI+0.315*GTIN -5956.86333-3.27489717*T;,, N 96Zen ! $ FUNCTION GTIN 298.15 -357905+330.498*T-52.4587*T*LN(T) -9.28E-04*T**2+1.48976561E-08*T**3+871000*T**(-1); 6000.00 N ! $ ------------------------------------------------------------------------------ $ Ti-V $ $ From G. Ghosh 2002 (Included in LB Vol. 4) $ $ G. Ghosh, J. Phase Equilib., 23, 310-28(2002). $ $ Checked against paper and LB. Checked at 6000K. $ PAR L(LIQUID,TI,V;0),, +368.55;,, N 02Gho ! PAR L(LIQUID,TI,V;1),, +2838.63;,, N 02Gho ! $ PAR L(BCC_A2,TI,V:VA;0),, +6523.17;,, N 02Gho ! PAR L(BCC_A2,TI,V:VA;1),, +2025.39;,, N 02Gho ! $ PAR L(A2_BCC,TI,V:VA;0),, +6523.17;,, N 02Gho ! PAR L(A2_BCC,TI,V:VA;1),, +2025.39;,, N 02Gho ! $ PAR L(HCP_A3,TI,V:VA;0),, +13233;,, N 02Gho ! $ $ Metastable $ PAR L(FCC_A1,TI,V:VA;0),, +13233;,, N Same ! PAR L(A1_FCC,TI,V:VA;0),, +13233;,, N Same ! $ PAR G(C14_LAVES,TI:V),, +2*GFCCTI+GHSERVV+42328;,, N Lin ! PAR G(C14_LAVES,V:TI),, +2*GHSERVV+GHSERTI;,, N Lin ! $ PAR G(MU_D85,V:TI:TI:V),, +7*GFCCVV+6*GBCCTI;,, N Lin ! PAR G(MU_D85,V:TI:V:V),, +7*GFCCVV+4*GBCCTI +2*GHSERVV;,, N Lin ! $ PAR G(SIGMA_D8B,V:TI:TI),, +10*GFCCVV+20*GBCCTI;,, N Lin ! PAR G(SIGMA_D8B,V:TI:V),, +10*GFCCVV+4*GBCCTI +16*GHSERVV;,, N Lin ! PAR G(SIGMA_D8B,V:V:TI),, +10*GFCCVV+4*GHSERVV +16*GBCCTI;,, N Lin ! $ ------------------------------------------------------------------------------ $ V-C $ $ From W. Huang 1991 (included in LB Vol. 2) $ $ W. Huang, Z. Metallkd., 82, 174-81(1991). $ $ Slight modification of the liquid interaction by A.V. Khvan 2011 to $ remove a small miscibility gap. $ $ Checked against LB and paper. Checked at 6000 K. $ $ Wrong sign for L(FCC_A1,V:C,VA;1) in the paper. $ $ There is a very small (stable) liquid miscibility gap close to C at 4716 $ to 4748 K. $ PAR L(LIQUID,C,V;0),, -284196+38.952*T;,, N 91Hua1 ! PAR L(LIQUID,C,V;1),, +96335-17.775*T;,, N 91Hua1 ! $PAR L(LIQUID,C,V;2),, +102050;,, N 91Hua1 ! PAR L(LIQUID,C,V;2),, +101050;,, N 11Khv ! $ PAR G(BCC_A2,V:C),, +GHSERVV+3*GHSERCC+108449;,, N 91Hua1 ! PAR L(BCC_A2,V:C,VA;0),, -297868;,, N 91Hua1 ! $ PAR G(A2_BCC,V:C),, +GHSERVV+3*GHSERCC+108449;,, N 91Hua1 ! PAR L(A2_BCC,V:C,VA;0),, -297868;,, N 91Hua1 ! $ PAR G(FCC_A1,V:C),, -117302+262.57*T -41.756*T*LN(T)-0.00557101*T**2+590546*T**(-1);,, N 91Hua1 ! PAR L(FCC_A1,V:C,VA;0),, -74811+10.201*T;,, N 91Hua1 ! PAR L(FCC_A1,V:C,VA;1),, -30394;,, N 91Hua1 ! $ PAR G(A1_FCC,V:C),, -117302+262.57*T -41.756*T*LN(T)-0.00557101*T**2+590546*T**(-1);,, N 91Hua1 ! PAR L(A1_FCC,V:C,VA;0),, -74811+10.201*T;,, N 91Hua1 ! PAR L(A1_FCC,V:C,VA;1),, -30394;,, N 91Hua1 ! $ PAR G(HCP_A3,V:C),, -85473+182.441*T -30.551*T*LN(T)-0.00538998*T**2+229029*T**(-1);,, N 91Hua1 ! PAR L(HCP_A3,V:C,VA;0),, +12430-3.986*T;,, N 91Hua1 ! $ PAR G(V3C2,V:C),, +3*GHSERVV+2*GHSERCC -260341+16.897*T;,, N 91Hua1 ! $ $ metastable $ PAR G(CBCC_A12,V:C),, +GHSERVV+GHSERCC+10000;,, N 91Fer2 ! PAR G(CUB_A13,V:C),, +GHSERVV+GHSERCC+10000;,, N 91Fer2 ! PAR G(CEMENTITE_D011,V:C),, -156971+601.922*T -100.438*T*LN(T)+765557*T**(-1);,, N 91Fer2 ! $PAR G(CEMENTITE_D011,V:C),, +3*GHSERVV+GHSERCC-96000;,, N 91Hua4 ! PAR G(MC_ETA,V:C),, -115426.29+299.799*T -47.012*T*LN(T)+210127.634*T**(-1);,, N 02Bra ! PAR G(M7C3_D101,V:C),, -454245+1518.48*T -250.981*T*LN(T)+2148692*T**(-1);,, N 91Fer2 ! PAR G(CR3C2_D510,V:C),, +3*GHSERVV+2*GHSERCC -222500+16.6545*T;,, N 92Lee2 ! PAR G(M23C6_D84,V:V:C),, +GV23C6;,, N 91Fer2 ! PAR G(M5C2,V:C),, -307123.3+1059.7*T -175.66*T*LN(T)+1453274*T**(-1);,, N 91Fer2 ! $ FUNCTION GV23C6 298.15 -990367+4330.63*T-728.829*T*LN(T) +5003425*T**(-1); 6000.00 N ! $ ------------------------------------------------------------------------------ $ V-N $ $ From H. Ohtani and M. Hillert 1991 (Included in LB Vol. 4) $ $ H. Ohtani, M. Hillert, Calphad, 15, 11-24(1991). $ $ Checked against LB and paper. Checked at 6000 K. $ $ Misprint in the bcc interaction in the paper; one zero missing. $ $ The bcc-field shown in the phase diagram in the paper is not in agreement $ with the parameters given. The calculated N solubility is somewhat lower. $ $ TI2N_C4 becomes stable above 2200 K. This requires changes in Ti-V-N from $ 98Zen. $ $ In order to use V-N from 97Du it is necessary to remodel Fe-V-N. $ PAR L(LIQUID,N,V;0),, -239000;,, N 91Oht1 ! PAR L(LIQUID,N,V;1),, -8380;,, N 91Oht1 ! $ PAR G(FCC_A1,V:N),, +GHSERVV+GHSERNN -215000+101*T-2.22*T*LN(T)+0.00073*T**2;,, N 91Oht1 ! PAR L(FCC_A1,V:N,VA;0),, -131000+47.1*T;,, N 91Oht1 ! $ PAR G(A1_FCC,V:N),, +GHSERVV+GHSERNN -215000+101*T-2.22*T*LN(T)+0.00073*T**2;,, N 91Oht1 ! PAR L(A1_FCC,V:N,VA;0),, -131000+47.1*T;,, N 91Oht1 ! $ PAR G(BCC_A2,V:N),, +GHSERVV+3*GHSERNN+843000;,, N 91Oht1 ! PAR L(BCC_A2,V:N,VA;0),, -1680000+325*T;,, N 91Oht1 ! $ PAR G(A2_BCC,V:N),, +GHSERVV+3*GHSERNN+843000;,, N 91Oht1 ! PAR L(A2_BCC,V:N,VA;0),, -1680000+325*T;,, N 91Oht1 ! $ PAR G(HCP_A3,V:N),, +GHSERVV+0.5*GHSERNN -139000+50.4*T;,, N 91Oht1 ! PAR L(HCP_A3,V:N,VA;0),, -18400+4.84*T;,, N 91Oht1 ! PAR L(HCP_A3,V:N,VA;1),, -19700+2.13*T;,, N 91Oht1 ! $ $ Metastable $ PAR G(TI2N_C4,V:N),, +2*GHSERVV+GHSERNN -100000+20*T;,, N 98Zen1 ! $ ------------------------------------------------------------------------------ $ Ternary systems $ ------------------------------------------------------------------------------ $ Cr-C-N $ ------------------------------------------------------------------------------ $ Cr-Cu-C $ ------------------------------------------------------------------------------ $ Cr-Cu-Fe $ $ C.P. Wang, X.J. Liu, I. Ohnuma, R. Kainuma, K. Ishida, $ J. Phase Equilib., 23, 236-45(2002). $ $ Checked against paper. $ PAR L(LIQUID,CR,CU,FE;0),, +ZERO;,, N 97Oht ! $ PAR L(FCC_A1,CR,CU,FE:VA;0),, +35007.5-27.5*T;,, N 02Wan ! PAR L(A1_FCC,CR,CU,FE:VA;0),, +35007.5-27.5*T;,, N 02Wan ! $ PAR L(BCC_A2,CR,CU,FE:VA;0),, +38650-50*T;,, N 97Oht ! PAR L(A2_BCC,CR,CU,FE:VA;0),, +38650-50*T;,, N 97Oht ! $ ------------------------------------------------------------------------------ $ Cr-Cu-Mg $ ------------------------------------------------------------------------------ $ Cr-Cu-Mn $ ------------------------------------------------------------------------------ $ Cr-Cu-Mo $ ------------------------------------------------------------------------------ $ Cr-Cu-N $ ------------------------------------------------------------------------------ $ Cr-Cu-Nb $ ------------------------------------------------------------------------------ $ Cr-Cu-Ni $ ------------------------------------------------------------------------------ $ Cr-Cu-Si $ ------------------------------------------------------------------------------ $ Cr-Cu-Ti $ ------------------------------------------------------------------------------ $ Cr-Cu-V $ ------------------------------------------------------------------------------ $ Cr-Fe-C $ $ A.V. Khvan, B. Hallstedt, C. Broeckmann, Calphad, 46, 24-33(2014). $ PAR L(LIQUID,C,CR,FE;0),, -528500;,, N 14Khv ! PAR L(LIQUID,C,CR,FE;1),, +57150;,, N 14Khv ! PAR L(LIQUID,C,CR,FE;2),, +62630;,, N 14Khv ! $ PAR L(BCC_A2,CR,FE:C;0),, -1320000+667.7*T;,, N 14Khv ! PAR BMAG(BCC_A2,CR,FE:C;0),, -0.85;,, N 88And3 ! PAR TC(BCC_A2,CR,FE:C;0),, +1650;,, N 88And3 ! PAR TC(BCC_A2,CR,FE:C;1),, +550;,, N 88And3 ! $ PAR L(A2_BCC,CR,FE:C;0),, -1320000+667.7*T;,, N 14Khv ! PAR BMAG(A2_BCC,CR,FE:C;0),, -0.85;,, N 88And3 ! PAR TC(A2_BCC,CR,FE:C;0),, +1650;,, N 88And3 ! PAR TC(A2_BCC,CR,FE:C;1),, +550;,, N 88And3 ! $ PAR L(FCC_A1,CR,FE:C;0),, -69534+3.2353*T;,, N 14Khv ! PAR L(A1_FCC,CR,FE:C;0),, -69534+3.2353*T;,, N 14Khv ! $ PAR L(CEMENTITE_D011,CR,FE:C;0),, +14586-9.18*T;,, N 14Khv ! $ PAR G(M23C6_D84,FE:CR:C),, +0.130435*GCR23C6 +0.869565*GFE23C6;,, N 14Khv ! PAR G(M23C6_D84,CR:FE:C),, +0.869565*GCR23C6 +0.130435*GFE23C6;,, N 14Khv ! PAR L(M23C6_D84,CR,FE:CR:C;0),, +6609;,, N 14Khv ! PAR L(M23C6_D84,CR,FE:FE:C;0),, +6609;,, N 14Khv ! PAR L(M23C6_D84,CR:CR,FE:C;0),, +991;,, N 14Khv ! PAR L(M23C6_D84,FE:CR,FE:C;0),, +991;,, N 14Khv ! PAR L(M23C6_D84,CR,FE:CR:C;1),, -43600;,, N 14Khv ! PAR L(M23C6_D84,CR,FE:FE:C;1),, -43600;,, N 14Khv ! PAR L(M23C6_D84,CR:CR,FE:C;1),, -6540;,, N 14Khv ! PAR L(M23C6_D84,FE:CR,FE:C;1),, -6540;,, N 14Khv ! $ PAR L(M7C3_D101,CR,FE:C;0),, +81940-61.86*T;,, N 14Khv ! PAR L(M7C3_D101,CR,FE:C;1),, -7310;,, N 14Khv ! PAR L(M7C3_D101,CR,FE:C;2),, +27050;,, N 14Khv ! $ $ metastable $ PAR L(KSI_CARBIDE,CR,FE:C;0),, -139900;,, N 92Qiu2 ! $ ------------------------------------------------------------------------------ $ Cr-Fe-Mg $ ------------------------------------------------------------------------------ $ Cr-Fe-Mn $ $ B.-J. Lee, Metall. Trans. A, 24A, 1919-33(1993). $ $ Checked against paper. $ $ Changed model for sigma and high-sigma from 8:4:18 to 10:4:16. $ Ternary parameters were recalculated using the scheme in 93Lee3 with a $ modified correction term; -135000 J for sigma and -140000 J for high-sigma $ instead of -123570 J for both. $ B. Hallstedt, Nov. 2016. $ $ The sigma phase field is very close to that in 93Lee3, but the high-sigma $ field extends less far into the ternary. There are no experimental data $ to support one version or the other. $ PAR L(LIQUID,CR,FE,MN;0),, +2378;,, N 93Lee3 ! $ PAR L(FCC_A1,CR,FE,MN:VA;0),, +6715-10.3933*T;,, N 93Lee3 ! PAR L(A1_FCC,CR,FE,MN:VA;0),, +6715-10.3933*T;,, N 93Lee3 ! $ PAR L(BCC_A2,CR,FE,MN:VA;0),, -5996;,, N 93Lee3 ! PAR L(A2_BCC,CR,FE,MN:VA;0),, -5996;,, N 93Lee3 ! $ PAR G(SIGMA_D8B,FE:CR:MN),, +10*GFCCFE+4*GHSERCR +16*GBCCMN-49718-2.446*T;,, N 16Hal6 ! PAR G(SIGMA_D8B,MN:CR:FE),, +10*GFCCMN+4*GHSERCR +16*GHSERFE-113380-43.274*T;,, N 16Hal6 ! PAR L(SIGMA_D8B,FE:CR:CR,MN;0),, -947617+762.6*T;,, N 16Hal6 ! $ PAR G(HIGH_SIGMA,FE:CR:MN),, +10*GFCCFE+4*GHSERCR +16*GBCCMN+9350-48.969*T;,, N 16Hal6 ! PAR G(HIGH_SIGMA,MN:CR:FE),, +10*GFCCMN+4*GHSERCR +16*GHSERFE-81088-72.351*T;,, N 16Hal6 ! $ $ metastable $ PAR L(HCP_A3,CR,FE,MN:VA;0),, +34600;,, N 93Qiu3 ! $ ------------------------------------------------------------------------------ $ Cr-Fe-Mo $ $ J.-O. Andersson, N. Lange, Metall. Trans. A, 19A, 1385-94(1988). $ $ Extended model for C14_LAVES (99Lee). $ Cr added on the first sublattice of CHI_A12 (88Gus4). $ Modified Fe:Mo:Cr parameter for CHI_A12 (88Gus4). $ Cr-Mo interaction added for fcc and hcp. $ Cr-Fe liquid interaction modified (93Lee1). $ $ New lattice stabilities for C14_LAVES. $ Model for SIGMA changed from 8:4:18 to 10:4:16 and for MU_D85 from 7:2:4 $ to 1:4:2:6. The change of SIGMA model made it necessary to introduce Mo $ on the first sublattice. For this the Fe-Mo binary was modified with $ minimal changes. In spite of this it was very difficult to reasonably $ reproduce previous results in the Cr-Fe-Mo system and a (probably too) large $ number of parameters was used. $ $ 1273, 1373 K isothermal sections are very close to original. Largest change $ is for fcc-bcc equilibria, now in agreement with 92Qiu1. There is a $ considerable change in bcc-liquid equilibria in the Cr-Fe binary. Equilibria $ between liquid and sigma or R-phase do not change much. (This concerns $ canges before the change of SIGMA and MU models.) $ $ Cr was introduced on the first sublattice of CHI_A12 by P. Gustafson 1988 $ and some of the parameters modified. $ $ The parameters G(CHI_A12,CR:MO:CR), L(SIGMA_OLD,FE:CR:FE,MO;0) and $ L(SIGMA_OLD,FE:MO:CR,FE;0) have been further modified in TCFE-99, $ but the isothermal section at 1273 K is not well reproduced with the new $ parameters. The reason for doing them is also not clear. $ $ TCFE99: CHI_A12 phase field is larger and R_PHASE is not stable at 1273 K. $ TCFE8: Further changes of sigma, mu and chi phase fields. R-phase not stable $ at 1273 K. There is a very large shift of the liquidus (bcc, sigma, R) $ towards the Fe corner at 1873 K. TCFE8 = TCFE7. $ PAR G(CHI_A12,CR:MO:FE),, +24*GFCCCR+10*GHSERMO +24*GFCCFE+500000;,, N 88Gus4 ! PAR G(CHI_A12,FE:CR:MO),, +24*GFCCFE+10*GHSERCR +24*GFCCMO+100000;,, N 88And4 ! $PAR G(CHI_A12,FE:MO:CR),, +24*GFCCFE+10*GHSERMO $ +24*GFCCCR+20855-385*T;,, N 88And4 ! PAR G(CHI_A12,FE:MO:CR),, +24*GFCCFE+10*GHSERMO +24*GFCCCR+32555-385*T;,, N 88Gus4 ! $ PAR L(C14_LAVES,CR,FE:MO;0),, +40000;,, N 99Lee ! $ PAR G(MU_D85,CR:MO:CR:FE),, +3*GHSERCR+4*GHSERMO +6*GFCCFE;,, N Lin ! PAR G(MU_D85,CR:MO:FE:CR),, +7*GHSERCR+4*GHSERMO +2*GHSERFE;,, N Lin ! PAR G(MU_D85,CR:MO:FE:FE),, +GHSERCR+4*GHSERMO+2*GHSERFE +6*GFCCFE;,, N Lin ! PAR G(MU_D85,CR:MO:FE:MO),, +GHSERCR+4*GHSERMO+2*GHSERFE +6*GFCCMO;,, N Lin ! PAR G(MU_D85,CR:MO:MO:FE),, +GHSERCR+6*GHSERMO +6*GFCCFE;,, N Lin ! PAR G(MU_D85,FE:MO:CR:CR),, +GFCCFE+4*GHSERMO +8*GHSERCR;,, N Lin ! PAR G(MU_D85,FE:MO:CR:FE),, +7*GFCCFE+4*GHSERMO +2*GHSERCR+88740-110*T;,, N 17Hal4 ! PAR G(MU_D85,FE:MO:CR:MO),, +GFCCFE+4*GHSERMO+2*GHSERCR +6*GFCCMO;,, N Lin ! PAR G(MU_D85,FE:MO:FE:CR),, +GFCCFE+4*GHSERMO+2*GHSERFE +6*GHSERCR;,, N Lin ! PAR G(MU_D85,FE:MO:MO:CR),, +GFCCFE+6*GHSERMO +6*GHSERCR+128710-90*T;,, N 17Hal4 ! $ PAR G(R_PHASE,CR:MO:FE),, +27*GFCCCR+14*GHSERMO +12*GHSERFE+645260-620*T;,, N 88And4 ! PAR G(R_PHASE,FE:MO:CR),, +27*GFCCFE+14*GHSERMO +12*GHSERCR+600260-620*T;,, N 88And4 ! $ PAR G(SIGMA_D8B,FE:CR:MO),, +10*GFCCFE+4*GHSERCR +16*GHSERMO+550000-400*T;,, N 17Hal6 ! PAR G(SIGMA_D8B,FE:MO:CR),, +10*GFCCFE+4*GHSERMO +16*GHSERCR+184100-100*T;,, N 17Hal6 ! PAR G(SIGMA_D8B,MO:CR:FE),, +10*GFCCMO+4*GHSERCR +16*GHSERFE+150000;,, N 17Hal6 ! PAR L(SIGMA_D8B,FE:CR:CR,MO;0),, -438780+100*T;,, N 17Hal6 ! PAR L(SIGMA_D8B,FE:MO:CR,MO;0),, +70260;,, N 17Hal6 ! PAR L(SIGMA_D8B,FE:CR:FE,MO;0),, +570000;,, N 88And4 ! PAR L(SIGMA_D8B,FE:CR,MO:FE;0),, +274600-200*T;,, N 17Hal6 ! PAR L(SIGMA_D8B,FE:MO:CR,FE;0),, -36790-100*T;,, N 17Hal6 ! $ $ metastable $ PAR G(MONI,CR:FE:MO),, +UN_ASS;,, N ! PAR G(MONI,FE:CR:MO),, +UN_ASS;,, N ! $ PAR G(P_PHASE,CR:FE:MO),, +24*GFCCCR+20*GHSERFE +12*GHSERMO+100000+UN_ASS;,, N 99Lee ! PAR G(P_PHASE,FE:CR:MO),, +24*GFCCFE+20*GHSERCR +12*GHSERMO+100000+UN_ASS;,, N 99Lee ! $ ------------------------------------------------------------------------------ $ Cr-Fe-N $ $ K. Frisk, Metall. Trans. A, 21A, 2477-88(1990). $ $ Checked against paper. $ $ Cr-Fe modified liquid from 93Lee1 $ Fe-N from 93Du instead of 91Fri $ $ At 1273 the N-solubility in bcc is about twice as high as shown in the paper. $ This seems to be a mistake in the paper. At higher temperature the N $ solubility in bcc is close to that shown in the paper. $ $ The liquidus temperatures are lower than in the original 90Fri assessment, $ but data are lacking. The fcc+fcc (fcc-Fe+CrN) miscibility gap is rather $ different from 90Fri (at 1673 K). $ $ First parameter is from TCFE99, second from 90Fri1. $PAR L(LIQUID,CR,FE,N;0),, -127121+68.6*T;,, N Null ! PAR L(LIQUID,CR,FE,N;0),, -340750+187.4*T;,, N 90Fri1 ! $ PAR L(FCC_A1,CR,FE:N;0),, -128930+86.49*T;,, N 90Fri1 ! PAR L(FCC_A1,CR,FE:N;1),, +24330;,, N 90Fri1 ! PAR L(FCC_A1,CR,FE:N,VA;0),, -162516;,, N 90Fri1 ! $ PAR L(A1_FCC,CR,FE:N;0),, -128930+86.49*T;,, N 90Fri1 ! PAR L(A1_FCC,CR,FE:N;1),, +24330;,, N 90Fri1 ! PAR L(A1_FCC,CR,FE:N,VA;0),, -162516;,, N 90Fri1 ! $ PAR L(BCC_A2,CR,FE:N;0),, -799379+293*T;,, N 90Fri1 ! PAR TC(BCC_A2,CR,FE:N;0),, +1650;,, N 90Fri1 ! PAR TC(BCC_A2,CR,FE:N;1),, +550;,, N 90Fri1 ! PAR BMAG(BCC_A2,CR,FE:N;0),, -0.85;,, N 90Fri1 ! $ PAR L(A2_BCC,CR,FE:N;0),, -799379+293*T;,, N 90Fri1 ! PAR TC(A2_BCC,CR,FE:N;0),, +1650;,, N 90Fri1 ! PAR TC(A2_BCC,CR,FE:N;1),, +550;,, N 90Fri1 ! PAR BMAG(A2_BCC,CR,FE:N;0),, -0.85;,, N 90Fri1 ! $ PAR L(HCP_A3,CR,FE:N;0),, +12826-19.48*T;,, N 90Fri1 ! $ $ metastable $ PAR G(PI_CRFENIN,CR:FE:N),, +12.8*GHSERCR+7.2*GHSERFE +4*GHSERNN-160994;,, N 91Fri3 ! $ ------------------------------------------------------------------------------ $ Cr-Fe-Nb $ $ A. Jacob, C. Schmetterer, A. Khvan, A. Kondratiev, D. Ivanov, B. Hallstedt, $ Calphad, 54, 1-15(2016). $ $ Checked against paper. $ PAR L(LIQUID,CR,FE,NB;0),, +35000;,, N 16Jac1 ! PAR L(LIQUID,CR,FE,NB;1),, +25000;,, N 16Jac1 ! PAR L(LIQUID,CR,FE,NB;2),, -30000;,, N 16Jac1 ! $ PAR L(C14_LAVES,FE:CR,NB;0),, -100000;,, N 16Jac1 ! $ PAR L(C15_LAVES,FE:CR,NB;0),, -100000;,, N 16Jac1 ! $ PAR G(MU_D85,CR:NB:CR:FE),, +3*GHSERCR+6*GHSERFE+4*GHSERNB -51272;,, N 16Jac1 ! PAR G(MU_D85,CR:NB:FE:CR),, +7*GHSERCR+2*GHSERFE+4*GHSERNB +86129;,, N 16Jac1 ! PAR G(MU_D85,CR:NB:FE:FE),, +GHSERCR+8*GHSERFE+4*GHSERNB +32907;,, N 16Jac1 ! PAR G(MU_D85,CR:NB:FE:NB),, +GHSERCR+2*GHSERFE+10*GHSERNB +434399;,, N 16Jac1 ! PAR G(MU_D85,CR:NB:NB:FE),, +GHSERCR+6*GHSERFE+6*GHSERNB -158000-19*T;,, N 16Jac1 ! PAR G(MU_D85,FE:NB:CR:CR),, +8*GHSERCR+GHSERFE+4*GHSERNB +30559;,, N 16Jac1 ! PAR G(MU_D85,FE:NB:CR:FE),, +2*GHSERCR+7*GHSERFE+4*GHSERNB -45258;,, N 16Jac1 ! PAR G(MU_D85,FE:NB:CR:NB),, +2*GHSERCR+GHSERFE+10*GHSERNB +338945;,, N 16Jac1 ! PAR G(MU_D85,FE:NB:FE:CR),, +6*GHSERCR+3*GHSERFE+4*GHSERNB +97604;,, N 16Jac1 ! PAR G(MU_D85,FE:NB:NB:CR),, +6*GHSERCR+GHSERFE+6*GHSERNB -9919;,, N 16Jac1 ! PAR G(MU_D85,NB:NB:CR:FE),, +2*GHSERCR+6*GHSERFE+5*GHSERNB +13767;,, N 16Jac1 ! PAR G(MU_D85,NB:NB:FE:CR),, +6*GHSERCR+2*GHSERFE+5*GHSERNB +192989;,, N 16Jac1 ! PAR L(MU_D85,CR,FE:NB:NB:CR,FE;0),, -120000;,, N 16Jac1 ! $ PAR G(SIGMA_D8B,FE:CR:NB),, +10*GHSERFE+4*GHSERCR +16*GHSERNB+323133;,, N 16Jac1 ! PAR G(SIGMA_D8B,FE:NB:CR),, +10*GHSERFE+4*GHSERNB +16*GHSERCR+93933;,, N 16Jac1 ! $PAR G(SIGMA_D8B,NB:CR:FE),, +10*GHSERNB+4*GHSERCR $ +16*GHSERFE+806333;,, N 16Jac1 ! $ ------------------------------------------------------------------------------ $ Cr-Fe-Ni $ $ B.-J. Lee, J. Korean Inst. Met. Mater., 31, 480-89(1993). $ $ Checked against paper (93Lee4 and 90Hil). $ $ Cr-Ni is changed from 92Lee to 16Tan. $ $ Sigma phase model is changed from 8:4:18 to 10:4:16. $ Ni:Cr:Cr parameter adjusted for better fit in Cr-Fe-Ni. $ $ Results are very similar to those of 93Lee4, including the 74 wt.% Fe $ isopleth. There are small shifts in fcc, bcc, liquid and sigma phase $ boundaries. $ $ Fcc and bcc ordering is added; 4SL fcc and 2SL bcc with Va. $ Fcc ordering was also added by P. Franke 2011 (based on Fe-Ni from 03Dup). $ $ Ordering did not behave well at high temperature (similar to the $ Fe-Mn-Ni system). At 1673 K L1_2 is stable as (Fe,Ni)3Cr, from around $ Fe2NiCr to FeNi2Cr. The 823 K isothermal section is correctly reproduced $ with no ordered phases. Results at 773 and 673 K are similar to the $ the results P. Franke 2011. The high temperature problem was solved by $ changing the UFFENI parameter in the Fe-Ni system. $ PAR L(LIQUID,CR,FE,NI;0),, +36583;,, N 93Lee1 ! PAR L(LIQUID,CR,FE,NI;1),, +13254;,, N 93Lee1 ! PAR L(LIQUID,CR,FE,NI;2),, -10018;,, N 93Lee1 ! $ PAR L(FCC_A1,CR,FE,NI:VA;0),, +16580-9.7835*T;,, N 93Lee1 ! PAR L(A1_FCC,CR,FE,NI:VA;0),, +16580-9.7835*T;,, N 93Lee1 ! $ PAR L(BCC_A2,CR,FE,NI:VA;0),, -2673+2.04145*T;,, N 93Lee1 ! PAR L(A2_BCC,CR,FE,NI:VA;0),, -2673+2.04145*T;,, N 93Lee1 ! $ PAR G(SIGMA_D8B,FE:CR:NI),, +10*GFCCFE+4*GHSERCR +16*GBCCNI;,, N Lin ! PAR G(SIGMA_D8B,NI:CR:FE),, +10*GHSERNI+4*GHSERCR +16*GHSERFE;,, N Lin ! $ $ metastable $ PAR G(CHI_A12,FE:CR:NI),, +24*GFCCFE+10*GHSERCR +24*GHSERNI;,, N Lin ! PAR G(CHI_A12,NI:CR:FE),, +24*GHSERNI+10*GHSERCR +24*GFCCFE;,, N Lin ! PAR L(CHI_A12,CR,FE:CR:NI;0),, -174000;,, N 99Lee ! $ PAR G(HIGH_SIGMA,FE:CR:NI),, +10*GFCCFE+4*GHSERCR +16*GBCCNI;,, N Lin ! PAR G(HIGH_SIGMA,NI:CR:FE),, +10*GHSERNI+4*GHSERCR +16*GHSERFE;,, N Lin ! $ ------------------------------------------------------------------------------ $ Cr-Fe-Si $ $ From B. Hallstedt 2008 (based on the assessment from M. Lindholm 1997) $ $ Cr-Si was changed from 94Cou to 00Du, but the simple model for $ M5SI3_D88 kept. M5SI3_D88 also appears as a high-temperature phase in Cr-Si. $ This changes the M5SI3_D88 phase field compared to 97Lin. Experimentally not $ much is known in this system. It was tried to stay close to the assessment $ by Lindholm. $ $ Liquid interaction modified to reproduce the melting temperatures in the $ Cr0.6Fe0.4-Si section from 97Lin. $ New (but rough) M5Si3 interaction to produce a reasonable M5Si3 phase field. $ The stability of the sigma phase was slightly decreased. $ PAR L(LIQUID,CR,FE,SI;0),, -40000;,, N 08Hal4 ! $ PAR L(BCC_A2,CR,FE,SI:VA;0),, -54000;,, N 97Lin ! PAR L(A2_BCC,CR,FE,SI:VA;0),, -54000;,, N 97Lin ! $ PAR L(CR3SI_A15,CR,FE:SI:VA;0),, +10000;,, N 97Lin ! $ PAR L(CR5SI3_D8M,CR,FE:SI;0),, +12000;,, N 97Lin ! $ PAR L(M5SI3_D88,CR,FE:SI:VA;0),, +60000+20*T;,, N 08Hal4 ! PAR L(M5SI3_D88,CR,FE:SI:VA;1),, +40000;,, N 08Hal4 ! $ PAR L(MSI_B20,CR,FE:SI;0),, +15000;,, N 97Lin ! $ PAR G(SIGMA_D8B,FE:CR:SI),, +10*GFCCFE+4*GHSERCR +16*GBCCSI-900000+275*T;,, N 17Hal10 ! PAR L(SIGMA_D8B,FE:CR:CR,SI;0),, -2115000+155*T;,, N 97Lin ! PAR L(SIGMA_D8B,FE:CR:FE,SI;0),, -2015000+155*T;,, N 97Lin ! $ $ metastable $ $ Skip these parameters. There is no real support for them. $ Restored in version 4b. $ The fcc interaction was estimated to give reasonable Cr distribution $ during solidification of high Si cast iron. $ PAR L(FCC_A1,CR,FE,SI:VA;0),, -100000;,, N 17Hal20 ! PAR L(A1_FCC,CR,FE,SI:VA;0),, -100000;,, N 17Hal20 ! PAR L(HCP_A3,CR,FE,SI:VA;0),, -54000;,, N Same ! $ ------------------------------------------------------------------------------ $ Cr-Fe-Ti $ PAR G(SIGMA_D8B,FE:CR:TI),, +10*GFCCFE+4*GHSERCR +16*GBCCTI;,, N Lin ! PAR G(SIGMA_D8B,FE:TI:CR),, +10*GFCCFE+4*GBCCTI +16*GHSERCR;,, N Lin ! $ ------------------------------------------------------------------------------ $ Cr-Fe-V $ $ B.-J. Lee, Z. Metallkd., 83, 292-299(1992). $ $ Checked against paper. $ $ Changing SIGMA_OLD to SIGMA_D8B leads to moderate changes of the sigma phase $ field. The fit to data remains about equally good, but ternary parameters $ and Cr-V parameters should probably be refitted. $ PAR L(LIQUID,CR,FE,V;0),, +14881;,, N 92Lee3 ! PAR L(LIQUID,CR,FE,V;1),, +17968;,, N 92Lee3 ! PAR L(LIQUID,CR,FE,V;2),, -7692;,, N 92Lee3 ! $ PAR L(BCC_A2,CR,FE,V:VA;0),, +14881;,, N 92Lee3 ! PAR L(BCC_A2,CR,FE,V:VA;1),, +17968;,, N 92Lee3 ! PAR L(BCC_A2,CR,FE,V:VA;2),, -7692;,, N 92Lee3 ! $ PAR L(A2_BCC,CR,FE,V:VA;0),, +14881;,, N 92Lee3 ! PAR L(A2_BCC,CR,FE,V:VA;1),, +17968;,, N 92Lee3 ! PAR L(A2_BCC,CR,FE,V:VA;2),, -7692;,, N 92Lee3 ! $ PAR G(SIGMA_D8B,FE:CR:V),, +10*GFCCFE+4*GHSERCR +16*GHSERVV-245761-67.3294*T;,, N 92Lee3 ! PAR G(SIGMA_D8B,FE:V:CR),, +10*GFCCFE+4*GHSERVV +16*GHSERCR+155735-89.5976*T;,, N 92Lee3 ! PAR G(SIGMA_D8B,V:CR:FE),, +10*GFCCVV+4*GHSERCR +16*GHSERFE;,, N Lin ! PAR L(SIGMA_D8B,FE:CR:FE,V;0),, -235158;,, N 92Lee3 ! $ ------------------------------------------------------------------------------ $ Cr-Mg-C $ ------------------------------------------------------------------------------ $ Cr-Mg-Mn $ ------------------------------------------------------------------------------ $ Cr-Mg-Mo $ ------------------------------------------------------------------------------ $ Cr-Mg-N $ ------------------------------------------------------------------------------ $ Cr-Mg-Nb $ ------------------------------------------------------------------------------ $ Cr-Mg-Ni $ ------------------------------------------------------------------------------ $ Cr-Mg-Si $ ------------------------------------------------------------------------------ $ Cr-Mg-Ti $ ------------------------------------------------------------------------------ $ Cr-Mg-V $ ------------------------------------------------------------------------------ $ Cr-Mn-C $ $ B.-J. Lee, Metall. Trans. A, 24A, 1017-25 (1993). $ $ Checked against paper. $ $ Cr-C modified by 12Khv. $ Sigma and high-sigma changed from 8:4:18 to 10:4:16 in Cr-Mn. $ New Mn-C from 10Dju. $ $ The BCC_A2 interaction is the same as without C. This is either without $ influence on anything or wrong. The same applies for FCC_A1, HCP_A3, $ CBCC_A12 and CUB_A13. $ $ The HCP_A3 interaction is necessary, but is now different from the one $ without C. $ PAR L(BCC_A2,CR,MN:C;0),, -20328+18.7339*T;,, N 93Lee2 ! PAR L(BCC_A2,CR,MN:C;1),, -9162+4.4183*T;,, N 93Lee2 ! $ PAR L(A2_BCC,CR,MN:C;0),, -20328+18.7339*T;,, N 93Lee2 ! PAR L(A2_BCC,CR,MN:C;1),, -9162+4.4183*T;,, N 93Lee2 ! $ PAR L(FCC_A1,CR,MN:C;0),, -19088+17.5423*T;,, N 93Lee2 ! PAR L(A1_FCC,CR,MN:C;0),, -19088+17.5423*T;,, N 93Lee2 ! $ PAR L(HCP_A3,CR,MN:C;0),, +60000;,, N 93Lee2 ! $ PAR L(CBCC_A12,CR,MN:C;0),, -38349+22.6925*T;,, N 93Lee2 ! $PAR L(CBCC_A12,CR,MN:C;0),, -36796+20.385*T;,, N 98Lee ! $ PAR L(CUB_A13,CR,MN:C;0),, -31260+16.4919*T;,, N 93Lee2 ! $ PAR L(CEMENTITE_D011,CR,MN:C),, +9000;,, N 93Lee2 ! $ PAR G(M23C6_D84,CR:MN:C),, +0.869565*GCR23C6 +0.130435*GMN23C6;,, N 93Lee2 ! PAR G(M23C6_D84,MN:CR:C),, +0.869565*GMN23C6 +0.130435*GCR23C6;,, N 93Lee2 ! PAR L(M23C6_D84,CR,MN:CR:C;0),, -173680+160*T;,, N 93Lee2 ! PAR L(M23C6_D84,CR,MN:CR:C;1),, -286614;,, N 93Lee2 ! PAR L(M23C6_D84,CR,MN:MN:C;0),, -173680+160*T;,, N 93Lee2 ! PAR L(M23C6_D84,CR,MN:MN:C;1),, -286614;,, N 93Lee2 ! $ PAR L(M7C3_D101,CR,MN:C),, +72737-56.4964*T;,, N 93Lee2 ! $ ------------------------------------------------------------------------------ $ Cr-Mn-Mo $ PAR G(R_PHASE,CR:MO:MN),, +27*GFCCCR+14*GHSERMO +12*GBCCMN;,, N Lin ! PAR G(R_PHASE,MN:MO:CR),, +27*GFCCMN+14*GHSERMO +12*GHSERCR;,, N Lin ! $ PAR G(SIGMA_D8B,MN:CR:MO),, +10*GFCCMN+4*GHSERCR +16*GHSERMO;,, N Lin ! PAR G(SIGMA_D8B,MN:MO:CR),, +10*GFCCMN+4*GHSERMO +16*GHSERCR;,, N Lin ! PAR G(SIGMA_D8B,MO:CR:MN),, +10*GFCCMO+4*GHSERCR +16*GBCCMN;,, N Lin ! $ ------------------------------------------------------------------------------ $ Cr-Mn-N $ ----------------------------------------------------------------------------- $ Cr-Mn-Nb $ PAR G(SIGMA_D8B,MN:CR:NB),, +10*GFCCMN+4*GHSERCR +16*GHSERNB;,, N Lin ! PAR G(SIGMA_D8B,MN:NB:CR),, +10*GFCCMN+4*GHSERNB +16*GHSERCR;,, N Lin ! $ ------------------------------------------------------------------------------ $ Cr-Mn-Ni $ $ B. Hallstedt, unpublished, 2016. $ $ Added ternary parameters to, very roughly, reproduce isothermal sections $ at 1223 K from E.M. Slyusarenko et al., J. Alloys Compd. 1997 and at 923 K $ from M. Majdic and K. Fritscher, Z. Werkstofftechnik, 1987. $ $ The parameter L(FCC_4SL,CR,MN:*:*:*:VA) was given a positive value to $ partially suppress an L1_2 field ((Cr,Mn)Ni3) in the Ni corner at 923 K. $ PAR L(LIQUID,CR,MN,NI;0),, +30000;,, N 16Hal7 ! $ PAR L(FCC_A1,CR,MN,NI:VA;0),, +30000;,, N 16Hal7 ! PAR L(A1_FCC,CR,MN,NI:VA;0),, +30000;,, N 16Hal7 ! $ PAR L(BCC_A2,CR,MN,NI:VA;0),, +40000;,, N 16Hal7 ! PAR L(A2_BCC,CR,MN,NI:VA;0),, +40000;,, N 16Hal7 ! $ PAR L(CBCC_A12,CR,MN,NI:VA;0),, +60000;,, N 16Hal7 ! PAR L(CUB_A13,CR,MN,NI:VA;0),, +40000;,, N 16Hal7 ! $ PAR G(SIGMA_D8B,MN:CR:NI),, +10*GFCCMN+4*GHSERCR +16*GBCCNI;,, N 16Hal7 ! PAR G(SIGMA_D8B,NI:CR:MN),, +10*GHSERNI+4*GHSERCR +16*GBCCMN-190000;,, N 16Hal7 ! $ PAR G(HIGH_SIGMA,MN:CR:NI),, +10*GFCCMN+4*GHSERCR +16*GBCCNI;,, N 16Hal7 ! PAR G(HIGH_SIGMA,NI:CR:MN),, +10*GHSERNI+4*GHSERCR +16*GBCCMN-190000;,, N 16Hal7 ! $ $ metastable $ PAR L(HCP_A3,CR,MN,NI:VA;0),, +30000;,, N 16Hal7 ! $ ------------------------------------------------------------------------------ $ Cr-Mn-Si $ PAR G(SIGMA_D8B,MN:CR:SI),, +10*GFCCMN+4*GHSERCR +16*GBCCSI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Cr-Mn-Ti $ PAR G(SIGMA_D8B,MN:CR:TI),, +10*GFCCMN+4*GHSERCR +16*GBCCTI;,, N Lin ! PAR G(SIGMA_D8B,MN:TI:CR),, +10*GFCCMN+4*GBCCTI +16*GHSERCR;,, N Lin ! $ ------------------------------------------------------------------------------ $ Cr-Mn-V $ PAR G(SIGMA_D8B,MN:CR:V),, +10*GFCCMN+4*GHSERCR +16*GHSERVV;,, N Lin ! PAR G(SIGMA_D8B,MN:V:CR),, +10*GFCCMN+4*GHSERVV +16*GHSERCR;,, N Lin ! PAR G(SIGMA_D8B,V:CR:MN),, +10*GFCCVV+4*GHSERCR +16*GBCCMN;,, N Lin ! $ ------------------------------------------------------------------------------ $ Cr-Mo-C $ $ C. Qiu, ISIJ Int., 32, 1117-27(1992). $ $ Checked against paper. $ PAR L(HCP_A3,CR,MO:C;0),, -3905+18.5304*T;,, N 92Qiu2 ! PAR G(M23C6_D84,CR:MO:C),, +20*GHSERCR+3*GHSERMO +6*GHSERCC-439117-50.0535*T;,, N 92Qiu2 ! PAR L(CR3C2_D510,CR,MO:C;0),, +40000;,, N 92Qiu2 ! PAR L(M7C3_D101,CR,MO:C;0),, +165280;,, N 92Qiu2 ! $ $ metastable $ PAR L(FCC_A1,CR,MO:C;0),, -10240+17.65*T;,, N Null ! PAR L(A1_FCC,CR,MO:C;0),, -10240+17.65*T;,, N Null ! PAR L(CEMENTITE_D011,CR,MO:C;0),, +40000;,, N 92Qiu2 ! PAR L(KSI_CARBIDE,CR,MO:C;0),, -348033;,, N 92Qiu2 ! $ ------------------------------------------------------------------------------ $ Cr-Mo-N $ ------------------------------------------------------------------------------ $ Cr-Mo-Nb $ PAR G(SIGMA_D8B,MO:CR:NB),, +10*GFCCMO+4*GHSERCR +16*GHSERNB;,, N Lin ! PAR G(SIGMA_D8B,MO:NB:CR),, +10*GFCCMO+4*GHSERNB +16*GHSERCR;,, N Lin ! $ ------------------------------------------------------------------------------ $ Cr-Mo-Ni $ $ K. Frisk, TRITA-MAC 429, Stockholm 1990. $ $ Cr-Ni from 16Tan $ Added fcc interaction in Cr-Mo $ CrNi2 from 06Tur added $ Changed sigma model from 8:4:18 to 10:4:16 with Mo on first SL $ $ The ternary interaction parameter for FCC_A1 is present in TCFE99 and $ SSOL V2, but not in V3 or V4. It is included to balance the effect of the $ Cr-Mo interaction, which was not present in the original work by K. Frisk. $ The experimental data on the fcc-boundary are better fitted with the $ binary interaction included, without any ternary interaction. $ $PAR L(FCC_A1,CR,MO,NI:VA;0),, -30000;,, N Null ! $ PAR G(CRNI2_C11B,CR:MO,NI;0),, -80000;,, N 06Tur ! PAR G(CRNI2_C11B,CR,MO:NI;0),, -11000;,, N 06Tur ! $ PAR G(SIGMA_D8B,NI:MO:CR),, +10*GHSERNI+4*GHSERMO+16*GHSERCR -50000;,, N 17Hal11 ! PAR G(SIGMA_D8B,NI:CR:MO),, +10*GHSERNI+4*GHSERCR+16*GHSERMO -260000+125*T;,, N 17Hal11 ! PAR G(SIGMA_D8B,MO:CR:NI),, +10*GFCCMO+4*GHSERCR +16*GBCCNI+300000;,, N 17Hal11 ! $ PAR G(P_PHASE,CR:NI:MO),, +24*GFCCCR+20*GBCCNI+12*GHSERMO -434085;,, N 90Fri3 ! PAR G(P_PHASE,NI:CR:MO),, +24*GHSERNI+20*GHSERCR+12*GHSERMO -341858;,, N 90Fri3 ! $ PAR G(MONI,NI:CR:MO),, +6*GHSERNI+5*GHSERCR+3*GHSERMO -50000;,, N 90Fri3 ! PAR G(MONI,CR:NI:MO),, +6*GFCCCR+6*GBCCNI+3*GHSERMO -50000;,, N 90Fri3 ! $ $ Metastable $ PAR G(CHI_A12,CR:MO:NI),, +24*GFCCCR+10*GHSERMO +24*GHSERNI;,, N Lin ! PAR G(CHI_A12,NI:CR:MO),, +24*GHSERNI+10*GHSERCR +24*GFCCMO;,, N Lin ! PAR G(CHI_A12,NI:MO:CR),, +24*GHSERNI+10*GHSERMO +24*GFCCCR;,, N Lin ! $ PAR G(MU_D85,CR:MO:CR:NI),, +GFCCCR+4*GHSERMO+2*GHSERCR +6*GHSERNI;,, N Lin ! PAR G(MU_D85,CR:MO:MO:NI),, +GFCCCR+6*GHSERMO +6*GHSERNI;,, N Lin ! PAR G(MU_D85,CR:MO:NI:CR),, +7*GFCCCR+4*GHSERMO +2*GBCCNI;,, N Lin ! PAR G(MU_D85,CR:MO:NI:MO),, +GFCCCR+4*GHSERMO+2*GBCCNI +6*GFCCMO;,, N Lin ! PAR G(MU_D85,CR:MO:NI:NI),, +GFCCCR+4*GHSERMO+2*GBCCNI +6*GHSERNI;,, N Lin ! PAR G(MU_D85,NI:MO:CR:CR),, +GHSERNI+4*GHSERMO+2*GHSERCR +6*GFCCCR;,, N Lin ! PAR G(MU_D85,NI:MO:CR:MO),, +GHSERNI+4*GHSERMO+2*GHSERCR +6*GFCCMO;,, N Lin ! PAR G(MU_D85,NI:MO:CR:NI),, +7*GHSERNI+4*GHSERMO +2*GHSERCR;,, N Lin ! PAR G(MU_D85,NI:MO:MO:CR),, +GHSERNI+6*GHSERMO +6*GFCCCR;,, N Lin ! PAR G(MU_D85,NI:MO:NI:CR),, +GHSERNI+4*GHSERMO+2*GBCCNI +6*GFCCCR;,, N Lin ! $ PAR G(R_PHASE,CR:MO:NI),, +27*GFCCCR+12*GBCCNI +14*GHSERMO;,, N Lin ! PAR G(R_PHASE,NI:MO:CR),, +27*GHSERNI+12*GHSERCR +14*GHSERMO;,, N Lin ! $ ------------------------------------------------------------------------------ $ Cr-Mo-Si $ PAR G(SIGMA_D8B,MO:CR:SI),, +10*GFCCMO+4*GHSERCR +16*GBCCSI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Cr-Mo-Ti $ PAR G(SIGMA_D8B,MO:CR:TI),, +10*GFCCMO+4*GHSERCR +16*GBCCTI;,, N Lin ! PAR G(SIGMA_D8B,MO:TI:CR),, +10*GFCCMO+4*GBCCTI +16*GHSERCR;,, N Lin ! $ ------------------------------------------------------------------------------ $ Cr-Mo-V $ PAR G(SIGMA_D8B,MO:CR:V),, +10*GFCCMO+4*GHSERCR +16*GHSERVV;,, N Lin ! PAR G(SIGMA_D8B,MO:V:CR),, +10*GFCCMO+4*GHSERVV +16*GHSERCR;,, N Lin ! PAR G(SIGMA_D8B,V:CR:MO),, +10*GFCCVV+4*GHSERCR +16*GHSERMO;,, N Lin ! PAR G(SIGMA_D8B,V:MO:CR),, +10*GFCCVV+4*GHSERMO +16*GHSERCR;,, N Lin ! $ ------------------------------------------------------------------------------ $ Cr-Nb-C $ $ A.V. Khvan, B. Hallstedt, K. Chang, Calphad, 39, 54-61(2012). $ PAR L(LIQUID,C,CR,NB;0),, +100000;,, N 12Khv1 ! $ PAR L(FCC_A1,CR,NB:C;0),, -23000;,, N 12Khv1 ! PAR L(A1_FCC,CR,NB:C;0),, -23000;,, N 12Khv1 ! PAR L(HCP_A3,CR,NB:C;0),, +18500;,, N 12Khv1 ! $ PAR G(M23C6_D84,CR:NB:C),, +0.8695652*GCR23C6 +3*GHSERNB+0.7826087*GHSERCC-130000;,, N 12Khv1 ! $ ------------------------------------------------------------------------------ $ Cr-Nb-N $ ------------------------------------------------------------------------------ $ Cr-Nb-Ni $ PAR G(SIGMA_D8B,NI:CR:NB),, +10*GHSERNI+4*GHSERCR +16*GHSERNB;,, N Lin ! PAR G(SIGMA_D8B,NI:NB:CR),, +10*GHSERNI+4*GHSERNB +16*GHSERCR;,, N Lin ! $ ------------------------------------------------------------------------------ $ Cr-Nb-Si $ ------------------------------------------------------------------------------ $ Cr-Nb-Ti $ ------------------------------------------------------------------------------ $ Cr-Nb-V $ PAR G(SIGMA_D8B,V:CR:NB),, +10*GFCCVV+4*GHSERCR +16*GHSERNB;,, N Lin ! PAR G(SIGMA_D8B,V:NB:CR),, +10*GFCCVV+4*GHSERNB +16*GHSERCR;,, N Lin ! $ ------------------------------------------------------------------------------ $ Cr-Ni-C $ $ B.-J. Lee, Calphad, 16, 121-49(1992). $ $ Cr-C modified by 12Khv. $ New Cr-Ni from 16Tan. $ Ni-C modified by 06Hal1. $ Cr-Ni-C modified by 06Hal2. $ PAR L(FCC_A1,CR,NI:C;0),, +ZERO;,, N 06Hal3 ! PAR TC(FCC_A1,CR,NI:C;0),, -3605;,, N Null ! PAR BMAG(FCC_A1,CR,NI:C;0),, -1.91;,, N Null ! $ PAR L(A1_FCC,CR,NI:C;0),, +ZERO;,, N 06Hal3 ! PAR TC(A1_FCC,CR,NI:C;0),, -3605;,, N Null ! PAR BMAG(A1_FCC,CR,NI:C;0),, -1.91;,, N Null ! $ PAR TC(BCC_A2,CR,NI:C;0),, +2373;,, N Null ! PAR TC(BCC_A2,CR,NI:C;1),, +617;,, N Null ! PAR BMAG(BCC_A2,CR,NI:C;0),, +4;,, N Null ! $ PAR TC(A2_BCC,CR,NI:C;0),, +2373;,, N Null ! PAR TC(A2_BCC,CR,NI:C;1),, +617;,, N Null ! PAR BMAG(A2_BCC,CR,NI:C;0),, +4;,, N Null ! $ PAR G(M23C6_D84,CR:NI:C),, +0.8695652*GCR23C6 +0.1304348*GNI23C6;,, N 92Lee1 ! PAR G(M23C6_D84,NI:CR:C),, +0.8695652*GNI23C6 +0.1304348*GCR23C6;,, N 92Lee1 ! PAR L(M23C6_D84,CR,NI:CR:C;0),, +ZERO;,, N 06Hal3 ! PAR L(M23C6_D84,CR,NI:NI:C;0),, +ZERO;,, N 06Hal3 ! $ PAR L(M7C3_D101,CR,NI:C;0),, +ZERO;,, N 06Hal3 ! $ $ Metastable $ PAR L(CEMENTITE_D011,CR,NI:C;0),, +27898;,, N Null ! $ ------------------------------------------------------------------------------ $ Cr-Ni-N $ ------------------------------------------------------------------------------ $ Cr-Ni-Si $ $ J.C. Schuster, Y. Du, Metall. Mater. Trans. A, 31A, 1795-1803(2000). $ $ Checked against paper. $ $ Cr-Ni from 16Tan instead of 92Lee. $ FCC_4SL instead of L12_FCC (modified parameters from 12Yua). $ M5SI3_D88 (Cr5Si3) modelled as stoichiometric. $ Cr removed from 1st sl and Ni added on 3rd sl of SIGMA_D8B. $ $ Ni3Si (L12) has a stability range towards CrNi3, which was previously not $ present. The extension does not seem excessive. The sigma phase field is $ more narrow with essentially fixed Cr to Ni ratio. It is also stable closer $ to Cr-Ni at high temperature. This should require some adjustments. $ NI2SI_C37 is slightly more stable. Other changes are minor. The Ni-Si binary $ from 12Yua should be used instead of 99Du, but this requires complete $ reoptimisation of the ternary. $ PAR L(LIQUID,CR,NI,SI;0),, +2632.97;,, N 00Sch ! PAR L(LIQUID,CR,NI,SI;1),, -31200.06;,, N 00Sch ! PAR L(LIQUID,CR,NI,SI;2),, -195772.95;,, N 00Sch ! $ PAR L(FCC_A1,CR,NI,SI:VA;0),, -103437.71;,, N 00Sch ! PAR L(A1_FCC,CR,NI,SI:VA;0),, -103437.71;,, N 00Sch ! $ PAR G(CR3NI5SI2,CR:NI:SI),, +3*GHSERCR+5*GHSERNI+2*GHSERSI -257244.2-57.6017*T;,, N 00Sch ! PAR G(CR5NI5SI3,CR:NI:SI),, +5*GHSERCR+5*GHSERNI+3*GHSERSI -394722.4-41.94047*T;,, N 00Sch ! $ PAR L(NI2SI_C37,CR,NI:SI;0),, +65656.96-41.65881*T;,, N 00Sch ! PAR L(NI2SI_C37,CR,NI:SI;1),, -14620.24;,, N 00Sch ! $ PAR G(SIGMA_D8B,NI:CR:SI),, +10*GHSERNI+4*GHSERCR +16*GHSERSI+150000;,, N 00Sch ! $PAR L(SIGMA_D8B,CR,NI:CR:SI;0),, +75848.4+87.9975*T;,, N 00Sch ! PAR L(SIGMA_D8B,NI:CR:CR,SI;0),, -3512346+321.015*T;,, N 00Sch ! $ ------------------------------------------------------------------------------ $ Cr-Ni-Ti $ PAR G(SIGMA_D8B,NI:CR:TI),, +10*GHSERNI+4*GHSERCR +16*GBCCTI;,, N Lin ! PAR G(SIGMA_D8B,NI:TI:CR),, +10*GHSERNI+4*GBCCTI +16*GHSERCR;,, N Lin ! $ ------------------------------------------------------------------------------ $ Cr-Ni-V $ PAR G(SIGMA_D8B,NI:CR:V),, +10*GHSERNI+4*GHSERCR +16*GHSERVV;,, N Lin ! PAR G(SIGMA_D8B,NI:V:CR),, +10*GHSERNI+4*GHSERVV +16*GHSERCR;,, N Lin ! PAR G(SIGMA_D8B,V:CR:NI),, +10*GFCCVV+4*GHSERCR +16*GBCCNI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Cr-Si-C $ $ Y. Du, J.C. Schuster, L. Perring, J. Am. Ceram. Soc., 83, 2067-73(2000). $ $ Checked against paper. $ $ Cr-C from 12Khv instead of 92Lee. $ Si-C from 91Lac instead of 96Gro (for compatibility with Fe-Si-C from 98Mie). $ Simplified model for M5SI3_D88 (fixed Cr/Si ratio). $ $ There is a small change for M5SI3_D88. The liquid (with Si-C from 91Lac) is $ much more stable and there is quite a bit of liquid at 1673 K. At this $ temperature there should only be liquid close to the Cr-Si binary. $ PAR L(LIQUID,C,CR,SI;0),, -248421;,, N 00Du2 ! PAR L(LIQUID,C,CR,SI;1),, +40606;,, N 00Du2 ! PAR L(LIQUID,C,CR,SI;2),, -30000;,, N 00Du2 ! $ PAR G(CR3SI_A15,CR:SI:C),, +3*GHSERCR+GHSERSI+3*GHSERCC -40000;,, N 00Du2 ! PAR G(CR3SI_A15,SI:CR:C),, +GHSERCR+3*GHSERSI+3*GHSERCC +40000;,, N 00Du2 ! $ PAR G(M5SI3_D88,CR:SI:C),, +5*GHSERCR+3*GHSERSI+GHSERCC -295220-3.25085*T;,, N 00Du2 ! $ ------------------------------------------------------------------------------ $ Cr-Si-N $ ------------------------------------------------------------------------------ $ Cr-Si-Ti $ ------------------------------------------------------------------------------ $ Cr-Si-V $ PAR G(SIGMA_D8B,V:CR:SI),, +10*GFCCVV+4*GHSERCR +16*GBCCSI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Cr-Ti-C $ ------------------------------------------------------------------------------ $ Cr-Ti-N $ ------------------------------------------------------------------------------ $ Cr-Ti-V $ PAR G(SIGMA_D8B,V:CR:TI),, +10*GFCCVV+4*GHSERCR +16*GBCCTI;,, N Lin ! PAR G(SIGMA_D8B,V:TI:CR),, +10*GFCCVV+4*GBCCTI +16*GHSERCR;,, N Lin ! $ ------------------------------------------------------------------------------ $ Cr-V-C $ $ B.-J. Lee, D.N. Lee, J. Phase Equilib., 13, 349-364(1992). $ $ Checked against paper. $ $ Cr-C from 12Khv instead of 92Lee. $ $ Liquid interaction modified to approximately reproduce ternary invariant $ temperatures. The largest difference is now 11 K. $ PAR L(LIQUID,C,CR,V;0),, -769497;,, N 92Lee2 ! $PAR L(LIQUID,C,CR,V;1),, +263981;,, N 92Lee2 ! PAR L(LIQUID,C,CR,V;1),, +230000;,, N 17Hal14 ! PAR L(LIQUID,C,CR,V;2),, +3599;,, N 92Lee2 ! $ PAR L(FCC_A1,CR,V:C;0),, +35698-50.0981*T;,, N 92Lee2 ! PAR L(A1_FCC,CR,V:C;0),, +35698-50.0981*T;,, N 92Lee2 ! $ PAR L(HCP_A3,CR,V:C;0),, +17165-9.9072*T;,, N 92Lee2 ! $ PAR G(M23C6_D84,CR:V:C),, +0.8695652*GCR23C6 +0.1304348*GV23C6;,, N 92Lee2 ! PAR G(M23C6_D84,V:CR:C),, +0.8695652*GV23C6 +0.1304348*GCR23C6;,, N 92Lee2 ! PAR L(M23C6_D84,CR,V:CR:C;0),, -382069;,, N 92Lee2 ! PAR L(M23C6_D84,CR,V:V:C;0),, -382069;,, N 92Lee2 ! $ PAR L(M7C3_D101,CR,V:C;0),, -110271;,, N 92Lee2 ! PAR L(CR3C2_D510,CR,V:C;0),, +21072;,, N 92Lee2 ! $ PAR G(CR2VC2,CR:V:C),, +2*GHSERCR+GHSERVV+2*GHSERCC -105987-38.2069*T;,, N 92Lee2 ! $ $ metastable $ PAR L(CEMENTITE_D011,CR,V:C;0),, -29622-8.0892*T;,, N 92Lee2 ! PAR L(CEMENTITE_D011,CR,V:C;1),, -5160-7.5711*T;,, N 92Lee2 ! $ ------------------------------------------------------------------------------ $ Cr-V-N $ ------------------------------------------------------------------------------ $ Cu-C-N $ ------------------------------------------------------------------------------ $ Cu-Fe-C $ $ B. Hallstedt, unpublished, 2017. $ $ This dataset is essentially an extrapolation from the three binaries. $ Comparison was made with the assessment from K. Shubhank and Y.-B. Kang, $ Calphad, 45, 127-37(2014). A ternary liquid interaction is necessary to $ reproduce data. $ $ Shubhank and Kang used the MQM liquid model and their own assessments $ for the three binaries, which do not differ much from the binaries used here. $ PAR L(LIQUID,C,CU,FE;0),, -90000;,, N 17Hal16 ! $ $ ------------------------------------------------------------------------------ $ Cu-Fe-Mg $ ------------------------------------------------------------------------------ $ Cu-Fe-Mn $ $ J. Miettinen, Calphad, 27, 141-45(2003). $ $ Checked against paper. $ $ Cu-Fe from 95Che instead of 93Ans (or87Jan). $ $ The fcc miscibility gap is more narrow, especially for relatively high $ Cu and Mn contents. $ PAR L(LIQUID,CU,FE,MN;0),, +115000-60*T;,, N 03Mie3 ! PAR L(LIQUID,CU,FE,MN;1),, +13000;,, N 03Mie3 ! PAR L(LIQUID,CU,FE,MN;2),, +10000;,, N 03Mie3 ! $ PAR L(FCC_A1,CU,FE,MN:VA;0),, -68000+50*T;,, N 03Mie3 ! PAR L(A1_FCC,CU,FE,MN:VA;0),, -68000+50*T;,, N 03Mie3 ! $ PAR L(BCC_A2,CU,FE,MN:VA;0),, +30000;,, N 03Mie3 ! PAR L(A2_BCC,CU,FE,MN:VA;0),, +30000;,, N 03Mie3 ! $ ------------------------------------------------------------------------------ $ Cu-Fe-Mo $ $ C.P. Wang, X.J. Liu, I. Ohnuma, R. Kainuma, S.M. Hao, K. Ishida, $ J. Phase Equilib., 21, 54-62(2000). $ $ Checked against paper. $ $ In the isoplethal section at 5 wt% Mo there should be two fcc phases, but $ no lambda. Wang et al. seem to have labeled the diagram incorrectly. $ PAR L(LIQUID,CU,FE,MO;0),, +ZERO;,, N 00Wan ! $ PAR L(FCC_A1,CU,FE,MO:VA;0),, -3000;,, N 00Wan ! PAR L(A1_FCC,CU,FE,MO:VA;0),, -3000;,, N 00Wan ! $ PAR L(BCC_A2,CU,FE,MO:VA;0),, +40000-48*T;,, N 00Wan ! PAR L(A2_BCC,CU,FE,MO:VA;0),, +40000-48*T;,, N 00Wan ! $ ------------------------------------------------------------------------------ $ Cu-Fe-N $ ------------------------------------------------------------------------------ $ Cu-Fe-Nb $ $ C.P. Wang, X.J. Liu, I. Ohnuma, R. Kainuma, S.M. Hao, K. Ishida, $ J. Phase Equilib., 21, 54-62(2000). $ $ Checked against paper. $ $ Fe-Nb from 16Jac instead of 90Hua. $ $ Changes along the Fe-Nb edge are considerable, but the ternary does not $ change much. $ PAR L(LIQUID,CU,FE,NB;0),, +ZERO;,, N 00Wan ! $ PAR L(FCC_A1,CU,FE,NB:VA;0),, -33000;,, N 00Wan ! PAR L(BCC_A2,CU,FE,NB:VA;0),, +30000-19.6*T;,, N 00Wan ! $ ------------------------------------------------------------------------------ $ Cu-Fe-Ni $ $ A. Jansson, TRITA-MAC 340, KTH, Stockholm 1987. $ $ Cu-Fe from 95Che instead of 87Jan. $ Cu-Ni from 92Mey instead of 87Jan. $ Fe-Ni modified by 93Lee and ordering from 03Dup/16Hal. $ Cu-Fe-Ni ordering from 01Ser. $ $ Parameters taken from H. Ohtani et al., ISIJ Int., 37, 207-16(1997). $ Parameters are also in C. Servant et al., Calphad, 25, 79-95(2001). $ $ 97Oht used Cu-Fe from 93Swa rather than 87Jan. $ $ Checked against 97Oht, 01Ser (and 14Dre). $ $ In contrast to 01Ser there is no equilibrium between FeNi3 and fcc-Cu at $ 723 or 773 K. FeNi3 does nor extend quite far enough from the binary. $ PAR L(LIQUID,CU,FE,NI;0),, -68786+30.9*T;,, N 87Jan ! $ PAR L(FCC_A1,CU,FE,NI:VA;0),, -73272+30.9*T;,, N 87Jan ! PAR TC(FCC_A1,CU,FE,NI:VA;0),, +7000;,, N 87Jan ! PAR BMAG(FCC_A1,CU,FE,NI:VA;0),, +20;,, N 87Jan ! $ PAR L(A1_FCC,CU,FE,NI:VA;0),, -73272+30.9*T;,, N 87Jan ! PAR TC(A1_FCC,CU,FE,NI:VA;0),, +7000;,, N 87Jan ! PAR BMAG(A1_FCC,CU,FE,NI:VA;0),, +20;,, N 87Jan ! $ PAR L(FCC_4SL,CU,FE:*:*:*:VA;0),, -7600;,, N 01Ser ! $ PAR L(BCC_A2,CU,FE,NI:VA;0),, +ZERO;,, N 87Jan ! PAR L(A2_BCC,CU,FE,NI:VA;0),, +ZERO;,, N 87Jan ! $ ------------------------------------------------------------------------------ $ Cu-Fe-Si $ $ C.P. Wang, X.J. Liu, I. Ohnuma, R. Kainuma, K. Ishida, $ J. Phase Equilib., 23, 236-45(2002). $ $ Checked against paper. $ $ Ordering in bcc included (B2_BCC) $ CuSi from 16Hal instead of 98Jac $ $ There are some changes compared to the original assessment, in particular $ the liquid miscibility gap and towards the Cu-Si edge. $ PAR L(LIQUID,CU,FE,SI;0),, +23000-19.5*T;,, N 02Wan ! PAR L(LIQUID,CU,FE,SI;1),, +50000-19.5*T;,, N 02Wan ! PAR L(LIQUID,CU,FE,SI;2),, +23000-19.5*T;,, N 02Wan ! $ PAR L(FCC_A1,CU,FE,SI:VA;0),, -231494.5+130*T;,, N 02Wan ! PAR L(A1_FCC,CU,FE,SI:VA;0),, -231494.5+130*T;,, N 02Wan ! $ PAR L(BCC_A2,CU,FE,SI:VA;0),, -158642.5+50*T;,, N 02Wan ! PAR L(BCC_A2,CU,FE,SI:VA;1),, -182105.5+70*T;,, N 02Wan ! PAR L(BCC_A2,CU,FE,SI:VA;2),, -158642.5+50*T;,, N 02Wan ! $ PAR L(A2_BCC,CU,FE,SI:VA;0),, -158642.5+50*T;,, N 02Wan ! PAR L(A2_BCC,CU,FE,SI:VA;1),, -182105.5+70*T;,, N 02Wan ! PAR L(A2_BCC,CU,FE,SI:VA;2),, -158642.5+50*T;,, N 02Wan ! $ ------------------------------------------------------------------------------ $ Cu-Fe-Ti $ ------------------------------------------------------------------------------ $ Cu-Fe-V $ ------------------------------------------------------------------------------ $ Cu-Mg-C $ ------------------------------------------------------------------------------ $ Cu-Mg-Mn $ ------------------------------------------------------------------------------ $ Cu-Mg-Mo $ ------------------------------------------------------------------------------ $ Cu-Mg-N $ ------------------------------------------------------------------------------ $ Cu-Mg-Nb $ ------------------------------------------------------------------------------ $ Cu-Mg-Ni $ ------------------------------------------------------------------------------ $ Cu-Mg-Si $ ------------------------------------------------------------------------------ $ Cu-Mg-Ti $ ------------------------------------------------------------------------------ $ Cu-Mg-V $ ------------------------------------------------------------------------------ $ Cu-Mn-C $ ------------------------------------------------------------------------------ $ Cu-Mn-Mo $ ------------------------------------------------------------------------------ $ Cu-Mn-N $ ------------------------------------------------------------------------------ $ Cu-Mn-Nb $ ------------------------------------------------------------------------------ $ Cu-Mn-Ni $ ------------------------------------------------------------------------------ $ Cu-Mn-Si $ ------------------------------------------------------------------------------ $ Cu-Mn-Ti $ ------------------------------------------------------------------------------ $ Cu-Mn-V $ ------------------------------------------------------------------------------ $ Cu-Mo-C $ ------------------------------------------------------------------------------ $ Cu-Mo-N $ ------------------------------------------------------------------------------ $ Cu-Mo-Nb $ ------------------------------------------------------------------------------ $ Cu-Mo-Ni $ ------------------------------------------------------------------------------ $ Cu-Mo-Si $ ------------------------------------------------------------------------------ $ Cu-Mo-Ti $ ------------------------------------------------------------------------------ $ Cu-Mo-V $ ------------------------------------------------------------------------------ $ Cu-Nb-C $ ------------------------------------------------------------------------------ $ Cu-Nb-N $ ------------------------------------------------------------------------------ $ Cu-Nb-Ni $ ------------------------------------------------------------------------------ $ Cu-Nb-Si $ ------------------------------------------------------------------------------ $ Cu-Nb-Ti $ ------------------------------------------------------------------------------ $ Cu-Nb-V $ ------------------------------------------------------------------------------ $ Cu-Ni-C $ ------------------------------------------------------------------------------ $ Cu-Ni-N $ ------------------------------------------------------------------------------ $ Cu-Ni-Si $ ------------------------------------------------------------------------------ $ Cu-Ni-Ti $ ------------------------------------------------------------------------------ $ Cu-Ni-V $ ------------------------------------------------------------------------------ $ Cu-Si-C $ ------------------------------------------------------------------------------ $ Cu-Si-N $ ------------------------------------------------------------------------------ $ Cu-Si-Ti $ ------------------------------------------------------------------------------ $ Cu-Si-V $ ------------------------------------------------------------------------------ $ Cu-Ti-C $ ------------------------------------------------------------------------------ $ Cu-Ti-N $ ------------------------------------------------------------------------------ $ Cu-Ti-V $ ------------------------------------------------------------------------------ $ Cu-V-C $ ------------------------------------------------------------------------------ $ Cu-V-N $ ------------------------------------------------------------------------------ $ Fe-C-N $ $ H. Du, J. Phase Equilib., 14, 682-93(1993). $ $ Checked against paper. $ $ There are small differences compared to the paper visible at 863 K. $ Fcc is slightly too stable and hcp is slightly shifted. $ $ For more carbon rich compositions than cementite, M5C2 and M7C3 are more $ stable than FECN_CHI (when using Fe-Mn-C from 11Dju). This is probably quite $ reasonable (in particular M5C2) and N solubility should be modelled. $ $ FECN_CHI should be replaced by M5C2 with N solubility. $ $ The value from 88And2 was kept for L(HCP_A3,FE:C,VA) instead of the new $ value from 93Du. This makes the hcp phase somewhat less stable in Fe-C-N. $ PAR L(LIQUID,C,FE,N;0),, +490996-109.135*T;,, N 91Du ! PAR L(LIQUID,C,FE,N;1),, +192167-109.135*T;,, N 91Du ! PAR L(LIQUID,C,FE,N;2),, +490996-109.135*T;,, N 91Du ! $ PAR L(FCC_A1,FE:C,N;0),, -21893;,, N 93Du ! PAR L(A1_FCC,FE:C,N;0),, -21893;,, N 93Du ! $ PAR L(HCP_A3,FE:C,N;0),, -62984;,, N 93Du ! $ ------------------------------------------------------------------------------ $ Fe-Mg-C $ ------------------------------------------------------------------------------ $ Fe-Mg-Mn $ ------------------------------------------------------------------------------ $ Fe-Mg-Mo $ ------------------------------------------------------------------------------ $ Fe-Mg-N $ ------------------------------------------------------------------------------ $ Fe-Mg-Nb $ ------------------------------------------------------------------------------ $ Fe-Mg-Ni $ ------------------------------------------------------------------------------ $ Fe-Mg-Si $ ------------------------------------------------------------------------------ $ Fe-Mg-Ti $ ------------------------------------------------------------------------------ $ Fe-Mg-V $ ------------------------------------------------------------------------------ $ Fe-Mn-C $ $ D. Djurovic, B. Hallstedt, J. von Appen, R. Dronskowski, $ Calphad, 35, 479-91(2011). $ PAR L(LIQUID,C,FE,MN;0),, -71514-11.3063*T;,, N 11Dju ! PAR L(LIQUID,C,FE,MN;1),, +19817;,, N 11Dju ! PAR L(LIQUID,C,FE,MN;2),, +27885;,, N 11Dju ! $ PAR L(FCC_A1,FE,MN:C;0),, +20082-11.6312*T;,, N 11Dju ! PAR L(A1_FCC,FE,MN:C;0),, +20082-11.6312*T;,, N 11Dju ! $ PAR L(HCP_A3,FE,MN:C;0),, +21742-50.2703*T;,, N 11Dju ! PAR L(HCP_A3,FE,MN:C;1),, -32608;,, N 11Dju ! $ PAR L(CBCC_A12,FE,MN:C;0),, -36732;,, N 11Dju ! PAR L(CUB_A13,FE,MN:C;0),, -36732;,, N 11Dju ! $ PAR L(CEMENTITE_D011,FE,MN:C;0),, -7715+1.3687*T;,, N 11Dju ! PAR L(M5C2,FE,MN:C;0),, +8743-15.1917*T;,, N 11Dju ! PAR L(M7C3_D101,FE,MN:C;0),, +20157-24.7104*T;,, N 11Dju ! $ PAR G(M23C6_D84,FE:MN:C),, +0.869565*GFE23C6 +0.130435*GMN23C6;,, N 11Dju ! PAR G(M23C6_D84,MN:FE:C),, +0.130435*GFE23C6 +0.869565*GMN23C6;,, N 11Dju ! PAR L(M23C6_D84,FE,MN:FE,MN:C;0),, -95000;,, N 11Dju ! $ ------------------------------------------------------------------------------ $ Fe-Mn-Mo $ PAR G(R_PHASE,FE:MO:MN),, +27*GFCCFE+14*GHSERMO +12*GBCCMN;,, N Lin ! PAR G(R_PHASE,MN:MO:FE),, +27*GFCCMN+14*GHSERMO +12*GHSERFE;,, N Lin ! $ PAR G(SIGMA_D8B,FE:MO:MN),, +10*GFCCFE+4*GHSERMO +16*GBCCMN;,, N Lin ! PAR G(SIGMA_D8B,MN:MO:FE),, +10*GFCCMN+4*GHSERMO +16*GHSERFE;,, N Lin ! $ ------------------------------------------------------------------------------ $ Fe-Mn-N $ $ C. Qiu, Metall. Trans. A, 24A, 629-45(1993). $ $ Checked against paper. $ $ Fe-N from 93Du instead of 91Fri. $ $ The isothermal section at 973 K changes very slightly. $ PAR L(LIQUID,FE,MN,N;0),, -15211+18.43*T;,, N 93Qiu2 ! $ PAR L(FCC_A1,FE,MN:N;0),, +53968-38.102*T;,, N 93Qiu2 ! PAR L(FCC_A1,FE,MN:N;1),, -27787;,, N 93Qiu2 ! $ PAR L(A1_FCC,FE,MN:N;0),, +53968-38.102*T;,, N 93Qiu2 ! PAR L(A1_FCC,FE,MN:N;1),, -27787;,, N 93Qiu2 ! $ PAR L(FE4N_L1,FE,MN:N;0),, +36297-28.8876*T;,, N 93Qiu2 ! $ ------------------------------------------------------------------------------ $ Fe-Mn-Nb $ $ A.V. Khvan, B. Hallstedt, Calphad, 40, 10-15(2013). $ $ Checked against paper. $ $ Same as the description from S.H. Liu 2012, but with a modified Fe-Nb and $ slightly modified MU_D85. $ PAR G(MU_D85,FE:NB:FE:MN),, +3*GHSERFE+6*GHSERMN+4*GHSERNB -61620;,, N 12Liu ! PAR G(MU_D85,FE:NB:NB:MN),, +GHSERFE+6*GHSERMN+6*GHSERNB -151320;,, N 13Khv1 ! PAR G(MU_D85,MN:NB:FE:FE),, +8*GHSERFE+GHSERMN+4*GHSERNB -86710;,, N 12Liu ! PAR G(MU_D85,MN:NB:FE:MN),, +2*GHSERFE+7*GHSERMN+4*GHSERNB -64610;,, N 12Liu ! PAR G(MU_D85,MN:NB:NB:FE),, +6*GHSERFE+GHSERMN+6*GHSERNB -187070;,, N 13Khv1 ! PAR G(MU_D85,MN:NB:FE:NB),, +2*GHSERFE+GHSERMN+10*GHSERNB +331760;,, N 12Liu ! PAR G(MU_D85,NB:NB:FE:MN),, +2*GHSERFE+6*GHSERMN+5*GHSERNB +31720;,, N 12Liu ! $ $ Metastable $ PAR G(SIGMA_D8B,FE:NB:MN),, +10*GFCCFE+4*GHSERNB +16*GBCCMN;,, N Lin ! PAR G(SIGMA_D8B,MN:NB:FE),, +10*GFCCMN+4*GHSERNB +16*GHSERFE;,, N Lin ! $ ------------------------------------------------------------------------------ $ Fe-Mn-Ni $ $ L. Zhang, Y. Du, H. Xu, S. Liu, Y. Liu, F. Zheng, N. Dupin, H. Zhou, C. Tang, $ Int. J. Mater. Res., 100, 160-75(2009). $ $ The only parameter coming from 09Zha is L(CUB_A13,FE,NI:VA;0). We refer to $ 09Zha for comparison with their calculations. They used separate 2SL models $ for L1_2 (MnNi3 and FeNi3) and L1_0 (MnNi). Here a 4SL fcc model is used. $ $ This dataset nicely reproduces phase diagrams and experimental data shown in $ 09Zha (as long as ordered fcc is excluded at high temperature), which $ is not quite the case with TCFE8 or steel11h (SGTE). $ $ Using option F for FCC_4SL. $ $ The high temperature problem with FCC_4SL was solved by $ changing the UFFENI parameter in the Fe-Ni system. It was then necessary $ to add a ternary order parameter to avoid an L1_2 field at 873 K in the $ Mn-rich corner. $ $ Using ternary ordering energies reults in L1_0 and L1_2 extending $ far into the ternary. When not using option F the extension is considerably $ larger. $ $ The problems described below have been solved (by changing UFFENI). $ $ At high temperature (from below solidus up to quite far above liquidus) $ L1_2 becomes stable as (Fe,Ni)3Mn from about Fe2.5Ni0.5Mn to FeNi2Mn. $ This could be prevented by making FE:FE:MN:NI and NI:NI:FE:MN positive. $ The same thing happens when no wildcards are used. $ $ By adding positive values to the ternary compounds the L1_0 and L1_2 phases $ near the Mn-Ni edge and, in particular at the Mn corner are stabilised at $ low temperature. $ $PAR G(FCC_4SL,FE:FE:MN:NI:VA),, +FFE2MNNI;,, N 16Hal1 ! $PAR G(FCC_4SL,MN:MN:FE:NI:VA),, +FFEMN2NI;,, N 16Hal1 ! $PAR G(FCC_4SL,NI:NI:FE:MN:VA),, +FFEMNNI2;,, N 16Hal1 ! $PAR G(FCC_4SL,FE:FE:MN:NI:VA),, +10*T;,, N 16Hal1 ! $PAR G(FCC_4SL,MN:MN:FE:NI:VA),, +ZERO;,, N 16Hal1 ! $PAR G(FCC_4SL,NI:NI:FE:MN:VA),, +10*T;,, N 16Hal1 ! PAR G(FCC_4SL,MN:MN:FE:NI:VA),, -3000;,, N 16Hal1 ! $ FUNCTION FFE2MNNI 298.15 +2*U1FFEMN+2*U1FFENI+U1FMNNI; 6000 N ! FUNCTION FFEMN2NI 298.15 +2*U1FFEMN+U1FFENI+2*U1FMNNI; 6000 N ! FUNCTION FFEMNNI2 298.15 +U1FFEMN+2*U1FFENI+2*U1FMNNI; 6000 N ! $ ------------------------------------------------------------------------------ $ Fe-Mn-Si $ $ A. Forsberg, J. Agren, J. Phase Equilib., 14, 354-63(1993). $ $ Checked against paper. $ $ In the paper the ordering of the bcc phase was not $ considered. The diagrams were calculated for the disordered phase only. $ Ordering increases the size of the bcc/B2 phase field as compared with the $ paper. I.e. the system should be reoptimised. $ PAR L(LIQUID,FE,MN,SI;0),, -180473;,, N 93For ! PAR L(LIQUID,FE,MN,SI;1),, -95027;,, N 93For ! PAR L(LIQUID,FE,MN,SI;2),, +154386;,, N 93For ! $ PAR L(FCC_A1,FE,MN,SI:VA;0),, -56655-55.613*T;,, N 93For ! PAR TC(FCC_A1,FE,MN,SI:VA;0),, +13854;,, N 93For ! $ PAR L(A1_FCC,FE,MN,SI:VA;0),, -56655-55.613*T;,, N 93For ! PAR TC(A1_FCC,FE,MN,SI:VA;0),, +13854;,, N 93For ! $ PAR L(BCC_A2,FE,MN,SI:VA;0),, -97474;,, N 93For ! PAR L(A2_BCC,FE,MN,SI:VA;0),, -97474;,, N 93For ! $ PAR L(HCP_A3,FE,MN,SI:VA;0),, -24892-154.98*T;,, N 93For ! $ PAR L(CBCC_A12,FE,MN,SI:VA;0),, -91507;,, N 93For ! PAR L(CUB_A13,FE,MN,SI:VA;0),, -91507;,, N 93For ! $ PAR L(MSI_B20,FE,MN:SI),, -10780+22.14*T;,, N 93For ! PAR L(M5SI3_D88,FE,MN:SI:VA),, +24568;,, N 93For ! PAR G(MN3SI,FE,MN:SI),, -16552;,, N 93For ! $ ------------------------------------------------------------------------------ $ Fe-Mn-Ti $ PAR G(SIGMA_D8B,FE:TI:MN),, +10*GFCCFE+4*GBCCTI +16*GBCCMN;,, N Lin ! PAR G(SIGMA_D8B,MN:TI:FE),, +10*GFCCMN+4*GBCCTI +16*GHSERFE;,, N Lin ! $ ------------------------------------------------------------------------------ $ Fe-Mn-V $ $ W. Huang, Calphad, 15, 195-208(1991). $ $ Checked against paper. $ $ Old sigma parameters kept for SIGMA_D8B. These give very similar results $ in the ternary. $ PAR G(SIGMA_D8B,FE:V:MN),, +10*GFCCFE+4*GHSERVV +16*GBCCMN-200000;,, N 91Hua3 ! PAR G(SIGMA_D8B,MN:V:FE),, +10*GFCCMN+4*GHSERVV +16*GHSERFE-150000;,, N 91Hua3 ! PAR L(SIGMA_D8B,FE:V:MN,V;0),, -100000;,, N 91Hua3 ! PAR L(SIGMA_D8B,MN:V:FE,V;0),, -300000;,, N 91Hua3 ! $ ------------------------------------------------------------------------------ $ Fe-Mo-C $ $ J.-O. Andersson, Calphad, 12, 9-23(1988). $ $ Checked against paper. $ $ New models for C14_LAVES, SIGMA_D8B and MU_D85 in Fe-Mo. $ $ Modified bcc interaction. The bcc interaction is based on activity $ measurements from Wada and similar to that in the Cr-Fe-C system. $ PAR L(LIQUID,C,FE,MO;0),, -37800;,, N 88And2 ! $ $PAR L(BCC_A2,FE,MO:C;0),, -1750000+940*T;,, N 88And2 ! PAR L(BCC_A2,FE,MO:C;0),, -1250000+667.7*T;,, N 91Lee ! PAR TC(BCC_A2,FE,MO:C;0),, +335;,, N 88And2 ! PAR TC(BCC_A2,FE,MO:C;1),, +526;,, N 88And2 ! $ PAR L(A2_BCC,FE,MO:C;0),, -1250000+667.7*T;,, N 91Lee ! PAR TC(A2_BCC,FE,MO:C;0),, +335;,, N 88And2 ! PAR TC(A2_BCC,FE,MO:C;1),, +526;,, N 88And2 ! $ PAR L(FCC_A1,FE,MO:C;0),, +6000;,, N 88And2 ! PAR L(A1_FCC,FE,MO:C;0),, +6000;,, N 88And2 ! $ PAR L(HCP_A3,FE,MO:C;0),, +13030-33.8*T;,, N 88And2 ! $ PAR G(KSI_CARBIDE,FE,MO:C),, -380000;,, N 88And2 ! $ PAR G(M6C_E93,FE:MO:FE:C),, +4*GHSERFE+2*GHSERMO+GHSERCC +77705-101.5*T;,, N 88And2 ! PAR G(M6C_E93,FE:MO:MO:C),, +2*GHSERFE+4*GHSERMO+GHSERCC -122410+30.25*T;,, N 88And2 ! PAR L(M6C_E93,FE:MO:FE,MO:C;0),, -37700;,, N 88And2 ! $ $ metastable $ PAR G(M23C6_D84,FE:MO:C;0),, +20*GHSERFE+3*GHSERMO +6*GHSERCC-76351-5.0949*T;,, N 92Qiu2 ! $ ------------------------------------------------------------------------------ $ Fe-Mo-N $ $ K. Frisk, Metall. Trans. A, 23A, 1271-78(1992). $ $ Fe-N from 93Du instead of 91Fri. $ $ There is not much to check against, but the N solubility in L is correct. $ The phase diagram is complex (above atmospheric pressure) and $ the calculation most certainly incorrect. $ There are only some N solubility data in the Fe-rich corner. $ PAR L(LIQUID,FE,MO,N;0),, +ZERO;,, N 92Fri2 ! PAR L(FCC_A1,FE,MO:N;0),, +ZERO;,, N 92Fri2 ! PAR L(A1_FCC,FE,MO:N;0),, +ZERO;,, N 92Fri2 ! PAR L(BCC_A2,FE,MO:N;0),, -151200;,, N 92Fri2 ! PAR L(A2_BCC,FE,MO:N;0),, -151200;,, N 92Fri2 ! $ ------------------------------------------------------------------------------ $ Fe-Mo-Nb $ PAR G(SIGMA_D8B,FE:MO:NB),, +10*GFCCFE+4*GHSERMO +16*GHSERNB;,, N Lin ! PAR G(SIGMA_D8B,FE:NB:MO),, +10*GFCCFE+4*GHSERNB +16*GHSERMO;,, N Lin ! PAR G(SIGMA_D8B,MO:NB:FE),, +10*GFCCMO+4*GHSERNB +16*GHSERFE;,, N Lin ! $ ------------------------------------------------------------------------------ $ Fe-Mo-Ni $ $ K. Frisk, Metall. Trans. A, 23A, 639-49(1992). $ $ Checked against paper. $ $ Model for SIGMA changed from 8:4:18 to 10:4:16 and Mo included on first SL. $ The SIGMA phase field is more narrow and extends further towards Mo-Ni $ at high temperature. $ $ Model for MU changed from 7:2:4 to 1:4:2:6. The MU phase field is slightly $ wider, more stable towards low temperature and less stable towards high $ temperature (liquidus field almost disappeared). $ $ New end member values for C14_LAVES. $ PAR L(LIQUID,FE,MO,NI;0),, +50000;,, N 92Fri1 ! $ PAR L(BCC_A2,FE,MO,NI:VA;0),, -35743;,, N 92Fri1 ! PAR L(A2_BCC,FE,MO,NI:VA;0),, -35743;,, N 92Fri1 ! $ PAR L(FCC_A1,FE,MO,NI:VA;0),, -204791+163.93*T;,, N 92Fri1 ! PAR L(FCC_A1,FE,MO,NI:VA;1),, +11555-55.81*T;,, N 92Fri1 ! PAR L(FCC_A1,FE,MO,NI:VA;2),, +77975;,, N 92Fri1 ! $ PAR L(A1_FCC,FE,MO,NI:VA;0),, -204791+163.93*T;,, N 92Fri1 ! PAR L(A1_FCC,FE,MO,NI:VA;1),, +11555-55.81*T;,, N 92Fri1 ! PAR L(A1_FCC,FE,MO,NI:VA;2),, +77975;,, N 92Fri1 ! $ PAR G(MONI,FE:NI:MO),, +6*GFCCFE+5*GHSERNI +3*GHSERMO;,, N 92Fri1 ! PAR G(MONI,NI:FE:MO),, +6*GHSERNI+5*GHSERFE +3*GHSERMO;,, N 92Fri1 ! $ PAR G(MU_D85,FE:MO:FE:NI),, +GFCCFE+4*GHSERMO+2*GHSERFE +6*GHSERNI;,, N Lin ! PAR G(MU_D85,FE:MO:MO:NI),, +GFCCFE+6*GHSERMO +6*GHSERNI+9285-45*T;,, N 17Hal8 ! PAR G(MU_D85,FE:MO:NI:NI),, +GFCCFE+4*GHSERMO+2*GBCCNI +6*GHSERNI;,, N Lin ! PAR G(MU_D85,FE:MO:NI:FE),, +GFCCFE+4*GHSERMO+2*GBCCNI +6*GFCCFE;,, N Lin ! PAR G(MU_D85,FE:MO:NI:MO),, +GFCCFE+4*GHSERMO+2*GBCCNI +6*GFCCMO;,, N Lin ! PAR G(MU_D85,NI:MO:FE:FE),, +GHSERNI+4*GHSERMO+2*GHSERFE +6*GFCCFE;,, N Lin ! PAR G(MU_D85,NI:MO:FE:MO),, +GHSERNI+4*GHSERMO+2*GHSERFE +6*GFCCMO;,, N Lin ! PAR G(MU_D85,NI:MO:FE:NI),, +7*GHSERNI+4*GHSERMO +2*GHSERFE;,, N Lin ! PAR G(MU_D85,NI:MO:MO:FE),, +GHSERNI+6*GHSERMO +6*GFCCFE-30000;,, N 17Hal8 ! PAR G(MU_D85,NI:MO:NI:FE),, +GHSERNI+4*GHSERMO+2*GBCCNI +6*GFCCFE;,, N Lin ! $ PAR G(P_PHASE,FE:NI:MO),, +24*GFCCFE+20*GBCCNI +12*GHSERMO;,, N 92Fri1 ! PAR G(P_PHASE,NI:FE:MO),, +24*GHSERNI+20*GHSERFE +12*GHSERMO-170245+100*T;,, N 92Fri1 ! $ PAR G(R_PHASE,FE:MO:NI),, +27*GFCCFE+14*GHSERMO +12*GBCCNI;,, N 92Fri1 ! PAR G(R_PHASE,NI:MO:FE),, +27*GHSERNI+14*GHSERMO +12*GHSERFE;,, N 92Fri1 ! $ PAR G(SIGMA_D8B,FE:MO:NI),, +10*GFCCFE+4*GHSERMO +16*GBCCNI+150000;,, N 17Hal8 ! PAR G(SIGMA_D8B,NI:MO:FE),, +10*GHSERNI+4*GHSERMO +16*GHSERFE+150000;,, N 17Hal8 ! $ $ Metastable $ PAR G(CHI_A12,FE:MO:NI),, +24*GFCCFE+10*GHSERMO +24*GHSERNI;,, N Lin ! PAR G(CHI_A12,NI:MO:FE),, +24*GHSERNI+10*GHSERMO +24*GFCCFE;,, N Lin ! $ ------------------------------------------------------------------------------ $ Fe-Mo-Si $ PAR G(SIGMA_D8B,FE:MO:SI),, +10*GFCCFE+4*GHSERMO +16*GBCCSI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Fe-Mo-Ti $ $ Modified from Z.-P. Jin and C. Qiu 1993 $ $ Z.-P. Jin, C. Qiu, Metall. Trans. A, 24A, 2137-44(1993). $ $ This dataset includes Fe-Ti from 12Bo instead of 89Bal (or 98Dum) and Mo-Ti $ from 98Sau instead of 93Jin. $ $ Checked against paper. $ $ Model for MU_D85 changed from 7:2:4 to 1:2:4:6. $ $ Nonstoichiometry added and end member values for C14_LAVES changed. $ $ FeTi is now described as B2_BCC. $ $ Ti added to the sigma model. The Ti solubility in sigma remains small. $ $ There are quite substantial changes of the Laves, mu and FeTi phase fields. $ $ The MU_D85 phase is possibly too stable at high temperature. $ $ The parameter G(MU_D85,FE:TI:TI:FE) was modified to improve the fit in the $ Fe-Nb-Ti system. This increases the Ti content in the mu phase. $ $ TCFE8 does not reproduce this system correctly. $ PAR L(C14_LAVES,FE:MO,TI;0),, +10000;,, N 17Hal9 ! $ PAR G(MU_D85,FE:MO:TI:FE),, +7*GFCCFE+4*GHSERMO+2*GBCCTI -160000;,, N 17Hal9 ! PAR G(MU_D85,FE:MO:TI:MO),, +GFCCFE+4*GHSERMO+2*GBCCTI +6*GFCCMO;,, N Lin ! PAR G(MU_D85,FE:TI:FE:MO),, +GFCCFE+4*GBCCTI+2*GHSERFE +6*GFCCMO;,, N Lin ! PAR G(MU_D85,FE:TI:MO:FE),, +7*GFCCFE+4*GBCCTI+2*GHSERMO ;,, N Lin ! PAR G(MU_D85,FE:TI:MO:MO),, +GFCCFE+4*GBCCTI+2*GHSERMO +6*GFCCMO;,, N Lin ! PAR G(MU_D85,FE:TI:TI:MO),, +GFCCFE+6*GBCCTI +6*GFCCMO;,, N Lin ! $ PAR G(SIGMA_D8B,FE:MO:TI),, +10*GFCCFE+4*GHSERMO +16*GBCCTI;,, N Lin ! PAR G(SIGMA_D8B,FE:TI:MO),, +10*GFCCFE+4*GBCCTI +16*GHSERMO;,, N Lin ! PAR G(SIGMA_D8B,MO:TI:FE),, +10*GFCCMO+4*GBCCTI +16*GHSERFE;,, N Lin ! $ ------------------------------------------------------------------------------ $ Fe-Mo-V $ PAR G(SIGMA_D8B,FE:MO:V),, +10*GFCCFE+4*GHSERMO +16*GHSERVV;,, N Lin ! PAR G(SIGMA_D8B,FE:V:MO),, +10*GFCCFE+4*GHSERVV +16*GHSERMO;,, N Lin ! PAR G(SIGMA_D8B,MO:V:FE),, +10*GFCCMO+4*GHSERVV +16*GHSERFE;,, N Lin ! PAR G(SIGMA_D8B,V:MO:FE),, +10*GFCCVV+4*GHSERMO +16*GHSERFE;,, N Lin ! $ ------------------------------------------------------------------------------ $ Fe-Nb-C $ $ A.V. Khvan, B. Hallstedt, Calphad, 40, 10-15(2013). $ $ See also 12Khv2. $ $ Checked against paper. $ $ NbC solubilities in fcc are very similar to 90Hua and somewhat lower than $ 01Lee. $ PAR L(FCC_A1,FE,NB:C;0),, -67500+29*T;,, N 05Can ! PAR L(FCC_A1,FE,NB:C,VA;0),, -40000;,, N 05Can ! $ PAR L(A1_FCC,FE,NB:C;0),, -67500+29*T;,, N 05Can ! PAR L(A1_FCC,FE,NB:C,VA;0),, -40000;,, N 05Can ! $ ------------------------------------------------------------------------------ $ Fe-Nb-N $ $ A.V. Khvan, B. Hallstedt, Calphad, 40, 10-15(2013). $ $ Same as 01Lee, but with changed Fe-N, Fe-Nb and Nb-N. $ $ Checked against paper. $ PAR L(LIQUID,FE,N,NB;0),, -160000;,, N 01Lee ! $ ------------------------------------------------------------------------------ $ Fe-Nb-Ni $ PAR G(SIGMA_D8B,FE:NB:NI),, +10*GFCCFE+4*GHSERNB +16*GBCCNI;,, N Lin ! PAR G(SIGMA_D8B,NI:NB:FE),, +10*GHSERNI+4*GHSERNB +16*GHSERFE;,, N Lin ! $ ------------------------------------------------------------------------------ $ Fe-Nb-Si $ $ A. Jacob, unpublished, 2016. $ $ Checked against the dataset from A. Jacob and FeNbSi-16Jac-orig.tdb. $ $ This is a preliminary description of the system, based on the description $ presented in the PhD Thesis of A. Jacob. $ $ The parameters for Nb-Si are claimed to be from 09Gen, but the parameters $ used by 16Jac are different. Their origin is unclear. Here the published $ parameters from 09Gen are used. $ $ Ternary phases and C14 are possibly too stable at high temperature. $ $ Very similar to the original dataset at 1273 and 1473 K. At 1273 the $ equilibrium Nb5Si3_D8L + FeNbSi shifts to C14 + FeNb2Si2. At 1473 the $ equilibrium Fe4Nb4Si7 + FeNb2Si2 shifts to NbSi2 + Fe3Nb4Si5. $ At 2073 K the extension of the liquid in the Si-rich part and the bcc phase $ in the Nb-rich part are different, but otherwise differences are very small. $ PAR L(C14_LAVES,FE,SI:NB;0),, -490000;,, N 16Jac2 ! $ PAR G(MU_D85,FE:NB:FE:SI),, +3*GHSERFE+4*GHSERNB +6*GHSERSI-423669;,, N 16Jac2 ! PAR G(MU_D85,FE:NB:NB:SI),, +GHSERFE+6*GHSERNB +6*GHSERSI-563997;,, N 16Jac2 ! PAR G(MU_D85,FE:NB:SI:FE),, +7*GHSERFE+4*GHSERNB +2*GHSERSI-269490;,, N 16Jac2 ! PAR G(MU_D85,FE:NB:SI:NB),, +GHSERFE+10*GHSERNB +2*GHSERSI+104260;,, N 16Jac2 ! PAR G(MU_D85,FE:NB:SI:SI),, +GHSERFE+4*GHSERNB +8*GHSERSI-324870;,, N 16Jac2 ! PAR G(MU_D85,NB:NB:FE:SI),, +2*GHSERFE+5*GHSERNB +6*GHSERSI-257275;,, N 16Jac2 ! PAR G(MU_D85,NB:NB:SI:FE),, +6*GHSERFE+5*GHSERNB +2*GHSERSI-184730;,, N 16Jac2 ! PAR G(MU_D85,SI:NB:FE:FE),, +8*GHSERFE+4*GHSERNB +GHSERSI-211120;,, N 16Jac2 ! PAR G(MU_D85,SI:NB:FE:NB),, +2*GHSERFE+10*GHSERNB +GHSERSI+272997;,, N 16Jac2 ! PAR G(MU_D85,SI:NB:FE:SI),, +2*GHSERFE+4*GHSERNB +7*GHSERSI-101010;,, N 16Jac2 ! PAR G(MU_D85,SI:NB:NB:FE),, +6*GHSERFE+6*GHSERNB +GHSERSI-327728;,, N 16Jac2 ! PAR G(MU_D85,SI:NB:SI:FE),, +6*GHSERFE+4*GHSERNB +3*GHSERSI-489060;,, N 16Jac2 ! PAR L(MU_D85,FE:NB:NB:FE,SI;0),, -900000;,, N 16Jac2 ! PAR L(MU_D85,FE:NB:NB:NB,SI;0),, -1000000;,, N 16Jac2 ! $ PAR G(FENBSI2,FE:NB:SI),, +GHSERFE+2*GHSERSI+GHSERNB -232160+7*T;,, N 16Jac2 ! PAR G(FE4NB4SI7,FE:NB:SI),, +4*GHSERFE+4*GHSERSI+7*GHSERNB -896000+80*T;,, N 16Jac2 ! PAR G(FENBSI1,FE:NB:SI),, +GHSERFE+GHSERSI+GHSERNB -173680-6*T;,, N 16Jac2 ! PAR G(FENB2SI2,FE:NB:SI),, +GHSERFE+2*GHSERSI+2*GHSERNB -327000;,, N 16Jac2 ! PAR G(FE3NB4SI5,FE:NB:SI),, +3*GHSERFE+5*GHSERSI+4*GHSERNB -741000;,, N 16Jac2 ! PAR G(FENB4SI,FE:NB:SI),, +GHSERFE+GHSERSI+4*GHSERNB -174020-45*T;,, N 16Jac2 ! $ $ Metastable $ PAR G(SIGMA_D8B,FE:NB:SI),, +10*GFCCFE+4*GHSERNB +16*GBCCSI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Fe-Nb-Ti $ $ B. Hallstedt, unpublished, 2017. $ $ The experimental data from H. Xu et al. (J. Alloys Compd., 396, 151-55(2005)) $ are roughly reproduced without introducing too many parameters. $ The exp. data from C.P. Wang et al. 2011 are considered unreliable, but are $ also roughly reproduced. $ $ The liquid is clearly more stable than in the assessment by 11Wan and the $ bcc field on the Nb-Ti side is wider. $ PAR G(MU_D85,FE:NB:TI:FE),, +7*GFCCFE+4*GHSERNB +2*GBCCTI-200000;,, N 17Hal17 ! PAR G(MU_D85,FE:NB:TI:NB),, +GFCCFE+4*GHSERNB +2*GBCCTI+6*GFCCNB;,, N Lin ! PAR G(MU_D85,FE:TI:FE:NB),, +GFCCFE+4*GHSERTI +2*GHSERFE+6*GFCCNB;,, N Lin ! PAR G(MU_D85,FE:TI:NB:FE),, +7*GFCCFE+4*GHSERTI +2*GHSERNB-200000;,, N 17Hal17 ! PAR G(MU_D85,FE:TI:NB:NB),, +GFCCFE+4*GHSERTI +2*GHSERNB+6*GFCCNB;,, N Lin ! PAR G(MU_D85,FE:TI:TI:NB),, +GFCCFE+6*GHSERTI+6*GFCCNB;,, N Lin ! PAR G(MU_D85,NB:NB:TI:FE),, +GFCCNB+4*GHSERNB +2*GHSERTI+6*GFCCFE;,, N Lin ! PAR G(MU_D85,NB:TI:FE:FE),, +GFCCNB+4*GHSERTI +2*GHSERFE+6*GFCCFE;,, N Lin ! PAR G(MU_D85,NB:TI:FE:NB),, +7*GFCCNB+4*GHSERTI +2*GHSERFE;,, N Lin ! PAR G(MU_D85,NB:TI:NB:FE),, +GFCCNB+4*GHSERTI +2*GHSERNB+6*GFCCFE;,, N Lin ! PAR G(MU_D85,NB:TI:TI:FE),, +GFCCNB+6*GHSERTI+6*GFCCFE;,, N Lin ! $ $ Metastable $ PAR G(SIGMA_D8B,FE:NB:TI),, +10*GFCCFE+4*GHSERNB +16*GBCCTI;,, N Lin ! PAR G(SIGMA_D8B,FE:TI:NB),, +10*GFCCFE+4*GBCCTI +16*GHSERNB;,, N Lin ! $ ------------------------------------------------------------------------------ $ Fe-Nb-V $ $ A.V. Khvan, K. Chang, B. Hallstedt, Calphad, 43, 143-48(2013). $ $ Using Fe-Nb with modified MU_D85 from 16Jac1. $ $ Checked against paper. $ $ The ternary MU_D85 parameters were modified to match the change in Fe-Nb. $ The Laves phase field is somewhat wider and the Laves+mu+bcc three-phase $ triangle is more narrow. $ PAR L(BCC_A2,FE,NB,V:VA;0),, +74752;,, N 13Khv2 ! PAR L(A2_BCC,FE,NB,V:VA;0),, +74752;,, N 13Khv2 ! $ PAR L(C14_LAVES,FE,V:NB;0),, -48522;,, N 13Khv2 ! $ PAR G(MU_D85,FE:NB:FE:V),, +3*GHSERFE+4*GHSERNB+6*GHSERVV +47813;,, N 13Khv2 ! PAR G(MU_D85,FE:NB:NB:V),, +GHSERFE+6*GHSERNB+6*GHSERVV +25031-67.91*T;,, N 17Hal19 ! PAR G(MU_D85,FE:NB:V:FE),, +7*GHSERFE+4*GHSERNB+2*GHSERVV -178727;,, N 13Khv2 ! PAR G(MU_D85,FE:NB:V:NB),, +GHSERFE+10*GHSERNB+2*GHSERVV +485717;,, N 13Khv2 ! PAR G(MU_D85,FE:NB:V:V),, +GHSERFE+4*GHSERNB+8*GHSERVV -2242;,, N 13Khv2 ! PAR G(MU_D85,NB:NB:FE:V),, +2*GHSERFE+5*GHSERNB+6*GHSERVV +193815;,, N 13Khv2 ! PAR G(MU_D85,NB:NB:V:FE),, +6*GHSERFE+5*GHSERNB+2*GHSERVV -96693;,, N 13Khv2 ! PAR G(MU_D85,V:NB:FE:FE),, +8*GHSERFE+4*GHSERNB+GHSERVV -101302;,, N 13Khv2 ! PAR G(MU_D85,V:NB:FE:NB),, +2*GHSERFE+10*GHSERNB+GHSERVV +476515;,, N 13Khv2 ! PAR G(MU_D85,V:NB:FE:V),, +2*GHSERFE+4*GHSERNB+7*GHSERVV +106683;,, N 13Khv2 ! PAR G(MU_D85,V:NB:NB:FE),, +6*GHSERFE+6*GHSERNB+GHSERVV -152878;,, N 13Khv2 ! PAR G(MU_D85,V:NB:V:FE),, +6*GHSERFE+4*GHSERNB+3*GHSERVV -185453;,, N 13Khv2 ! PAR L(MU_D85,FE:NB:NB:FE,V;0),, -55000;,, N 17Hal19 ! $ PAR G(SIGMA_D8B,FE:NB:V),, +10*GHSERFE+4*GHSERNB +16*GHSERVV-368205;,, N 13Khv2 ! PAR G(SIGMA_D8B,FE:V:NB),, +10*GHSERFE+4*GHSERVV +16*GHSERNB+463349;,, N 13Khv2 ! $PAR G(SIGMA_D8B,NB:V:FE),, +10*GFCCNB+4*GHSERVV $ +16*GHSERFE;,, N 13Khv2 ! PAR G(SIGMA_D8B,V:NB:FE),, +10*GHSERVV+4*GHSERNB +16*GHSERFE+81731;,, N 13Khv2 ! $ ------------------------------------------------------------------------------ $ Fe-Ni-C $ $ A. Gabriel, P. Gustafson, I. Ansara, Calphad, 11, 203-18(1987). $ $ Checked against paper. Wrong sign for L(BCC_A2,FE,NI:C;0) in paper. $ $ The hcp interaction should probably not be the same as the fcc interaction. $ $ New cementite in Fe-C from 10Hal. $ Fe-Ni liquid modified by 93Lee1 and fcc ordering added by 03Dup. $ Ni-C modified by 06Hal2. $ PAR L(LIQUID,C,FE,NI;0),, +122200-58.8*T;,, N 87Gab ! PAR L(LIQUID,C,FE,NI;1),, +92200-58.8*T;,, N 87Gab ! PAR L(LIQUID,C,FE,NI;2),, +152200-58.8*T;,, N 87Gab ! $ PAR L(FCC_A1,FE,NI:C;0),, +49074-7.32*T;,, N 87Gab ! PAR L(FCC_A1,FE,NI:C;1),, -25800;,, N 87Gab ! $ PAR L(A1_FCC,FE,NI:C;0),, +49074-7.32*T;,, N 87Gab ! PAR L(A1_FCC,FE,NI:C;1),, -25800;,, N 87Gab ! $ PAR L(BCC_A2,FE,NI:C;0),, -956.63-1.28726*T;,, N 87Gab ! PAR L(BCC_A2,FE,NI:C;1),, +1789.03-1.92912*T;,, N 87Gab ! $ PAR L(A2_BCC,FE,NI:C;0),, -956.63-1.28726*T;,, N 87Gab ! PAR L(A2_BCC,FE,NI:C;1),, +1789.03-1.92912*T;,, N 87Gab ! $ PAR L(CEMENTITE_D011,FE,NI:C;0),, +29400;,, N 87Gab ! $ $ Metastable $ $PAR L(HCP_A3,FE,NI:C;0),, +49074-7.32*T;,, N Same ! $PAR L(HCP_A3,FE,NI:C;1),, -25800;,, N Same ! $ PAR G(M23C6_D84,FE:NI:C),, +0.869565*GFE23C6 +0.130435*GNI23C6;,, N 91Lee ! PAR G(M23C6_D84,NI:FE:C),, +0.869565*GNI23C6 +0.130435*GFE23C6;,, N 91Lee ! PAR L(M23C6_D84,FE,NI:FE:C;0),, +196000;,, N 91Lee ! PAR L(M23C6_D84,FE,NI:NI:C;0),, +196000;,, N 91Lee ! $ PAR L(M7C3_D101,FE,NI:C;0),, +68600;,, N 91Lee ! $ ------------------------------------------------------------------------------ $ Fe-Ni-N $ $ K. Frisk, Z. Metallkd., 82, 59-66(1991). $ $ Checked against paper. $ $ Using Fe-N from 93Du instead of 91Fri. $ $ The fcc+Fe4N+hcp equilibrium is located at lower Ni content at 773K, but this $ is at high P(N2) and there are no exp. data. $ PAR L(FCC_A1,FE,NI:N;0),, -22710+5.19*T;,, N 91Fri2 ! PAR L(FCC_A1,FE,NI:N;1),, +3334;,, N 91Fri2 ! $ PAR L(A1_FCC,FE,NI:N;0),, -22710+5.19*T;,, N 91Fri2 ! PAR L(A1_FCC,FE,NI:N;1),, +3334;,, N 91Fri2 ! $ ------------------------------------------------------------------------------ $ Fe-Ni-Si $ $ B. Hallstedt, unpublished, 2008. $ $ Reoptimised against fcc, bcc and liquid data. $ $ The fcc+bcc+Liq equilibrium at 1373 K is at higher Ni content and a bit $ rotated compared to 99Mie. $ $ This evaluation only contains the liquid, fcc and bcc interactions. Fcc and $ bcc ordering and ternary solubilities in the silicides and possible $ ternary silicides remains to be done. $ $ The extension of the Ni3Si (FCC_4SL) phase field seems reasonable. $ $ FE2SI and NI2SI_THETA might have the same structure. $ PAR L(LIQUID,FE,NI,SI;0),, -101000;,, N 08Hal1 ! PAR L(LIQUID,FE,NI,SI;1),, +31000;,, N 08Hal1 ! PAR L(LIQUID,FE,NI,SI;2),, +ZERO;,, N 08Hal1 ! $ PAR L(FCC_A1,FE,NI,SI:VA;0),, -112000-22*T;,, N 08Hal1 ! PAR L(FCC_A1,FE,NI,SI:VA;1),, -15000-22*T;,, N 08Hal1 ! PAR L(FCC_A1,FE,NI,SI:VA;2),, -22*T;,, N 08Hal1 ! $ PAR L(A1_FCC,FE,NI,SI:VA;0),, -112000-22*T;,, N 08Hal1 ! PAR L(A1_FCC,FE,NI,SI:VA;1),, -15000-22*T;,, N 08Hal1 ! PAR L(A1_FCC,FE,NI,SI:VA;2),, -22*T;,, N 08Hal1 ! $ PAR L(BCC_A2,FE,NI,SI:VA;0),, -158000;,, N 08Hal1 ! PAR L(BCC_A2,FE,NI,SI:VA;1),, -72000;,, N 08Hal1 ! PAR L(BCC_A2,FE,NI,SI:VA;2),, +ZERO;,, N 08Hal1 ! $ PAR L(A2_BCC,FE,NI,SI:VA;0),, -158000;,, N 08Hal1 ! PAR L(A2_BCC,FE,NI,SI:VA;1),, -72000;,, N 08Hal1 ! PAR L(A2_BCC,FE,NI,SI:VA;2),, +ZERO;,, N 08Hal1 ! $ ------------------------------------------------------------------------------ $ Fe-Ni-Ti $ PAR G(SIGMA_D8B,FE:TI:NI),, +10*GFCCFE+4*GBCCTI +16*GBCCNI;,, N Lin ! PAR G(SIGMA_D8B,NI:TI:FE),, +10*GHSERNI+4*GBCCTI +16*GHSERFE;,, N Lin ! $ ------------------------------------------------------------------------------ $ Fe-Ni-V $ PAR G(SIGMA_D8B,FE:V:NI),, +10*GFCCFE+4*GHSERVV +16*GBCCNI;,, N Lin ! PAR G(SIGMA_D8B,NI:V:FE),, +10*GHSERNI+4*GHSERVV +16*GHSERFE;,, N Lin ! $ ------------------------------------------------------------------------------ $ Fe-Si-C $ $ J. Miettinen, Calphad 22, 231-56(1998). $ PAR L(LIQUID,C,FE,SI;0),, +400000;,, N 98Mie ! PAR L(LIQUID,C,FE,SI;1),, -55000;,, N 98Mie ! PAR L(LIQUID,C,FE,SI;2),, +450000;,, N 98Mie ! $ PAR L(FCC_A1,FE,SI:C;0),, +226100-34.25*T;,, N 98Mie ! PAR L(FCC_A1,FE,SI:C;1),, -202400;,, N 98Mie ! $ PAR L(A1_FCC,FE,SI:C;0),, +226100-34.25*T;,, N 98Mie ! PAR L(A1_FCC,FE,SI:C;1),, -202400;,, N 98Mie ! $ PAR L(BCC_A2,FE,SI:C;0),, +1000000-100*T;,, N 98Mie ! PAR L(BCC_A2,FE,SI:C;1),, -900000;,, N 98Mie ! $ PAR L(A2_BCC,FE,SI:C;0),, +1000000-100*T;,, N 98Mie ! PAR L(A2_BCC,FE,SI:C;1),, -900000;,, N 98Mie ! $ PAR G(FE8SI2C,FE:SI:C),, +8*GHSERFE+2*GHSERSI+GHSERCC -231047+5.566*T;,, N 91Lac ! $ ------------------------------------------------------------------------------ $ Fe-Si-N $ $ No assessment $ $ ------------------------------------------------------------------------------ $ Fe-Si-Ti $ PAR G(SIGMA_D8B,FE:TI:SI),, +10*GFCCFE+4*GBCCTI +16*GBCCSI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Fe-Si-V $ $ No assessment $ PAR G(SIGMA_D8B,FE:V:SI),, +10*GFCCFE+4*GHSERVV +16*GBCCSI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Fe-Ti-C $ $ L.F.S. Dumitrescu, M. Hillert, ISIJ Int., 39, 84-90(1999). $ $ Using Fe-Ti from 12Bo instead of 98Dum. $ $ Checked against paper. $ $ Isothermal sections are ok. The Fe-TiC vertical section in the paper is $ incorrect (fcc#1 is missing). The liquidus is ok though. $ $ The TiC solubility in fcc-Fe is lower than 99Dum (orig) and even slightly $ lower than with 01Lee (orig). $ $ The liquid interaction was adjusted to match data on the TiC liquidus. $ $PAR L(LIQUID,C,FE,TI;0),, -123670;,, N 99Dum2 ! PAR L(LIQUID,C,FE,TI;0),, -146600;,, N 17Hal3 ! $ PAR L(FCC_A1,FE,TI:C,VA;0),, +ZERO;,, N 99Dum2 ! PAR L(FCC_A1,FE,TI:C,VA;1),, +258879;,, N 99Dum2 ! PAR L(FCC_A1,FE,TI:C,VA;2),, -258879;,, N 99Dum2 ! $ PAR L(A1_FCC,FE,TI:C,VA;0),, +ZERO;,, N 99Dum2 ! PAR L(A1_FCC,FE,TI:C,VA;1),, +258879;,, N 99Dum2 ! PAR L(A1_FCC,FE,TI:C,VA;2),, -258879;,, N 99Dum2 ! $ ------------------------------------------------------------------------------ $ Fe-Ti-N $ $ B.-J. Lee, Metall. Mater. Trans. A, 32A, 2423-39(2001). $ $ Using Fe-Ti from 12Bo instead of 98Dum and Fe-N from 93Du instead of 91Fri. $ $ Checked against paper. $ $ The TiN solubility in fcc-Fe is somewhat lower than the original 01Lee. $ $ The TiN solubility in fcc-Fe in TCFE8 is the same as in 99Dum and $ 01Lee (orig). $ $ Ternary liquid interaction removed. It has a very small influence in the $ Fe corner, but causes a large N-solubility in the Fe-Ti liquid. This $ does not seem probable. $ $PAR L(LIQUID,FE,N,TI;0),, -300000;,, N 01Lee ! $ ------------------------------------------------------------------------------ $ Fe-Ti-V $ PAR G(SIGMA_D8B,FE:TI:V),, +10*GFCCFE+4*GBCCTI +16*GHSERVV;,, N Lin ! PAR G(SIGMA_D8B,FE:V:TI),, +10*GFCCFE+4*GHSERVV +16*GBCCTI;,, N Lin ! PAR G(SIGMA_D8B,V:TI:FE),, +10*GFCCVV+4*GBCCTI +16*GHSERFE;,, N Lin ! $ ------------------------------------------------------------------------------ $ Fe-V-C $ $ W. Huang, Z. Metallkd., 82, 391-401(1991). $ $ Checked against paper. $ $ In the original assessment V3C2 is modelled without Fe solubility. $ Cementite (V3C) was modified in 91Fer and used in 91Hua4. $ PAR L(LIQUID,C,FE,V;0),, -60000;,, N 91Hua2 ! PAR L(LIQUID,C,FE,V;1),, -60000;,, N 91Hua2 ! PAR L(LIQUID,C,FE,V;2),, +100000;,, N 91Hua2 ! $ PAR L(FCC_A1,FE,V:C;0),, -7645.5-2.069*T;,, N 91Hua2 ! PAR L(FCC_A1,FE,V:C;1),, -7645.5-2.069*T;,, N 91Hua2 ! PAR L(FCC_A1,FE,V:C,VA;0),, -40000;,, N 91Hua2 ! $ PAR L(A1_FCC,FE,V:C;0),, -7645.5-2.069*T;,, N 91Hua2 ! PAR L(A1_FCC,FE,V:C;1),, -7645.5-2.069*T;,, N 91Hua2 ! PAR L(A1_FCC,FE,V:C,VA;0),, -40000;,, N 91Hua2 ! $ PAR L(BCC_A2,FE,V:C;0),, -23674+0.465*T;,, N 91Hua2 ! PAR L(BCC_A2,FE,V:C;1),, +8283;,, N 91Hua2 ! $ PAR L(A2_BCC,FE,V:C;0),, -23674+0.465*T;,, N 91Hua2 ! PAR L(A2_BCC,FE,V:C;1),, +8283;,, N 91Hua2 ! $ PAR L(HCP_A3,FE,V:C;0),, -15291-4.138*T;,, N 91Hua2 ! $ $PAR L(CEMENTITE_D011,FE,V:C;0),, -45657-12.414*T;,, N 91Hua2 ! PAR L(CEMENTITE_D011,FE,V:C;0),, -45873-12.414*T;,, N 91Hua4 ! $ $ Metastable $ PAR G(M23C6_D84,FE:V:C),, +0.869565*GFE23C6 +0.130435*GV23C6;,, N 91Hua4 ! PAR G(M23C6_D84,V:FE:C),, +0.869565*GV23C6 +0.130435*GFE23C6;,, N 91Hua4 ! $ ------------------------------------------------------------------------------ $ Fe-V-N $ $ H. Ohtani, M. Hillert, Calphad, 15, 25-39(1991). $ $ Checked against paper. $ $ Using Fe-N from 93Du instead of 91Fri. $ $ No visible difference except Fe-solubility in VN at very high temperature, $ which is now lower. $ PAR L(LIQUID,FE,N,V;0),, -228000;,, N 91Oht2 ! PAR L(LIQUID,FE,N,V;1),, +3600000;,, N 91Oht2 ! PAR L(LIQUID,FE,N,V;2),, +104000;,, N 91Oht2 ! $ PAR L(FCC_A1,FE,V:N;0),, -60000;,, N 91Oht2 ! PAR L(FCC_A1,FE,V:N,VA;0),, -120000;,, N 91Oht2 ! $ PAR L(A1_FCC,FE,V:N;0),, -60000;,, N 91Oht2 ! PAR L(A1_FCC,FE,V:N,VA;0),, -120000;,, N 91Oht2 ! $ ------------------------------------------------------------------------------ $ Mg-C-N $ ------------------------------------------------------------------------------ $ Mg-Mn-C $ ------------------------------------------------------------------------------ $ Mg-Mn-Mo $ ------------------------------------------------------------------------------ $ Mg-Mn-N $ ------------------------------------------------------------------------------ $ Mg-Mn-Nb $ ------------------------------------------------------------------------------ $ Mg-Mn-Ni $ ------------------------------------------------------------------------------ $ Mg-Mn-Si $ ------------------------------------------------------------------------------ $ Mg-Mn-Ti $ ------------------------------------------------------------------------------ $ Mg-Mn-V $ ------------------------------------------------------------------------------ $ Mg-Mo-C $ ------------------------------------------------------------------------------ $ Mg-Mo-N $ ------------------------------------------------------------------------------ $ Mg-Mo-Nb $ ------------------------------------------------------------------------------ $ Mg-Mo-Ni $ ------------------------------------------------------------------------------ $ Mg-Mo-Si $ ------------------------------------------------------------------------------ $ Mg-Mo-Ti $ ------------------------------------------------------------------------------ $ Mg-Mo-V $ ------------------------------------------------------------------------------ $ Mg-Nb-C $ ------------------------------------------------------------------------------ $ Mg-Nb-N $ ------------------------------------------------------------------------------ $ Mg-Nb-Ni $ ------------------------------------------------------------------------------ $ Mg-Nb-Si $ ------------------------------------------------------------------------------ $ Mg-Nb-Ti $ ------------------------------------------------------------------------------ $ Mg-Nb-V $ ------------------------------------------------------------------------------ $ Mg-Ni-C $ ------------------------------------------------------------------------------ $ Mg-Ni-N $ ------------------------------------------------------------------------------ $ Mg-Ni-Si $ ------------------------------------------------------------------------------ $ Mg-Ni-Ti $ ------------------------------------------------------------------------------ $ Mg-Ni-V $ ------------------------------------------------------------------------------ $ Mg-Si-C $ ------------------------------------------------------------------------------ $ Mg-Si-N $ ------------------------------------------------------------------------------ $ Mg-Si-Ti $ ------------------------------------------------------------------------------ $ Mg-Si-V $ ------------------------------------------------------------------------------ $ Mg-Ti-C $ ------------------------------------------------------------------------------ $ Mg-Ti-N $ ------------------------------------------------------------------------------ $ Mg-Ti-V $ ------------------------------------------------------------------------------ $ Mg-V-C $ ------------------------------------------------------------------------------ $ Mg-V-N $ ------------------------------------------------------------------------------ $ Mn-C-N $ ------------------------------------------------------------------------------ $ Mn-Mo-C $ ------------------------------------------------------------------------------ $ Mn-Mo-N $ ------------------------------------------------------------------------------ $ Mn-Mo-Nb $ PAR G(SIGMA_D8B,MN:MO:NB),, +10*GFCCMN+4*GHSERMO +16*GHSERNB;,, N Lin ! PAR G(SIGMA_D8B,MN:NB:MO),, +10*GFCCMN+4*GHSERNB +16*GHSERMO;,, N Lin ! PAR G(SIGMA_D8B,MO:NB:MN),, +10*GFCCMO+4*GHSERNB +16*GBCCMN;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mn-Mo-Ni $ PAR G(R_PHASE,NI:MO:MN),, +27*GHSERNI+14*GHSERMO +12*GBCCMN;,, N Lin ! PAR G(R_PHASE,MN:MO:NI),, +27*GFCCMN+14*GHSERMO +12*GBCCNI;,, N Lin ! $ PAR G(SIGMA_D8B,MN:MO:NI),, +10*GFCCMN+4*GHSERMO +16*GBCCNI;,, N Lin ! PAR G(SIGMA_D8B,NI:MO:MN),, +10*GHSERNI+4*GHSERMO +16*GBCCMN;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mn-Mo-Si $ PAR G(SIGMA_D8B,MN:MO:SI),, +10*GFCCMN+4*GHSERMO +16*GBCCSI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mn-Mo-Ti $ PAR G(SIGMA_D8B,MN:MO:TI),, +10*GFCCMN+4*GHSERMO +16*GBCCTI;,, N Lin ! PAR G(SIGMA_D8B,MN:TI:MO),, +10*GFCCMN+4*GBCCTI +16*GHSERMO;,, N Lin ! PAR G(SIGMA_D8B,MO:TI:MN),, +10*GFCCMO+4*GBCCTI +16*GBCCMN;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mn-Mo-V $ PAR G(SIGMA_D8B,MN:MO:V),, +10*GFCCMN+4*GHSERMO +16*GHSERVV;,, N Lin ! PAR G(SIGMA_D8B,MN:V:MO),, +10*GFCCMN+4*GHSERVV +16*GHSERMO;,, N Lin ! PAR G(SIGMA_D8B,MO:V:MN),, +10*GFCCMO+4*GHSERVV +16*GBCCMN;,, N Lin ! PAR G(SIGMA_D8B,V:MO:MN),, +10*GFCCVV+4*GHSERMO +16*GBCCMN;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mn-Nb-C $ $ A.V. Khvan, B. Hallstedt, K. Chang, Calphad, 39, 54-61(2012). $ $ Checked against paper. $ PAR G(M23C6_D84,MN:NB:C),, +0.8695652*GMN23C6 +3*GHSERNB+0.7826087*GHSERCC-130000;,, N 12Khv1 ! $PAR G(M23C6_D84,NB:MN:C),, +UN_ASS;,, N ! $ ------------------------------------------------------------------------------ $ Mn-Nb-N $ $ A.V. Khvan, B. Hallstedt, Calphad, 40, 10-15(2013). $ $ No parameters for this system. Checked against paper. $ ------------------------------------------------------------------------------ $ Mn-Nb-Ni $ PAR G(SIGMA_D8B,MN:NB:NI),, +10*GFCCMN+4*GHSERNB +16*GBCCNI;,, N Lin ! PAR G(SIGMA_D8B,NI:NB:MN),, +10*GHSERNI+4*GHSERNB +16*GBCCMN;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mn-Nb-Si $ PAR G(SIGMA_D8B,MN:NB:SI),, +10*GFCCMN+4*GHSERNB +16*GBCCSI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mn-Nb-Ti $ PAR G(SIGMA_D8B,MN:NB:TI),, +10*GFCCMN+4*GHSERNB +16*GBCCTI;,, N Lin ! PAR G(SIGMA_D8B,MN:TI:NB),, +10*GFCCMN+4*GBCCTI +16*GHSERNB;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mn-Nb-V $ $ Metastable $ PAR G(SIGMA_D8B,MN:NB:V),, +10*GFCCMN+4*GHSERNB +16*GHSERVV;,, N Lin ! PAR G(SIGMA_D8B,MN:V:NB),, +10*GFCCMN+4*GHSERVV +16*GHSERNB;,, N Lin ! $PAR G(SIGMA_D8B,NB:V:MN),, +10*GFCCNB+4*GHSERVV $ +16*GBCCMN;,, N Lin ! PAR G(SIGMA_D8B,V:NB:MN),, +10*GFCCVV+4*GHSERNB +16*GBCCMN;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mn-Ni-C $ $ Not yet modelled. $ $ ------------------------------------------------------------------------------ $ Mn-Ni-N $ ------------------------------------------------------------------------------ $ Mn-Ni-Si $ ------------------------------------------------------------------------------ $ Mn-Ni-Ti $ PAR G(SIGMA_D8B,MN:TI:NI),, +10*GFCCMN+4*GBCCTI +16*GBCCNI;,, N Lin ! PAR G(SIGMA_D8B,NI:TI:MN),, +10*GHSERNI+4*GBCCTI +16*GBCCMN;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mn-Ni-V $ PAR G(SIGMA_D8B,MN:V:NI),, +10*GFCCMN+4*GHSERVV +16*GBCCNI;,, N Lin ! PAR G(SIGMA_D8B,NI:V:MN),, +10*GHSERNI+4*GHSERVV +16*GBCCMN;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mn-Si-C $ ------------------------------------------------------------------------------ $ Mn-Si-N $ ------------------------------------------------------------------------------ $ Mn-Si-Ti $ PAR G(SIGMA_D8B,MN:TI:SI),, +10*GFCCMN+4*GBCCTI +16*GBCCSI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mn-Si-V $ PAR G(SIGMA_D8B,MN:V:SI),, +10*GFCCMN+4*GHSERVV +16*GBCCSI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mn-Ti-C $ ------------------------------------------------------------------------------ $ Mn-Ti-N $ ------------------------------------------------------------------------------ $ Mn-Ti-V $ PAR G(SIGMA_D8B,MN:TI:V),, +10*GFCCMN+4*GBCCTI +16*GHSERVV;,, N Lin ! PAR G(SIGMA_D8B,MN:V:TI),, +10*GFCCMN+4*GHSERVV +16*GBCCTI;,, N Lin ! PAR G(SIGMA_D8B,V:TI:MN),, +10*GFCCVV+4*GBCCTI +16*GBCCMN;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mn-V-C $ $ A. Fernandez Guillermet, W. Huang, Int. J. Thermophys., 12, 1077-1102(1991). $ $ Checked against paper. $ $ Using Mn-C from 10Dju instead of 90Hua. $ $ The Mn solubility in VC is slightly higher and the Mn solubility in V3C2 is $ slightly lower than in the original 91Fer dataset. Liquidus temperatures $ are somewhat lower (at least in the Mn-rich corner). There are no $ experimental to support one or the other. $ PAR L(BCC_A2,MN,V:C;0),, -10000;,, N 91Fer2 ! PAR L(A2_BCC,MN,V:C;0),, -10000;,, N 91Fer2 ! PAR L(CBCC_A12,MN,V:C;0),, -22225.2;,, N 91Hua4 ! PAR L(CUB_A13,MN,V:C;0),, -17724;,, N 91Hua4 ! $ PAR G(M23C6_D84,MN:V:C),, +0.869565*GMN23C6 +0.130435*GV23C6;,, N 91Fer2 ! PAR G(M23C6_D84,V:MN:C),, +0.869565*GV23C6 +0.130435*GMN23C6;,, N 91Fer2 ! $ ------------------------------------------------------------------------------ $ Mn-V-N $ ------------------------------------------------------------------------------ $ Mo-C-N $ ------------------------------------------------------------------------------ $ Mo-Nb-C $ $ C. Zhang, Y. Peng, P. Zhou, W. Zhang, Y. Du, Calphad, 51, 104-10(2015). $ $ Checked against paper and author's tdb. $ $ Using Nb-C from 01Lee instead of 97Hua. $ $ Some interactions (in particular liquid) have very large temperature $ dependencies. The bcc interaction seems questionable. $ $ With the new Nb-C the bcc+Nb2C+NbC triangle is shifted towards lower Mo $ content. The change in Nb2C and MC composition is small. The mutual $ solubilities in Mo2C and Nb2C are somewhat lower. The C-content of the low-C $ phase boundary of Nb-rich MC is higher. Mo2C is not more present at 2640°C. $ There are changes in the 32.15 at.%C vertical section. $ $ This system should be remodelled. A pop-file is provided by 15Zha1. $ PAR L(LIQUID,C,MO,NB;0),, -904983.51+150*T;,, N 15Zha1 ! PAR L(LIQUID,C,MO,NB;1),, -554680.05+150*T;,, N 15Zha1 ! PAR L(LIQUID,C,MO,NB;2),, +228894.03+41.142*T;,, N 15Zha1 ! $ PAR L(FCC_A1,MO,NB:C;0),, -84005.09+29.061*T;,, N 15Zha1 ! PAR L(FCC_A1,MO,NB:C;1),, +153432.08-39.012*T;,, N 15Zha1 ! PAR L(FCC_A1,MO,NB:C;2),, -6461.64;,, N 15Zha1 ! PAR L(FCC_A1,MO,NB:C,VA;0),, +ZERO;,, N 15Zha1 ! PAR L(FCC_A1,MO,NB:C,VA;1),, -200000;,, N 15Zha1 ! PAR L(FCC_A1,MO,NB:C,VA;2),, -200000;,, N 15Zha1 ! $ PAR L(BCC_A2,MO,NB:C;0),, +500000+200*T;,, N 15Zha1 ! $ PAR L(HCP_A3,MO,NB:C;0),, -3348;,, N 15Zha1 ! PAR L(HCP_A3,MO,NB:C;1),, -15187.77-8.966*T;,, N 15Zha1 ! PAR L(HCP_A3,MO,NB:C;2),, -104585.7+42.823*T;,, N 15Zha1 ! PAR L(HCP_A3,MO,NB:C,VA;0),, +20000;,, N 15Zha1 ! $ PAR L(MC_ETA,MO,NB:C;0),, -204000;,, N 15Zha1 ! $ ------------------------------------------------------------------------------ $ Mo-Nb-N $ ------------------------------------------------------------------------------ $ Mo-Nb-Ni $ PAR G(SIGMA_D8B,MO:NB:NI),, +10*GFCCMO+4*GHSERNB +16*GBCCNI;,, N Lin ! PAR G(SIGMA_D8B,NI:MO:NB),, +10*GHSERNI+4*GHSERMO +16*GHSERNB;,, N Lin ! PAR G(SIGMA_D8B,NI:NB:MO),, +10*GHSERNI+4*GHSERNB +16*GHSERMO;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mo-Nb-Si $ PAR G(SIGMA_D8B,MO:NB:SI),, +10*GFCCMO+4*GHSERNB +16*GBCCSI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mo-Nb-Ti $ PAR G(SIGMA_D8B,MO:NB:TI),, +10*GFCCMO+4*GHSERNB +16*GBCCTI;,, N Lin ! PAR G(SIGMA_D8B,MO:TI:NB),, +10*GFCCMO+4*GBCCTI +16*GHSERNB;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mo-Nb-V $ PAR G(SIGMA_D8B,MO:NB:V),, +10*GFCCMO+4*GHSERNB +16*GHSERVV;,, N Lin ! PAR G(SIGMA_D8B,MO:V:NB),, +10*GFCCMO+4*GHSERVV +16*GHSERNB;,, N Lin ! PAR G(SIGMA_D8B,V:MO:NB),, +10*GFCCVV+4*GHSERMO +16*GHSERNB;,, N Lin ! PAR G(SIGMA_D8B,V:NB:MO),, +10*GFCCVV+4*GHSERNB +16*GHSERMO;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mo-Ni-C $ ------------------------------------------------------------------------------ $ Mo-Ni-N $ ------------------------------------------------------------------------------ $ Mo-Ni-Si $ PAR G(SIGMA_D8B,NI:MO:SI),, +10*GHSERNI+4*GHSERMO +16*GBCCSI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mo-Ni-Ti $ PAR G(SIGMA_D8B,MO:TI:NI),, +10*GFCCMO+4*GBCCTI +16*GBCCNI;,, N Lin ! PAR G(SIGMA_D8B,NI:MO:TI),, +10*GHSERNI+4*GHSERMO +16*GBCCTI;,, N Lin ! PAR G(SIGMA_D8B,NI:TI:MO),, +10*GHSERNI+4*GBCCTI +16*GHSERMO;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mo-Ni-V $ PAR G(SIGMA_D8B,MO:V:NI),, +10*GFCCMO+4*GHSERVV +16*GBCCNI;,, N Lin ! PAR G(SIGMA_D8B,NI:MO:V),, +10*GHSERNI+4*GHSERMO +16*GHSERVV;,, N Lin ! PAR G(SIGMA_D8B,NI:V:MO),, +10*GHSERNI+4*GHSERVV +16*GHSERMO;,, N Lin ! PAR G(SIGMA_D8B,V:MO:NI),, +10*GFCCVV+4*GHSERMO +16*GBCCNI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mo-Si-C $ ------------------------------------------------------------------------------ $ Mo-Si-N $ ------------------------------------------------------------------------------ $ Mo-Si-Ti $ PAR G(SIGMA_D8B,MO:TI:SI),, +10*GFCCMO+4*GBCCTI +16*GBCCSI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mo-Si-V $ PAR G(SIGMA_D8B,MO:V:SI),, +10*GFCCMO+4*GHSERVV +16*GBCCSI;,, N Lin ! PAR G(SIGMA_D8B,V:MO:SI),, +10*GFCCVV+4*GHSERMO +16*GBCCSI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mo-Ti-C $ $ Modified from J.-H. Shim et al. 1996 $ $ J.-H. Shim, C.-S. Oh, D.N. Lee, Metall. Mater. Trans. B, 27B, 955-66(1996). $ $ This dataset includes Ti-C from 98Dum instead of 96Jon and Mo-Ti from $ 98Sau instead of 96Shi. The negative L(BCC_A2,MO:C,VA;0) introduced by 96Shi $ is partly removed. $ $ Checked against paper. $ $ There are changes compared to 96Shi, but not too drastic. The C solubility $ in bcc is somewhat lower to be more compatible with data from Mo-C. $ PAR L(LIQUID,C,MO,TI;0),, -379405;,, N 96Shi ! PAR L(LIQUID,C,MO,TI;1),, -15909;,, N 96Shi ! PAR L(LIQUID,C,MO,TI;2),, -111135;,, N 96Shi ! $ PAR L(BCC_A2,MO,TI:C;0),, -459700;,, N 96Shi ! PAR L(BCC_A2,MO,TI:C,VA;0),, -250000;,, N 15Hal1 ! $ PAR L(A2_BCC,MO,TI:C;0),, -459700;,, N 96Shi ! PAR L(A2_BCC,MO,TI:C,VA;0),, -250000;,, N 15Hal1 ! $ PAR L(FCC_A1,MO,TI:C;0),, +32845-27.218*T;,, N 96Shi ! PAR L(A1_FCC,MO,TI:C;0),, +32845-27.218*T;,, N 96Shi ! $ $PAR L(HCP_A3,MO,TI:C;0),, -15349.5;,, N 96Shi ! PAR L(HCP_A3,MO,TI:C;0),, +ZERO;,, N 15Hal1 ! $ $PAR L(MC_ETA,MO,TI:C;0),, -110500;,, N 96Shi ! PAR L(MC_ETA,MO,TI:C;0),, -90000;,, N 15Hal1 ! $ ------------------------------------------------------------------------------ $ Mo-Ti-N $ ------------------------------------------------------------------------------ $ Mo-Ti-V $ PAR G(SIGMA_D8B,MO:TI:V),, +10*GFCCMO+4*GBCCTI +16*GHSERVV;,, N Lin ! PAR G(SIGMA_D8B,MO:V:TI),, +10*GFCCMO+4*GHSERVV +16*GBCCTI;,, N Lin ! PAR G(SIGMA_D8B,V:MO:TI),, +10*GFCCVV+4*GHSERMO +16*GBCCTI;,, N Lin ! PAR G(SIGMA_D8B,V:TI:MO),, +10*GFCCVV+4*GBCCTI +16*GHSERMO;,, N Lin ! $ ------------------------------------------------------------------------------ $ Mo-V-C $ $ J. Bratberg, K. Frisk, Calphad, 26, 459-76(2002). $ PAR L(LIQUID,C,MO,V;0),, +120000;,, N 02Bra ! $ PAR L(BCC_A2,MO,V:C;0),, +330000;,, N 02Bra ! PAR L(A2_BCC,MO,V:C;0),, +330000;,, N 02Bra ! PAR L(FCC_A1,MO,V:C;0),, -28000;,, N 02Bra ! PAR L(A1_FCC,MO,V:C;0),, -28000;,, N 02Bra ! PAR L(HCP_A3,MO,V:C;0),, -30000;,, N 02Bra ! PAR L(MC_ETA,MO,V:C;0),, -70000;,, N 02Bra ! $ ------------------------------------------------------------------------------ $ Mo-V-N $ ------------------------------------------------------------------------------ $ Nb-C-N $ $ A.V. Khvan, B. Hallstedt, Calphad, 40, 10-15(2013). $ $ Same as Lee 2001, but with a modified Nb-N. $ $ Checked against paper. $ $ This assessement shows better agreement with N2 pressure data than Nb-C-N $ from W. Huang 1997. $ PAR L(FCC_A1,NB:C,N;0),, +12.5922*T;,, N 01Lee ! PAR L(FCC_A1,NB:C,N,VA;0),, +ZERO;,, N 01Lee ! PAR L(FCC_A1,NB:C,N,VA;1),, +ZERO;,, N 01Lee ! PAR L(FCC_A1,NB:C,N,VA;2),, -312985;,, N 01Lee ! $ PAR L(A1_FCC,NB:C,N;0),, +12.5922*T;,, N 01Lee ! PAR L(A1_FCC,NB:C,N,VA;0),, +ZERO;,, N 01Lee ! PAR L(A1_FCC,NB:C,N,VA;1),, +ZERO;,, N 01Lee ! PAR L(A1_FCC,NB:C,N,VA;2),, -312985;,, N 01Lee ! $ PAR L(HCP_A3,NB:C,N;0),, -15000;,, N 01Lee ! PAR L(HCP_A3,NB:C,N,VA;0),, -30000;,, N 01Lee ! $ ------------------------------------------------------------------------------ $ Nb-Ni-C $ ------------------------------------------------------------------------------ $ Nb-Ni-N $ ------------------------------------------------------------------------------ $ Nb-Ni-Si $ PAR G(SIGMA_D8B,NI:NB:SI),, +10*GHSERNI+4*GHSERNB +16*GBCCSI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Nb-Ni-Ti $ PAR G(SIGMA_D8B,NI:NB:TI),, +10*GHSERNI+4*GHSERNB +16*GBCCTI;,, N Lin ! PAR G(SIGMA_D8B,NI:TI:NB),, +10*GHSERNI+4*GBCCTI +16*GHSERNB;,, N Lin ! $ ------------------------------------------------------------------------------ $ Nb-Ni-V $ PAR G(SIGMA_D8B,NI:NB:V),, +10*GHSERNI+4*GHSERNB +16*GHSERVV;,, N Lin ! PAR G(SIGMA_D8B,NI:V:NB),, +10*GHSERNI+4*GHSERVV +16*GHSERNB;,, N Lin ! PAR G(SIGMA_D8B,V:NB:NI),, +10*GFCCVV+4*GHSERNB +16*GBCCNI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Nb-Si-C $ ------------------------------------------------------------------------------ $ Nb-Si-N $ ------------------------------------------------------------------------------ $ Nb-Si-Ti $ ------------------------------------------------------------------------------ $ Nb-Si-V $ PAR G(SIGMA_D8B,V:NB:SI),, +10*GFCCVV+4*GHSERNB +16*GBCCSI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Nb-Ti-C $ $ B.-J. Lee, Metall. Mater. Trans. A, 32A, 2423-39(2001). $ $ Checked against paper. $ $ Nb-Ti from 01Zha instead of 98Sau. $ $ There is a slight shift of the MC end point of the bcc+Nb2C+MC equilibrium. $ PAR L(LIQUID,C,NB,TI;0),, +140812;,, N 01Lee ! $ PAR L(FCC_A1,NB,TI:C;0),, -33979;,, N 01Lee ! PAR L(FCC_A1,NB,TI:C,VA;0),, +97661;,, N 01Lee ! $ PAR L(A1_FCC,NB,TI:C;0),, -33979;,, N 01Lee ! PAR L(A1_FCC,NB,TI:C,VA;0),, +97661;,, N 01Lee ! $ PAR L(HCP_A3,NB,TI:C;0),, -10739+13.0928*T;,, N 01Lee ! $ ------------------------------------------------------------------------------ $ Nb-Ti-N $ $ B.-J. Lee, Metall. Mater. Trans. A, 32A, 2423-39(2001). $ $ Checked against paper. $ $ Nb-N from 13Khv instead of 96Hua. $ Nb-Ti from 01Zha instead of 98Sau. $ $ There are slight shifts of the phase boundaries (mostly MN). $ PAR L(FCC_A1,NB,TI:N;0),, +ZERO;,, N 01Lee ! PAR L(FCC_A1,NB,TI:N,VA;0),, -50000;,, N 01Lee ! $ PAR L(A1_FCC,NB,TI:N;0),, +ZERO;,, N 01Lee ! PAR L(A1_FCC,NB,TI:N,VA;0),, -50000;,, N 01Lee ! $ PAR L(HCP_A3,NB,TI:N;0),, -8430+13.0928*T;,, N 01Lee ! $ ------------------------------------------------------------------------------ $ Nb-Ti-V $ PAR G(SIGMA_D8B,V:NB:TI),, +10*GFCCVV+4*GHSERNB +16*GBCCTI;,, N Lin ! PAR G(SIGMA_D8B,V:TI:NB),, +10*GFCCVV+4*GBCCTI +16*GHSERNB;,, N Lin ! $ ------------------------------------------------------------------------------ $ Nb-V-C $ $ K. Frisk, Calphad, 32, 326-37(2008). $ $ The only plot shown in 08Fri is the miscibility gap in the MC carbide $ at acr(C)=1 (mur(C)=0). If L(FCC_A1,NB,V:VA;0) is set to zero then $ the critical temperature is at 1905 K, which is 10 to 20 K higher than in $ 08Fri. With L(FCC_A1,NB,V:VA;0)=+9080 the critical temperature is 1950 K. $ $ At 1573 K M2C shows continuous solubility, in contrast to MC. There are $ no data to compare with. $ PAR L(FCC_A1,NB,V:C;0),, +29000;,, N 08Fri ! PAR L(FCC_A1,NB,V:C;1),, -5000;,, N 08Fri ! $ PAR L(A1_FCC,NB,V:C;0),, +29000;,, N 08Fri ! PAR L(A1_FCC,NB,V:C;1),, -5000;,, N 08Fri ! $ ------------------------------------------------------------------------------ $ Nb-V-N $ ------------------------------------------------------------------------------ $ Ni-C-N $ ------------------------------------------------------------------------------ $ Ni-Si-C $ $ Y. Du, J.C. Schuster, Metall. Mater. Trans. A, 30A, 2409-18(1999). $ $ 4SL model for fcc with modified parameters (Ni-Si). $ Using Si-C from 91Lac instead of 96Gro. $ $ Si-C from 91Lac is not good, but in order to use 96Gro Fe-Si-C has to be $ remodelled. $ $ There are only minor differences in the solid state, but the liquid is more $ stable in 91Lac than in 96Gro. By removing the ternary interaction the $ 1443 and 1798 K sections and even the 10 at.% C vertical section are still $ well reproduced. $ $PAR L(LIQUID,C,NI,SI;0),, -145240;,, N 99Du ! $ ------------------------------------------------------------------------------ $ Ni-Si-N $ ------------------------------------------------------------------------------ $ Ni-Si-Ti $ PAR G(SIGMA_D8B,NI:TI:SI),, +10*GHSERNI+4*GBCCTI +16*GBCCSI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Ni-Si-V $ PAR G(SIGMA_D8B,NI:V:SI),, +10*GHSERNI+4*GHSERVV +16*GBCCSI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Ni-Ti-C $ ------------------------------------------------------------------------------ $ Ni-Ti-N $ ------------------------------------------------------------------------------ $ Ni-Ti-V $ PAR G(SIGMA_D8B,NI:TI:V),, +10*GHSERNI+4*GBCCTI +16*GHSERVV;,, N Lin ! PAR G(SIGMA_D8B,NI:V:TI),, +10*GHSERNI+4*GHSERVV +16*GBCCTI;,, N Lin ! PAR G(SIGMA_D8B,V:TI:NI),, +10*GFCCVV+4*GBCCTI +16*GBCCNI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Ni-V-C $ $ B. Hallstedt, unpublished, 2008 $ $ No parameters added for the ternary. Experimental data at 1373 K are $ reasonably reproduced. There is an experimental vertical section Ni-VC, $ but this probably does not represent the true vertical section, $ which is considerably more complex. $ $ metastable $ PAR G(M23C6_D84,NI:V:C),, +0.8695652*GNI23C6 +0.1304348*GV23C6;,, N Lin ! PAR G(M23C6_D84,V:NI:C),, +0.8695652*GV23C6 +0.1304348*GNI23C6;,, N Lin ! $ ------------------------------------------------------------------------------ $ Ni-V-N $ ------------------------------------------------------------------------------ $ Si-C-N $ ------------------------------------------------------------------------------ $ Si-Ti-C $ ------------------------------------------------------------------------------ $ Si-Ti-N $ ------------------------------------------------------------------------------ $ Si-Ti-V $ PAR G(SIGMA_D8B,V:TI:SI),, +10*GFCCVV+4*GBCCTI +16*GBCCSI;,, N Lin ! $ ------------------------------------------------------------------------------ $ Si-V-C $ ------------------------------------------------------------------------------ $ Si-V-N $ ------------------------------------------------------------------------------ $ Ti-C-N $ $ B.-J. Lee, Metall. Mater. Trans. A, 32A, 2423-39(2001). $ $ Checked against paper. $ $ At 1423 K the hcp phase field is a bit wider than in the paper. $ PAR L(FCC_A1,TI:C,N;0),, -54176;,, N 96Jon3 ! PAR L(FCC_A1,TI:C,N,VA;0),, -160000;,, N 01Lee ! $ PAR L(A1_FCC,TI:C,N;0),, -54176;,, N 96Jon3 ! PAR L(A1_FCC,TI:C,N,VA;0),, -160000;,, N 01Lee ! $ PAR L(HCP_A3,TI:C,N;0),, -32725;,, N 96Jon3 ! PAR L(HCP_A3,TI:C,N,VA;0),, -15000;,, N 01Lee ! $ PAR L(TI2N_C4,TI:C,N;0),, -25000;,, N 01Lee ! $ ------------------------------------------------------------------------------ $ Ti-V-C $ $ W. Zhang, Y. Peng, Y. Du, L. Chen, Y. Li, S. Wang, G. Wen, W. Xie, $ Int. J. Refract. Met. Hard Mater., 48, 346-54(2015). $ $ Checked against paper. $ $ Using Ti-C from 99Dum instead of 03Fri. $ $ There are quite large differences between this dataset and the 08Mar dataset. $ In this dataset MC is shifted to higher C content, is more narrow and the $ MC end point of the bcc+V2C+MC equilibrium is at much lower V content. $ $ 08Mar only considered a subset of the available experimental data. 15Zha $ reproduces experimental data considerably better, in particular the $ V2C+MC (hcp+fcc) two-phase region seems well supported by experiment. $ I.e. the 15Zha dataset should be given preference, although their parameters $ are considerably more ugly. $ $ The change of Ti-C leads to a substantial increase of the Ti solubility $ in V2C and a shift of MC composition in the bcc+V2C+MC equilibrium to lower $ V content. There is also a substantial increase in the Ti content in the $ bcc phase. After a modification of the hcp interaction only the Ti content $ in bcc remains higher. This is a consequence of the less stable TiC from $ 99Dum compared to to 03Fri. This seems consistent with data from $ Eremenko and Tret'yachenko at 1723 K. However, a stronger temperature $ dependence of the Ti solubility in V2C does remain. The liquid interaction $ was drastically simplified. A eutectic just below 1898 K identifed by Rudy $ is reproduced, but its composition is somewhat shifted. $ $PAR L(LIQUID,C,TI,V;0),, -111424.88-30.306*T;,, N 15Zha2 ! $PAR L(LIQUID,C,TI,V;1),, -102629.55+11.569*T;,, N 15Zha2 ! $PAR L(LIQUID,C,TI,V;2),, +180287.5-86.582*T;,, N 15Zha2 ! PAR L(LIQUID,C,TI,V;0),, +30000;,, N 17Hal18 ! $ PAR L(FCC_A1,TI,V:C;0),, -130833.62+45.055*T;,, N 15Zha2 ! PAR L(FCC_A1,TI,V:C,VA;0),, +219939.63-52.077*T;,, N 15Zha2 ! $ PAR L(BCC_A2,TI,V:C,VA;0),, -130142.15;,, N 15Zha2 ! $ $PAR L(HCP_A3,TI,V:C;0),, -43582.86+8.744*T;,, N 15Zha2 ! PAR L(HCP_A3,TI,V:C;0),, -30000+8.744*T;,, N 17Hal18 ! PAR L(HCP_A3,TI,V:C,VA;0),, +25869.21;,, N 15Zha2 ! $ ------------------------------------------------------------------------------ $ Ti-V-N $ $ K. Zeng, R. Schmid-Fetzer, Mater. Sci. Technol., 14, 1083-91(1998). $ $ Checked against paper. $ $ The V-N and Ti-V binaries are different from those used by 98Zen1. $ PAR L(BCC_A2,TI,V:N;0),, +90000;,, N 98Zen1 ! PAR L(A2_BCC,TI,V:N;0),, +90000;,, N 98Zen1 ! $ PAR L(HCP_A3,TI,V:N;0),, +10000;,, N 98Zen1 ! PAR L(HCP_A3,TI,V:N;1),, +10000;,, N 98Zen1 ! $ PAR L(TI2N_C4,TI,V:N;0),, -60000;,, N 98Zen1 ! $ ------------------------------------------------------------------------------ $ V-C-N $ $ K. Frisk, Calphad, 32, 326-37(2008). $ $ The isothermal section at 1873 K is reproduced, but not data on N solubility $ in V(C,N). These data do not seem compatible with the isothermal section. $ PAR L(FCC_A1,V:C,N;0),, -20000;,, N 08Fri ! PAR L(A1_FCC,V:C,N;0),, -20000;,, N 08Fri ! $ ------------------------------------------------------------------------------ $ Quaternary systems $ ------------------------------------------------------------------------------ $ Cr-Fe-Mo-C $ $ C. Qiu, ISIJ Int., 32, 1117-27(1992). $ PAR L(HCP_A3,CR,FE,MO:C;0),, -57062;,, N 92Qiu2 ! PAR L(M23C6_D84,CR,FE:MO:C;0),, -177850+153.905*T;,, N 92Qiu2 ! PAR G(M6C_E93,FE:MO:CR:C),, +2*GHSERFE+2*GHSERCR +2*GHSERMO+GHSERCC-25298-54.8698*T;,, N 92Qiu2 ! $ ------------------------------------------------------------------------------ $ Cr-Fe-V-C $ $ B.-J. Lee, D.N. Lee, J. Phase Equilib., 13, 349-364(1992). $ PAR L(M7C3_D101,CR,FE,V:C;0),, -250158;,, N 92Lee2 ! $ PAR L(M23C6_D84,CR,FE:V:C;0),, -205342+141.6667*T;,, N 92Lee2 ! PAR L(M23C6_D84,CR,V:FE:C;0),, -382069;,, N 92Lee2 ! PAR L(M23C6_D84,CR,FE,V:CR:C;0),, -1499585;,, N 92Lee2 ! PAR L(M23C6_D84,CR,FE,V:FE:C;0),, -1499585;,, N 92Lee2 ! PAR L(M23C6_D84,CR,FE,V:V:C;0),, -1499585;,, N 92Lee2 ! $ ------------------------------------------------------------------------------ $ Fe-Mn-Nb-C $ $ A.V. Khvan, B. Hallstedt, Calphad, 40, 10-15(2013). $ $ See also 12Khv2. $ $ No parameters for this system. Checked against manuscript. $ $ ------------------------------------------------------------------------------ $ Fe-Mn-Nb-N $ $ A.V. Khvan, B. Hallstedt, Calphad, 40, 10-15(2013). $ $ No parameters for this system. Checked against manuscript. $ $ ------------------------------------------------------------------------------ $ Fe-Mn-V-C $ $ W. Huang, Metall. Trans. A, 22A, 1911-20(1991). $ $ There are no parameters for this system. $ $ The vertical section at 1% Mn and 0.1% V is not quite reproduced for $ C > 1%. $ $ ------------------------------------------------------------------------------ $ Fe-Mo-Si-C $ $ B. Hallstedt, unpublished, 2017. $ $ This is not a model of the quaternary system, but just a parameter to $ allow Si solubility in M6C. $ PAR G(M6C_E93,FE:MO:SI:C),, +2*GHSERFE+2*GHSERMO +2*GHSERSI+GHSERCC-350000;,, N 17Hal1 ! $ ------------------------------------------------------------------------------ $ Fe-Nb-Si-C $ ------------------------------------------------------------------------------ $ Fe-Si-Ti-C $ ------------------------------------------------------------------------------ $ Fe-Si-V-C $ ------------------------------------------------------------------------------ $ Fe-Si-C-N $ ------------------------------------------------------------------------------ $ $ LIST-OF-REFERENCE NUMBER SOURCE Null 'Unknown source' Lin 'Linear combination of lattice stabilities' Same 'Same or similar interaction as in the corresponding stable phase' REFLAV 'Laves phase convention: G(LAVES,X:X)=+3*GHSERXX+15000' NIST 'NIST-Ni0209 Database, Ursula Kattner, 2002' COST 'COST 507 database' SGCOST 'COST 507 database, SGTE unary database V.3.0, 1996; Al, B, Nd, Ti, Zn' 80Bre 'L. Brewer, R.H. Lamoreaux, Atomic Energy Rev., Spec. Iss., No. 7, IAEA, Vienna, 1980, pp. 119, 236-38; Cu-Mo' 82Fer 'A. Fernandez Guillermet, Calphad, 6, 127-40 (1982); Fe-Mo' 83And 'J.-O. Andersson, Calphad, 7, 305-15(1983); Fe-V' 85Gus 'P. Gustafson, Scand. J. Metall., 14, 259-67(1985); Fe-C' 85Xin 'Z.S. Xing, D.D. Gohil, A.T. Dinsdale, T. Chart, DMA(A) 103, National Physical Laboratory, London, 1985; Fe-Ni' 86Din 'A.T. Dinsdale, T.G. Chart, NPL, unpublished, 1986; Cr-Ni' 86Mur 'J.L. Murray, Bull. Alloy Phase Diagrams, 7, 245-48(1986); Mg-Ti' 87And1 'J.-O. Andersson, B. Sundman, Calphad, 11, 83-92(1987); Cr-Fe' 87And2 'J.-O. Andersson, Calphad, 11, 271-76(1987); Cr-C' 87Cha 'L. Chandrasekaran, unpublished work, 1987; Cu-C, Cu-Fe-C' 87Gab 'A. Gabriel, P. Gustafson, I. Ansara, Calphad, 11, 203-18(1987); Ni-C, Fe-Ni-C' 87Gus2 'P. Gustafson, TRITA-MAC 354 (1987); Cr-Fe-Mo-W-C' 87Jan 'A. Jansson, TRITA-MAC 340 (1987); Cu-Fe-Ni' 88And1 'J.-O. Andersson, Calphad, 12, 1-8(1988); Mo-C' 88And2 'J.-O. Andersson, Calphad, 12, 9-23(1988); Fe-Mo, Fe-Mo-C' 88And3 'J.-O. Andersson, Metall. Trans A, 19A, 627-36(1988); Cr-Fe-C' 88And4 'J.-O. Andersson, N. Lange, Metall. Trans. A, 19A, 1385-94(1988); Cr-Fe-Mo' 88Fer3 'A. Fernandez Guillermet, Z. Metallkd., 79, 524-36(1988); Co-Ni-C, Co-Fe-Ni-C' 88Fri 'K. Frisk, P. Gustafson, Calphad, 12, 247-254(1988); Cr-Mo' 88Gus4 'P. Gustafson, Metall. Trans. A, 19A, 2531-46(1988); Cr-Fe-W' 88Gus5 'P. Gustafson, Metall. Trans. A, 19A, 2547-54(1988); Cr-Fe-W-C' 88Gus6 'P. Gustafson, Calphad, 11, 277-92(1987); Cr-Ni-W' 89Hua2 'W. Huang, Calphad, 13, 243-52(1989); Fe-Mn' 89NPL 'NPL, unpublished, 1989; Mn-Si-C' 89Vah 'C. Vahlas, P.-Y. Chevalier, E. Blanquet, Calphad, 13, 273-92(1989); Mo-Si' 90Fri1 'K. Frisk, Metall. Trans. A, 21A, 2477-88(1990); Cr-Fe-N' 90Fri2 'K. Frisk, Calphad, 14, 371-380(1990); Mo-Ni' 90Fri3 'K. Frisk, TRITA-MAC 429, Stockholm 1990; Cr-Mo-Ni' 90Ham 'M. Hamalainen, K. Jaaskelainen, R. Luoma, M. Nuotio, P. Taskinen, O. Teppo, Calphad, 14, 125-37(1990); Cr-Cu, Cu-Nb' 90Hil 'M. Hillert, C. Qiu, Metall. Trans. A, 21A, 1673-80(1990); Cr-Fe-Ni' 90Hua1 'W. Huang, Scand. J. Metall., 19, 26-32(1990); C-Mn,' 90Hua2 'W. Huang, Metall. Trans. A, 21A, 2115-23(1990); Fe-Mn-C' 90Hua3 'W. Huang, Z. Metallkd., 81, 397-404(1990); Fe-Nb-C' 90Kaj 'M. Kajihara, M. Hillert, Metall. Mater. Trans. A, 21A, 2777-87(1990); Cr-C' 90SUB 'SGTE Substance Database, version 1990' 91Ans 'I Ansara, unpublished, 1991; Cr-Si' 91Din 'A.T. Dinsdale, Calphad, 15, 317-425(1991).' 91Du 'H. Du, M. Hillert, Z. Metallkd., 82, 310-16(1991); Fe-C-N' 91Fer1 'A. Fernandez Guillermet, K. Frisk, Int. J. Thermophys., 12, 417-31(1991); Ni-N' 91Fer2 'A. Fernandez Guillermet, W. Huang, Int. J. Thermophys., 12, 1077-1102(1991); Mn-V-C' 91Fri1 'K. Frisk, Calphad, 15, 79-106(1991); Cr-N, Fe-N, Mo-N' 91Fri2 'K. Frisk, Z. Metallkd., 82, 59-66(1991); Fe-Ni-N' 91Fri3 'K. Frisk, Z. Metallkd., 82, 108-17(1991); Cr-Fe-Ni-N' 91Fri4 'K. Frisk, Report IM-2929, 1991; Cu-N, Cu-Fe-C-N' 91Hua1 'W. Huang, Z. Metallkd., 82, 174-81(1991); V-C' 91Hua2 'W. Huang, Z. Metallkd., 82, 391-401(1991); Fe-V, Fe-V-C' 91Hua3 'W. Huang, Calphad, 15, 195-208(1991); Mn-V, Fe-Mn-V' 91Hua4 'W. Huang, Metall. Trans. A, 22A, 1911-20(1991); Fe-Mn-V-C' 91Lac 'J. Lacaze, B. Sundman, Metall. Mater. Trans. A, 22A, 2211-23(1991); Fe-Si, Si-C, Fe-Si-C' 91Lee 'B.-J. Lee, unpublished revision 1991; C-Cr-Fe-Ni' 91Oht1 'H. Ohtani, M. Hillert, Calphad, 15, 11-24(1991); V-N' 91Oht2 'H. Ohtani, M. Hillert, Calphad, 15, 25-39(1991); Fe-V-N' 91Tib 'J.E. Tibballs, SI-report 890221-5, 1991 (also COST 507 report, 1998); Mn-Si' 92Fer 'A. Fernandez-Guillermet, G. Grimvall, J. Phys. Chem. Solids, 53, 105-25(1992); Cr-C, Ni-C' 92Fri1 'K. Frisk, Metall. Trans. A, 23A, 639-49(1992); Fe-Mo-Ni' 92Fri2 'K. Frisk, Metall. Trans. A, 23A, 1271-78(1992); Fe-Mo-N' 92Lee1 'B.-J. Lee, Calphad, 16, 121-49(1992); Cr-C, Ni-C, Cr-Ni-C' 92Lee2 'B.-J. Lee, D.N. Lee, J. Phase Equilib., 13, 349-64(1992); Cr-Fe-V-C' 92Lee3 'B.-J. Lee, Z. Metallkd., 83, 292-99(1992); Cr-V, Cr-Fe-V' 92Mey 'S. an Mey, Calphad 16, 255-60(1992); Cu-Ni' 92Qiu1 'C. Qiu, Calphad, 16, 281-89(1992); Cr-Fe-Mo' 92Qiu2 'C. Qiu, ISIJ Int., 32, 1117-27(1992); Cr-Fe-Mo-C' 93Cos 'J.G. Costa Neto, S.G. Fries, H.L. Lukas, S. Garna, G. Effenberg, Calphad, 17, 219-28(1993); Cr-Nb' 93Du 'H. Du, J. Phase Equilib., 14, 682-93(1993); Fe-N, Fe-C-N' 93For 'A. Forsberg, J. Agren, J. Phase Equilib., 14, 354-63(1993); Fe-Mn-Si' 93Fri 'K. Frisk, Calphad, 17, 335-49(1993); Cr-Mn-N' 93Jin 'Z.-P. Jin, C. Qiu, Metall. Trans. A, 24A, 2137-44(1993); Mo-Ti, Fe-Mo-Ti' 93Lee1 'B.-J. Lee, Calphad, 17, 251-68(1993); Cr-Fe, Fe-Ni, Cr-Fe-Ni' 93Lee2 'B.-J. Lee, Metall. Trans. A, 24A, 1017-25 (1993); Cr-Fe-Mn-C' 93Lee3 'B.-J. Lee, Metall. Trans. A, 24A, 1919-33(1993); Cr-Mn, Cr-Fe-Mn' 93Lee4 'B.-J. Lee, Taehan Kumsok Hakhoechi, 31, 480-89(1993); Cr-Fe-Ni' 93Qiu1 'C. Qiu, A. Fernandez Guillermet, Z. Metallkd., 84, 11-22(1993); Mn-N' 93Qiu2 'C. Qiu, Metall. Trans. A, 24A, 629-45(1993); Fe-Mn-N' 93Qiu3 'C. Qiu, Metall. Trans. A, 24A, 2393-2409(1993); Cr-Fe-Mn-N' 94Cou 'C.A. Coughanowr, I. Ansara, H.L. Lukas, Calphad, 18, 125-40(1994); Cr-Si' 94Har 'K.C. Hari Kumar, P. Wollants, L. Delaey, Calphad, 18, 71-79(1994); Nb-V' 95Che 'Q. Chen, Z.P. Jin, Metall. Mater. Trans. A, 26A, 417-26(1995); Cu-Fe' 95Dup 'N. Dupin, Thesis, LTPCM, France, 1995; Al-Cr-Ni, Cr-Ni-Ti' 95Lee 'B.-J. Lee, unpublished, 1993-95' 96Bel 'P. Bellen, K.C. Hari Kumar, P. Wollants, Z. Metallkd., 87, 972-78(1996); Ni-Ti' 96Bol 'A. Bolcavage, U.R. Kattner, J. Phase Equilib., 17, 92-100(1996); Nb-Ni' 96Fri 'K. Frisk, B. Uhrenius, Metall. Mater. Trans., 27A, 2869-80(1996); Mo-C-N' 96Har2 'K.C. Hari Kumar, I. Ansara, P. Wollants, L. Delaey, Z. Metallkd., 87, 666-72(1996); Cu-Ti' 96Hua 'W. Huang, Metall. Mater. Trans. A, 27A, 3591-3600(1996); Nb-N' 96Jon3 'S. Jonsson, Z. Metallkd., 87, 713-20(1996); Ti-C-N' 96Sei 'H.J. Seifert, H.L. Lukas, G. Petzow, Z. Metallkd., 87, 2-13(1996); Si-Ti' 96Shi 'J.-H. Shim, C.-S. Oh, D.N. Lee, Metall. Mater. Trans. B, 27B, 955-66(1996); Mo-Ti-C' 96Vre 'J. Vrestal, J. Stepankova, P. Broz, Scand. J. Metall., 25, 224-31(1996); Cu-Mn' 96Zen 'K. Zeng, R. Schmid-Fetzer, Z. Metallkd., 87, 540-54(1996); Ti-N' ! ADD_REFERENCES DUMMY1 'dummy 1' 97Lin 'M. Lindholm, J. Phase Equilib., 18, 432-40(1997); Cr-Fe-Si' 97Oht 'H. Ohtani, H. Suda, H. Ishida, ISIJ Int., 37, 207-16(1997); Cr-Cu-Fe' 97SUB 'SGTE substance database, version 1997' 98Ans 'I. Ansara, COST 507, Final report round 2, 1998; Cr-Mg' 98Hua 'W. Huang, UWM, unpublished research, 1998; Al-Mo-Ni' 98Jac2 'M.H.G. Jacobs, P.J. Spencer, COST 507, Final report round 2, 1998; Mg-Ni' 98Kor 'J. Korb, K. Hack, COST 507, Final report round 2, 1998; Ni-V' 98Lee 'B.-J. Lee, COST 507, Final report round 2, 1998; Cr-Mn' 98Lia2 'P. Liang, H.L. Lukas, H.J. Seifert, G. Ghosh, G. Effenberg, F. Aldinger, Calphad, 22, 527-44 (1998); Cu-Mg, Cu-Mg-Zn' 98Luk 'H.L. Lukas, COST 507, Final report round 2, 1998; Mg-Si' 98Mie 'J. Miettinen, Calphad 22, 231-56(1998); Fe-Si, Fe-Si-C' 98Ran 'M.H. Rand, N. Saunders, COST 507, Final report round 2, 1998; Si-V' 98Sau2 'N. Saunders, COST 507, Final report round 2, 1998; Mn-Ti' 98Sau3 'N. Saunders, COST 507, Final report round 2, 1998; Mo-Ti' 98Tib 'J. Tibballs, COST 507, Final report round 2, 1998; Fe-Mg' 98Zen1 'K. Zeng, R. Schmid-Fetzer, Mater. Sci. Technol., 14, 1083-91(1998); Ti-V-N' 98Zen2 'K. Zeng, M. Hamalainen, COST 507, Final report round 2, 1998; Cr-Cu' 99Dav 'A. Davydov, U.R. Kattner, J. Phase Equilib., 20, 5-16(1999); Co-Mo' 99Du 'Y. Du, J.C. Schuster, Metall. Mater. Trans. A, 30A, 2409-18(1999); Ni-Si, Ni-Si-C' 99Dum1 'L.F.S. Dumitrescu, M. Hillert, B. Sundman, Z. Metallkd., 90, 534-41(1999); Ti-C, Ti-C-N' 99Dum2 'L.F.S. Dumitrescu, M. Hillert, ISIJ Int., 39, 84-90(1999); Fe-Ti-C' 99Dup1 'N. Dupin, I. Ansara, Z. Metallkd., 90, 76-85(1999); Al-Ni' 99Dup2 'N. Dupin, unpublished, 1999; Cr-Ni-Ti, Al-Cr-Ni-Ti' 99Gho 'G. Ghosh, Metall. Mater. Trans. A, 30A, 1481-94(1999), SGTE unary database V.5.0, 2009; Ni' 99Lee 'B.-J. Lee, unpublished, 1999' 99Mie 'J. Miettinen, Calphad, 23, 249-62(1999); Fe-Ni-Si' 99SGUN 'SGTE unary database V.4.1, 1999.' 99Sun 'B. Sundman, unpublished, 1999; Fe-Si-C' 00Du1 'Y. Du, J.C. Schuster, J. Phase Equilib., 21, 281-86(2000); Cr-Si' 00Du2 'Y. Du, J.C. Schuster, L. Perring, J. Am. Ceram. Soc., 83, 2067-73(2000); Cr-Si-C' 00Dup 'N. Dupin, unpublished, 2000; Al-Ni-Ti' 00Moo 'K.-W. Moon, W.J. Boettinger, U.R. Kattner, F.S. Biancaniello, C.A. Handwerker, J. Electron. Mater., 29, 1122-36(2000); Cu' 00Sch 'J.C. Schuster, Y. Du, Metall. Mater. Trans. A, 31A, 1795-1803(2000); Cr-Ni-Si' 00SUB 'SGTE substance database, version 2000' 00Wan 'C.P. Wang, X.J. Liu, I. Ohnuma, R. Kainuma, S.M. Hao, K. Ishida, J. Phase Equilib., 21, 54-62(2000); Cu-Mo, Cu-Fe-Mo, Cu-Fe-Nb' 00Wes 'S. Westman, unpublished, 2000; Cr-Fe, Fe-Mo, Fe-V, Mn-V' 00Yan1 'X.Y. Yan, F. Zhang, Y.A. Zhang, J. Phase Equilib., 21, 379-84(2000); Mg-Si' 00Zhu 'W. Zhuang, J. Shen, Y. Liu, L. Ling, S. Shang, Y. Du, J.C. Schuster, Z. Metallkd., 91, 121-27(2000); Cr-Ti' 01Dup 'N. Dupin, I. Ansara, B. Sundman, Calphad, 25, 279-98(2001); Al-Cr-Ni' 01Lee 'B.-J. Lee, Metall. Mater. Trans. A, 32A, 2423-39(2001); Nb-C, Fe-Nb-C, Fe-Nb-N, Fe-Nb-Ti, Fe-Ti-N, Nb-C-N, Nb-Ti-C, Nb-Ti-N, Ti-C-N' 01Ser 'C. Servant et al., Calphad, 25, 79-95(2001); Cu-Fe-Ni' 01Sun 'B. Sundman, fix to avoid BCC with just Va (in LB1-v2).' 01Zha 'Y. Zhang, H. Liu, Z. Jin, Calphad, 25, 305-17(2001); Nb-Ti' 02Bra 'J. Bratberg, K. Frisk, Calphad, 26, 459-76(2002); Mo-V, Mo-V-C' 02Gho 'G. Ghosh, J. Phase Equilib., 23, 310-28(2002); Ti-V' 02Sun 'B. Sundman, modified sigma parameters, 2002; Fe-V, Mn-V, Ni-V, ternaries' 02Wan 'C.P. Wang, X.J. Liu, I. Ohnuma, R. Kainuma, K. Ishida, J. Phase Equilib., 23, 236-45(2002); Cr-Cu-Fe, Cu-Fe-Si' 03Che 'P.-Y. Chevalier, E. Fischer, unpublished research, 2003; Mo-Si' 03Dup 'N. Dupin, B. Sundman, March 2003 at JEEP, including SRO in Al-Ni and Fe-Ni' 03Ma 'X. Ma, C. Li, F. Wang, W. Zhang, Calphad, 27, 383-88(2003); Si-N' 03Mie2 'J. Miettinen, Calphad, 27, 103-14(2003); Cu, Cu-Mn' 03Mie3 'J. Miettinen, Calphad, 27, 141-45(2003); Cu-Fe-Mn' 04Din 'A.T. Dinsdale, unpublished, 2004; Cu-C' 04Guo 'C. Guo, Z. Du, J. Alloys Compd., 385, 109-13(2004); La, Mg' 04Xio 'W. Xiong, Y. Du, Y. Liu, B.Y. Huang, H.H. Xu, H.L. Chen, Z. Pan, Calphad, 28, 133-40(2004); Mo-Nb' 05Can 'S. Canderyd, Report IM-2005-109, KIMAB, Stockholm, 2005; Fe-Nb-C' 05Gro 'J. Groebner, D. Mirkovic, M. Ohno, R. Schmid-Fetzer, J. Phase Equilib. Diffus., 26, 234-39(2005); Mg-Mn' 05Guo 'C. Guo, Z. Du, Intermetallics, 13, 525-34(2005); Mn-Ni' 06Che 'H. Chen, Y. Du, Calphad, 30, 308-15(2006); Nb-Ni' 06Hal2 'B. Hallstedt, unpublished, 2006; Ni-C' 06Hal3 'B. Hallstedt, unpublished, 2006; Cr-Ni-C' 06Hal4 'B. Hallstedt, unpublished, 2006; Mg-C' 06Slu 'M.H.F. Sluiter, Calphad, 30, 357-66(2006); Endmember values' 06Tur 'P.E.A. Turchi, L. Kaufman, Z.-K. Liu, Calphad, 30, 70-87(2006); Cr-Mo-Ni, Cr-Mo-Ni-W' 07Fra 'P. Franke, Int. J. Mater. Res., 98, 954-60(2007); Mn-Ni' 07Hal1 'B. Hallstedt, unpublished, 2007; Cr-Si' 07Zha 'L. Zhang, Y. Du, Calphad, 31, 529-40(2007); Al-Fe-Ni' 08Fri 'K. Frisk, Calphad, 32, 326-37(2008); Nb-V-C, V-C-N' 08Hal1 'B. Hallstedt, unpublished, 2008; Fe-Ni-Si' 08Hal2 'B. Hallstedt, unpublished, 2008; Cu-C' 08Hal3 'B. Hallstedt, fcc ordering parameters, 2008; Fe-Mn' 08Hal4 'B. Hallstedt, unpublished, 2008; Cr-Fe-Si' 08Zha1 'J. Zhao, Y. Du, L.Zhang, H. Xu, Calphad, 32, 252-55(2008); Cu-V' 08Zha2 'L. Zhang, Y. Du, Q. Chen, H. Xu, F. Zheng, C. Tang, H. Chen, Int. J. Mater. Res., 99, 1306-18(2008); Cu-Fe-Mn' 08Zhu 'Z. Zhu, Y. Du, L. Zhang, H. Chen, H. Xu, C. Tang, J. Alloys Compd., 460, 632-38(2008); Al-Nb' 09Gen 'T. Geng, C. Li, J. Bao, X. Zhao, Z. Du, C. Guo, Intermetallics, 17, 343-57(2009); Nb-Si' 09Wan 'C.P. Wang, H.L. Zhang, S.L. Wang, Z. Lin, X.J. Liu, A.T. Tang, F.S. Pan, J. Alloys Compd., 481, 291-95(2009); Ho, Mn, Sm' 09Zha 'L. Zhang, Y. Du, H. Xu, S. Liu, Y. Liu, F. Zheng, N. Dupin, H. Zhou, C. Tang, Int. J. Mater. Res., 100, 160-75(2009); Fe-Mn-Ni' 10Dju 'D. Djurovic, B. Hallstedt, J. von Appen, R. Dronskowski, Calphad, 34, 279-85(2010); Mn-C' 10Hal 'B. Hallstedt, D. Djurovic, J. von Appen, R. Dronskowski, A. Dick, F. Koermann, T. Hickel, J. Neugebauer, Calphad, 34, 129-33(2010); Fe-C' 10Pav 'J. Pavlu, J. Vrestal, M. Sob, Calphad, 34, 215-21(2010); Cr-Ti' 11Dju 'D. Djurovic, B. Hallstedt, J. von Appen, R. Dronskowski, Calphad, 35, 479-91(2011); Fe-Mn, Fe-Mn-C' 11Khv 'A.V. Khvan, slight modification of liquid interaction, 2011; V-C' 11Wan 'J. Wang, C. Liu, C. Leinenbach, U.E. Klotz, P.J. Uggowitzer, J.F. Loeffler, Calphad, 35, 82-94(2011); Cu-Ti, Cu-Sn-Ti' ! ADD_REFERENCES DUMMY2 'dummy 2' 12Bo 'H. Bo, J. Wang, L. Duarte, C. Leinenbach, L. Liu, H. Liu, Z. Jin, Trans. Nonferrous Met. Soc. China, 22, 2204-11(2012); Fe-Ti' 12Hal 'B. Hallstedt, adjusted magnetic parameters, 2012; Fe-Mn, Fe-Mn-C' 12Khv1 'A.V. Khvan, B. Hallstedt, K. Chang, Calphad, 39, 54-61(2012); Cr-C, Cr-Nb-C, Mn-Nb-C' 12Khv2 'A.V. Khvan, B. Hallstedt, Calphad, 39, 62-69(2012); Fe-Nb, Fe-Nb-C, Fe-Mn-Nb-C' 12Liu 'S.H. Liu, B. Hallstedt, D. Music, Y. Du, Calphad, 38, 43-58(2012); Fe-Nb, Mn-Nb, Fe-Mn-Nb' 12Yua 'X. Yuan, L. Zhang, Y. Du, W. Xiong, Y. Tang, A. Wang, S. Liu, Mater. Chem. Phys., 135, 94-105(2012); Ni-Si' 13Khv1 'A.V. Khvan, B. Hallstedt, Calphad, 40, 10-15(2013); Fe-Nb, Nb-C, Nb-N, Fe-Mn-Nb, Fe-Nb-C, Fe-Nb-N, Nb-C-N, Fe-Mn-Nb-C, Fe-Mn-Nb-N' 13Khv2 'A.V. Khvan, K. Chang, B. Hallstedt, Calphad, 43, 143-48(2013); Fe-Nb-V' 13Slu 'M.H.F. Sluiter, unpublished research (2013); More endmember values' 14Khv 'A.V. Khvan, B. Hallstedt, C. Broeckmann, Calphad, 46, 24-33(2014); Cr-Fe-C' 14Raj 'V.B. Rajkumar, K.C. Hari Kumar, J. Alloys Compd., 611, 303-12(2014); Fe-Mo' 14Sch 'C. Schmetterer, A. Khvan, A. Jacob, B. Hallstedt, T. Markus J. Phase Equilib. Diffus., 35, 434-44(2014); Cr-Nb' 14Shu 'K. Shubhank, Y.-B. Kang, Calphad, 45, 127-37(2014); Cu-C' 14Zhu 'W.J. Zhu, L.I. Duarte, C. Leinenbach, Calphad, 47, 9-22(2014); Cu-Ni-Ti' 15Hal1 'B. Hallstedt, changed parameters due to new binaries, 2015; Mo-Ti-C' 15Hal2 'B. Hallstedt, parameter to destabilise BCC_A2, 2015; Mg-C' 15Hal3 'B. Hallstedt, unpublished, 2015; Mg-N' 15Hal4 'B. Hallstedt, unpublished, 2015; Mg-Nb' 15Hal5 'B. Hallstedt, unpublished, 2015; Mg-V' 15Zha1 'C. Zhang, Y. Peng, P. Zhou, W. Zhang, Y. Du, Calphad, 51, 104-10(2015); Mo-Nb-C' 15Zha2 'W. Zhang, Y. Peng, Y. Du, L. Chen, Y. Li, S. Wang, G. Wen, W. Xie, Int. J. Refract. Met. Hard Mater., 48, 346-54(2015); Ti-V-C' 16Hal1 'B. Hallstedt, ternary fcc ordering parameter, 2016; Fe-Mn-Ni' 16Hal3 'B. Hallstedt, added reciprocal to fcc-ordering, 2016; Cr-Ni' 16Hal4 'B. Hallstedt, Cr-Ni sigma phase parameter adjusted, 2016; Cr-Fe-Ni' 16Hal5 'B. Hallstedt, changed U1FFENI, 2016' 16Hal6 'B. Hallstedt, refitted sigma parameters, 2016; Cr-Mn, Cr-Fe-Mn' 16Hal7 'B. Hallstedt, unpublished, 2016; Cr-Mn-Ni' 16Hal9 'B. Hallstedt, Modification of Cu2Mg and CuMg2 parameters; Cu-Mg' 16Hal10 'B. Hallstedt, J. Groebner, M. Hampl, R. Schmid-Fetzer, Calphad, 53, 25-38(2016); Cu-Si, Al-Cu-Si' 16Jac1 'A. Jacob, C. Schmetterer, A. Khvan, A. Kondratiev, D. Ivanov, B. Hallstedt, Calphad, 54, 1-15(2016); Fe-Nb, Cr-Fe-Nb' 16Jac2 'A. Jacob, unpublished, 2016; Nb-Si, Fe-Nb-Si' 16Lia 'S.-M. Liang, P. Wang, R. Schmid-Fetzer, Calphad, 54, 82-96(2016); Mg, Mg-Si' 16Tan 'F. Tang, B. Hallstedt, Calphad, 55, 260-69(2016); Cr-Ni' 17Hal1 'B. Hallstedt, Si solubility in M6C, 2017; Fe-Mo-Si-C' 17Hal2 'B. Hallstedt, New C14_LAVES parameters and Ti lattice stability, 2017; Cr-Ti, Fe-Ti, Mn-Ti' 17Hal3 'B. Hallstedt, adjusted liquid interaction, 2017; Fe-Ti-C' 17Hal4 'B. Hallstedt, new parameters for MU_D85, 2017; Fe-Mo, Mn-Mo, Cr-Fe-Mo' 17Hal5 'B. Hallstedt, New C14_LAVES parameters, 2017; Cr-Mo' 17Hal6 'B. Hallstedt, new parameters for SIGMA_D8B, 2017; Fe-Mo, Mn-Mo, Cr-Fe-Mo' 17Hal7 'B. Hallstedt, adjusted interaction MU_D85, 2017; Nb-Ni' 17Hal8 'B. Hallstedt, new parameters for SIGMA_D8B, MU_D85, C14_LAVES, 2017; Fe-Mo-Ni' 17Hal9 'B. Hallstedt, new parameters for MU_D85, C14_LAVES, 2017; Fe-Mo-Ti' 17Hal10 'B. Hallstedt, New parameters SIGMA_D8B, C14_LAVES, 2017; Cr-Fe-Si' 17Hal11 'B. Hallstedt, modified parameters for SIGMA_D8B and P_PHASE, 2017; Cr-Mo-Ni' 17Hal12 'B. Hallstedt, added parameters for FE4N_L1, 2017; Fe-N, Cr-Fe-N, Fe-Mn-N' 17Hal13 'B. Hallstedt, adjusted parameter for FCC_4SL, 2017; Ni-Si' 17Hal14 'B. Hallstedt, modified liquid interaction, 2017; Cr-V-C' 17Hal15 'B. Hallstedt, sanitized parameters for BCC_A2, 2017; Cu-C' 17Hal16 'B. Hallstedt, ternary liquid interaction, 2017; Cu-Fe-C' 17Hal17 'B. Hallstedt, unpublished, 2017; Fe-Nb-Ti' 17Hal18 'B. Hallstedt, changed hcp and liquid interaction, 2017; Ti-V-C' 17Hal19 'B. Hallstedt, modified MU_D85, 2017; Fe-Nb-V' 17Hal20 'B. Hallstedt, estimated fcc interaction, 2017; Cr-Fe-C' 17Jac 'A. Jacob, E. Povoden-Karadeniz, E. Kozeschnik, Calphad, 56, 80-91(2017); Cr-Si, Nb-Si, Cr-Nb-Si' ! ================================================ FILE: examples/macros/map1.OCM ================================================ new Y set echo Y @$ ========================================================= @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ map1.OCM @$ Calculate the phase diagram for Ag-Cu @$ ========================================================= @& set echo r t ./agcu set cond t=1000 p=1e5 n=1 x(cu)=.2 c e l r 2 @& set ax 1 x(cu) 0 1 0.025 set ax 2 t 800 1500 10 l ax l sh set ref ag fcc,,,,, set ref cu fcc,,,,, @& map @& @$ This is the normal x-T phase diagram plot plot x(*,cu) T title map 1 fig 1 render @& @$ Zoom of the Ag rich side plot x(*,cu) T scale x N 0 0.2 title map 1 fig 2 @& @$ Changing the axis plot T x(*,cu) title map 1 fig 3 render @& @$ We can plot with activity instead of phase composition ! plot ac(cu) T title map 1 fig 4 render @& @$ Another funny way to plot the phase diagram calculation !! plot x(*,cu) gm(*) extra tie 3 title map 1 fig 5 @$========================================================================== @$ end of map1 macro @$========================================================================== set inter ================================================ FILE: examples/macros/map10.OCM ================================================ new Y set echo Y @$ ==================================================================== @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ map10.OCM @$ Calculating the isothermal section at 1200 K for Cr-Fe-Ni @$ ==================================================================== @& set echo r t ./saf2507 fe cr ni set c t=1200 p=1e5 n=1 x(cr)=.45 x(ni)=.5 set ref cr bcc * ,, set ref ni fcc * ,, c e l,,,, @& set ax 1 x(cr) 0 1 ,,,, set ax 2 x(ni) 0 1 ,,,, map @$ this diagram has no potential axis, that requires some special care @& @$ The graphics for this kind of diagram is not fully developed @$ The lines for the invariants are missing @$ Some graphical options set by user are ignored plot title map 10 fig 1 @& plot text 0.47 0.07 .8 0 n {/Symbol s} text n 0.6 0.02 .8 0 y text n 0.2 0.5 .8 0 y title map 10 fig 2 @& plot extra tie_line 2 title map 10 fig 3 @& @$ Testing Gibbs triangle plot extra gibbs text n 0.51 0.25 .8 -48 y title map 10 fig 4 @& @$ scale plots a whole square plot scale x n 0 .5 title map 10 fig 5 @& @$ Changing the plot axis reinitiates all plot options !!?? plot x(*,fe) title map 10 fig 6 @& @$ It looks a bit nicer as Gibbs triangle plot extra gibbs y extra tie 3 title map 10 fig 7 @& @$ Finally plot activity lines plot ac(cr) ac(ni) @$========================================================================== @$ end of map10 macro @$========================================================================== set inter ================================================ FILE: examples/macros/map11.OCM ================================================ new Y set echo Y @$================================================================= @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ map11.OCM @$ Calculation of the Cr-Fe binary @$================================================================= @& set echo @$ 3 separate parts, now using 3 start equilibria @$ r t ./steel1 cr fe set c t=600 p=1e5 n=1 x(cr)=.2 c e l RESULTS 1 @& set ref cr bcc * ,, set ref fe bcc * ,, set ax 1 x(cr) 0 1 .025 set ax 2 t 400 2500 25 @$ Set this as start point with a direction set as_start 0 @& @$ Add one more start point for the gamma loop set c t=1200 x(cr)=.1 c e @$ in this case the direction is important set as_start 1 @$ Add one more for the liquidus set c x(cr)=.5 t=2200 c e set as_start -2 @& @$ To avoid metastable bcc/sigma line set adv map 2 @& li equil @& map plot X(*,CR) T title map 11 fig 1 RENDER @$ @$ This diagram will sometimes have a metastable @$ extrapolation of the sigma+bcc lines because the @$ two bcc phases merges at hight T and the 3-phase line @$ is not found when lowering the T. @$ And/or it may have an invariant indicated at the congruent transition! @& plot text 0.46 1000 .8 0 n {/Symbol s} text n .03 1300 .8 0 y text n .4 1400 .8 0 y text n .2 2000 .8 0 y title map 11 fig 2 @& @$========================================================================== @$ end of map11 macro @$========================================================================== set interactive ================================================ FILE: examples/macros/map12.OCM ================================================ new Y set echo Y @$ ============================================================= @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ map12.OCM @$ Calculating Mo-Re phase diagram from a database file @$ eventually this will test the XTDB format @$ ============================================================= set echo read t ./MoRe set c t=1000 p=1e5 n=1 x(re)=.9 c e l,,,, @& set ax 1 x(re) 0 1 ,,, set ax 2 t 300 4000 25 map plot title map 12 fig 1 @& @$ add a label and move the keys plot pos left bottom text .6 2400 .9 0 Y title map 12 fig 2 @$========================================================================== @$ end of map12 macro @$========================================================================== set inter ================================================ FILE: examples/macros/map13.OCM ================================================ @$ new Y set echo Y @$ @$ =========================================================== @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ Calculating Al-Ni binary phase diagram @$ with 4 sublattice order/disorder models for FCC, BCC (and HCP) @$ using partitioning and permutation of parameters @$ =================================================================== set echo Y r t ./alni-4slx @& set c t=1000 p=1E5 n=1 x(al)=.2 c e l , 2 @& set ax 1 x(al) 0 1 ,, set ax 2 t 400 2000 25 map plot title map 13 fig 1 @& @$ =================================================================== @$ This time the whole diagram ... wow @& @$ Add some phase labels plot title map 13 fig 2 text 0.3 1900 .8 0 y text n 0.05 1400 .8 0 y text n 0.23 1200 .8 90 y text n 0.45 1500 .8 0 y @& @$ =================================================================== @$ We can plot it in a strange way ... plot SM(*) extra tie 3 title map 13 fig 3 pos bottom left @$========================================================================== @$ end of map13 macro @$========================================================================== set inter ================================================ FILE: examples/macros/map14.OCM ================================================ new Y set echo Y @$ ==================================================================== @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ map14.OCM @$ Calculating the isothermal section for Cr-Fe-Mo @$ ==================================================================== @& set echo r t ./steel1 fe cr mo set c t=1400 p=1e5 n=1 x(cr)=.3 x(mo)=.05 c e l,,,, @& set ax 1 x(cr) 0 1 ,,,, set ax 2 x(mo) 0 1 ,,,, map @$ this diagram has no potential axis, that requires some special care @$ There is a small fcc/bcc region is missing set c x(mo)=.001 x(cr)=.12 c e l,,,,, @& map n @& @$ The graphics for this kind of diagram is not fully developed plot title map 14 fig 1 @& @$ plot as Gibbs triangle with tie-lines plot extra gibbs Y extra tie 3 @$ Also set the color of the monovariants to red extra color FF0000 title map 14 fig 2 extra lower Fe @& plot extra color a0ffa0 title map14 fig 3 gra 3 crfemo-1400-leftcorner Y @$========================================================================== @$ end of map14 macro @$========================================================================== set inter ================================================ FILE: examples/macros/map15.OCM ================================================ @$ new Y set echo Y @$=============================================================== @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ MAP15 BEF isotherms at 3 T @$=============================================================== set echo r t ./BEF @$ First at 500 K, @$ We have to start inside the small sigma miscibility gap set c t=500 p=1e5 n=1 x(re)=.37 x(ni)=.29 c e l,,,,, @$ We have two sigma phases stable @& @$ Set axis set ax 1 x(re) 0 1 ,, set ax 2 x(ni) 0 1 ,, @& map @& plot title map 15 fig 1a @& @$ Sometimes some parts are missing, try adding another startpoint @$ does not work on LINUX set c x(ni)=.2 set c x(re)=.36 x(ni)=.1 c e l,,,,, @& map N plot @$ It looks OK, plot as a Gibbs triangle and add tie-lines @& plot extra ? @$ This gives the browser window and we must select from the extra menu extra ?? gibbs y extra tie 3 extra lower Mo title Map 15 fig 1b: BEF model Mo-Ni-Re isotherm 500 K @$ Usually some parts are missing or have spurious tei-line @$ Mapping is still to be improved with experience @& @$------------------------------------------------- @$ Then at 1500 K set c t=1500 x(re)=.2 x(ni)=.2 c e l,,,,, @& map plot title Map 15 fig 2a: BEF model Mo-Ni-Re isotherm 1500 K extra gib y extra tie 10 @$ set a light gray monovariant extra color f0f0f0 ffff00 @& @$ Sometimes a part on the Re rich side missing, add a new start point set c x(ni)=.1 x(re)=.8 c e map n plot @$ some extra options extra gibbs y extra tie 10 extra color f0f0f0 ffff00 title Map 15 fig 2b: BEF model Mo-Ni-Re isotherm 1500 K @& @$------------------------------------------------------- @$ Finally at 2500 K set c t=2500 p=1e5 n=1 x(re)=.7 x(ni)=.27 c e l,,,,, @& set ax 1 x(re) 0 1 , set ax 2 x(ni) 0 1 , @$ Just to be sure ... c e map plot extra gib y extra tie 3 title Map 15 fig 3: BEF model Mo-Ni-Re isotherm 2500 K @$ restore default colors if we run several macros ... extra color 7CFF40 7CFF40 @$ Set a text in the lower left corner extra lower Mo @$========================================================================== @$ end of map15 macro @$========================================================================== set inter ================================================ FILE: examples/macros/map16.OCM ================================================ @$ new Y set echo Y @$=================================================================== @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ Mapping of isopleth in C-Cr-Fe @$ @$=================================================================== @$ @$ r t ./steel7 fe cr c set c t=1200 p=1e5 n=1 w%(cr)=13 w%(c)=1 set ref C graphite c e @& l RESULTS 1 @& set ax 1 w%(c) 0 2 .02 set ax 2 t 800 1800 ,, map @& plot T_C @$ Plotting this text is a bit complicated @$ The Y coordinate must be in the units used to calculate the diagram (Kelvin) @$ but the text will be plotted using the units for the plot (Celcius) @$ This will eventually be corrected (until then edit the ocgnu.plt file) text 1 1100 2 0 Y title map 16 Fig 1 @$ The lines with the same phase fix has the same color @& l ax @$ Plot with chemical potential of C @& plot ac(c) T Title Map 16 Fig 2 @$ This diagram a bit strange as we have 2 potential axis in a ternary system @$ Along all lines there is a phase fix and and one or 2 more phases stable. @$ The single phase and two-phase regions are areas @$ but the 3-phase regions are also lines (the line FCC+M7C+M23C!!) @$ The invariant equilibrium with 4 stable phases is just a point @$ All according to Gibbs phase rule. @& plot x(c) HM title map 16, Fig 3, composition vs enthalpy, the invariant is clearly visible @$ In this diagram the invariant looks like a road crossing. @$========================================================================== @$ end of map16 macro @$========================================================================== set inter ================================================ FILE: examples/macros/map17.OCM ================================================ new Y set echo Y @$ ============================================================== @$ @$ calculate Al-Fe phase diagram including A2/B2 line in BCC @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ ============================================================== @$ r t ./AlFe-4SLBF @& @$ Calculate an equilibrium in the B2 set c t=1000 p=1e5 n=1 x(al)=.3 c e l , 2 @& @$ Change to condition in difference of y to the current value set c y(bcc,fe#3)-y(bcc,fe#2) l c set c x(al)=none c e l,,,, @$ We must not use the gridminimizer but with the current @$ conditions it is not allowed. We can use "c e" but safer with "c n" @$ @$ The phase has B2 ordering as two sublattices have equal and high Fe content @$ and the other equal but lower Fe content. @$ @$ Here the difference in Fe content is high @$ We can to calculate a line when this difference is small @$ First ensure we can set the difference as condition @& @$ Change the value of the difference in y @$ That is easy using the notation specifying the condition number l c set c 4:=.2 l c @& c n l,,,, @$ The overall composition has changed as we are closer to the A2/B2 line @$ Decrease the difference again @& set c 4:=.01 l c @& @$ We are now sufficiently close to the A2/B2 transition line c n l,,, @& @$ Set a T axis set ax 1 T 300 2000 5 step @$ plot the a2/b2 transition line plot x(al) T title map 17 fig 1a @& @$ Sometimes the lie stops at 1200 because the line up to the liquid @$ is considered wrong. Make sure it is included amend line y y @$ plot as dashed line on a file to be appended plot x(al) T extra line 0 title map 17 fig 1b @$ The final Y means overwrite any previous file output alfe-a2b2 Y @& @$ set inter @$ ============================================== @$ Now the Al-Fe phase diagram new Y r t ./AlFe-4SLBF @& @$ Start with the High Al side set c t=1000 p=1e5 n=1 x(al)=.52 c e l RESULTS 2 @& @$ Axis for the diagram set ax 1 x(al) 0 1 .01 set ax 2 t 300 2000 25 map @& pl X(*,AL) T title map 17 fig 2a @$ Mapping stops at B2/A2 transition in equilibrium with liquid @$ That is an error which has to be fixed. @& set c t=1900 p=1e5 n=1 x(al)=.3 c e l,,, @& map n pl X(*,AL) T title map 17 fig 2b @$ The line liquid/BCC is still not complete, @$ The part connectiong to the high Al curve was automatically @$ excluded by OC as mapping stopped when the B2 became stable @$ BUT we can restore that part! amend line Y Y Y @& plot title map 17 fig 2c @$ Note there are two curves for liq/bcc around 50% Al. @$ These can be removed by editing the ocgnu.plt file @$ Now just the BCC/D03/B2 region missing @& set c t=600 x(al)=.25 c e l,,, @$ Note that one composition set hase equal fractions in all 4 @$ sublattices whereas the other has high and equal fraction of Fe @$ in 2 sublattices, less high fraction of Fe in the third and @$ high fraction of Al in the fourth. This is D0_3 ordering. @$ @$ The grid minimizer in OC must know that the BCC has B permutation to find @$ this ordering miscibility gap. With that information it generates @$ gridpoints taking the ordering into account. @& map n @& pl X(*,AL) T title map 17 fig 2d @& @$ Now the gamma loop set c x(al)=.015 t=1400 c e l,,,, @& map n @$ Now plot everyting and append the already calculated and plotted a2/b2 curve @& plot append alfe-a2b2 text .1 1100 .8 0 n BCC-A2 text n .35 1100 .8 0 n BCC-B2 text n .3 500 .8 0 n BCC-D03 title map 17 fig 3 @$ @$ Developing OC is a hobby for me, @$ I have no ambition to solve all your problems calculating phase diagrams ... @& @$ Calculating and adding the para/ferro magnetic transion @$ along the Curie T curve is a task you can do yourself! @$ If you want you can calculate and add the B2/D0_3 transition curve also. @$========================================================================== @$ end of map17 macro @$========================================================================== set inter ================================================ FILE: examples/macros/map18.OCM ================================================ new Y set echo Y @$ ========================================================= @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ map18.OCM @$ Calculate an isopleth phase diagram for Al-Mg-Zn @$ ========================================================= @& set echo y r t ./cost507R al mg zn @$ The map is sensitive to the startpoint !! set cond t=900 p=1e5 n=1 x(mg)=.8 x(zn)=.05 c e l r 1 @& set ax 1 x(mg) 0 1 0.025 set ax 2 t 300 1000 25 map plot title map18 fig 1 @& @$ magnify the T axis plot title map18 fig 2 scale y n 500 750 extra line 2 text .5 680 .8 0 @$ A nice diagram but the step length control is not very good @$========================================================================== @$ end of map18 macro @$========================================================================== set inter ================================================ FILE: examples/macros/map19.OCM ================================================ @$ new Y set echo Y @$======================================================================== @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ Calculating the NaCl-MgCl phase diagram and activity curves using MQMQA @$ @$======================================================================== r t ./MgNaClX @& l d @& l mq @$ Listing of the MQMQA quadruplets with bonds @& set stat ph liq-na liq-mg=s l sh a @$ These phases are the pure liquid chlorids, used only for activity curves @& set c t=2000 p=1e5 n(mg)=.5 n(na)+n(mg)=1 ac(cl)=1 c n @& l , 2 @& set ax 1 n(mg) 0 1 .01 set ax 2 t 300 2000 10 @& map @& plot x(*,mg) T_C scale y n 300 850 title map 19 Fig 1 extra axis-factor x 3 text .15 350 .9 0 n Note fraction scale multiplied by 3, the composition of compounds wrong @$ The scaling on horisontal axis in in moles Mg in the phases. @$ MgCl2 has 1/3, MgNaCl3 has 1/5=0.2, MgNa2Cl4 has 1/7=0.143 @$ As the axis is multiplied with 3 the compound fractions are wrong @& @$ ============================== @$ Now calculate activities in liquid SALT at 1073 K @$ The condition for Cl is that is has constant activity @$ because the salt is stable only in a quasi-binary section NaCl-MgCl2 @$ The amount of Cl cannot vary outside this region. @$ If there are other phases (gas for example) @$ which can exist outside the NaCl-MgCl2 quasibinary @$ one can use a condition of the amount of Cl @$ The activity condition can cause numerical problems @& set c t=1073 @& set stat ph *=sus set stat ph liqref_mgcl2 liqref_nacl=d set stat ph salt=e 1 @$ We must set the LIQREF phases as dormant to have DGM of NaCl and MgCl2. @$ The DGM is the driving force for these compounds as liquid @$ and related to the chemical potential of these compounds. @& c e l , 2 @$ There should not be any probem so far @& @$ OC cannot plot the activities of MgCl2 and NaCl directly @$ as they are not components. We must also take care of the reference state. @$ The Gibbs energies of pure NaCl and MgCl2 liquids are calculated @$ in GM(liqref-NaCl) and GM(liqref-MgCl) for one mole of atoms ent sym refmgcl2=3*gm(liqref-mgcl2); @$ MU(MG) is the chemical potential of 1 mole Mg (as mu(cl)=0 or ac(cl)=1) @$ Subtracting the reference state gives the chemical potential of MgCl2 enter sym mumgcl2=mu(mg)-refmgcl2; @$ The activity is the exponential of the chemical potential divided by RT enter sym acmgcl2=exp((mu(mg)-refmgcl2)/RT); @$ The same for NaCl (with 2 moles of atoms) as for MgCl2 enter sym refnacl=2*gm(liqref-nacl); enter sym munacl=mu(na)-refnacl; enter sym acnacl=exp((mu(na)-refnacl)/RT); @& @$ We must remove the second axis to calculate with STEP set ax 2 none l ax @& @$ For some unknown reason n(mg) axis does not go to lower values @$ Thus stat at n(mg)=.01 set c n(mg)=.01 c e step @$ and there should be no problmens so far @& plot y(salt,*) title map 19 Fig 2 out ./ymgnacl Y @$ This plot show the fraction of the constituents (quadrupoles) @& plot acnacl out ./acnacl Y title map 19 Fig 3 @$ This plot is the activity of NaCl with liquid at same T as reference state @& plot acmgcl2 title map 19 Fig 4 @$ This plot is the activity of MgCl2 with liquid at same T as reference state @& plot acmgcl2 app ./acnacl title map 19 Fig 5 out ./acmgnacl Y @$ Both activity plots together fit the Fig. 8 in the paper by Pelton 2001 @$========================================================================== @$ end of map10 macro @$========================================================================== set inter ================================================ FILE: examples/macros/map2.OCM ================================================ new Y set echo Y @$ ============================================================= @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ map2.OCM @$ Calculate the miscibility gap and liquidus for Cr-Mo @$ ============================================================= @& set echo r t ./steel1 cr mo set cond t=800 p=1e5 n=1 x(mo)=.5 c e l r 1 @& set ax 1 x(mo) 0 1 ,, set ax 2 t 500 3000 25 l ax l sh @& map @& plot x(*,cr) T title map 2 fig 1 render @& set cond t=2500 x(mo)=.3 c e map N plot title map 2 fig 2 @& plot @$ One more option for scale of text! text 0.5 1400 .8 0 y text n 0.5 2800 .8 0 y title map 2 fig 3 @& @$========================================================================== @$ end of map2 macro @$========================================================================== set inter ================================================ FILE: examples/macros/map3.OCM ================================================ new Y set echo Y @$ ================================================================= @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ map3.OCM @$ Calculate the stable C-Fe phase diagram @$ ================================================================= @& set echo r t ./steel1 fe c set cond t=1200 p=1e5 n=1 x(c)=.2 set ref-state c graph c e l r 1 @& set ax 1 x(c) 0 1 ,,, set ax 2 t 500 2000 10 l ax l sh @& map @& plot x(*,c) T title map 3 fig 1 render @& @$ Again this plot will be written on the WORKING DIRECTORY @$ and will be appended from there later plot w%(*,c) T_C scale x n 0 7 title map 3 fig 2 out ./stable Y render @& @$--------------------------------------------------------- @$ Calculate the metastable Fe-C with cementite set st ph *=sus set st ph fcc bcc liquid cem=ent 0 l c set c x(c)=.2 t=1200 c e l,,,,, @& @$ Change the axis as we are not interested in high C content set ax 1 x(c) 0 .4 ,,, l ax @& map @$ Plot the metastable Fe-C diagram plot w%(*,C) t_c title map 3 fig 3 @& @$ now overlay the stable @$ NOTE the stable.plt file was saved on the WORKING DIRECTORY plot title map 3 fig 4 append ./stable @& @$ Scale the X-axis plot title map 3 fig 5 scale x n 0 7 @$ @& plot title map 3 fig 6 scale x n 0 2.5 scale y n 700 1200 pos top left 12 text 1 1100 1.2 0 n austenite @& @$ Finally, plot the metastable diagram with enthalpy axis !! @$ the state variable H(*) means the enthalpy of each phase plot x(*,c) HM(*) extra tie ? 3 title map 3 fig 7 @$ Normally we cannot plot tie-lines in a binary x-T diagram @$ but when T is exchanged for HM(*) both axis are exensive (normallized) @$ properties and then we can plot tie-lines! @& @$ Note: plotting with composition axis chenged to activity @$ will plot the (vertical) 3-phase lines at wrong activity .... why? @$========================================================================== @$ end of map3 macro @$========================================================================== set inter ================================================ FILE: examples/macros/map4.OCM ================================================ new Y set echo Y @$ =============================================================== @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ map4.OCM @$ Calculate the phase diagram for O-U @$ =============================================================== @& set echo r t ./OU set c t=2800 p=1e5 n=1 x(o)=.5 c e l r 2 @& set ax 1 x(o) 0 1 0.005 set ax 2 t 300 3500 20 map plot x(*,o) T title map 4 fig 1a render @& @$ Sometimes lower O-rich side at low T is missing @& set c t=500 x(o)=.68 c e map N plot title map4 fig 1b @& @$ Now add some layout features plot title map 4 fig 2 @$ this command moves the idenification of lines in bottom left @$ the empty line means accept curront font and size position bottom left @$ This command adds the names of phases stable at given positions text 0.59 3300 .8 0 y @$ First question asked for 2nd and later "text" is if to amend an existing one @$ This is inside the C1 phase text n 0.65 2600 .8 90 y @$ This is inside the gas phase text n 0.9 3100 .8 0 y title map 4 fig 2B render @& @$ To add a label at 700 K and high oxygen I need to calculate @$ that equilibria explicitly first!! set c t=700 x(o)=.8 c e l,,,, @& plot text n 0.8 700 .8 0 y title map 4 fig 3 @& plot title map 4 fig 4 scale x N .58 .78 render @& plot title map 4 fig 5 scale y N 2500 3200 @& @$------------------------------------------------------------- @$ As a final touch calculate the congruent melting of UO2 @$ First calculate an equilibrium in the liquid (or solid) above it l c set c x(o)=.66 t=3300 c e l,,,,, @& @$---------------------------------------------------------- @$ Then set C1_MO2 as fix with zero amount set stat ph c1_mo2=f 0 set c t=none l c c e l,,,,, @& @$--------------------------------------------------------- @$ Finally replace the condition of U with the condition @$ that it should be the same in liquid and C1 @$ IT IS IMPORTANT TO USE THE COMPOSITION SETS THAT ARE STABLE ABOVE set c x(ion_liquid,u)-x(c1_mo2,u)=0 set c x(o)=none l c c e l,,,, @$ Voila! @$ T=3139 K and x(o)=.6638, slightly on the U rich side. debug symbol t 3139.16 @& @$========================================================================== @$ end of map4 macro @$========================================================================== set interactive ================================================ FILE: examples/macros/map5.OCM ================================================ new Y set echo Y @$ =============================================================== @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ map5.OCM @$ Calculate the phase diagram for Fe-Mo @$ =============================================================== @& set echo r t ./steel1 fe mo @& @$------------------------------------------------------------------------ @$ Create an extra composition set for BCC ... not really necessay amend phase bcc comp Y FE >.5 <.1 amend phase bcc def <.1 >.5 @& @$-------------------------------------------------------------------- @$ Set conditions set cond t=2000 p=1e5 n=1 x(mo)=.7 c e l r 1 @& @$-------------------------------------------------------------------- @$ Set axis for phase diagram set ax 1 x(mo) 0 1 ,, set ax 2 t 300 3000 25 l ax l sh @& @$-------------------------------------------------------------------- map @& @$-------------------------------------------------------------------- @$ Plot the diagram plot x(*,mo) T title map 5 fig 1 render @& @$-------------------------------------------------------------------- @$ we must calculate the gamma loop separately set c t=1400 x(mo)=.002 c e l,,,,, @& @$-------------------------------------------------------------------- map N plot x(*,mo) T position bottom right title map 5 fig 2 render @& @$ Set range (scaling) of T plot x(*,mo) T scale y N 1400 1900 title map5 fig 3 render @& @$ Add some labels plot title map 5 fig 4 text .5 1700 .8 0 y text n .4 1530 .8 0 y text n .1 1850 .8 0 y text n .36 1650 .8 0 n R @& @$ Change to greek phase names plot title map 5 fig 5 text y 4 {/Symbol s} text y 3 {/Symbol m} @& @$========================================================================== @$ end of map5 macro @$========================================================================== set inter ================================================ FILE: examples/macros/map6.OCM ================================================ new Y set echo Y @$ =========================================================== @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ map6.OCM @$ Calculate an isopleth for Cr-Fe-Ni at 8 mass% Ni @$ =========================================================== @& set echo r t ./saf2507 cr fe ni set c t=1200 p=1e5 w(cr)=.2 w(ni)=.08 n=1 c e l 4 @& set ax 1 w(cr) 0 1 0.01 set ax 2 t 800 2200 25 map @& plot w(CR) T title map 6 fig 1 render @$ All lines at at w(cr)=0.92 at the rght because there is 8% Ni @$ A line in the lower middle end above 800 K, add a start point set c w(cr)=.3 t=1000 c e map n @$ now plot @& @$ add some labels plot scale y n 800 2200 title map 6 fig 2 text 0.1 2000 .9 0 y text n .5 1500 .9 0 y text n .05 1200 .9 0 y text n .46 1160 .9 0 y {/Symbol s} text n .75 1200 .9 0 y @& plot title map 6 fig 3 scale y n 1700 1800 @& plot title map 6 fig 4 scale y n 1150 1250 @& @$========================================================================== @$ end of map6 macro @$========================================================================== set interactive ================================================ FILE: examples/macros/map7.OCM ================================================ new Y set echo Y @$ ============================================================= @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ map7.OCM @$ Calculate an isopleth for a HSS @$ ============================================================= @& set echo r t ./steel1 c cr fe mo v @$ There will be a cubic carbide stable in this system @$ create a composition set of the fcc phase for that amend phase fcc Y MC NONE <.5 >.5 >.5 <.5 @$ amend the default composition also of the austenite amend phase fcc default <.1 >.5 <.1 <.1 <.1 >.9 @& @$ calculate a first equilibrium at 1200 where we have both fcc phases set reference C graph @$ Startpoint change needed for new gridminimizer, same diagram set c t=1300 p=1e5 n=1 w%(c)=0.8 w%(cr)=5, w%(mo)=8 w%(v)=1 @$ It is important that the grid minimizer provide gridpoints with small @$ amounts of alloying elements !!! c e l r 4 @& set axis 1 w%(c) 0 2 ,,, set axis 2 T 800 1800 25 l ax @& map @$ You may get a buffer overflow error here @$ but there is not yet any way saving of results on file implemented @$ Until then you have to restrict yourself to smaller diagrams @& plot title map 7 fig 1 @& @$ Some lines are still missing but the invariants are OK @$ There is a need for several automatic startpoints @$ add some labels plot title map 7 fig 2 scale x n 0 2 @$ Position of keys, Size of font must be on separate line! pos bottom left 12 @$ Label some areas text 0.7 1150 .8 0 y text n 0.4 1050 .8 0 y text n .55 1300 .8 0 y text n .5 1470 .8 0 y text n 0.1 1450 .8 0 y text n 0.8 1580 .8 0 y @& @$ We can list all calculated equilibria l l @& @$ or all node points l eq plot scale y n 1500 1700 scale x n 0 1 text n 0.3 1670 .8 0 y title map 7 fig 3 @& plot scale y n 1000 1350 scale x n 0 2 title map7 fig 4 @$========================================================================== @$ end of map7 macro @$========================================================================== set inter ================================================ FILE: examples/macros/map8.OCM ================================================ new Y set echo Y @$ ==================================================================== @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ map8.OCM @$ Enter the data interactively and @$ Calculate a phase diagram for FCC ordering in the Fe-Ni system @$ using partition and permutations @$ @$ NOTE in this case we use the option to set FCC_PERMUTATIONS @$ so each unique parameters is entered only once (compare with map4.OCM) @$ @$ We also set the bit 23 of the phase not to subtract the ordered part @& as disordered. Thus the disordered part has just a regular parameter, @$ we do not have to add the ordered part as disordered as in map4.OCM. @$ ========================================================================= @& set echo @$ Enter the elements and their reference states enter element Fe Iron BCC 55.847 0 0 enter element Ni Nickel FCC 58.69 0 0 @$ These functions describe the end-member energies at Fe3Ni, Fe2Ni2 and FeNi3 @$ respectivly. The VASP energies relative to pure Fe amd Ni as fcc are: @$ Fe3Ni1 -0.071689 eV for 1 atom?? @$ Fe2Ni2 -0.138536 eV for 1 atom?? @$ Fe1Ni3 -0.125748 eV for 1 atom?? @$ To modify to J/mol atoms multiply with 96500 @$ bond energy multiplied with 3, 4 and 3 respectively. enter tp-sym evtoj constant 96500 enter tp-sym GA3B1 fun 1 -0.071689*evtoj;,,,,, enter tp-sym GA2B2 fun 1 -0.138536*evtoj;,,,,, enter tp-sym GA1B3 fun 1 -0.125748*evtoj;,,,,, @$ We set a positive regular solution parameter enter tp-sym L0 fun 1 12000; ,,,,, @$ this is an approximate SRO contribution to the LRO phase. It is @$ set to about a quater of the L1_0 ordering energy, @$ equal to the Fe-Ni bond energy enter tp-sym GSRO fun 1 -0.034*evtoj;,,,,, @$ Using the partitioned model the contribition from the ordered parameters @$ will cancel when the phase is disordered. If we want them to contribute @$ we must add them to the disordered part enter tp-sym LD0 fun 1 GA3B1+1.5*GA2B2+GA1B3+1.5*GSRO;,,,,,, enter tp-sym LD1 fun 1 2*GA3B1-2*GA1B3;,,,,,, enter tp-sym LD2 fun 1 GA3B1-1.5*GA2B2+GA1B3-1.5*GSRO;,,,,,, @$ ================================================== @$ This is an fcc phase with lro but no explicit sro @$ described with the sublattice model enter phase PARTITIONED_FCC CEF 4 .25 Fe NI; .25 Fe NI; .25 Fe NI; .25 Fe NI; @$ we must set that this has FCC permutations before entering parameters amend phase part-fcc ? fcc-perm @& @$ we must add disordered set before entering parameters @$ We are not modeling the disordered part independently amend phase part dis 4 NO @& @$ enter the parameter, note permutations taken into account enter param G(part,Fe:Fe:Fe:Ni),,GA3B1; 6000 N test enter param G(part,Fe:Ni:Ni:Ni),,GA1B3; 6000 N test enter param G(part,Fe:Fe:Ni:Ni),,GA2B2; 6000 N test enter param G(part,Fe,Ni:Fe,Ni:*:*),,GSRO; 6000 N test amend biblio test VASP calculation by test; @$ These are possible disordered parameters enter param GD(part,Fe,Ni;0),,L0; 6000 N test list data ,, @& @$ we should create composition for the ordered sets sets manually @$ this default constitution is Fe3Ni_L12 amend phase part comp-set y , , <.2 >.5 >.2 <.5 >.2 <.5 >.5 <.2 @$ this default constitution is FeNi_L10 amend phase part comp-set y , , <.2 >.5 <.2 >.5 >.5 <.2 >.5 <.2 @$ this default constitution is FeNi3_L12 amend phase part comp-set y , , <.2 >.5 <.2 >.5 <.2 >.5 >.5 <.2 @$ However, the L12 can have max Ni or Fe on any sublattice, there is no @$ check that it is always the first or last sublattice with the highest @$ fraction of the minor element. This should be arranged in todo_after ... l sh a @& @$ First start point between the A1 and L1_2 phases in the middle set c t=350 p=1e5 n=1 x(ni)=.57 c e l r 2 @& set ax 1 x(ni) 0 1 0.025 set ax 2 t 10 1000 10 map @& plot title map 8 fig 1 @$ Sometimes parts are missing, add a point on Ni-rich side @& @$ this falis for oc6d @$ set c x(ni)=.60 T=500 set c x(ni)=.9 t=400 c e l,,,, @& map N plot title map 8 fig 2 @& @$ Sometimes parts are missing, add a point an on Fe-rich side set c x(ni)=.45 t=200 c e map N plot title map 8 fig 3 @& @$ The mapping is not really good handling the order/disorder transitions set inter @$ Third start point on the Fe-rich side set c x(ni)=.4 T=300 c e l,,,, @& map N plot pos top left title map 8 fig 3 @& @$========================================================================== @$ end of map8 macro @$========================================================================== set inter ================================================ FILE: examples/macros/map9.OCM ================================================ new Y set echo Y @$ =================================================================== @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ map9.OCM @$ OC macro file for RE-W system, @$ Data is entered interactively @$ M Palumbo, S G Fries, T Hammerschmidt et al, @$ Comp. Mat. Sci, Vol 81 (2014) 433-445; @$ =================================================================== @& set echo enter element RE Rhenium HCP 186.21 5355.5 36.526 enter element W Tungsten BCC 183.85 4970.0 32.62 enter tpfun GHSERRE fun 298.15 0;,,,, enter tpfun GHSERW fun 298.15 0;,,,, enter tpfun UNASS fun 298.15 0; 300,,,, enter tpfun ZERO fun 298.15 0; 6000,,,, @$ eVtoJ is J/eV per atom, eVtoJ29 the same for 29 atoms etc. enter tpfun eVtoJ const 96490,,,, enter tpfun eVtoJ8 fun 298.15 8*eVtoJ;,,,,, enter tpfun eVtoJ12 fun 298.15 12*eVtoJ;,,,,, enter tpfun eVtoJ13 fun 298.15 13*eVtoJ;,,,,, enter tpfun eVtoJ24 fun 298.15 24*eVtoJ;,,,,, enter tpfun eVtoJ29 fun 298.15 29*eVtoJ;,,,, enter tpfun eVtoJ30 fun 298.15 30*eVtoJ;,,,,, l tp * @$--------------- @& enter phase fcc CEF 4 .25 RE W; .25 RE W; .25 RE W; .25 RE W; @$ mark that we have parameter permutations according to fcc tetrahedrons amend phase fcc ? fcc_perm @& ent par G(fcc,RE:RE:RE:RE) 298.15 0.062787*eVtoJ;,,,14Pal fcc.A @$ The L1_2 ordering parameter on the Re side ent par G(fcc,W:RE:RE:RE) 298.15 0.11703575*eVtoJ;,,,14Pal L12.A3B @$ The L1_0 ordering parameter ent par G(fcc,W:W:RE:RE) 298.15 0.2098125*eVtoJ;,,,14Pal L10.AB @$ The L1_2 ordering parameter on the W side ent par G(fcc,W:W:W:RE) 298.15 0.33351125*eVtoJ;,,,14Pal L12.AB3 ent par G(fcc,W:W:W:W) 298.15 0.474125*eVtoJ;,,,14Pal fcc.B @$----------- list data @& amend bib 14Pal M Palumbo, S G Fries, T Hammerschmidt et al, Comp. Mat. Sci, Vol 81 (2014) 439-445; list data @& enter phase bcc CEF 4 .25 RE W; .25 RE W; .25 RE W; .25 RE W; @$ mark that we have parameter permutations according to bcc tetrahedrons amend phase bcc bcc_perm ent par G(bcc,RE:RE:RE:RE) 298.15 0.320286*eVtoJ;,,,14Pal bcc.A @$ The D03 ordering parameter on Re side ent par G(bcc,W:RE:RE:RE) 298.15 0.21785575*eVtoJ;,,,14Pal D03.A3B @$ The B2 ordering parameter, sublattice 1&2 are next nearest neighbours ent par G(bcc,W:W:RE:RE) 298.15 0.0971185*eVtoJ;,,,14Pal B2.AB @$ The B32 ordering parameter ent par G(bcc,W:RE:W:RE) 298.15 0.1385725*eVtoJ;,,,14Pal B32.AB @$ The D03 ordering parameter on W side ent par G(bcc,W:W:W:RE) 298.15 0.04742525*eVtoJ;,,,14Pal D03.AB3 ent par G(bcc,W:W:W:W) 298.15 0*eVtoJ;,,,14Pal bcc.B @$----------- list data @& list phase bcc data @& @$------- enter phase hcp CEF 4 .25 RE W; .25 RE W; .25 RE W; .25 RE W; @$ The HCP tetrahedron is the same as FCC amend phase hcp fcc_perm ent par G(hcp,RE:RE:RE:RE) 298.15 0*eVtoJ;,,,14Pal hcp.A ent par G(hcp,W:RE:RE:RE) 298.15 0.12874775*eVtoJ;,,,14Pal D0_19.A3B ent par G(hcp,W:W:RE:RE) 298.15 0.2823905*eVtoJ;,,,14Pal B19.AB ent par G(hcp,W:W:W:RE) 298.15 0.38047325*eVtoJ;,,,14Pal D0_19.AB3 ent par G(hcp,W:W:W:W) 298.15 0.490701*eVtoJ;,,,14Pal hcp.B list phase hcp data @& @$------- ent phase A15 CEF 2 2 RE W; 6 RE W; ent par G(A15,RE:RE) 298.15 0.185144*eVtoJ8;,,,14Pal A15.A ent par G(A15,RE:W) 298.15 0.19109475*eVtoJ8;,,,14Pal A15.AB ent par G(A15,W:RE) 298.15 0.02878425*eVtoJ8;,,,14Pal A15.BA ent par G(A15,W:W) 298.15 0.089645*eVtoJ8;,,,14Pal A15.B list phase A15 data @& @$-------- ent phase sigma CEF 5 2 RE W; 4 RE W; 8 RE W; 8 RE W; 8 RE W; ent par G(sigma,RE:RE:RE:RE:RE) 298.15 0.103465*eVtoJ30;,,,14Pal sigma.A ent par G(sigma,W:RE:RE:RE:RE) 298.15 0.117920533*eVtoJ30;,,,14Pal sigma.BAAAA ent par G(sigma,RE:W:RE:RE:RE) 298.15 0.074164067*eVtoJ30;,,,14Pal sigma.ABAAA ent par G(sigma,W:W:RE:RE:RE) 298.15 0.0887456*eVtoJ30;,,,14Pal sigma.BBAAA ent par G(sigma,RE:RE:RE:RE:W) 298.15 0.075425133*eVtoJ30;,,,14Pal sigma.AAAAB ent par G(sigma,RE:RE:RE:W:RE) 298.15 0.144846133*eVtoJ30;,,,14Pal sigma.AAABA ent par G(sigma,RE:RE:W:RE:RE) 298.15 0.062163133*eVtoJ30;,,,14Pal sigma.AABAA ent par G(sigma,W:RE:RE:RE:W) 298.15 0.096883667*eVtoJ30;,,,14Pal sigma.BAAAB ent par G(sigma,W:RE:RE:W:RE) 298.15 0.166788667*eVtoJ30;,,,14Pal sigma.BAABA ent par G(sigma,W:RE:W:RE:RE) 298.15 0.078029667*eVtoJ30;,,,14Pal sigma.BABAA ent par G(sigma,RE:W:RE:RE:W) 298.15 0.0425622*eVtoJ30;,,,14Pal sigma.ABAAB ent par G(sigma,RE:W:RE:W:RE) 298.15 0.1150282*eVtoJ30;,,,14Pal sigma.ABABA ent par G(sigma,RE:W:W:RE:RE) 298.15 0.0432172*eVtoJ30;,,,14Pal sigma.ABBAA ent par G(sigma,W:W:RE:RE:W) 298.15 0.067439733*eVtoJ30;,,,14Pal sigma.BBAAB ent par G(sigma,W:W:RE:W:RE) 298.15 0.141463733*eVtoJ30;,,,14Pal sigma.BBABA ent par G(sigma,W:W:W:RE:RE) 298.15 0.062896733*eVtoJ30;,,,14Pal sigma.BBBAA ent par G(sigma,RE:RE:RE:W:W) 298.15 0.145899267*eVtoJ30;,,,14Pal sigma.AAABB ent par G(sigma,RE:RE:W:RE:W) 298.15 0.052479267*eVtoJ30;,,,14Pal sigma.AABAB ent par G(sigma,RE:RE:W:W:RE) 298.15 0.151518267*eVtoJ30;,,,14Pal sigma.AABBA ent par G(sigma,W:RE:RE:W:W) 298.15 0.1732738*eVtoJ30;,,,14Pal sigma.BAABB ent par G(sigma,W:RE:W:RE:W) 298.15 0.0767538*eVtoJ30;,,,14Pal sigma.BABAB ent par G(sigma,W:RE:W:W:RE) 298.15 0.1743168*eVtoJ30;,,,14Pal sigma.BABBA ent par G(sigma,RE:W:RE:W:W) 298.15 0.117787333*eVtoJ30;,,,14Pal sigma.ABABB ent par G(sigma,RE:W:W:RE:W) 298.15 0.031243333*eVtoJ30;,,,14Pal sigma.ABBAB ent par G(sigma,RE:W:W:W:RE) 298.15 0.135710333*eVtoJ30;,,,14Pal sigma.ABBBA ent par G(sigma,W:W:RE:W:W) 298.15 0.149161867*eVtoJ30;,,,14Pal sigma.BBABB ent par G(sigma,W:W:W:RE:W) 298.15 0.059292867*eVtoJ30;,,,14Pal sigma.BBBAB ent par G(sigma,W:W:W:W:RE) 298.15 0.165621867*eVtoJ30;,,,14Pal sigma.BBBBA ent par G(sigma,RE:RE:W:W:W) 298.15 0.1662344*eVtoJ30;,,,14Pal sigma.AABBB ent par G(sigma,W:RE:W:W:W) 298.15 0.192115933*eVtoJ30;,,,14Pal sigma.BABBB ent par G(sigma,RE:W:W:W:W) 298.15 0.142513467*eVtoJ30;,,,14Pal sigma.ABBBB ent par G(sigma,W:W:W:W:W) 298.15 0.17298*eVtoJ30;,,,14Pal sigma.B list phase sigma data @& @$------------- ent phase chi CEF 4 1 RE W; 4 RE W; 12 RE W; 12 RE W; ent par G(chi,RE:RE:RE:RE) 298.15 0.057085*eVtoJ29;,,,14Pal chi.A ent par G(chi,W:RE:RE:RE) 298.15 0.044341138*eVtoJ29;,,,14Pal chi.BAAA ent par G(chi,RE:W:RE:RE) 298.15 0.010266552*eVtoJ29;,,,14Pal chi.ABAA ent par G(chi,W:W:RE:RE) 298.15 0.00176469*eVtoJ29;,,,14Pal chi.BBAA ent par G(chi,RE:RE:RE:W) 298.15 0.222213655*eVtoJ29;,,,14Pal chi.AAAB ent par G(chi,RE:RE:W:RE) 298.15 0.107317655*eVtoJ29;,,,14Pal chi.AABA ent par G(chi,W:RE:RE:W) 298.15 0.203353793*eVtoJ29;,,,14Pal chi.BAAB ent par G(chi,W:RE:W:RE) 298.15 0.093724793*eVtoJ29;,,,14Pal chi.BABA ent par G(chi,RE:W:RE:W) 298.15 0.154246207*eVtoJ29;,,,14Pal chi.ABAB ent par G(chi,RE:W:W:RE) 298.15 0.065460207*eVtoJ29;,,,14Pal chi.ABBA ent par G(chi,W:W:RE:W) 298.15 0.138812345*eVtoJ29;,,,14Pal chi.BBAB ent par G(chi,W:W:W:RE) 298.15 0.059790345*eVtoJ29;,,,14Pal chi.BBBA ent par G(chi,RE:RE:W:W) 298.15 0.32744331*eVtoJ29;,,,14Pal chi.AABB ent par G(chi,W:RE:W:W) 298.15 0.312474448*eVtoJ29;,,,14Pal chi.BABB ent par G(chi,RE:W:W:W) 298.15 0.294603862*eVtoJ29;,,,14Pal chi.ABBB ent par G(chi,W:W:W:W) 298.15 0.283917*eVtoJ29;,,,14Pal chi.B list phase chi data @& @$---------- ent phase mu CEF 5 1 RE W; 6 RE W; 2 RE W; 2 RE W; 2 RE W; ent par G(mu,RE:RE:RE:RE:RE) 298.15 0.213904*eVtoJ13;,,,14Pal mu.A ent par G(mu,W:RE:RE:RE:RE) 298.15 0.232698923*eVtoJ13;,,,14Pal mu.BAAAA ent par G(mu,RE:RE:RE:RE:W) 298.15 0.237154846*eVtoJ13;,,,14Pal mu.AAAAB ent par G(mu,RE:RE:RE:W:RE) 298.15 0.172403846*eVtoJ13;,,,14Pal mu.AAABA ent par G(mu,RE:RE:W:RE:RE) 298.15 0.166768846*eVtoJ13;,,,14Pal mu.AABAA ent par G(mu,W:RE:RE:RE:W) 298.15 0.261267769*eVtoJ13;,,,14Pal mu.BAAAB ent par G(mu,W:RE:RE:W:RE) 298.15 0.187943769*eVtoJ13;,,,14Pal mu.BAABA ent par G(mu,W:RE:W:RE:RE) 298.15 0.189324769*eVtoJ13;,,,14Pal mu.BABAA ent par G(mu,RE:RE:RE:W:W) 298.15 0.195145692*eVtoJ13;,,,14Pal mu.AAABB ent par G(mu,RE:RE:W:RE:W) 298.15 0.193476692*eVtoJ13;,,,14Pal mu.AABAB ent par G(mu,RE:RE:W:W:RE) 298.15 0.136986692*eVtoJ13;,,,14Pal mu.AABBA ent par G(mu,W:RE:RE:W:W) 298.15 0.216702615*eVtoJ13;,,,14Pal mu.BAABB ent par G(mu,W:RE:W:RE:W) 298.15 0.216780615*eVtoJ13;,,,14Pal mu.BABAB ent par G(mu,W:RE:W:W:RE) 298.15 0.156615615*eVtoJ13;,,,14Pal mu.BABBA ent par G(mu,RE:RE:W:W:W) 298.15 0.157312538*eVtoJ13;,,,14Pal mu.AABBB ent par G(mu,RE:W:RE:RE:RE) 298.15 0.340443538*eVtoJ13;,,,14Pal mu.ABAAA ent par G(mu,W:RE:W:W:W) 298.15 0.174036462*eVtoJ13;,,,14Pal mu.BABBB ent par G(mu,W:W:RE:RE:RE) 298.15 0.369531462*eVtoJ13;,,,14Pal mu.BBAAA ent par G(mu,RE:W:RE:RE:W) 298.15 0.385507385*eVtoJ13;,,,14Pal mu.ABAAB ent par G(mu,RE:W:RE:W:RE) 298.15 0.294760385*eVtoJ13;,,,14Pal mu.ABABA ent par G(mu,RE:W:W:RE:RE) 298.15 0.314514385*eVtoJ13;,,,14Pal mu.ABBAA ent par G(mu,W:W:RE:RE:W) 298.15 0.421966308*eVtoJ13;,,,14Pal mu.BBAAB ent par G(mu,W:W:RE:W:RE) 298.15 0.326644308*eVtoJ13;,,,14Pal mu.BBABA ent par G(mu,W:W:W:RE:RE) 298.15 0.344868308*eVtoJ13;,,,14Pal mu.BBBAA ent par G(mu,RE:W:RE:W:W) 298.15 0.346191231*eVtoJ13;,,,14Pal mu.ABABB ent par G(mu,RE:W:W:RE:W) 298.15 0.355482231*eVtoJ13;,,,14Pal mu.ABBAB ent par G(mu,RE:W:W:W:RE) 298.15 0.276514231*eVtoJ13;,,,14Pal mu.ABBBA ent par G(mu,W:W:RE:W:W) 298.15 0.381076154*eVtoJ13;,,,14Pal mu.BBABB ent par G(mu,W:W:W:RE:W) 298.15 0.393287154*eVtoJ13;,,,14Pal mu.BBBAB ent par G(mu,W:W:W:W:RE) 298.15 0.310854154*eVtoJ13;,,,14Pal mu.BBBBA ent par G(mu,RE:W:W:W:W) 298.15 0.320410077*eVtoJ13;,,,14Pal mu.ABBBB ent par G(mu,W:W:W:W:W) 298.15 0.356369*eVtoJ13;,,,14Pal mu.B list phase mu data @& @$-------- ent phase C14 CEF 3 2 RE W; 6 RE W; 4 RE W; ent par G(C14,RE:RE:RE) 298.15 0.286726*eVtoJ12;,,,14Pal C14.A ent par G(C14,RE:W:RE) 298.15 0.331349833*eVtoJ12;,,,14Pal C14.ABA ent par G(C14,W:RE:RE) 298.15 0.203029667*eVtoJ12;,,,14Pal C14.BAA ent par G(C14,RE:RE:W) 298.15 0.4255515*eVtoJ12;,,,14Pal C14.AAB ent par G(C14,W:W:RE) 298.15 0.2850135*eVtoJ12;,,,14Pal C14.BBA ent par G(C14,RE:W:W) 298.15 0.527325333*eVtoJ12;,,,14Pal C14.ABB ent par G(C14,W:RE:W) 298.15 0.380295167*eVtoJ12;,,,14Pal C14.BAB ent par G(C14,W:W:W) 298.15 0.459543*eVtoJ12;,,,14Pal C14.B list phase C14 data @& @$----------- ent phase C15 CEF 2 8 RE W; 16 RE W; ent par G(C15,RE:RE) 298.15 0.345061*eVtoJ24;,,,14Pal C15.A ent par G(C15,W:RE) 298.15 0.250001667*eVtoJ24;,,,14Pal C15.A2B ent par G(C15,RE:W) 298.15 0.491933333*eVtoJ24;,,,14Pal C15.AB2 ent par G(C15,W:W) 298.15 0.454032*eVtoJ24;,,,14Pal C15.B list phase C15 data @& @$---------- ent phase C36 CEF 5 4 RE W; 4 RE W; 4 RE W; 6 RE W; 6 RE W; ent par G(C36,RE:RE:RE:RE:RE) 298.15 0.31195*eVtoJ24;,,,14Pal C36.A ent par G(C36,RE:RE:W:RE:RE) 298.15 0.337458833*eVtoJ24;,,,14Pal C36.AABAA ent par G(C36,RE:W:RE:RE:RE) 298.15 0.250287833*eVtoJ24;,,,14Pal C36.ABAAA ent par G(C36,W:RE:RE:RE:RE) 298.15 0.247355833*eVtoJ24;,,,14Pal C36.BAAAA ent par G(C36,RE:RE:RE:RE:W) 298.15 0.37904175*eVtoJ24;,,,14Pal C36.AAAAB ent par G(C36,RE:RE:RE:W:RE) 298.15 0.34407575*eVtoJ24;,,,14Pal C36.AAABA ent par G(C36,RE:W:W:RE:RE) 298.15 0.315368667*eVtoJ24;,,,14Pal C36.ABBAA ent par G(C36,W:RE:W:RE:RE) 298.15 0.305384667*eVtoJ24;,,,14Pal C36.BABAA ent par G(C36,W:W:RE:RE:RE) 298.15 0.224973667*eVtoJ24;,,,14Pal C36.BBAAA ent par G(C36,RE:RE:W:RE:W) 298.15 0.442608583*eVtoJ24;,,,14Pal C36.AABAB ent par G(C36,RE:RE:W:W:RE) 298.15 0.410960583*eVtoJ24;,,,14Pal C36.AABBA ent par G(C36,RE:W:RE:RE:W) 298.15 0.353971583*eVtoJ24;,,,14Pal C36.ABAAB ent par G(C36,RE:W:RE:W:RE) 298.15 0.321842583*eVtoJ24;,,,14Pal C36.ABABA ent par G(C36,W:RE:RE:RE:W) 298.15 0.346623583*eVtoJ24;,,,14Pal C36.BAAAB ent par G(C36,W:RE:RE:W:RE) 298.15 0.315309583*eVtoJ24;,,,14Pal C36.BAABA ent par G(C36,RE:RE:RE:W:W) 298.15 0.4229085*eVtoJ24;,,,14Pal C36.AAABB ent par G(C36,W:W:W:RE:RE) 298.15 0.2877075*eVtoJ24;,,,14Pal C36.BBBAA ent par G(C36,RE:W:W:RE:W) 298.15 0.415114417*eVtoJ24;,,,14Pal C36.ABBAB ent par G(C36,RE:W:W:W:RE) 298.15 0.397507417*eVtoJ24;,,,14Pal C36.ABBBA ent par G(C36,W:RE:W:W:RE) 298.15 0.380724417*eVtoJ24;,,,14Pal C36.BABBA ent par G(C36,W:W:RE:RE:W) 298.15 0.328912417*eVtoJ24;,,,14Pal C36.BBAAB ent par G(C36,W:W:RE:W:RE) 298.15 0.295539417*eVtoJ24;,,,14Pal C36.BBABA ent par G(C36,RE:RE:W:W:W) 298.15 0.506832333*eVtoJ24;,,,14Pal C36.AABBB ent par G(C36,RE:W:RE:W:W) 298.15 0.416418333*eVtoJ24;,,,14Pal C36.ABABB ent par G(C36,W:RE:RE:W:W) 298.15 0.403344333*eVtoJ24;,,,14Pal C36.BAABB ent par G(C36,W:RE:W:RE:W) 298.15 0.403344333*eVtoJ24;,,,14Pal C36.BABAB ent par G(C36,W:W:W:RE:W) 298.15 0.38162625*eVtoJ24;,,,14Pal C36.BBBAB ent par G(C36,W:W:W:W:RE) 298.15 0.36110925*eVtoJ24;,,,14Pal C36.BBBBA ent par G(C36,RE:W:W:W:W) 298.15 0.496471167*eVtoJ24;,,,14Pal C36.ABBBB ent par G(C36,W:RE:W:W:W) 298.15 0.481127167*eVtoJ24;,,,14Pal C36.BABBB ent par G(C36,W:W:RE:W:W) 298.15 0.382497167*eVtoJ24;,,,14Pal C36.BBABB ent par G(C36,W:W:W:W:W) 298.15 0.459342*eVtoJ24;,,,14Pal C36.B list phase C36 data @& list short @& @$--------- @$ Calculate the stable phase diagram set c t=2000 p=1e5 n=1 x(w)=.3 c e l r @& l r 2 @& set ax 1 x(w) 0 1 ,, set ax 2 T 300 4000 25 map plot title map 9 fig 1 text .02 5000 .8 0 y text n .22 5000 .8 0 y text n .4 5000 .8 0 y text n .8 4000 .8 0 y text n .6 2610 .8 0 y render @& @$ Calculate speciation in sigma across the whole diagram at 1000 K @$ take smaller steps in x(w) to have nicer plots set ax 1 x(w) 0 1 .01 set ax 2 none list ax @& set stat phase *=sus set stat phase sigma=ent 1 l short @& @$ conditions not restored after map l c set c x(w)=.3 t=2000 @$ avoid using grid minimizer as that creates two composition sets c n l,,,, @& @$ when using step delete previous map results step normal Y plot x(w) y(sigma,*) title map 9 fig 2 render @& @$ also plot the Gibbs energy, enthalpy and heat capacity plot x(w) gm title map 9 fig 3 render @& plot x(w) hm title map 9 fig 4 @& enter symbol cp hm.t; plot x(w) cp title map 9 fig 5 render @& @$ Calculate the Gibbs energy curves for all phases at 3000 K set stat ph *=ent 0 c e step sep Y plot x(w) gm(*) position outside right title map 9 fig 6 render @& plot x(w) hm(*) title map 9 fig 7 render @& @$ Plot the constitution of the chi phase plot x(w) y(chi,*) title map 9 fig 8 list phase chi model @& @$ Finally calculate the Gibbs energy of an endmember c ph sigma 1 n 1 0 1 0 1 only @& @$========================================================================== @$ end of map9 macro @$========================================================================== set inter ================================================ FILE: examples/macros/maplast.OCM ================================================ @$ running test macros from map15 @$ Frequetly there is a crash after map15, I assume because no memory left set echo Y @& ********************************************************* @$ The Mo-Ni-Re isothermal section at 2500, 1500 and 500 K. @$ ********************************************************* mac ./map15 @& ********************************************************* @$ The isopleth C-13wCr-Fe with a 4 phase invariant equilinrium @$ ********************************************************* mac ./map16 @& ********************************************************* @$ The Al-Fe binary with a dashed A2/B2 transition line @$ ********************************************************* mac ./map17 @& ********************************************************* @$ The Al-Mg-Zn isopleth at x(zn)=0.05 @$ ********************************************************* mac ./map18 @& ********************************************************* @$ Testing the UNIQUAC model @$ ********************************************************* mac ./uniquac @& ********************************************************* @$ Calculation for 20 elements and 191 phases using COST507 @$ ********************************************************* mac ./allcost @& ********************************************************* @$ Calculating 21 equilibria in parallel @$ First test of parallel calculations @$ ********************************************************* mac ./parallel1 @& ********************************************************* @$ Enter a table with many equilibria and calculate all @$ Can be used to test parallel calculations @$ ********************************************************* mac ./parallel2 @& ********************************************************* @$ Assessment using fictitious binary experimental data @$ ********************************************************* mac ./opttest1 @& ********************************************************* @$ Assessment start of the Cu-Mg case study must be run by itself @$ on the directory with the macro files @$ ********************************************************* @$ @$ mac ./opttest2 @$ @& ********************************************************* @$ that is all @$ ********************************************************* set inter ================================================ FILE: examples/macros/melting.OCM ================================================ new YES set echo Y @$ ========================================================= @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ melting.OCM @$ Calculating multicomponent single equilibria @$ Including the melting point of the alloy @$ @$ At the end test using the grid minimizer after "c n" @$ to detect any gripoint below the current equilibrium @$ ========================================================= @& set echo r t ./steel7 @$ ------------------------------------------------------------- @& set c t=1173 p=1e5 n=1 x(c)=.04 x(cr)=.06, x(mo)=.05 x(si)=.003 x(v)=.01 c e l ,,, @$ The equilibrium has two FCC phases, one represent cunbic carbide @$ Check result with a denser grid @$ ------------------------------------------------------------- @& set advanced ? 2 c e @$ The denser grid has about 10 times more gridpoints, here 145000 compared @$ with 21000 with normal grid. The result in this case is the same @$ but with complicated cases it is important to check. @& l ,,, @$ ------------------------------------------------------------- @& @$ We can also list the constitution of the phases l , 2 @$ Note how the carbon content is different in the two FCC phases @$ ------------------------------------------------------------- @& @$ Now calculate the melting T of this alloy @$ by setting liquid fix and remove condition on T c tran liq 1 l , 1 @$ Note that the grid minimizer could not be used for this calculation @$ but is is automatically called afterwards to check if there is any @$ gridpoint below the calculated equilibrium. The melting T is 1501 K. @& @$ ------------------------------------------------------------- @$ Turn off the dense grid as it is not really necessary here set adv grid 1 @& @$ Test setting a condition on the carbon content of the metallic FCC @$ Note that the metallic FCC (austenite) is the second composition set !!! set c x%(fcc#2,c) set c x(c)=none c e l,,,, @$ This is the same equilibrium calculated with different conditions @$ The liquid is not listed but has a very small driving force as @& @$ shown in the next command, -0.00000000172 l sh p @& @$ Now decrease the carbon content of the austenite set c x%(fcc#2,c)=3 c e l,,,, @$ Note that the total amount of C also decreases @$ to 0.03618 in mole fraction @$ and the liquid is no longer stable. @& @$------------------------------------------------------------- @$ Calculate the new melting T for a steel with 3 mole percent C in the fcc @$ now using the "set phase ... status" command @$ and remove the condition on T set ph liq status fix 0 set c t=none l c @& c e l,,,, @$ The melting T with the new carbon content is 1518.89 K @$ ------------------------------------------------------------- @& @$ Now set condition on current H and remove condition on N set c H set c N=none c e l r 1 @$ We have the same quilibrium with different conditions @$ ------------------------------------------------------------- @& @$ Now decrease H a little set c H=40000 c e l,,,, @$ Note the size of the system has changed, N=0.84874 !! @$ ------------------------------------------------------------- @& @$ Now test a new feature, recalculating an equilibrium if the gridtest @$ after a calculation shows a new phase should be stable @$ First reinitiate and read the database again new Y r t ./steel7 set c t=2000 p=1e5 n=1 x(c)=.04 x(cr)=.06, x(mo)=.05 x(si)=.003 x(v)=.01 @& c e l,,,, @$ nothing particular, we have just the liquid stable @$ If we now set T=1173 and calculate without the grid minimizer ... @& @$ OC will not discover that the FCC phase should have a second comp.set set c T=1173 c n l,,,, @$ We have FCC, M6 and M7C3 stable but there is no FCC#2 phase! @$ This is not the global equilibrium we we calculated in the beginning @$ We have G=-57639.4 J debug symbol g -57639.4 @& @$ Instead of "c n" we can use "calculate with_check_after" @$ and then OC will use the current equilibrium as start values to calculate @$ and then use the grid minimizer to check if there are any point below @& c w l ,,,, @$ We now have a more stable equilibrium with the FCC#2 phase @$ and G=-57673.8 J, 34 J less than previous metastable equilibrium @$ @$ The use of a grid test "after" the equilibrium calculation is useful for @$ simulations as the "c n" is much faster but now and again @$ it must be checked with a grid. @& @$ ------------------------------------------------------------------ @$ That is all for now @& @$========================================================================== @$ end of melting macro @$========================================================================== set inter ================================================ FILE: examples/macros/mqtest-1C.OCM ================================================ @$ test entering an A-AB-B system with SRO new Y set echo Y @$ ============== ELEMENTS enter element Fe Fe LIQUID 10 0 0 enter element C C LIQUID 10 0 0 @$================= SPECIEES @$ enter specie AB A0.5B0.5 @$ Constituents in the MQMQA liquid specify 2-4 elements. @$ The / separate elements in sublattice 1 and 2 (A+,B+)(Va) @$ The -Q (without numner) to avoid ambiguety in paramameters @$ All endmembers (quadrupoles) must be electrically neutral and the @$ stochiometry of the species must be set to obtain that @$================= FUNCTIONS @$================= PHASES AND CONSTITUENTS @$ This is to have a baseline enter phase gas ideal Fe C enter PARAMETER G(GAS,Fe;0) 298.15 100000; 6000 N REF3 enter PARAMETER G(GAS,C;0) 298.15 100000; 6000 N REF2 @$================= MQMQA @$ @$ The constituents are created when entering the phase. The user must @$ give all quadrupoles (endmembers) specifying the elements with a "," @$ between elements in same sublattice and "/" separating elements in @$ first and second sublattice. No spaces in the sequence of elements in a @$ quadrupole. For each element in a quad it must be followed by one real @$ number for each element (in the order of the elements). The real number @$ is related to the charge of the element. Each quad must be neutral. @$ @$ The species for the quad is created when tereting the phase and it @$ has a suffic -Q to make their names unique @$ quadrupoles are Fe1/3, Fe1/3C1/6, C1/3, corresponding to C-Fe2C-Fe @$ according to Max enter phase liquid MQMQA Fe/VA 6.0 6.0 2.4 C,Fe/VA 6.0 3.0 6.0 C/VA 6.0 6.0 2.4 enter parameter g(liquid,Fe/VA-q) 298.15 0; 6000 N ref6 enter parameter g(liquid,CFe/VA-q) 298.15 -5000; 6000 N ref6 enter parameter g(liquid,C/VA-q) 298.15 0; 6000 N ref6 @$================= I2SL skipped @& @$ thermochimica gives these quadrupole fractions c ph liq 2.171 .0327 .76375 ALL @& @$ last fraction .20356 of Fe-Fe/Va-Va. First fraction C-C/Va-Va @$ @$ Thermochimica G -26595 J/mol atoms l , 2 set c t=1000 p=1e5 n=1 x(Fe)=.7 @$ set inter FIRST TRY: --->OC6:... echo: c ph liq 1 Current (Y), default (D) or new (N) constitution? /N/: Fraction of C/VA-Q03 /1/: ... echo: .038899 Fraction of CFE/VA-Q02 /0.961101/: ... echo: .74600 Last fraction set to: 2.1510E-01 Calculate what for phase? /ONLY_G/: Using T= 1000.00 K and P= 1.000000E+05 Pa, results in J/F.U. 3X calling MQMQA liquid model 3X in MQMQA, version 3: 3 2.185E+00 3X summed all amounts, next normallize 3X no mixing in sublattice 2 3X SSUB: -6.1086E-01 -4.32E-01 -3.09E-02 1.85E-01 3X SEND: 0.0000E+00 -3.43E+00 -2.06E+00 -2.70E+00 3X SQUAD: 1.6257E-01 -9.51E+00 -4.81E+00 -5.29E+00 3X second derivatives are approximate. Atoms/FU: 0.45766666666666667 G, dG/dT dG/dP d2G/dT2: -2.208775E+04 6.350502E-01 0.000000E+00 0.000000E+00 G/RT, H, atoms/F.U: -5.804510E+00 -2.272280E+04 4.576667E-01 --->OC6:--->OC6:--->OC6:... echo: @$ last fraction .2151 of Fe-Fe/Va-Va. First fraction C-C/Va-Va --->OC6:... echo: @$ --->OC6:... echo: @$ Thermochimica G -24392.8 J --->OC6:--->OC6:... echo: set c t=1000 p=1e5 n=1 x(Fe)=.7 --->OC6:--->OC6:--->OC6:... echo: @$ --->OC6:--->OC6:... echo: set inter --->OC6: --->OC6:sh g ... echo: sh g *** Warning, values can be inconsistent with current conditions G= -2.2087752E+04 ------------------------------------------------------------------ ================================================ FILE: examples/macros/opttest1.OCM ================================================ new Y @$ ================================================================== @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ opttest1.OCM @$ setup file for simple assessment @$ ================================================================== set echo @$ step 1: enter binary data a phase enter element A A FCC 10. 0. 0. enter element B B FCC 10. 0. 0. enter phase FCC CEF 1 1.0 A B @$ enter 100 optimizing coefficients enter opt 100 2500 @$ parameter to be optimized enter parameter G(FCC,A,B) 298.15 A10+A11*T+A12*T*LN(T)+A13*T**2; 6000 N myref l d @& @$ amend the bibliographic reference amend bib myref current assessment; l d @$ We will need some symbols, the heat capacity enter symbol cp1=hm.T; @$ We have also enthalpy differences so we need a symbol for the @$ enthalpy at a fix T, 298.15 K. We first enter the symbols @$ and will show later how to use them enter symbol h298=hm; enter symbol hdiff=hm-h298; l symb @$ Note that the "dot derivative" is prefixed by the "special" letter D @& @$ We will also use a symbol to specify the experimental uncertainty @$ of the heat capacities enter symbol dcp=1; @$---------------------------------------------------- @& @$ step 2: set start values for the optimizing coefficients @$ sometimes these are very important, sometimes one can start from zero set optcoeff_variab 11 10 set opt_var 12 -10 set opt_var 13 0.001 @$ list the optimizing variables list opt short @$ Note the experimental information is not sufficient to determine H298 @$ that means A10 cannot be optimized @& @$ The coefficients are TP constants l tp @&============================================ @$ Make sure we can save this on unformatted file save unf ./opttest1 Y @& @$ reinitiate and read back new Y read unf ./opttest1 @& @$ Check we have parameters and data l data @& l opt short @$ No experimental data entered and no optimization made @$ All parameters have their starting values and sum of error irrelevant @& @$---------------------------------------------------- @$ We will use a feaure that a certain symbol must be calculated at a certain @$ equilibrium. This means we cannot use parallel calculation because @$ the code to handle this is not yet implemented. @$ We must turn off parallelization set adv level n Y set bit glo 15 @& @$---------------------------------------------------- @$ step 3: experiments, enter equilibrium Y where Y means the @$ following command will refer to the new equilibrium @$ first experimental equilibrium, will be equil 2 enter equil FCC1_ZA Y enter comment the reference enthalpy set c t=298.15 p=1e5 n=1 x(b)=.5 c n l,,,,, @& @$ list equilibria, we have now two and the ** indicate "current" l eq @$ @$ specify that the symbol H298 should be calculated at this equilibrium amend symbol H298 x 2 l symb @$ Note that H298 now is prefixed by the equilibrium number and an X @& c n l,,,,, c symb h298 show hm h298 @$ The value of HM and H298 is 723.1516 @& @$ At this equilibrium we also provide experimental values of @$ S298 = SM (integrated Cp from 0 K) and CP enter experiment SM=17:1 enter experiment CP1=18:1 c n l,,, @$ The calculated values of SM is 19.858 and CP1 2.35095 @$---------------------------------------------------- @& @$ enter a second experiment, the enthalpy difference enter equil FCC2_ZB Y set c t=800 p=1e5 n=1 x(b)=.5 enter experiment hdiff=2000:500 c n l,,,, c symb * show hm h298 hdiff @$ Note H298 is the value calculated at 298.15 K, 723.15164, @$ Current value of HM is 1840 and HDIFF 1116.8 @$ -------------------------------------------------------------- @& enter experiment cp1=20:dcp enter experiment hdiff=9000:500 @$ Calculate without gridminimizer c n l,,,, @$ The experiments, prescribed and actual values are also listed @$ @$ ------------------------------------------------------------- @& l equil @$ There are now 3 equilibria @& @$ a third experiment (4th equilibria)............................. 3 enter equil FCC3_ZC Y set c t=1000 p=1e5 n=1 x(b)=.5 enter experiment hdiff=15000:500 enter experiment cp1=22:dcp l equil @$ Forth experiment an enthalpy of mixing.......................... 4 enter equil FCC4_ZD Y set c t=1200 p=1e5 n=1 x(b)=.5 enter experiment hdiff=20000:500 enter experiment cp1=24:dcp l equil @& @$ This command tells OC which equilibria has experiments @$ The last experiment is by default set range_exp 2 @$ Calculate all experimental equilibria without grid minimizer c all N @& l opt short @$ As we have not optimized the coefficients this command gives nothing @$ except the inital values of the coefficients. @$ The column labeld RSD should be the "Relative Standard Deviation" @$ i.e. an estimated uncertainty of the coefficients, should be less than 1.0 @$ The last column lists the model parameter where the coefficent is used @$ is a kind of shorthand, _G means an endmember parameter followed by the @$ first 4 character of the phase and then the constituents and the degree @& @$ We optimize zere times to calculate with the initial parameters opt 0 l opt short @$ The total error with the start values of the coefficients is 3745 @$ The normalized error, 748.91, is the total error divided by the @$ degrees of freedom. The temperature dependence of Cp should @$ normally increase with T. Now we optimize! @& opt 100 @& l opt short @$ The total sum of errors has decreased to 11.45, the normalized to 2.29 @$ A11 is 400.095; A12 -65.2871; A13 -0.0120393 @$ The coefficent A11 is positive and A12 is negative as one should expect. @$ The negative value of A13 indicates that Cp increases with T @$ As already mentioned there is no experimenatal data to determine H298 @$ at x(b)=.5. That value depend on the enthalpy of mixing or formation @$ relative the pure elements. @$ A normallized error around one means that we have fitted the experiments @$ on the average within the experimental uncertainty. @$ We should not attept to make this value zero! @& @$ Rescale the coefficients if they have changed a lot amend opt y l opt chort @& opt 100 l opt short @$ No change of the normalized sum of errors: 2.2907 @$ or the coefficients: 400.095; -65.2871; -0.0120393 @$ but the values of RSD are now viable. @$ If an RSD is larger than 1 that coefficient is meaningless @$ and should not not be optimized. @$ If it is less than 1 but larger than 0.1 only the first digit of the @$ coefficient is significant. For example A13 has RSD=0.318483 and @$ the coefficient has only one significant digit, i.e -0.01 @$ =============================0 @$ At an end of an assessment the RSD can be used to reduce the number @$ of digits in the published result by fixing their values @$ rounded to the significant number of digits one by one @$ starting from the coefficient with the highest RSD @$ @& @$ Save the results to take a coffee break @$ Answer Y if file already exist save unf ./opttest1 Y @& @$ ========================= @$ Back from coffee break @$ ========================= new Y @$ ****************************************************************** @$ rerun the optimization with larger experimental uncertainties for Cp @& read unf ./opttest1 l opt short @& l symb @$ Assuming the experiment of Cp are less reliable than HDIFF we can @$ increase their uncertainty of the Cp values. @& amend symb dcp 100 l symb @& @$ optimize again opt 0 l opt @& opt 100 l opt short @$ The coefficients do not change much but total sum of errors is now 4.886 @$ and the normallized 0.97723 @$ The calculated Cp values has increased and better fit to HDIFF @$ The coefficients A11 is 346.818; A12 is -56.6234; A13 is -0.0210028 @$ The RSD are 0.114988, 0.1121 and 0.232735 respectively amend opt Y opt 100 l opt short @$ Test a value, we cannot test optimizing variables ... sel eq 3 c e debug symbol hdiff 9997.8138 @$ set inter ================================================ FILE: examples/macros/opttest2-map-diagram.OCM ================================================ @$ @$ Cu-Mg phase diagram @$ Calculation and comparison to experiments @$ sel eq 1 set stat ph *=ent 0 set cond *:=none set cond t=500 p=1e5 n=1 x(mg)=0.1 calc eq set axis 1 x(mg) 0 1,, set axis 2 t 300 1500 25 c e @& map Y @& l c @$ add an extra start point set c t=1000 x(mg)=.9 c e map N @& plot append ./oc_many9 set interactive ================================================ FILE: examples/macros/opttest2-plot-cpcumg2.OCM ================================================ @$ @$ CuMg2 heat capacity @$ Calculation and comparison to experiments @$ sel eq 1 set stat ph *=sus set stat ph cumg2=e 1 set condition *:=none set condition t=1100 p=1e5 n(cu)=1 n(mg)=2 set axis 1 t 10 1500 10 @$ The phase is stoichiometric do not use grid minimizer c n step sep Y plot T cpm1 append ./oc_many2 scale y n 0 100 axis-label x T/K axis-label y Heat capacity CuMg2 (J.Mol-1.K-1) @& set inter ================================================ FILE: examples/macros/opttest2-plot-cplaves.OCM ================================================ @$ @$ Cu2Mg (C15 Laves) heat capacity @$ Calculation and comparison to experiments @$ @$ Modified to avoid creating composition sets 220808/BoS sel eq 1 set stat ph *=sus set stat ph laves=e 0 set condition *:=none set condition t=1100 p=1e5 n=1 x(mg)=.3333333 l cond c ph laves 1 N 1 1e-6 @& set axis 1 t 10 2500 10 c n l res 2 step norm Y plot T CPM2 append ./oc_many1 scale y n 0 100 axis-label x T/K axis-label y Heat capacity Cu2Mg (J.Mol-1.K-1) set interactive ================================================ FILE: examples/macros/opttest2-plot-hliq.OCM ================================================ @$ @$ Mixing enthalpy in the liquid phase @$ Calculation and comparison to experiments @$ @$ step and map is done in equilibrium 1 select eq 1 set stat phase *=sus set stat phase LIQUID=entered 0 @$ This removes all conditions set condition *:=none set condition t=1100 p=1e5 n=1 x(mg)=.5 set reference-state mg LIQUID * 1e5 set reference-state cu LIQUID * 1e5 set axis 1 x(mg) 0 1 ,,, calculate equilibrium step normal Y @& plot x(mg) HM append ./oc_many5 axis-label y Mixing enthalpy (J.mol-1) scale y n -15000 0 render @& set interactive ================================================ FILE: examples/macros/opttest2.OCM ================================================ @$ new Y @$ ================================================================ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ opttest2.OCM @$ Assessment example for the Cu-Mg system in steps @$ There are memory leaks during STEP/MAP @$ ================================================================ @$ @$ IMPORTANT: @$ Before running this macro use the command: @$ SET ADVANCED WORSPACE @$ to set the working directory to the directory with the optttest2.OCM @$ @$ This is required because the macro create oc_manyi.plt and *.OCU files @$ which are used in later submacros @$ @$ There are some error messages calculating some equilibria but @$ the final result is still reasonable @$ @$ ================================================================ @& set echo mac ./opttest2A @& mac ./opttest2B @& mac ./opttest2C @& mac ./opttest2D @& mac ./opttest2E @& mac ./opttest2F @& mac ./opttest2G set inter ================================================ FILE: examples/macros/opttest2A.OCM ================================================ @$ new Y @$ ================================================================ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ opttest2.OCM @$ Assessment example for the Cu-Mg system. @$ This macro will run also the following steps or they can be run @$ separately as each step saves the result on an UNFORMATTED file @$=================================================================== @$=================================================================== @$============== Cu-Mg assment: step 0: enter models and experimental data @$=================================================================== @$=================================================================== @& set echo @& @$---------------------------------------------------------------- @$ Enter 100 optimizing coefficient called A00 to A99 @$ This must be done ebfore using them in parameters or functions. @$ Also the dimension of workspace (can be changed) @$---------------------------------------------------------------- enter opt_coef 100 2500 @& @$---------------------------------------------------------------- @$ enter the phases and parameters @$---------------------------------------------------------------- enter element CU Cupper FCC_A1 6.3546E+01 5.0041E+03 3.3150E+01 enter element MG Magnesium HCP_A3 2.4305E+01 4.9980E+03 3.2671E+01 @$ OC requires that functions are in calling order here ent tp GHSERCU fun 298.15 -7770.458+130.485235*T-24.112392*T*LN(T) -.00265684*T**2+1.29223E-07*T**3+52478*T**(-1); 1.35777E+03 Y -13542.026+183.803828*T-31.38*T*LN(T)+3.64167E+29*T**(-9); 3.20000E+03 N ent tp GLIQCU fun 298.15 +GHSERCU +12964.735-9.511904*T -5.8489E-21*T**7; 1.35777E+03 Y -46.545+173.881484*T-31.38*T*LN(T); 3.20000E+03 N ent tp GHSERMG fun 298.15 -8367.34+143.675547*T-26.1849782*T*LN(T) +4.858E-04*T**2-1.393669E-06*T**3+78950*T**(-1); 9.23000E+02 Y -14130.185+204.716215*T-34.3088*T*LN(T)+1.038192E+28*T**(-9); 3.00000E+03 N ent tp GHCPCU fun 298.15 +GHSERCU +600+.2*T; 3.20000E+03 N ent tp GLIQMG fun 298.15 +GHSERMG +8202.243-8.83693*T -8.0176E-20*T**7; 9.23000E+02 Y -5439.869+195.324057*T-34.3088*T*LN(T); 3.00000E+03 N ent tp GFCCMG fun 298.15 +GHSERMG +2600-.9*T; 3.00000E+03 N enter phase LIQUID CEF 1 1.0 CU,MG ; enter param G(LIQUID,CU;0) 298.15 +GLIQCU ; 3.20000E+03 N 91Din enter param G(LIQUID,MG;0) 298.15 +GLIQMG ; 3.00000E+03 N 91DIN enter param G(LIQUID,CU,MG;0) 2.98150E+02 A00+A01*T; 6.00000E+03 N MYVAL enter param G(LIQUID,CU,MG;1) 2.98150E+02 A02+A03*T; 6.00000E+03 N MYVAL enter param G(LIQUID,CU,MG;2) 2.98150E+02 A04+A05*T; 6.00000E+03 N MYVAL @$ OC BUG: The coefficent for T*ln(T) sometimes disappear when plotting @$ enter phase CUMG2 @$ CEF 2 1.0 CU; 2.0 MG; @$ enter param G(CUMG2,CU:MG;0) 298.15 +A30+A31*T+A99*T*LN(T)+A32*T*LN(T)+ @$ A33*T**2+A34*T**(-1)+A35*T**3; 6.00000E+03 N MYVAL @$ Temporarily avoid the bug by entering T*LN(T) as a separate TP function @$ The bug will be fixed when I understand how it happen @$ enter TP TLNT fun 1 T*LN(T); 20000 N enter phase CUMG2 CEF 2 1.0 CU; 2.0 MG; enter param G(CUMG2,CU:MG;0) 298.15 +A30+A31*T+A32*T*LN(T)+ A33*T**2+A34*T**(-1)+A35*T**3; 6.00000E+03 N MYVAL enter phase FCC_A1 CEF 2 1.0 CU MG; 1.0 VA; amend phase FCC_A1 add magnetic -3.0 2.80000E-01 enter param G(FCC_A1,CU:VA;0) 298.15 +GHSERCU ; 3.20000E+03 N 91DIN enter param G(FCC_A1,MG:VA;0) 298.15 +GFCCMG ; 3.00000E+03 N 91DIN enter param G(FCC_A1,CU,MG:VA;0) 298.15 +A11 +A12*T; 6.00000E+03 N MYVAL enter param G(FCC_A1,CU,MG:VA;1) 298.15 +A13 +A14*T; 6.00000E+03 N MYVAL enter phase HCP_A3 CEF 2 1.0 CU MG; 0.5 VA; amend phase HCP_A3 add magnetic -3.0 2.80000E-01 enter param G(HCP_A3,CU:VA;0) 298.15 +GHCPCU ; 3.20000E+03 N 91DIN enter param G(HCP_A3,MG:VA;0) 298.15 +GHSERMG ; 3.00000E+03 N 91DIN enter param G(HCP_A3,CU,MG:VA;0) 298.15 +A21 +A22*T; 6.00000E+03 N MYVAL enter param G(HCP_A3,CU,MG:VA;1) 298.15 +A23 +A24*T; 6.00000E+03 N MYVAL enter phase LAVES_C15 CEF 2 2.0 CU MG; 1.0 CU MG; enter param G(LAVES_C15,CU:CU;0) 298.15 +45000+3*GHSERCU ; 6.00000E+03 N SL enter param G(LAVES_C15,MG:CU;0) 298.15 +104160+2*GHSERMG +GHSERCU; 6.00000E+03 N SL enter param G(LAVES_C15,CU:MG;0) 298.15 +A40+A41*T+A42*T*LN(T) +A43*T**2+A44*T**(-1)+A45*T**3; 6.00000E+03 N MYVAL enter param G(LAVES_C15,MG:MG;0) 298.15 +17700+3*GFCCMG ; 6.00000E+03 N SL enter param G(LAVES_C15,CU,MG:CU;0) 298.15 +A46 ; 6.00000E+03 N MYVAL enter param G(LAVES_C15,CU:CU,MG;0) 298.15 +A47 ; 6.00000E+03 N MYVAL enter param G(LAVES_C15,MG:CU,MG;0) 298.15 +A47 ; 6.00000E+03 N MYVAL enter param G(LAVES_C15,CU,MG:MG;0) 298.15 +A46 ; 6.00000E+03 N MYVAL amend bib 91DIN A Dinsdale Calphad 1991; amend bib SL M H F Sluiter Calphad 2006; amend bib MYVAL My assessed value; @& l data @& @$------------------------------------------------------------------------ @$ Now the experimental data converted from a POP file @$ created by Nathalie Dupin, Malin Selleby and Christine Gueneau. @$ The equilibria with experiments can be identified by a number (assigned @$ sequentially) or a name (max 24 characters). @$ A range of numbers or an abbreviations of the name can be used to select @$ which equilibria should be involved by setting its weight. @$ Equilibria with zero weight will be ignored. @$------------------------------------------------------------------------ @$ @& @$ NOTE a ; or an empty line following is needed enter symbol P0=101325; @$ ========================================== enter equilibrium EQ_1_CP15 YES set status phase *=sus set status PHASE LAVES_C15=ENT 1 set cond P=P0 T=298.15 N(MG)=1 N(CU)=2 @$ These are special symbols for "dot derivatives". Cp is the T derivative of H enter symbol CPM2=HM(LAVES).T; enter symbol CPM1=HM(CUMG2).T; @$ experiments have an uncertainty after a colon ":" enter experiment CPM2=24.4 : .1 @$ we cannot enter plot_data before the first "enter many_equilibria" @$ enter plot_data 1 298.15 24.4 8 Feufel enter comment C15 - CP 298 - FEUFEL @$ This is a single equilibrium with experimental data @& @$================================= enter many_equilibria ENT 1 LAVES_C15 condition P=P0 T=@1 N(MG)=1 N(CU)=2 experiment CPM2=@2 :.1 comment FEUFEL C15 - CP DSC plot_data 1 @1 @2 8 Feufel @$ The plot_data command saves the whole line @$ (after plot_data) on a file @$ that will be opened inside the many_equilibria @$ command. The first number is a dataset number, @$ can be 1 to 9 and data for the same dataset @$ will be saved on the same file oc_manyj.plt where @$ j is the dataset number. The next two numbers @$ are coordinates, the last number, 1-15, a plot symbol. @$ Finally a text reference can be given @$ The oc_manyj.plt data can be plotted as is but @$ will be nicer after they have some editing @& table_start EQ_T1_2_CP15_F 100 17 EQ_T1_3_CP15_F 343 24.90 EQ_T1_4_CP15_F 363 25.24 EQ_T1_5_CP15_F 383 25.37 EQ_T1_6_CP15_F 403 25.44 EQ_T1_7_CP15_F 423 25.50 EQ_T1_8_CP15_F 443 25.60 EQ_T1_9_CP15_F 463 25.64 EQ_T1_10_CP15_F 483 25.74 EQ_T1_11_CP15_F 503 25.82 EQ_T1_12_CP15_F 523 25.83 EQ_T1_13_CP15_F 543 25.87 EQ_T1_14_CP15_F 563 25.94 EQ_T1_15_CP15_F 583 26.03 EQ_T1_16_CP15_F 603 26.18 EQ_T1_17_CP15_F 623 26.23 EQ_T1_18_CP15_F 643 26.31 EQ_T1_19_CP15_F 663 26.39 EQ_T1_20_CP15_F 683 26.64 EQ_T1_21_CP15_F 703 26.75 EQ_T1_22_CP15_F 723 26.95 EQ_T1_23_CP15_F 743 27.47 EQ_T1_24_CP15_F 763 27.43 table_end @$ @& @$================================= enter many_equilibria ENT 1 LAVES_C15 condition P=P0 T=@2 N(MG)=1 N(CU)=2 experiment CPM2=@3: .1 comment C15 - PHONON CALC - CRIVELLO plot_data 1 @2 @3 2 Crivello table_start EQ_T2_30_CP15_P 30 20 0.72162 EQ_T2_31_CP15_P 31 30 2.1669 EQ_T2_32_CP15_P 32 40 4.3074 EQ_T2_33_CP15_P 33 50 6.7287 EQ_T2_34_CP15_P 34 60 9.11073 EQ_T2_35_CP15_P 35 70 11.28642 EQ_T2_36_CP15_P 36 80 13.19342 EQ_T2_37_CP15_P 37 90 14.82796 EQ_T2_38_CP15_P 38 100 16.21377 EQ_T2_39_CP15_P 39 110 17.3842 EQ_T2_40_CP15_P 40 120 18.3733 EQ_T2_41_CP15_P 41 130 19.21185 EQ_T2_42_CP15_P 42 140 19.9262 EQ_T2_43_CP15_P 43 150 20.53826 EQ_T2_44_CP15_P 44 160 21.06597 EQ_T2_45_CP15_P 45 170 21.52387 EQ_T2_46_CP15_P 46 180 21.9238 EQ_T2_47_CP15_P 47 190 22.27536 EQ_T2_48_CP15_P 48 200 22.58634 EQ_T2_49_CP15_P 49 210 22.8631 EQ_T2_50_CP15_P 50 220 23.11088 EQ_T2_51_CP15_P 51 230 23.33401 EQ_T2_52_CP15_P 52 240 23.53603 EQ_T2_53_CP15_P 53 250 23.71991 EQ_T2_54_CP15_P 54 260 23.88818 EQ_T2_55_CP15_P 55 270 24.04287 EQ_T2_56_CP15_P 56 280 24.18579 EQ_T2_57_CP15_P 57 290 24.31843 EQ_T2_58_CP15_P 58 300 24.44204 EQ_T2_59_CP15_P 59 310 24.55777 EQ_T2_60_CP15_P 60 320 24.66653 EQ_T2_61_CP15_P 61 330 24.7691 EQ_T2_62_CP15_P 62 340 24.86624 EQ_T2_63_CP15_P 63 350 24.95854 EQ_T2_64_CP15_P 64 360 25.04652 EQ_T2_65_CP15_P 65 370 25.13065 EQ_T2_66_CP15_P 66 380 25.2114 EQ_T2_67_CP15_P 67 390 25.28911 EQ_T2_68_CP15_P 68 400 25.36401 EQ_T2_69_CP15_P 69 410 25.43645 EQ_T2_70_CP15_P 70 420 25.50675 EQ_T2_71_CP15_P 71 430 25.57505 EQ_T2_72_CP15_P 72 440 25.64156 EQ_T2_73_CP15_P 73 450 25.70655 EQ_T2_74_CP15_P 74 460 25.77003 EQ_T2_75_CP15_P 75 470 25.83227 EQ_T2_76_CP15_P 76 480 25.89344 EQ_T2_77_CP15_P 77 490 25.95348 EQ_T2_78_CP15_P 78 500 26.01259 EQ_T2_79_CP15_P 79 510 26.07098 EQ_T2_80_CP15_P 80 520 26.12865 EQ_T2_81_CP15_P 81 530 26.18561 EQ_T2_82_CP15_P 82 540 26.24207 EQ_T2_83_CP15_P 83 550 26.29805 EQ_T2_84_CP15_P 84 560 26.35354 EQ_T2_85_CP15_P 85 570 26.4087 EQ_T2_86_CP15_P 86 580 26.46352 EQ_T2_87_CP15_P 87 590 26.5182 EQ_T2_88_CP15_P 88 600 26.57262 EQ_T2_89_CP15_P 89 610 26.62678 EQ_T2_90_CP15_P 90 620 26.68089 EQ_T2_91_CP15_P 91 630 26.73492 EQ_T2_92_CP15_P 92 640 26.7889 EQ_T2_93_CP15_P 93 650 26.84285 EQ_T2_94_CP15_P 94 660 26.89681 EQ_T2_95_CP15_P 95 670 26.95088 EQ_T2_96_CP15_P 96 680 27.005 EQ_T2_97_CP15_P 97 690 27.05915 EQ_T2_98_CP15_P 98 700 27.11354 EQ_T2_99_CP15_P 99 710 27.16812 EQ_T2_100_CP15_P 100 720 27.22276 EQ_T2_101_CP15_P 101 730 27.27771 EQ_T2_102_CP15_P 102 740 27.33283 EQ_T2_103_CP15_P 103 750 27.38814 EQ_T2_104_CP15_P 104 760 27.44385 EQ_T2_105_CP15_P 105 770 27.49973 EQ_T2_106_CP15_P 106 780 27.55588 EQ_T2_107_CP15_P 107 790 27.6125 EQ_T2_108_CP15_P 108 800 27.66953 EQ_T2_109_CP15_P 109 810 27.72683 EQ_T2_110_CP15_P 110 820 27.78436 EQ_T2_111_CP15_P 111 830 27.84238 EQ_T2_112_CP15_P 112 840 27.9009 EQ_T2_113_CP15_P 113 850 27.95975 EQ_T2_114_CP15_P 114 860 28.01896 EQ_T2_115_CP15_P 115 870 28.07876 EQ_T2_116_CP15_P 116 880 28.13917 EQ_T2_117_CP15_P 117 890 28.19976 EQ_T2_118_CP15_P 118 900 28.26095 EQ_T2_119_CP15_P 119 910 28.32291 EQ_T2_120_CP15_P 120 920 28.38519 EQ_T2_121_CP15_P 121 930 28.44783 EQ_T2_122_CP15_P 122 940 28.51116 EQ_T2_123_CP15_P 123 950 28.57536 EQ_T2_124_CP15_P 124 960 28.63981 EQ_T2_125_CP15_P 125 970 28.70504 EQ_T2_126_CP15_P 126 980 28.77107 EQ_T2_127_CP15_P 127 990 28.8372 EQ_T2_128_CP15_P 128 1000 28.90433 EQ_T2_129_CP15_P 129 1500 33.47658 table_end @$ @$================================= enter many_equilibria ENT 1 CUMG2 condition P=P0 T=@1 N(MG)=2 N(CU)=1 experiment CPM1=@2:.1 comment CUMG2 - CP - FEUFEL plot_data 2 @1 @2 8 Feufel table_start EQ_T3_130_CP2 100 12 EQ_T3_131_CP2 298.15 24.12 EQ_T3_132_CP2 343 24.81 EQ_T3_133_CP2 363 25.02 EQ_T3_134_CP2 383 25.24 EQ_T3_135_CP2 403 25.33 EQ_T3_136_CP2 423 25.49 EQ_T3_137_CP2 443 25.60 EQ_T3_138_CP2 463 25.70 EQ_T3_139_CP2 483 25.81 EQ_T3_140_CP2 503 25.89 EQ_T3_141_CP2 523 25.98 EQ_T3_142_CP2 543 26.04 EQ_T3_143_CP2 563 26.17 EQ_T3_144_CP2 583 26.27 EQ_T3_145_CP2 603 26.40 EQ_T3_146_CP2 623 26.49 EQ_T3_147_CP2 643 26.59 EQ_T3_148_CP2 663 26.69 EQ_T3_149_CP2 683 26.81 EQ_T3_150_CP2 703 26.96 EQ_T3_151_CP2 723 27.13 EQ_T3_152_CP2 743 27.47 EQ_T3_153_CP2 763 27.76 table_end @$ @$================================= enter many_equilibria ENT 1 LIQ condition P=P0 N=1 T=@3 X(MG)=@4 reference MG LIQ * 1E5 @$ experiment MUR(MG)=@2:20% experiment MU(MG)=@2:20% comment LIQ - MG PRESS - SCHMAHL AND SIEBEN plot_data 4 @4 @2 7 Schmahl table_start EQ_T4_190_MUL_S 190 -83 865 .936 EQ_T4_191_MUL_S 191 -385 895 .936 EQ_T4_192_MUL_S 192 -685 925 .936 EQ_T4_193_MUL_S 193 -687 940 .936 EQ_T4_194_MUL_S 194 -952 872 .857 EQ_T4_195_MUL_S 195 -1255 902 .857 EQ_T4_196_MUL_S 196 -1485 922 .857 EQ_T4_197_MUL_S 197 -1488 941 .857 EQ_T4_198_MUL_S 198 -2079 881 .765 EQ_T4_199_MUL_S 199 -2286 901 .765 EQ_T4_200_MUL_S 200 -2494 921 .765 EQ_T4_201_MUL_S 201 -2550 960 .765 EQ_T4_202_MUL_S 202 -4384 891 .667 EQ_T4_203_MUL_S 203 -4600 911 .667 EQ_T4_204_MUL_S 204 -4758 931 .667 EQ_T4_205_MUL_S 205 -4793 966 .667 EQ_T4_206_MUL_S 206 -7762 925 .581 EQ_T4_207_MUL_S 207 -7958 1005 .581 EQ_T4_208_MUL_S 208 -8980 942 .521 EQ_T4_209_MUL_S 209 -9259 1052 .521 EQ_T4_210_MUL_S 210 -21123 1096 .330 EQ_T4_211_MUL_S 211 -30969 1118 .224 EQ_T4_212_MUL_S 212 -31495 1198 .224 table_end @$ @$================================= enter many_equilibria ENT 1 LIQ condition P=P0 N=1 X(MG)=@6 T=@2 reference MG LIQ * 1E5 @$ experiment ACR(MG)=@5:16% experiment AC(MG)=@5:16% comment LIQ - MG PRESSURE - JUNEJA plot_data 3 @6 @5 8 Juneja table_start EQ_T5_220_MUL_J 220 1056 9.4698 -0.0466 0.8982 0.9005 -943 EQ_T5_221_MUL_J 221 1032 9.6927 -0.0471 0.8972 0.9005 -931 EQ_T5_222_MUL_J 222 1018 9.8254 -0.0474 0.8966 0.9005 -924 EQ_T5_223_MUL_J 223 1010 9.9028 -0.0476 0.8962 0.9005 -920 EQ_T5_224_MUL_J 224 990 10.1019 -0.048 0.8953 0.9005 -910 EQ_T5_225_MUL_J 225 979 10.2125 -0.0483 0.8948 0.9005 -905 EQ_T5_226_MUL_J 226 1052 9.5102 -0.1367 0.7299 0.7652 -2754 EQ_T5_227_MUL_J 227 1039 9.6208 -0.1377 0.7283 0.7652 -2739 EQ_T5_228_MUL_J 228 1036 9.654 -0.138 0.7278 0.7652 -2737 EQ_T5_229_MUL_J 229 1018 9.8254 -0.1395 0.7253 0.7652 -2718 EQ_T5_230_MUL_J 230 995 10.0521 -0.1415 0.722 0.7652 -2695 EQ_T5_231_MUL_J 231 989 10.1074 -0.1419 0.7212 0.7652 -2687 EQ_T5_232_MUL_J 232 976 10.2457 -0.1431 0.7192 0.7652 -2675 EQ_T5_233_MUL_J 233 957 10.4503 -0.1449 0.7163 0.7652 -2655 EQ_T5_234_MUL_J 234 1073 9.3222 -0.2433 0.5711 0.6728 -4997 EQ_T5_235_MUL_J 235 1050 9.5268 -0.2471 0.5661 0.6728 -4967 EQ_T5_236_MUL_J 236 1038 9.6319 -0.2491 0.5636 0.6728 -4948 EQ_T5_237_MUL_J 237 1009 9.9084 -0.2542 0.5569 0.6728 -4911 EQ_T5_238_MUL_J 238 980 10.2015 -0.2596 0.55 0.6728 -4871 EQ_T5_239_MUL_J 239 1122 8.913 -0.5165 0.3044 0.5053 -11095 EQ_T5_240_MUL_J 240 1089 9.1839 -0.5295 0.2954 0.5053 -11041 EQ_T5_241_MUL_J 241 1086 9.2116 -0.5309 0.2945 0.5053 -11038 EQ_T5_242_MUL_J 242 1041 9.6042 -0.5498 0.282 0.5053 -10956 EQ_T5_243_MUL_J 243 1025 9.7591 -0.5572 0.2772 0.5053 -10934 EQ_T5_244_MUL_J 244 1005 9.9471 -0.5663 0.2715 0.5053 -10894 EQ_T5_245_MUL_J 245 1150 8.6973 -0.7575 0.1748 0.4449 -16676 EQ_T5_246_MUL_J 246 1119 8.9351 -0.7728 0.1687 0.4449 -16557 EQ_T5_247_MUL_J 247 1103 9.0623 -0.781 0.1656 0.4449 -16490 EQ_T5_248_MUL_J 248 1063 9.4107 -0.8035 0.1572 0.4449 -16352 EQ_T5_249_MUL_J 249 1143 8.7471 -1.0032 0.0993 0.3704 -21948 EQ_T5_250_MUL_J 250 1132 8.8355 -1.0108 0.0976 0.3704 -21899 EQ_T5_251_MUL_J 251 1105 9.0512 -1.0292 0.0935 0.3704 -21771 EQ_T5_252_MUL_J 252 1082 9.2448 -1.0457 0.09 0.3704 -21661 EQ_T5_253_MUL_J 253 1235 8.0945 -1.1301 0.0741 0.3007 -26720 EQ_T5_254_MUL_J 254 1216 8.2217 -1.1435 0.0719 0.3007 -26614 EQ_T5_255_MUL_J 255 1188 8.4153 -1.1638 0.0686 0.3007 -26465 EQ_T5_256_MUL_J 256 1145 8.736 -1.1974 0.0635 0.3007 -26243 EQ_T5_257_MUL_J 257 1137 8.7968 -1.2038 0.0625 0.3007 -26209 EQ_T5_258_MUL_J 258 1122 8.913 -1.216 0.0608 0.3007 -26121 EQ_T5_259_MUL_J 259 1101 9.0789 -1.2334 0.0584 0.3007 -26001 EQ_T5_260_MUL_J 260 1229 8.1388 -1.4613 0.0346 0.2366 -34372 EQ_T5_261_MUL_J 261 1218 8.2106 -1.4704 0.0339 0.2366 -34271 EQ_T5_262_MUL_J 262 1209 8.2715 -1.4782 0.0332 0.2366 -34228 EQ_T5_263_MUL_J 263 1185 8.4374 -1.4994 0.0317 0.2366 -34004 EQ_T5_264_MUL_J 264 1156 8.6475 -1.5263 0.0298 0.2366 -33766 EQ_T5_265_MUL_J 265 1246 8.0226 -1.6589 0.0219 0.1729 -39585 EQ_T5_266_MUL_J 266 1227 8.1498 -1.6783 0.021 0.1729 -39410 EQ_T5_267_MUL_J 267 1203 8.3102 -1.7026 0.0198 0.1729 -39228 EQ_T5_268_MUL_J 268 1185 8.4374 -1.7219 0.019 0.1729 -39047 EQ_T5_269_MUL_J 268 1171 8.5369 -1.7371 0.0183 0.1729 -38951 table_end @$ @$================================= enter many_equilibria ENT 1 LIQ condition P=P0 N=1 T=@3 X(MG)=@2 reference MG LIQ * 1E5 @$ experiment ACR(MG)=@6:20% experiment AC(MG)=@6:20% comment LIQ - MG PRESSURE - GARG plot_data 3 @2 @6 9 Garg table_start EQ_T6_270_ACL_G 270 0.11 1173 8.52514919 -2.1844 0.0065 -49053.0 EQ_T6_271_ACL_G 271 0.11 1200 8.333333333 -2.1543 0.0070 -49490.3 EQ_T6_272_ACL_G 272 0.11 1300 7.692307692 -2.0536 0.0088 -51109.8 EQ_T6_273_ACL_G 273 0.11 1342 7.451564829 -2.0159 0.0096 -51790.0 EQ_T6_274_ACL_G 274 0.18 1148 8.710801394 -1.7634 0.0172 -38753.7 EQ_T6_275_ACL_G 275 0.18 1232 8.116883117 -1.6820 0.0208 -39670.3 EQ_T6_276_ACL_G 276 0.22 1013 9.871668312 -1.6637 0.0217 -32263.4 EQ_T6_277_ACL_G 277 0.22 1100 9.090909091 -1.5645 0.0273 -32946.3 EQ_T6_278_ACL_G 278 0.22 1221 8.19000819 -1.4501 0.0355 -33896.0 EQ_T6_279_ACL_G 279 0.29 1073 9.319664492 -1.2135 0.0612 -24926.4 EQ_T6_280_ACL_G 280 0.29 1100 9.090909091 -1.1881 0.0648 -25018.9 EQ_T6_281_ACL_G 281 0.29 1188 8.417508418 -1.1133 0.0770 -25320.4 EQ_T6_282_ACL_G 282 0.37 1085 9.216589862 -0.8874 0.1296 -18432.3 EQ_T6_283_ACL_G 283 0.37 1100 9.090909091 -0.8767 0.1328 -18462.2 EQ_T6_284_ACL_G 284 0.37 1139 8.779631255 -0.8503 0.1412 -18539.8 EQ_T6_285_ACL_G 285 0.42 1048 9.541984733 -0.7958 0.1600 -15966.9 EQ_T6_286_ACL_G 286 0.42 1100 9.090909091 -0.7652 0.1717 -16113.2 EQ_T6_287_ACL_G 287 0.5 1049 9.532888465 -0.6406 0.2288 -12863.9 EQ_T6_288_ACL_G 288 0.5 1100 9.090909091 -0.6194 0.2402 -13042.6 EQ_T6_289_ACL_G 289 0.66 845 11.83431953 -0.3770 0.4197 -6098.9 EQ_T6_290_ACL_G 290 0.66 900 11.11111111 -0.3597 0.4369 -6196.8 EQ_T6_291_ACL_G 291 0.66 1022 9.784735812 -0.3278 0.4701 -6414.0 EQ_T6_292_ACL_G 292 0.76 913 10.95290252 -0.1985 0.6332 -3469.1 EQ_T6_293_ACL_G 293 0.76 1003 9.970089731 -0.1877 0.6491 -3603.5 EQ_T6_294_ACL_G 294 0.9 892 11.21076233 -0.0718 0.8475 -1226.8 EQ_T6_295_ACL_G 295 0.9 1003 9.970089731 -0.0669 0.8573 -1284.2 table_end @$ @$================================= enter many_equilibria ENT 1 CUMG2,LAVES condition P=P0 N=1 X(MG)=.5 T=@2 reference MG HCP * 1E5 @$ experiment MUR(MG)=@6:20% experiment MU(MG)=@6:20% comment C15+CUMG2 - MG PRESSURE - SMITH plot_data 4 @2 @6 7 Smith table_start EQ_T7_300_MU2 AC2 675 -6.4800 3.3113E-07 0.0786 -14276 EQ_T7_301_MU2 AC2 725 -5.6800 2.0893E-06 0.0839 -14937 EQ_T7_302_MU2 AC2 775 -4.9832 1.0394E-05 0.0889 -15597 EQ_T7_303_MU2 AC2 825 -4.3709 4.2569E-05 0.0935 -16258 EQ_T7_304_MU2 AC2 875 -3.8286 1.4840E-04 0.0977 -16918 table_end @$ @$================================= enter many_equilibria ENT 1 FCC,LAVES condition P=P0 N=1 X(MG)=.2 T=@2 reference MG HCP * 1E5 @$ experiment MUR(MG)=@6:20% experiment MU(MG)=@6:20% comment CU+C15 - MG PRESSURE - SMITH plot_data 4 @2 @6 7 Smith table_start EQ_T8_310_MUF2 AF2 751 -6.3515 4.4514E-07 0.0078 -30310 EQ_T8_311_MUF2 AF2 801 -5.6417 2.2821E-06 0.0094 -31066 EQ_T8_312_MUF2 AF2 851 -5.0153 9.6549E-06 0.0111 -31822 EQ_T8_313_MUF2 AF2 901 -4.4584 3.4805E-05 0.0129 -32579 table_end @$ @$================================= enter many_equilibria ENT 1 @2,@3 condition P=P0 N=1 T=@6 X(MG)=@9 reference MG HCP * 1E5 @$ experiment MUR(MG)=@4:@5 experiment MU(MG)=@4:@5 plot_data 4 @6 @4 8 Eremenko comment EMF - EREMENKO table_start EQ_T9_320_MU3 AFC FCC_A1 L_C15 -34373 1050 723 .0400 .333300 .2 EQ_T9_321_MU3 AFC FCC_A1 L_C15 -34078 1050 873 .0550 .333300 .2 EQ_T9_322_MU2 AC2 L_C15 CUMG2 -5638 840 823 .3333 .666667 .5 EQ_T9_323_MU2 AC2 L_C15 CUMG2 -5977 840 723 .3333 .666667 .5 table_end @$ @$================================= enter many_equilibria ENT 1 LIQUID condition P=P0 N=1 T=1100 X(MG)=@3 reference CU LIQUID * 1E5 reference MG LIQUID * 1E5 @$ experiment HMR=@2:5% experiment HM=@2:5% comment BATALIN LIQ - CALO - plot_data 5 @3 @2 2 Batalin table_start EQ_T10_330_HLIQ_B 330 -3.7240E3 1.0222E-01 EQ_T10_331_HLIQ_B 331 -5.9639E3 2.0807E-01 EQ_T10_332_HLIQ_B 332 -7.0270E3 3.0134E-01 EQ_T10_333_HLIQ_B 333 -7.5960E3 4.0118E-01 EQ_T10_334_HLIQ_B 334 -7.8558E3 5.0111E-01 EQ_T10_335_HLIQ_B 335 -7.5589E3 6.0119E-01 EQ_T10_336_HLIQ_B 336 -6.5816E3 7.0146E-01 EQ_T10_337_HLIQ_B 337 -4.9239E3 8.0190E-01 EQ_T10_338_HLIQ_B 338 -2.8333E3 9.0246E-01 table_end @$ @$================================= enter many_equilibria ENT 1 LIQUID condition P=P0 N=1 T=1100 X(MG)=@2 reference CU LIQUID * 1E5 reference MG LIQUID * 1E5 @$ experiment HMR=@3:5% experiment HM=@3:5% comment HULTGREN LIQ - CALO - plot_data 5 @2 @3 8 Hultgren table_start EQ_T11_340_HLIQ_H 340 1.9481E-01 -7.3231E3 EQ_T11_341_HLIQ_H 341 3.0398E-01 -9.1922E3 EQ_T11_342_HLIQ_H 342 3.9729E-01 -1.0070E4 EQ_T11_343_HLIQ_H 343 4.9084E-01 -1.0081E4 EQ_T11_344_HLIQ_H 344 5.9750E-01 -9.2904E3 EQ_T11_345_HLIQ_H 345 7.0753E-01 -8.0051E3 EQ_T11_346_HLIQ_H 346 8.0478E-01 -6.2233E3 EQ_T11_347_HLIQ_H 347 8.9570E-01 -4.0077E3 table_end @$ @$================================= enter many_equilibria ENT 1 LIQUID condition P=P0 N=1 T=1120 X(CU)=@3 reference CU LIQUID * 1E5 reference MG LIQUID * 1E5 @$ experiment HMR=@2:5% experiment HM=@2:5% comment SOMMER LIQ - CALO - plot_data 5 @4 @2 3 Sommer table_start EQ_T12_350_HLIQ_S 350 -1900 .075 .925 EQ_T12_351_HLIQ_S 351 -3200 .13 .87 EQ_T12_352_HLIQ_S 352 -3500 .15 .85 EQ_T12_353_HLIQ_S 353 -4800 .21 .79 EQ_T12_354_HLIQ_S 354 -5600 .245 .755 EQ_T12_355_HLIQ_S 355 -5800 .27 .73 EQ_T12_356_HLIQ_S 356 -7000 .33 .67 EQ_T12_357_HLIQ_S 357 -6600 .33 .67 EQ_T12_358_HLIQ_S 358 -7500 .38 .62 EQ_T12_359_HLIQ_S 359 -7900 .425 .575 EQ_T12_360_HLIQ_S 360 -8100 .43 .57 EQ_T12_361_HLIQ_S 361 -8400 .47 .53 EQ_T12_362_HLIQ_S 362 -8300 .475 .525 EQ_T12_363_HLIQ_S 363 -8700 .505 .495 EQ_T12_364_HLIQ_S 364 -8600 .515 .485 EQ_T12_365_HLIQ_S 365 -8500 .52 .48 EQ_T12_366_HLIQ_S 366 -8900 .54 .46 EQ_T12_367_HLIQ_S 367 -8900 .54 .46 EQ_T12_368_HLIQ_S 368 -8500 .565 .435 EQ_T12_369_HLIQ_S 369 -9000 .59 .41 EQ_T12_370_HLIQ_S 370 -8900 .61 .39 EQ_T12_371_HLIQ_S 371 -8950 .635 .365 EQ_T12_372_HLIQ_S 372 -8850 .65 .35 EQ_T12_373_HLIQ_S 373 -8800 .67 .33 EQ_T12_374_HLIQ_S 374 -8650 .685 .315 EQ_T12_375_HLIQ_S 375 -8550 .7 .3 table_end @$ ========================================== enter equilibrium EQ_400_HC15_K YES set status phase *=sus set status PHASE LAVES_C15=ENT 1 set cond P=P0 T=299 N(CU)=2 N(MG)=1 set reference_state CU FCC_A1 * 1E5 set reference_state MG HCP_A3 * 1E5 @$ enter experiment HMR=-11171.3:420 enter experiment HM=-11171.3:420 enter plot_data 6 .33 -11171.3 7 King enter comment C15 - CALORIMETRY - KING @$ ========================================== enter equilibrium EQ_401_HCUMG2_K YES set status phase *=sus set status PHASE CUMG2=ENT 1 set cond P=P0 T=299 N(MG)=2 N(CU)=1 set reference_state CU FCC_A1 * 1E5 set reference_state MG HCP_A3 * 1E5 @$ enter experiment HMR=-9539.5:420 enter experiment HM=-9539.5:420 enter plot_data 6 .67 -9539.5 7 King enter comment CUMG2 - CALORIMETRY - KING @$ ========================================== enter equilibrium EQ_402_HC15_F YES set status phase *=sus set status PHASE LAVES_C15=ENT 1 set cond P=P0 T=299 N(MG)=1 N(CU)=2 set reference_state CU FCC_A1 * 1E5 set reference_state MG HCP_A3 * 1E5 @$ enter experiment HMR=-12700:2000 enter experiment HM=-12700:2000 enter plot_data 6 .33 -12700 8 Feufel enter comment C15 - SOLUTION CALORIMETRY - FEUFEL @$ ========================================== enter equilibrium EQ_403_HCUMG2_F YES set status phase *=sus set status PHASE CUMG2=ENT 1 set cond P=P0 T=299 N(MG)=2 N(CU)=1 set reference_state CU FCC_A1 * 1E5 set reference_state MG HCP_A3 * 1E5 @$ enter experiment HMR=-9800:1800 enter experiment HM=-9800:1800 enter plot_data 6 .67 -9800 8 Feufel enter comment CUMG2 - SOLUTION CALORIMETRY - FEUFEL enter symbol HFUS=HM(LIQUID)-HM; @$ ========================================== enter equilibrium EQ_410_HTC15 YES set status phase *=sus set status PHASE LIQUID=FIX 0 set status PHASE L_C15=ENT 1 set cond P=P0 N(MG)=1 N(CU)=2 enter experiment HFUS=15200:1500 enter plot_data 7 .33 15200 8 Feufel enter comment C15 - MELTING ENTHALPY - FEUFEL 95 @$ ========================================== enter equilibrium EQ_411_HTCUMG2 YES set status phase *=sus set status PHASE LIQUID=FIX 0 set status PHASE CUMG2=FIX 1 set cond P=P0 X(LIQ,MG)-X(CUMG2,MG)=0 enter experiment HFUS=13700:1400 enter plot_data 7 .67 13700:1400 8 Feufel enter comment CUMG2 - MELTING ENTHALPY - FEUFEL 95 @$ ========================================== enter equilibrium EQ_470_HC15_C YES set status phase *=sus set status PHASE LAVES_C15=ENT 1 set cond P=P0 T=298.15 N(MG)=1 N(CU)=2 set reference_state CU FCC_A1 * 1E5 set reference_state MG HCP_A3 * 1E5 @$ enter experiment HMR=-14369:1000 enter experiment HM=-14369:1000 enter plot_data 6 0.333333 -14369 10 12Cur enter comment C15 - DFT FORMATION H - 12CUR @$ ========================================== enter equilibrium EQ_471_HCUMG2_C YES set status phase *=sus set status PHASE CUMG2=ENT 1 set cond P=P0 T=298.15 N(CU)=1 N(MG)=2 set reference_state CU FCC_A1 * 1E5 set reference_state MG HCP_A3 * 1E5 @$ enter experiment HMR=-10700:1000 enter experiment HM=-10700:1000 enter plot_data 6 0.6666667 -10700 10 12Cur enter comment CUMG2 - DFT FORMATION H - 12CUR @$ ========================================== enter equilibrium EQ_472_HC15_Z YES set status phase *=sus set status PHASE LAVES_C15=ENT 1 set cond P=P0 T=298.15 N(MG)=1 N(CU)=2 set reference_state CU FCC_A1 * 1E5 set reference_state MG HCP_A3 * 1E5 @$ enter experiment HMR=-15720:1000 enter experiment HM=-15720:1000 enter plot_data 6 0.3333333 -15720 6 07Zho enter comment C15 - DFT FORMATION H - 07ZHO @$ ========================================== enter equilibrium EQ_473_HCUMG2_Z YES set status phase *=sus set status PHASE CUMG2=ENT 1 set cond P=P0 T=298.15 N(CU)=1 N(MG)=2 set reference_state CU FCC_A1 * 1E5 set reference_state MG HCP_A3 * 1E5 @$ enter experiment HMR=-13200:1000 enter experiment HM=-13200:1000 enter comment CUMG2 - DFT FORMATION H - 07ZHO enter plot_data 6 0.66666667 -13200 6 07Zho @$ @$================================= enter many_equilibria ENT 1 @3 condition P=P0 N=1 T=298.15 X(MG)=@4 reference CU @3 * 1E5 reference MG @3 * 1E5 @$ experiment HMR=@5:500 experiment HM=@5:500 plot_data @7 @4 @5 @6 07Shi comment @3 - SQS - 07SHI table_start EQ_T13_480_HFSQS_S 480 AFS FCC_A1 0.25 1580 2 8 EQ_T13_481_HFSQS_S 481 AFS FCC_A1 0.5 8070 2 8 EQ_T13_482_HFSQS_S 482 AFS FCC_A1 0.75 6980 2 8 EQ_T13_483_HHSQS_S 483 AHS HCP_A3 0.25 1120 2 8 EQ_T13_484_HHSQS_S 484 AHS HCP_A3 0.5 5650 2 8 EQ_T13_485_HHSQS_S 485 AHS HCP_A3 0.75 5810 2 8 table_end @$ ========================================== enter equilibrium EQ_486_HSSQS_W YES set status phase *=sus set status PHASE FCC_A1=FIX 1 set cond P=P0,T=298.15,X(MG)=0.5 set reference_state CU FCC_A1 * 1E5 set reference_state MG FCC_A1 * 1E5 @$ enter experiment HMR=-2600:500 enter experiment HM=-2600:500 enter plot_data 8 0.5 -2600 3 07Wol enter comment FCC_A1 - SQS - 07WOL @$ @$================================= @$ BOSSE: CHANGED FIX PHASE, eq 504 strange and removed enter many_equilibria ENT 1 LIQ FIX 0 @3 condition P=P0 N=1 X(LIQ,MG)=@4 experiment T=@5:5 comment LIQUIDUS @7 plot_data 9 @4 @5 7 @7 table_start EQ_T14_501_XLIQ_F 501 ALF FCC_A1 0.026 1338 9 08SAH EQ_T14_502_XLIQ_F 502 ALF FCC_A1 0.075 1263 9 08SAH EQ_T14_503_XLIQ_F 503 ALF FCC_A1 0.132 1174 9 08SAH @$ EQ_T14_504_XLIQ_F 504 ALF FCC_A1,L_C15 0.223 1009 9 08SAH EQ_T14_505_XLIQ_C 505 ALC L_C15 0.283 1062 9 08SAH EQ_T14_506_XLIQ_C 506 ALC L_C15 0.339 1070 9 08SAH EQ_T14_507_XLIQ_C 507 ALC L_C15 0.351 1070 9 08SAH EQ_T14_508_XLIQ_C 508 ALC L_C15 0.366 1065 9 08SAH EQ_T14_509_XLIQ_C 509 ALC L_C15 0.425 1064 9 08SAH EQ_T14_510_XLIQ_C 510 ALC L_C15 0.462 1049 9 08SAH EQ_T14_511_XLIQ_C 511 ALC L_C15 0.468 1051 9 08SAH EQ_T14_512_XLIQ_C 512 ALC L_C15 0.547 878 9 08SAH EQ_T14_513_XLIQ_C 513 ALC CUMG2 0.616 837 9 08SAH EQ_T14_514_XLIQ_C 514 ALC CUMG2 0.638 846 9 08SAH EQ_T14_515_XLIQ_C 515 ALC CUMG2 0.643 840 9 08SAH EQ_T14_516_XLIQ_2 516 AL2 CUMG2 0.655 844 9 08SAH EQ_T14_517_XLIQ_2 517 AL2 CUMG2 0.668 841 9 08SAH EQ_T14_518_XLIQ_2 518 AL2 CUMG2 0.672 846 9 08SAH EQ_T14_519_XLIQ_2 519 AL2 CUMG2 0.681 840 9 08SAH EQ_T14_520_XLIQ_2 520 AL2 CUMG2 0.724 833 9 08SAH EQ_T14_521_XLIQ_2 521 AL2 CUMG2 0.796 783 9 08SAH EQ_T14_522_XLIQ_H 522 ALH HCP_A3 0.920 823 9 08SAH EQ_T14_523_XLIQ_H 523 ALH HCP_A3 0.980 890 9 08SAH table_end @$ @$================================= enter many_equilibria ENT 1 LIQ FIX 0 @3 condition P=P0 N=1 X(LIQ,MG)=@4 experiment T=@5:5 comment LIQUIDUS @7 plot_data 9 @4 @5 8 @7 table_start EQ_T15_530_XLIQ_H 530 ALH HCP_A3 0.999988522 920.45 2 31JON EQ_T15_531_XLIQ_H 531 ALH HCP_A3 0.999973217 920.15 2 31JON EQ_T15_532_XLIQ_H 532 ALH HCP_A3 0.999908164 921.15 2 31JON EQ_T15_533_XLIQ_H 533 ALH HCP_A3 0.999881373 920.15 2 31JON EQ_T15_534_XLIQ_H 534 ALH HCP_A3 0.999843097 919.15 2 31JON EQ_T15_535_XLIQ_H 535 ALH HCP_A3 0.998984465 919.15 2 31JON EQ_T15_536_XLIQ_H 536 ALH HCP_A3 0.997961745 919.15 2 31JON EQ_T15_537_XLIQ_H 537 ALH HCP_A3 0.995188155 918.15 2 31JON EQ_T15_538_XLIQ_H 538 ALH HCP_A3 0.993501152 919.15 2 31JON EQ_T15_539_XLIQ_H 539 ALH HCP_A3 0.992926354 916.65 2 31JON EQ_T15_540_XLIQ_H 540 ALH HCP_A3 0.990245739 915.15 2 31JON EQ_T15_541_XLIQ_H 541 ALH HCP_A3 0.988861134 913.15 2 31JON EQ_T15_542_XLIQ_H 542 ALH HCP_A3 0.976614827 903.15 2 31JON EQ_T15_543_XLIQ_H 543 ALH HCP_A3 0.965379917 892.15 2 31JON EQ_T15_544_XLIQ_H 544 ALH HCP_A3 0.954980318 881.65 2 31JON EQ_T15_545_XLIQ_H 545 ALH HCP_A3 0.936288656 861.15 2 31JON EQ_T15_546_XLIQ_H 546 ALH HCP_A3 0.932310502 858.65 2 31JON EQ_T15_547_XLIQ_H 547 ALH HCP_A3 0.929569307 853.15 2 31JON EQ_T15_548_XLIQ_H 548 ALH HCP_A3 0.907484295 829.15 2 31JON EQ_T15_549_XLIQ_H 549 ALH HCP_A3 0.888068531 804.15 2 31JON EQ_T15_550_XLIQ_H 550 ALH HCP_A3 0.875924532 787.15 2 31JON EQ_T15_551_XLIQ_H 551 ALH HCP_A3 0.862229041 769.15 2 31JON EQ_T15_552_XLIQ_2 552 AL2 CUMG2 0.858552878 762.15 2 31JON EQ_T15_553_XLIQ_2 553 AL2 CUMG2 0.846831335 764.15 2 31JON EQ_T15_554_XLIQ_2 554 AL2 CUMG2 0.842221712 768.15 2 31JON EQ_T15_555_XLIQ_2 555 AL2 CUMG2 0.841739635 767.15 2 31JON EQ_T15_556_XLIQ_2 556 AL2 CUMG2 0.832897191 773.15 2 31JON EQ_T15_557_XLIQ_2 557 AL2 CUMG2 0.815949094 785.15 2 31JON EQ_T15_558_XLIQ_2 558 AL2 CUMG2 0.802468294 791.65 2 31JON EQ_T15_559_XLIQ_2 559 AL2 CUMG2 0.793793729 799.15 2 31JON EQ_T15_560_XLIQ_2 560 AL2 CUMG2 0.78389036 804.15 2 31JON EQ_T15_561_XLIQ_2 561 AL2 CUMG2 0.780606398 805.65 2 31JON EQ_T15_562_XLIQ_2 562 AL2 CUMG2 0.773960441 813.15 2 31JON EQ_T15_563_XLIQ_2 563 AL2 CUMG2 0.772389773 811.15 2 31JON EQ_T15_564_XLIQ_2 564 AL2 CUMG2 0.764885119 816.15 2 31JON EQ_T15_565_XLIQ_2 565 AL2 CUMG2 0.750072965 824.15 2 31JON EQ_T15_566_XLIQ_2 566 AL2 CUMG2 0.739626826 829.15 2 31JON EQ_T15_567_XLIQ_2 567 AL2 CUMG2 0.732548319 833.15 2 31JON EQ_T15_568_XLIQ_2 568 AL2 CUMG2 0.731291959 831.15 2 31JON EQ_T15_569_XLIQ_2 569 AL2 CUMG2 0.719661136 835.15 2 31JON EQ_T15_570_XLIQ_2 570 AL2 CUMG2 0.710283223 837.65 2 31JON EQ_T15_571_XLIQ_2 571 AL2 CUMG2 0.70372695 838.15 2 31JON EQ_T15_572_XLIQ_2 572 AL2 CUMG2 0.680499863 840.15 2 31JON EQ_T15_573_XLIQ_2 573 AL2 CUMG2 0.671897202 839.65 2 31JON EQ_T15_574_XLIQ_2 574 AL2 CUMG2 0.668934483 840.15 2 31JON EQ_T15_575_XLIQ_2 575 AL2 CUMG2 0.667039454 840.65 2 31JON EQ_T15_576_XLIQ_2 576 AL2 CUMG2 0.666315549 840.65 2 31JON EQ_T15_577_XLIQ_2 577 AL2 CUMG2 0.651882892 840.15 2 31JON EQ_T15_578_XLIQ_2 578 AL2 CUMG2 0.65150947 840.15 2 31JON EQ_T15_579_XLIQ_2 579 AL2 CUMG2 0.645873363 839.65 2 31JON EQ_T15_580_XLIQ_2 580 AL2 CUMG2 0.643695418 840.15 2 31JON EQ_T15_581_XLIQ_2 581 AL2 CUMG2 0.643505571 840.15 2 31JON EQ_T15_582_XLIQ_2 582 AL2 CUMG2 0.640935388 840.15 2 31JON EQ_T15_583_XLIQ_2 583 AL2 CUMG2 0.628564323 837.15 2 31JON EQ_T15_584_XLIQ_2 584 AL2 CUMG2 0.622954123 835.15 2 31JON EQ_T15_585_XLIQ_2 585 AL2 CUMG2 0.618679657 836.15 2 31JON EQ_T15_586_XLIQ_2 586 AL2 CUMG2 0.610628824 834.15 2 31JON EQ_T15_587_XLIQ_2 587 AL2 CUMG2 0.592452931 829.15 2 31JON EQ_T15_588_XLIQ_2 588 AL2 CUMG2 0.580218717 825.15 2 31JON EQ_T15_589_XLIQ_C 589 ALC L_C15 0.579895663 825.15 2 31JON EQ_T15_590_XLIQ_C 590 ALC L_C15 0.569011059 841.15 2 31JON EQ_T15_591_XLIQ_C 591 ALC L_C15 0.567358682 843.15 2 31JON EQ_T15_592_XLIQ_C 592 ALC L_C15 0.561701517 853.15 2 31JON EQ_T15_593_XLIQ_C 593 ALC L_C15 0.545394958 877.15 2 31JON EQ_T15_594_XLIQ_C 594 ALC L_C15 0.534711099 892.15 2 31JON EQ_T15_595_XLIQ_C 595 ALC L_C15 0.515007836 921.15 2 31JON EQ_T15_596_XLIQ_C 596 ALC L_C15 0.494197213 954.65 2 31JON EQ_T15_597_XLIQ_C 597 ALC L_C15 0.483495071 965.15 2 31JON EQ_T15_598_XLIQ_C 598 ALC L_C15 0.479623384 970.15 2 31JON EQ_T15_599_XLIQ_C 599 ALC L_C15 0.469827734 982.15 2 31JON EQ_T15_600_XLIQ_C 600 ALC L_C15 0.459862291 999.15 2 31JON EQ_T15_601_XLIQ_C 601 ALC L_C15 0.458117356 997.65 2 31JON EQ_T15_602_XLIQ_C 602 ALC L_C15 0.453664234 1000.15 2 31JON EQ_T15_603_XLIQ_C 603 ALC L_C15 0.436900467 1025.15 2 31JON EQ_T15_604_XLIQ_C 604 ALC L_C15 0.434945874 1027.15 2 31JON EQ_T15_605_XLIQ_C 605 ALC L_C15 0.433125101 1034.15 2 31JON EQ_T15_606_XLIQ_C 606 ALC L_C15 0.426495355 1037.65 2 31JON EQ_T15_607_XLIQ_C 607 ALC L_C15 0.42677898 1043.65 2 31JON EQ_T15_608_XLIQ_C 608 ALC L_C15 0.424079079 1041.15 2 31JON EQ_T15_609_XLIQ_C 609 ALC L_C15 0.41170404 1058.15 2 31JON EQ_T15_610_XLIQ_C 610 ALC L_C15 0.40791216 1060.15 2 31JON EQ_T15_611_XLIQ_C 611 ALC L_C15 0.405566839 1063.15 2 31JON EQ_T15_612_XLIQ_C 612 ALC L_C15 0.402622391 1062.15 2 31JON EQ_T15_613_XLIQ_C 613 ALC L_C15 0.394750088 1066.15 2 31JON EQ_T15_614_XLIQ_C 614 ALC L_C15 0.39160263 1069.15 2 31JON EQ_T15_615_XLIQ_C 615 ALC L_C15 0.384347345 1073.15 2 31JON EQ_T15_616_XLIQ_C 616 ALC L_C15 0.374230206 1081.15 2 31JON EQ_T15_617_XLIQ_C 617 ALC L_C15 0.366454694 1083.65 2 31JON EQ_T15_618_XLIQ_C 618 ALC L_C15 0.354448192 1089.15 2 31JON EQ_T15_619_XLIQ_C 619 ALC L_C15 0.345453039 1091.15 2 31JON EQ_T15_620_XLIQ_C 620 ALC L_C15 0.327905307 1093.15 2 31JON EQ_T15_621_XLIQ_C 621 ALC L_C15 0.325239723 1089.15 2 31JON EQ_T15_622_XLIQ_C 622 ALC L_C15 0.322563115 1081.15 2 31JON EQ_T15_623_XLIQ_C 623 ALC L_C15 0.309354522 1073.15 2 31JON EQ_T15_624_XLIQ_C 624 ALC L_C15 0.300571712 1069.15 2 31JON EQ_T15_625_XLIQ_C 625 ALC L_C15 0.297269508 1065.15 2 31JON EQ_T15_626_XLIQ_C 626 ALC L_C15 0.289910903 1061.15 2 31JON EQ_T15_627_XLIQ_C 627 ALC L_C15 0.281756937 1052.15 2 31JON EQ_T15_628_XLIQ_C 628 ALC L_C15 0.26879151 1045.15 2 31JON EQ_T15_629_XLIQ_C 629 ALC L_C15 0.263681279 1035.15 2 31JON EQ_T15_630_XLIQ_C 630 ALC L_C15 0.248490703 1026.65 2 31JON EQ_T15_631_XLIQ_C 631 ALC L_C15 0.219022491 1007.15 2 31JON EQ_T15_632_XLIQ_C 632 ALC L_C15 0.218044486 995.15 2 31JON EQ_T15_633_XLIQ_F 633 ALF FCC_A1 0.182109202 1074.15 2 31JON EQ_T15_634_XLIQ_F 634 ALF FCC_A1 0.161855238 1118.15 2 31JON EQ_T15_635_XLIQ_F 635 ALF FCC_A1 0.149254262 1131.15 2 31JON EQ_T15_636_XLIQ_F 636 ALF FCC_A1 0.137528714 1153.15 2 31JON EQ_T15_637_XLIQ_F 637 ALF FCC_A1 0.098210146 1231.15 2 31JON EQ_T15_638_XLIQ_F 638 ALF FCC_A1 0.087292384 1241.15 2 31JON EQ_T15_639_XLIQ_F 639 ALF FCC_A1 0.065702085 1278.15 2 31JON EQ_T15_640_XLIQ_F 640 ALF FCC_A1 0.056748638 1283.15 2 31JON EQ_T15_641_XLIQ_F 641 ALF FCC_A1 0.038279491 1315.15 2 31JON EQ_T15_642_XLIQ_F 642 ALF FCC_A1 0.043247143 1303.15 2 31JON table_end @$ @$================================= enter many_equilibria ENT 1 LIQ FIX 0 @3 condition P=P0 N=1 X(LIQ,MG)=@4 experiment T=@5:5 comment LIQUIDUS @7 plot_data 9 @4 @5 2 @7 table_start EQ_T16_650_XLIQ_C 650 ALC L_C15 0.29042 1056.11423 2 78BAG EQ_T16_651_XLIQ_C 651 ALC L_C15 0.30246 1062.70164 2 78BAG EQ_T16_652_XLIQ_C 652 ALC L_C15 0.31664 1066.7251 2 78BAG EQ_T16_653_XLIQ_C 653 ALC L_C15 0.32455 1068.30283 2 78BAG EQ_T16_654_XLIQ_C 654 ALC L_C15 0.33098 1069.057 2 78BAG EQ_T16_655_XLIQ_C 655 ALC L_C15 0.33955 1065.55796 2 78BAG EQ_T16_656_XLIQ_C 656 ALC L_C15 0.34894 1062.8919 2 78BAG EQ_T16_657_XLIQ_C 657 ALC L_C15 0.35718 1058.5529 2 78BAG EQ_T16_658_XLIQ_C 658 ALC L_C15 0.36806 1049.95383 2 78BAG table_end @$ @$================================= enter many_equilibria ENT 1 LIQ FIX 0 @3 condition P=P0 N=1 X(LIQ,MG)=@4 experiment T=@5:5 comment LIQUIDUS @7 plot_data 9 @4 @5 6 @7 table_start EQ_T17_659_XLIQ_F 659 ALF FCC_A1 0.008 1348.15 6 07URA EQ_T17_660_XLIQ_F 660 ALF FCC_A1 0.0515 1289.15 6 07URA EQ_T17_661_XLIQ_F 661 ALF FCC_A1 0.1 1221.15 6 07URA EQ_T17_662_XLIQ_F 662 ALF FCC_A1 0.1252 1171.15 6 07URA EQ_T17_663_XLIQ_F 663 ALF FCC_A1 0.143 1134.15 6 07URA EQ_T17_664_XLIQ_F 664 ALF FCC_A1 0.155 1091.15 6 07URA EQ_T17_665_XLIQ_F 665 ALF FCC_A1 0.175 1064.15 6 07URA EQ_T17_666_XLIQ_F 666 ALF FCC_A1 0.1898 1047.15 6 07URA EQ_T17_667_XLIQ_F 667 ALF FCC_A1 0.202 1021.15 6 07URA EQ_T17_668_XLIQ_F 668 ALF FCC_A1 0.22 998.15 6 07URA EQ_T17_669_XLIQ_C 669 ALC L_C15 0.225 1001.15 6 07URA EQ_T17_670_XLIQ_C 670 ALC L_C15 0.23 1008.15 6 07URA EQ_T17_671_XLIQ_C 671 ALC L_C15 0.232 1013.15 6 07URA EQ_T17_672_XLIQ_C 672 ALC L_C15 0.27 1038.15 6 07URA EQ_T17_673_XLIQ_C 673 ALC L_C15 0.269 1044.15 6 07URA EQ_T17_674_XLIQ_C 674 ALC L_C15 0.275 1050.15 6 07URA EQ_T17_675_XLIQ_C 675 ALC L_C15 0.28 1052.15 6 07URA EQ_T17_676_XLIQ_C 676 ALC L_C15 0.2875 1055.15 6 07URA EQ_T17_677_XLIQ_C 677 ALC L_C15 0.3 1059.15 6 07URA EQ_T17_678_XLIQ_C 678 ALC L_C15 0.316 1066.15 6 07URA EQ_T17_679_XLIQ_C 679 ALC L_C15 0.32 1068.15 6 07URA EQ_T17_680_XLIQ_C 680 ALC L_C15 0.33 1069.15 6 07URA EQ_T17_681_XLIQ_C 681 ALC L_C15 0.3307 1070.15 6 07URA EQ_T17_682_XLIQ_C 682 ALC L_C15 0.334 1072.15 6 07URA EQ_T17_683_XLIQ_C 683 ALC L_C15 0.34 1072.15 6 07URA EQ_T17_684_XLIQ_C 684 ALC L_C15 0.346 1071.15 6 07URA EQ_T17_685_XLIQ_C 685 ALC L_C15 0.3505 1069.15 6 07URA EQ_T17_686_XLIQ_C 686 ALC L_C15 0.3583 1067.15 6 07URA EQ_T17_687_XLIQ_C 687 ALC L_C15 0.3832 1067.15 6 07URA EQ_T17_688_XLIQ_C 688 ALC L_C15 0.3913 1065.15 6 07URA EQ_T17_689_XLIQ_C 689 ALC L_C15 0.395 1059.15 6 07URA EQ_T17_690_XLIQ_C 690 ALC L_C15 0.4 1060.15 6 07URA EQ_T17_691_XLIQ_C 691 ALC L_C15 0.41 1052.15 6 07URA EQ_T17_692_XLIQ_C 692 ALC L_C15 0.425 1051.15 6 07URA EQ_T17_693_XLIQ_C 693 ALC L_C15 0.4375 1036.15 6 07URA EQ_T17_694_XLIQ_C 694 ALC L_C15 0.4437 1035.15 6 07URA EQ_T17_695_XLIQ_C 695 ALC L_C15 0.475 1021.15 6 07URA EQ_T17_696_XLIQ_C 696 ALC L_C15 0.49 998.15 6 07URA EQ_T17_697_XLIQ_C 697 ALC L_C15 0.4927 998.15 6 07URA EQ_T17_698_XLIQ_C 698 ALC L_C15 0.4963 994.15 6 07URA EQ_T17_699_XLIQ_C 699 ALC L_C15 0.5062 980.15 6 07URA EQ_T17_700_XLIQ_C 700 ALC L_C15 0.51 978.15 6 07URA EQ_T17_701_XLIQ_C 701 ALC L_C15 0.5414 945.15 6 07URA EQ_T17_702_XLIQ_C 702 ALC L_C15 0.519 934.15 6 07URA EQ_T17_703_XLIQ_C 703 ALC L_C15 0.552 933.15 6 07URA EQ_T17_704_XLIQ_C 704 ALC L_C15 0.5581 919.15 6 07URA EQ_T17_705_XLIQ_C 705 ALC L_C15 0.5635 897.15 6 07URA EQ_T17_706_XLIQ_C 706 ALC L_C15 0.569 888.15 6 07URA EQ_T17_707_XLIQ_C 707 ALC L_C15 0.5742 873.15 6 07URA EQ_T17_708_XLIQ_C 708 ALC L_C15 0.585 828.15 6 07URA EQ_T17_709_XLIQ_2 709 AL2 CUMG2 0.5955 830.15 6 07URA EQ_T17_710_XLIQ_2 710 AL2 CUMG2 0.6077 835.15 6 07URA EQ_T17_711_XLIQ_2 711 AL2 CUMG2 0.622 837.15 6 07URA EQ_T17_712_XLIQ_2 712 AL2 CUMG2 0.6282 838.15 6 07URA EQ_T17_713_XLIQ_2 713 AL2 CUMG2 0.6328 839.15 6 07URA EQ_T17_714_XLIQ_2 714 AL2 CUMG2 0.6597 841.15 6 07URA EQ_T17_715_XLIQ_2 715 AL2 CUMG2 0.6614 842.15 6 07URA EQ_T17_716_XLIQ_2 716 AL2 CUMG2 0.667 843.15 6 07URA EQ_T17_717_XLIQ_2 717 AL2 CUMG2 0.6795 842.15 6 07URA EQ_T17_718_XLIQ_2 718 AL2 CUMG2 0.681 842.15 6 07URA EQ_T17_719_XLIQ_2 719 AL2 CUMG2 0.6918 841.15 6 07URA EQ_T17_720_XLIQ_2 720 AL2 CUMG2 0.706 839.15 6 07URA EQ_T17_721_XLIQ_2 721 AL2 CUMG2 0.7147 838.15 6 07URA EQ_T17_722_XLIQ_2 722 AL2 CUMG2 0.7915 795.15 6 07URA EQ_T17_723_XLIQ_2 723 AL2 CUMG2 0.83 767.15 6 07URA EQ_T17_724_XLIQ_2 724 AL2 CUMG2 0.84 753.15 6 07URA EQ_T17_725_XLIQ_H 725 ALH HCP_A3 0.8552 773.15 6 07URA EQ_T17_726_XLIQ_H 726 ALH HCP_A3 0.8805 803.15 6 07URA EQ_T17_727_XLIQ_H 727 ALH HCP_A3 0.936 753.15 6 07URA EQ_T17_728_XLIQ_H 728 ALH HCP_A3 0.9615 884.15 6 07URA EQ_T17_729_XLIQ_H 729 ALH HCP_A3 0.9679 895.15 6 07URA EQ_T17_730_XLIQ_H 730 ALH HCP_A3 0.9833 907.15 6 07URA EQ_T17_731_XLIQ_H 731 ALH HCP_A3 0.988 912.15 6 07URA EQ_T17_732_XLIQ_H 732 ALH HCP_A3 0.99 914.15 6 07URA table_end @$ ========================================== enter equilibrium EQ_800_ALCF_AEUT YES set status phase *=sus set status PHASE LIQUID =FIX 0 set status PHASE FCC_A1 L_C15=ENT 1 set cond P=P0 N=1 X(MG)=.2 enter experiment T=995.15:5 enter experiment X(LIQ,MG)=0.219:0.01 enter plot_data 9 .219 995 8 31Jon enter comment CU+C15 EUTECTIC - 31JON @$ ========================================== enter equilibrium EQ_801_ALCF_AEUT YES set status phase *=sus set status PHASE LIQUID =FIX 0 set status PHASE FCC_A1 L_C15=ENT 1 set cond P=P0 N=1 X(MG)=.2 enter experiment T=998.15:5 enter comment CU+C15 EUTECTIC - 78BAG @$ ========================================== enter equilibrium EQ_802_ALC2_AEUT YES set status phase *=sus set status PHASE LIQUID =FIX 0 set status PHASE L_C15 CUMG2=FIX 1 set cond P=P0 enter experiment T=825.15:5 enter experiment X(LIQ,MG)=0.580:0.01 enter plot_data 9 .580 825 8 31Jon enter comment C15+CUMG2 EUTECTIC - 31JON @$ ========================================== enter equilibrium EQ_803_ALC2_AEUT YES set status phase *=sus set status PHASE LIQUID=FIX 0 set status PHASE L_C15 CUMG2=ENT 1 set cond P=P0 N=1 X(MG)=.4 enter experiment T=825.15:5 enter comment C15+CUMG2 EUTECTIC - 78BAG @$ ========================================== enter equilibrium EQ_804_ALCH_AEUT YES set status phase *=sus set status PHASE LIQUID=FIX 0 set status PHASE CUMG2 HCP_A3=ENT 1 set cond P=P0 N=1 X(MG)=.8 enter experiment T= 758.15:5 enter experiment X(LIQ,MG)=0.855:0.01 enter plot_data 9 .855 758 8 31Jon enter comment CUM2+MG EUTECTIC - 31JON @$ ========================================== enter equilibrium EQ_805_CMELT YES set status phase *=sus set status PHASE LIQUID = ENT 1 set status PHASE L_C15=FIX 0 set cond P=P0 N=1 set cond X(LIQUID,MG)-X(L_C15,MG)=0 enter experiment T=1093.15:5 enter experiment X(MG)=.33333:.01 enter plot_data 9 .333 1093 8 31Jon enter comment C15 - CONGRUENT MELTING - 31JON @$ ========================================== enter equilibrium EQ_806_CMELT YES set status phase *=sus set status PHASE LIQUID = ENT 1 set status PHASE L_C15=FIX 0 set cond P=P0 N=1 set cond X(LIQUID,MG)-X(L_C15,MG)=0 enter experiment T=1066.15:5 enter experiment X(MG)=.33333:.01 enter plot_data 9 .333 1066 12 78Bag enter comment C15 - CONGRUENT MELTING - 78BAG @$ ========================================== enter equilibrium EQ_807_MELT2 YES set status phase *=sus set status PHASE LIQUID CUMG2=FIX 1 set cond P=P0 set cond X(LIQUID,MG)-X(CUMG2,MG)=0 enter experiment T=840.15:5 enter plot_data 9 .667 840 8 31Jon enter comment CUMG2 - CONGRUENT MELTING - 31JON @$ ========================================== enter equilibrium EQ_808_MELT2 YES set status phase *=sus set status PHASE LIQUID CUMG2=FIX 1 set cond P=P0 set cond X(LIQUID,MG)-X(CUMG2,MG)=0 enter experiment T=841.15:5 enter plot_data 9 .667 841 12 78Bag enter comment CUMG2 - CONGRUENT MELTING - 78BAG @$ @$================================= enter many_equilibria ENT 1 @3 FIX 0 @4 condition P=P0 N=1 X(MG)=@9 T=@6 experiment X(L_C15,MG)=@5:0.001 plot_data 9 @5 @6 12 @8 comment C15 HOMOGENEITY RANGE @8 table_start EQ_T18_901_RC15 901 ACF L_C15 FCC_A1 0.32632 572.281 2 78BAG .2 EQ_T18_902_RC15 902 ACF L_C15 FCC_A1 0.32595 668.01 2 78BAG .2 EQ_T18_903_RC15 903 ACF L_C15 FCC_A1 0.3247 771.64 2 78BAG .2 EQ_T18_904_RC15 904 ACF L_C15 FCC_A1 0.3223 812.226 2 78BAG .2 EQ_T18_905_RC15 905 ACF L_C15 FCC_A1 0.31903 867.469 2 78BAG .2 EQ_T18_906_RC15 906 ACF L_C15 FCC_A1 0.31598 918.203 2 78BAG .2 EQ_T18_907_RC15 907 ACF L_C15 FCC_A1 0.3103 989.257 2 78BAG .2 EQ_T18_908_RINT 908 AC2 L_C15 CUMG2 0.33581 573.229 2 78BAG .5 EQ_T18_909_RINT 909 AC2 L_C15 CUMG2 0.3372 667.799 2 78BAG .5 EQ_T18_910_RINT 910 AC2 L_C15 CUMG2 0.34477 771.263 2 78BAG .5 EQ_T18_911_RINT 911 AC2 L_C15 CUMG2 0.35054 812.822 2 78BAG .5 table_end @$ @$================================= enter many_equilibria ENT 1 @3,@4 condition P=P0 N=1 T=@6 X(MG)=.2 experiment X(@3,MG)=@5:0.001 comment CU SOLVUS @8 plot_data 9 @5 @6 @7 @8 table_start EQ_T19_921_XFCC 921 AFC FCC_A1 L_C15 0.07 990.15 12 78BAG EQ_T19_922_XFCC 922 AFC FCC_A1 L_C15 0.0553 773.15 8 31JON EQ_T19_923_XFCC 923 AFC FCC_A1 L_C15 0.0553 873.15 8 31JON EQ_T19_924_XFCC 924 AFC FCC_A1 L_C15 0.0616 953.15 8 31JON EQ_T19_925_XFCC 925 AFC FCC_A1 L_C15 0.0655 973.15 8 31JON EQ_T19_926_XFCC 926 AFC FCC_A1 L_C15 0.0669 995.15 8 31JON EQ_T19_927_XFCC 927 AFC FCC_A1 L_C15 0.0231 573.15 5 57ROG EQ_T19_928_XFCC 928 AFC FCC_A1 L_C15 0.033 673.15 5 57ROG EQ_T19_929_XFCC 929 AFC FCC_A1 L_C15 0.0445 773.15 5 57ROG EQ_T19_930_XFCC 930 AFC FCC_A1 L_C15 0.0579 873.15 5 57ROG EQ_T19_931_XFCC 931 AFC FCC_A1 L_C15 0.0748 973.15 5 57ROG EQ_T19_932_XFCC 932 AFC FCC_A1 L_C15 0.083 995.15 5 57ROG table_end @$ @$================================= enter many_equilibria ENT 1 @3,@4 condition P=P0 N=1 X(MG)=.8 T=@6 experiment X(HCP_A3,MG)=@5:0.001 comment MG SOLVUS @8 plot_data 9 @5 @6 @7 @8 table_start EQ_T20_941_XHCP 941 AH2 HCP_A3 CUMG2 0.99993 298.15 8 31JON EQ_T20_942_XHCP 942 AH2 HCP_A3 CUMG2 0.99989 738.15 8 31JON EQ_T20_943_XHCP 943 AH2 HCP_A3 CUMG2 0.99988 753.15 8 31JON EQ_T20_944_XHCP 944 AH2 HCP_A3 CUMG2 0.99987 758.15 8 31JON EQ_T20_945_XHCP 945 AH2 HCP_A3 CUMG2 0.99962 298 10 27HAN EQ_T20_946_XHCP 946 AH2 HCP_A3 CUMG2 0.9983 758.15 10 27HAN EQ_T20_947_XHCP 947 AH2 HCP_A3 CUMG2 0.99885 673.15 7 35STE EQ_T20_948_XHCP 948 AH2 HCP_A3 CUMG2 0.99789 753.15 7 35STE table_end @$ =========================== @$-------------------------------------------------------------- @$ Now we have entered all experimental equilibria @$-------------------------------------------------------------- @& @$ A blank line after this command means the last equilibrium is the end set range 2 @$-------------------------------------------------------------- @$ The command above defines the range of equilibria for assessment @$ We will later use the command "calculate all" which will @$ calculate all equilibra withing this range that have nonzero weight. @$ The default for last equilibrium is the current @$ @$ The range command also closes all "plot_data" files with a correct @$ termination for the GNUPLOT software. @$-------------------------------------------------------------- @& @$ list the symbols entered l sym @& @$ set the weight to zero for all experiments set wei 0 * @& l eq @$ listing of all equilibria @& save unf ./opttest2-cumg1 Y @$----------------------------------------------------------------- @$ The save command can be used to save all data and results on an @$ unformatted file. This can be read back into the program and @$ calculations can continue from the point where the save was mande. @$ This is an important feature to "freeze" different versions @$ not to loose results. @$ It is also a way to save the current status when taking a coffee break. @$ @$ Note that axis and calculated diagrams are not saved @$----------------------------------------------------------------- @& @$ Please read the text above carefully!! @$----------------------------------------------------------------- @& @$ Check the phase diagram with all parameters zero !! mac ./opttest2-map-diagram set inter ================================================ FILE: examples/macros/opttest2B.OCM ================================================ @$=================================================================== @$=================================================================== @$===================== Cu-Mg assment: step 1: fit Hmix in liquid @$=================================================================== @$=================================================================== @$ new Y @$----------------------------------------------------------------- @$ The new command removes all data @$----------------------------------------------------------------- set echo read unf ./opttest2-cumg1 @$----------------------------------------------------------------- @$ Here we read back the data from the save command. @$----------------------------------------------------------------- @& list active @$ All experiments have weight zero @& set wei 1 ACL set wei 1 HLIQ set wei 0 HLIQ_B set wei 0 HLIQ_H list active @$ Now we have selected data for the liquid @& @$----------------------------------------------------------------- @$ Here we Select experiments with H for liquid from Sommer and Garg @$ using abbreviations of the names of the equilibria @$----------------------------------------------------------------- @& @$ Calculate all non-zero experiments calc all n @$----------------------------------------------------------------- @$ The "calculate all" command calculates all equilibra in the range @$ given previously with non-zero weight. We do not use the grid @$ minimizer as all equilibria are for a single phase (liquid). @$ There is a listing of all calculated equilibria and in this @$ list the first colimn is the (sequentially assigned) equilibrium @$ number, then the first 12 characters of the quilibrium name (which is @$ 24 characters long) then T and then a list of stable phases at each @$ equilibrium. @$----------------------------------------------------------------- @& @$ List the model for the liquid l ph liq data @& @$ Select the T-independent regular parameter of the liquid to be @$ optimized. You must set a non-zero start value!! set opt_var 0 1 list opt @$------------------------------------------------------------------------ @$ Note that the rightmost column "Used in" give the names of TP functions @$ where this coefficient is used. @$ For coefficients used directly in model parameters the TP function name @$ start with an underscore, then a letter indentifying the type of property, @$ G means a Gibbs energy, then 6 max letters from the phase name and after @$ the constituent in order oof sublattices but with all special characters @$ like , or : removed. At the end the degree, 0-9. @$ The name is maximum 16 characters so it may be truncated. @$ But it is anyway useful in order to remember in phase the parameter is @$ associated with. @$ Calculation of RSD (Relative Standard Deviation) is not yet implemented. @$------------------------------------------------------------------------ @& @$ Optimize just one parameter opt 100 @$------------------------------------------------------------------------ @$ The optimize command requires a maximum numer of iterations. @$ It lists at regular intervals the sum of errors squared @$ and the current values of the model parameters. @$ At the end the final and initial sum of squares @$------------------------------------------------------------------------ @& @$ List the result list opt @$------------------------------------------------------------------------ @$ This lists the final value of the model parameters and for @$ each experiment with non-zero weight the data and error. @$ The list may be long and you may have to scroll bacwards @$ to see all experiments. @$------------------------------------------------------------------------ @& @$ The optimizing coefficients are also TP sysmbols l tp @& @$ Plot the enthalpy of mixing in the liquid macro ./opttest2-plot-hliq @& @$ ----------------------------------------------- @$ Now vary also the subregular T-independent parameter set opt_var 2 1 opt 100 @& l opt @$ ------------------------------------------------------- @$ With two parameters the sum of errors decreased @$ ------------------------------------------------------- @& @$ We can also list just the coefficients l opt coef @& @$ And plot the new fit to the experiments. macro ./opttest2-plot-hliq @& @$ ----------------------------------------------- @$ Vary the T-dependent regular parameter @$ ----------------------------------------------- set opt_var 1 0.1 @& opt 100 l opt coef @$ It may now be intersting to have correct RSD amend opt y opt 100 l opt coef @$ The RSD values reflect the number of significant digits of @$ the coefficients, if RSD is around 0.1 the coeffcient @$ as only one significant digit. @$ If 0.1>RSD>.001 there are two significant digits and so on @& macro ./opttest2-plot-hliq @& @$ We can plot the phase diagram with the new liquid parameters macro ./opttest2-map-diagram @$----------------------------------------------------------- @$ The liquid is now very stable down to low T @$ because we have not fitted any other parameters @$----------------------------------------------------------- @& @$----------------------------------------------------------- @$ Now we can make a break but before save the current results @$ Fix the liquid parameters set opt_fix 0-3 @$ Remove all equilibria created by STEP/MAP delete step_map save unf ./opttest2-cumg2 Y set inter ================================================ FILE: examples/macros/opttest2C.OCM ================================================ @$================================================================ @$================================================================ @$===== STEP 2 Fit Cp for the CuMg2 compound @$================================================================ @$================================================================ @& new Y set echo read unf ./opttest2-cumg2 @$ ---------------------------------------------------- @$ As before we start by reading the unformatted file with previous results @$ ---------------------------------------------------- @& set wei 0 * set wei 1 CP2 list active @& @$ ---------------------------------------------------- @$ These commands set the weight of all equilibria to zero @$ and then set the weight of those equilibria with "CP2" in the name @$ to unity. @$ ---------------------------------------------------- @& @$ List assessed coefficients l opt coef @& @$ list the parameters for the CuMg2 phase l ph cumg2 data @$ Optimize the coefficent in front of T*ln(T) (constant Cp) set opt_var 32 -10 calc all N 1 @& @$ make a "dry run" to have the initial error @$ NOTE important to give "N" for no gridmin and "1" to calculate once opt 0 @& @$ When runing this at the end of the "all.OCM" macro the values of CP @$ are all crazy and total sum of error "Infiniy" meaning the assessment fails @$ When running it by itslf no problem @$ Evidently some variable is not intitiated correctly after the "all" macro sel eq 126 c n l,,,, @& opt 100 @& l opt @& macro ./opttest2-plot-cpcumg2 @$ ----------------------------------------------- @$ The plot of the Cp is linear as we have just one parameter. @$ ----------------------------------------------- @& @$ Now add linear T dependence, set a small value set opt_var 33 .01 opt 100 @& l opt @& macro ./opttest2-plot-cpcumg2 @$ ----------------------------------------------- @$ The Cp in the plot has now a small slope in T @$ ----------------------------------------------- @& @$ Which more parameters can we vary? l ph cumg2 data @& @$ Add more coefficients for T**(-1) and T**2 set opt_var 34 1000 set opt_var 35 0.001 opt 100 @& l opt @& @$ To obtain the RSD values amend opt-coef y opt 100 l opt short @$ @& macro ./opttest2-plot-cpcumg2 @$ ----------------------------------------------- @$ The plot of the Cp is now reasonable in the range 300-2000 K @$ ----------------------------------------------- @& @$ ----------------------------------------------- @$ we have finished this step, set variables fix and save set opt_fix 32-35 l opt @& @$ remove all selected experimental equilibria set wei 0 * @& @$ Delete equilibria created during STEP/MAP del step_map save unf ./opttest2-cumg3 Y @$---------------------------------------------------- @$ We can now take a coffee break @$---------------------------------------------------- set inter ================================================ FILE: examples/macros/opttest2D.OCM ================================================ @$=================================================================== @$=================================================================== @$======= step 3: fit H formation of CuMg2 compound @$=================================================================== @$=================================================================== set echo new Y r u ./opttest2-cumg3 @$--------------------------------------------------- @$ Start by reading the unformatted file @$ and list previous results @$--------------------------------------------------- @& l ph cumg2 data l opt coef @& set wei 0 * set wei 1 HCUMG2_K list active @& @$--------------------------------------------------- @$ First set the weight of all experimenatal equilibria to zero @$ and then set the equilibrium with the enthalpy of @$ formation of the CuMg2 compoint to unity. @$ Optimize the T-independent coefficient for the CuMg2 phase @$--------------------------------------------------- @& set opt_var 30 1 opt 100 @& l opt @& macro ./opttest2-map-diagram @$--------------------------------------------------------- @$ The CuMg2 phase is stable to very high T, add the entropy @$ of formation (the linear T dependent term) @$ to destabilize CuMg2 @$ Use the experimental equilibrium for the congruent melting point @$--------------------------------------------------------- l ph cumg2 data set opt_var 31 1 @& set wei 1 MELT2 c all n 1 @$ Sometimes error calculating the melting points, equilibria 547 and 547 @& @$ Check conditions sel eq 547 l,,,, @& @$ Instead of calculating with both phases fix we can set CuMG2 as dormant @$ and T=840 as condition and the driving force of CUMG2=0 as experiment set status phase cumg=dorm set cond t=840 enter exper dgm(cumg2)=0:.01 c e l,,,,, @$ Now we can calculate the equilibrium and @$ we can fit V31 by forcing DGM(CUMG2) to be zero @& @$ Remove the next equilibrium with the same experiment sel eq next l,,,,, set wei 0 @& opt 100 l opt @$ set inter @$--------------------------------------------------------- @$ We are optimizing two experiments with 2 coefficents. @$ We get a good fit. @$--------------------------------------------------------- @& list opt @& macro ./opttest2-map-diagram @& @$------------------------------------------------------ @$ The CuMg2 phase is now reasonably fitted in the phase diagram @$ Take a break but first save !! @$------------------------------------------------------ set opt_fix 0-99 l opt set wei 0 * del step_map @& save unf ./opttest2-cumg4 Y set inter ================================================ FILE: examples/macros/opttest2E.OCM ================================================ @$=================================================================== @$=================================================================== @$======= step 4: fit Cp of the Laves phase @$=================================================================== @$=================================================================== @$ Back from the break ... new Y set echo r u ./opttest2-cumg4 @& @$ List previous results l opt @& @$ Ensure all expeimental equilibria has zero weight set wei 0 * @& @$ list the data for the Laves phas l ph laves_c15 data @& set opt_var 42 -10 @$ Estimate a start value for the coefficient of the T*ln(T) term @$ This value can be critical for the convergence in the beginning @$ and a bad estimate can complicate the calculations. @& set wei 1 CP15_F @$ Select experiments @& list active @$ And list them @& Remove eq 3 as we do not fit data below 298.15 K set wei 0 3 list active @& calc all n 1 c a n 1 @$ And calculate them @$ Sometimes there are problems, several calculate all may help @& opt 100 @& l opt @& macro ./opttest2-plot-cplaves @$--------------------------------------------------------- @$ There is a strange maximum of the Cp at low T. Why? @$ Check the constitution of the Laves phase @$--------------------------------------------------------- @& plot T y(laves,*) @$-------------------------------------------------------------------- @$ The constitution to totally wrong, we should have almost pure Cu in first @$ sublattice at all T. @$ The drastic change in constitution gives a big contribution to Cp @$ because when entropy change so does Cp! @& @$ We must set a the enthalpy of fromation of the Laves phase @$ to enshuring that we have Cu in first and Mg in second @$-------------------------------------------------------------------- l ph laves data set opt_fix 40 -300000 @& Set the T-independent parameter to a large negative value @& macro ./opttest2-plot-cplaves @& @$-------------------------------------------------------- @$ There is still a maximum but at a higher T @$ Check how the constitution varies! @$-------------------------------------------------------- plot T y(laves,*) @$-------------------------------------------------------------------- @$ Now we have the correct constitution at least up to the melting point @$-------------------------------------------------------------------- @& opt 0 @$-------------------------------------------------------------------- @$ Frequently many errors here ... we have to recalculate all equilibria @$ using the global gridminimizer @$-------------------------------------------------------------------- @& @$ set inter @$======================================== @$ Use calc all with grid minimizer c a y 1 opt 0 @$ Sometimes error still here for equilibrium 4 @& sel eq 4 calc ph laves 1 n 1 0 @$ and calculate the equilibrium c n l,,,,, @$ This is OK. If you have errors in other equilibria @$ try to fix them in the same way. @& @$ Otherwise try to calculate all again c a n 1 @$ Now no errors. @$ If you have more problem maybe stop the macro or add commands here @$ set inter @& @$-------------------------------------------------------------------- @$ Fit very bad, use more parameters @$ Here the start values of the parameters are critical @$ Consider that A43 is multipled with T**2, A44 with T**(-1) @$ and A45 with T**3 @$-------------------------------------------------------------------- set opt_var 43 .01 set opt_var 44 1000 set opt_var 45 .0001 list opt coef @& c a n 1 @& @$--------------------------------------------------------------------- @$ Check one equilibrium that constitution is OK, Cu in first, Mg in second @$--------------------------------------------------------------------- sel eq 4 l , 2 @$--------------------------------------------------------------------- @$ The constitution is reasonable for thie equilibrium @$--------------------------------------------------------------------- @& @$ now optimize A42-A45 opt 100 l opt @& @$ now include equilibrium 3 when parameters better sel eq 3 c ph lav 1 N 1 1e-12 c n l ,,,, @$ The heat capacity negative !!! add it @& set wei 1 @& @$ and run one more time opt 100 l opt @$ set inter @$-------------------------------------------------------------- @$ The sum or errors does not decrease, plot to check @$-------------------------------------------------------------- @& mac ./opttest2-plot-cplaves @& @$--------------------------------------------------------- @$ The Cp is OK but increase too mich at high T @$ Add a Cp estimation at high T (by phonon calculation) @$--------------------------------------------------------- sel eq 125 l,,, set wei 1 c e l,,,, c sym cpm2 @$ This heat capacity is calculated by DFT @& list active @$ set inter @$--------------------------------------------------------- @$ By adding this extimated Cp we can lower the Cp at high T @$--------------------------------------------------------- @& opt 100 @& l opt short @& @$ Plot the Cp mac ./opttest2-plot-cplaves @$ We have a reasonable fit to Cp @& @$--------------------------------------------------------- @$ Use the AMEND OPT Y command to set the current values as start values @$ and optimize again. This is important if the coefficents have @$ changed a lot @$--------------------------------------------------------- amend opt y @& opt 100 @& l opt @& @$ Finally plot again and check the constitution mac ./opttest2-plot-cplaves @& plot T y(laves,*) @$--------------------------------------------------------- @$ The constitution is perfectly ordered at all T @$--------------------------------------------------------- @& @$ Clean up for next step set opt_fix 0-99 l opt set wei 0 * del step_map_result @$--------------------------------------------------------- @$ Do not forget to remove STEP and MAP results before saving! @$--------------------------------------------------------- @& save unf ./opttest2-cumg5 Y set inter ================================================ FILE: examples/macros/opttest2F.OCM ================================================ @$=================================================================== @$=================================================================== @$======= step 5: fit H formation of the Laves phase @$=================================================================== @$=================================================================== @$ Consider Laves phase formation new Y set echo r u ./opttest2-cumg5 @& @$ Check we do not have any experimental equilibria l opt short @& @$ Check which parameters we should optimize for the Laves phase l ph laves_c15 data @& @$---------------------------------------------------------- @$ Include experiments HC15_K for the enthalpy of formation @$ and set the previously fixed enthalpy as variable @$---------------------------------------------------------- set wei 1 HC15_K set opt_var 40 @& @$----------------------------------------------------- @$ Calculate the experimental equilibria with gridminimizer @$----------------------------------------------------- c a y 1 c a n 1 @$ Error calculating the only equilibrium 305, we have to handle this @& sel eq 305 @$ Use the calculate phase command again!! c ph laves 1 n 1 0 c n l,,,, @$ Now it seems to work to calculate the equilibrium @& opt 0 @& l opt @& opt 100 @$---------------------------------------------------- @$ We have one experimental datum and one variable coefficient @$ A perfect fit @$---------------------------------------------------- @& l opt @$ Here the error is OK, almost zero @& macro ./opttest2-map-diagram @$---------------------------------------------------- @$ The Laves phase is too stable @$ Optimize the entropy of formation together with the @$ congruent melting @$---------------------------------------------------- @& set opt_var 41 400 set wei 1 CMELT l opt @& sel eq 546 c e l,,,, @$----------------------------------------------------------- @$ The calculation failed and we cannot use the grid minimizer @$ because of the constions. Note that LAVES is set as FIX @$ and the condition that x(mg) should be the same in liquid and laves. @$ @$ As T is too small try to set @$ a new start value for T with the command SET T_AND_P ... @$ This does not set a condition on T, just a start value @$----------------------------------------------------------- set init_t_and_p 1000 1e5 @& @$----------------------------------------------------------- @$ Also ensure that the liquid and Laves composition is correct @$ Use the command CALC PHASE for that @$----------------------------------------------------------- calc ph liq 1 n .333 calc ph lav n .99 .01 @& @$ Then try to calculate the equilibrium again! c n l,,,,, @$---------------------------------------------------- @$ Now we have a reasonable equilibrium. Note the composition @$ is the same in both phases but the T is too high. @$ We will optimize the coefficients to fit that. @$---------------------------------------------------- @& @$ We have to check the previous equilibrium also sel eq prev l,,,,, @$ This represent the same congruent melting. We do not need it. @& set wei 0 @& @$---------------------------------------------------- @$ Oprimize the enthalpy and congruent melting @$---------------------------------------------------- opt 0 @& l opt @& opt 100 @& l opt @& @$ plot the phase diagram mac ./opttest2-map-diagram @& @$--------------------------------------------------------- @$ Add some tie-line data between liquid and Laves @$--------------------------------------------------------- set wei 1 XLIQ_C @& c a y 1 @& @$ Optimize all these opt 0 @& l opt @& @$ Calculate all equilibria c a n 1 @& @$ Optimize a dry run opt 0 @& l opt @& @$ Optimize the coefficients opt 100 @& l opt @& mac ./opttest2-map-diagram @& @$------------------------------------------------------ @$ Also plot the heat capacity @$ NOTE to do this we must remove axis 2 as that is set!! @$------------------------------------------------------ set axis 2 none @& mac ./opttest2-plot-cplaves @& @$------------------------------------------------------ @$ We have some differences because the @$ constitution varies. Verify the stoichiometry is correct @$------------------------------------------------------ plot T y(laves,*) @$ The fraction of defects influences the heat capacity @& @$--------------------------------------------------------- @$ Clean up for next step set opt_fix 0-99 l opt @& set wei 0 * del step_map save unf ./opttest2-cumg6 Y set inter ================================================ FILE: examples/macros/opttest2G.OCM ================================================ @$=================================================================== @$=================================================================== @$======= step 6: fit solubilities in FCC and HCP @$=================================================================== @$=================================================================== @$ Fit solubilities in FCC and HCP new Y set echo r u ./opttest2-cumg6 @& @$ Remove any previous selections set wei 0 * set opt-fix 0-99 l eq @& l opt @& @$ Regular parameters in FCC and HCP set opt-var 11 -10000 set opt-var 21 10000 @& @$ Include experiments AFC and AH2 set wei 1 MU3 set wei 1 XFCC set wei 1 XLIQ_F set wei 1 XHCP set wei 1 XLIQ_H @& @$--------------------------------------------------------- @$ Handling some converge problems c a y 1 @& c a n 1 @& opt 0 @& l opt @& opt 100 @& l opt @& @$--------------------------------------------------------- @$ rescale the coefficients and optimize more @$--------------------------------------------------------- amend ? amend opt-coef y @& opt 100 @& l opt @& @$ ------------------------------------------------------ @$ sometimes mapping phase diagram memory crash here @$ problems with memory leaks during STEP/MAP @$ ------------------------------------------------------ mac ./opttest2-map-diagram @$--------------------------------------------------------- @$ We have now fitted the solubilities in FCC and HCP @$ and the compounds have correct melting T @$ but the solubility range of the Laves phase is too small @$--------------------------------------------------------- @$ Clean up for next step set opt-fix 0-99 del step_map l opt set wei 0 * @& save unf ./opttest2-cumg7 Y @& @$ Just for fun, check how the diagram looks like without the intermetallics l cond set c x(mg)=.3 set stat ph lav cumg2=s c e l,,,, @& set ax 1 x(mg) 0 1 set ax 2 t 300 1500 25 map plot @$ Without the intermetallic phases the FCC phase is stable @$ across almost the whole diagram. @& @$=================================================================== @$=================================================================== @$======= step 7: fit solubilities in Laves phase (not done) @$=================================================================== @$=================================================================== @$ We have not checked the fit to chemical potentials @$ @$ At the end a total optimization of all parameters together with @$ most of the experimental data must be made. @$ @$ IMPORTANT: The coefficients for the Cp should NOT be assessed @$ together with phase diagram data, they should remain fixed. set inter ================================================ FILE: examples/macros/parallel1.OCM ================================================ new Y set echo Y @$ ================================================================= @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ parallel1.OCM @$ testing parallelization @$ If you run this macro without using oc3P version it @$ will be executed sequentially. @& @$ @$ This macro should work but unless I calculate the equilibria one by one @$ when I enter them I get problems. There are probably some errors ... @$ @$ The problem may be connected with changing set of stable phases @$ but I have tested to change a few equilibria and recalculate so a few @$ equilibria with phase changes seems to work. Any help fixing this is @$ appreciated. @$ ================================================================= @$ set echo r t ./steel1 set c t=1200 p=1e5 n=1 w(c)=.01 w(cr)=.05 w(mo)=.08 w(si)=.003 w(v)=0.01 c e l,,,, @& @$ enter a second equilibrium and test we can calculate it enter equil para1 Y l c @& set c t=1200 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011 l c c e l,,,, @$ it seems to work, the result is different and the first unchanged sel eq 1 l,,,, @& @$ enter 20 more equilibria, just different T enter equil para3 Y set c t=1250 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011 c e enter equil para4 Y set c t=1300 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011 c e enter equil para5 Y set c t=1350 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011 c e enter equil para6 Y set c t=1400 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011 c e enter equil para7 Y set c t=1450 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011 c e enter equil para8 Y set c t=1500 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011 c e enter equil para9 Y set c t=1550 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011 c e enter equil para10 Y set c t=1600 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011 c e enter equil para11 Y set c t=1650 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011 c e enter equil para12 Y set c t=1700 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011 c e enter equil para13 Y set c t=1750 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011 c e enter equil para14 Y set c t=1800 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011 c e enter equil para15 Y set c t=1150 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011 c e enter equil para16 Y set c t=1100 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011 c e enter equil para17 Y set c t=1050 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011 c e enter equil para18 Y set c t=1000 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011 c e enter equil para19 Y set c t=950 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011 c e enter equil para20 Y set c t=900 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011 c e enter equil para21 Y set c t=850 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011 c e enter equil para22 Y set c t=800 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011 @& l eq @& @$ set all equilibria (except first) available for calc all set range 2 22 @& @$ calculate all with grid minimizer c a Y 1 @$ calculate all without grid minimmizer (and in parallel if oc3P) c a N 1 @$ Turn off parallel (if on) set bit glo 2 set bit glo 15 c a N 1 @& @$ ================================================================= @$ end of parallel1 macro @$ ================================================================= @$ set inter ================================================ FILE: examples/macros/parallel2.OCM ================================================ new Y set echo Y @$ ================================================================ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$> @$ @$ @$ @$ @$ @$ parallel2.OCM @$ testing enter many equilibria and calculate in parallel @& @$ The calculate all command using the grid minimizer does not calculate @$ in parallel as I get problems creating composition sets ... @$ Calculating without grid minimizer with oc3P will use parallel calculation @$ @$ I also allow the user to output extra data for each equlibrium @$ according to a suggestion by Andre @$ ================================================================ @& r t ./steel1 set cond t=1000 p=1e5 n=1 w(c)=0.01 w(cr)=.05 w(mo)=.08 w(si)=.003 w(v)=0.01 c e l,,,,, @& enter symbol cp=h.t; calc symb cp l state x(bcc,c) tc(bcc) @& enter many_equil @$ set all phases as entered entered 0 * @$ set conditions and refer some values to table columns condition t=@1 p=1e5 n=1 w(c)=@2 w(cr)=.05 w(mo)=.08 w(si)=.003 w(v)=0.01 @$ add a (predefined) symbol to be calculated at each equilibrium calc cp @$ add a list of (state) variables to be listed at each equilibrium list x(fcc,c) tc(bcc) @$ Now starts the table values @& table_start @$ comment line NOTE first value (column 0) on each line is equilibrium name!! @$ equilibrium names like FIRST, NEXT, PREVIOUS, DEFAULT, LAST forbidden @$ T is column 1, x(c) is column 2 (Preferably no TAB characters) ettan 760 0.008 tvaan 770 0.008 @& equil_003 780 0.008 equil_004 790 0.008 equil_005 800 0.008 equil_006 810 0.008 equil_007 820 0.008 equil_008 830 0.008 equil_009 840 0.008 equil_010 850 0.008 equil_011 860 0.008 equil_012 870 0.008 equil_013 880 0.008 equil_014 900 0.008 equil_015 910 0.008 equil_016 920 0.008 equil_017 930 0.008 equil_018 940 0.008 equil_019 950 0.008 equil_020 960 0.008 equil_021 970 0.008 equil_022 970 0.008 equil_023 980 0.008 equiL_024 990 0.008 equiL_025 1000 0.008 equiL_026 1070 0.008 equiL_027 1080 0.008 equiL_028 1110 0.008 equiL_029 1120 0.008 equiL_030 1130 0.008 equiL_031 1140 0.008 equiL_032 1150 0.008 equiL_033 1160 0.008 equiL_034 1170 0.008 equiL_035 1180 0.008 equiL_036 1190 0.008 equiL_037 1200 0.008 equiL_038 1210 0.008 equiL_039 1220 0.008 equiL_040 1230 0.008 equiL_041 1240 0.008 equil_042 1250 0.008 equil_043 1250 0.008 equil_044 1260 0.008 equiL_045 1270 0.008 equiL_046 1280 0.008 equiL_047 1290 0.008 equiL_048 1300 0.008 equiL_049 1320 0.008 equiL_050 1330 0.008 equiL_051 1340 0.008 equiL_052 1350 0.008 equiL_053 1360 0.008 equiL_054 1370 0.008 equiL_055 1380 0.008 equiL_056 1390 0.008 equiL_057 1400 0.008 equiL_058 1410 0.008 equiL_059 1420 0.008 equiL_060 1430 0.008 equiL_061 1440 0.008 equiL_062 1450 0.008 equil_063 1460 0.007 equil_064 1460 0.008 equil_065 1470 0.008 equiL_066 1480 0.008 equiL_067 1490 0.008 equiL_068 1500 0.008 equiL_069 1510 0.008 equiL_070 1520 0.008 equiL_071 1530 0.008 equiL_072 1540 0.008 equiL_073 1550 0.008 equiL_074 1560 0.008 equiL_075 1570 0.008 equiL_076 1580 0.008 equiL_077 1590 0.008 equiL_078 1600 0.008 equiL_079 1610 0.008 equiL_080 1620 0.008 equiL_081 1630 0.008 equiL_082 1640 0.008 equiL_083 1650 0.008 @$ equil_101 760 0.009 equil_102 770 0.009 equil_103 780 0.009 equil_104 790 0.009 equil_105 800 0.009 equil_106 810 0.009 equil_107 820 0.009 equil_108 830 0.009 equil_109 840 0.009 equil_110 850 0.009 equil_111 860 0.009 equil_112 870 0.009 equil_113 880 0.009 equil_114 900 0.009 equil_115 910 0.009 equil_116 920 0.009 equil_117 930 0.009 equil_118 940 0.009 equil_119 950 0.009 equil_120 960 0.009 equil_121 970 0.009 equil_122 980 0.009 equiL_123 990 0.009 equiL_124 1000 0.009 equiL_125 1070 0.009 equiL_126 1080 0.009 equiL_127 1110 0.009 equiL_128 1120 0.009 equiL_129 1130 0.009 equiL_130 1140 0.009 equiL_131 1150 0.009 equiL_132 1160 0.009 equiL_133 1170 0.009 equiL_134 1180 0.009 equiL_135 1190 0.009 equiL_136 1200 0.009 equiL_137 1210 0.009 equiL_138 1220 0.009 equiL_139 1230 0.009 equiL_140 1240 0.009 equil_141 1250 0.009 equil_142 1260 0.009 equiL_143 1270 0.009 equiL_144 1280 0.009 equiL_145 1290 0.009 equiL_146 1300 0.009 equiL_147 1320 0.009 equiL_148 1330 0.009 equiL_149 1340 0.009 equiL_150 1350 0.009 equiL_151 1360 0.009 equiL_152 1370 0.009 equiL_153 1380 0.009 equiL_154 1390 0.009 equiL_155 1400 0.009 equiL_156 1410 0.009 equiL_157 1420 0.009 equiL_158 1430 0.009 equiL_159 1440 0.009 equiL_160 1450 0.009 equil_161 1460 0.009 equil_162 1470 0.009 equiL_163 1480 0.009 equiL_164 1490 0.009 equiL_165 1500 0.009 equiL_166 1510 0.009 equiL_167 1520 0.009 equiL_168 1530 0.009 equiL_169 1540 0.009 equiL_170 1550 0.009 equiL_171 1560 0.009 equiL_172 1570 0.009 equiL_173 1580 0.009 equiL_174 1590 0.009 equiL_175 1600 0.009 equiL_176 1610 0.009 equiL_177 1620 0.009 equiL_178 1630 0.009 equiL_179 1640 0.009 equiL_180 1650 0.009 @& equil_201 760 0.010 equil_202 770 0.010 equil_203 780 0.010 equil_204 790 0.010 equil_205 800 0.010 equil_206 810 0.010 equil_207 820 0.010 equil_208 830 0.010 equil_209 840 0.010 equil_210 850 0.010 equil_211 860 0.010 equil_212 870 0.010 equil_213 880 0.010 equil_214 900 0.010 equil_215 910 0.010 equil_216 920 0.010 equil_217 930 0.010 equil_218 940 0.010 equil_219 950 0.010 equil_220 960 0.010 equil_221 870 0.010 equil_222 980 0.010 equiL_223 990 0.010 equiL_224 1000 0.010 equiL_225 1070 0.010 equiL_226 1080 0.010 equiL_227 1110 0.010 equiL_228 1120 0.010 equiL_229 1130 0.010 equiL_230 1140 0.010 equiL_231 1150 0.010 equiL_232 1160 0.010 equiL_233 1170 0.010 equiL_234 1180 0.010 equiL_235 1190 0.010 equiL_236 1200 0.010 equiL_237 1210 0.010 equiL_238 1220 0.010 equiL_239 1230 0.010 equiL_240 1240 0.010 equil_241 1250 0.010 equil_242 1260 0.010 equiL_243 1270 0.010 equiL_244 1280 0.010 equiL_245 1290 0.010 equiL_246 1300 0.010 equiL_247 1320 0.010 equiL_248 1330 0.010 equiL_249 1340 0.010 equiL_250 1350 0.010 equiL_251 1360 0.010 equiL_252 1370 0.010 equiL_253 1380 0.010 equiL_254 1390 0.010 equiL_255 1400 0.010 equiL_256 1410 0.010 equiL_257 1420 0.010 equiL_258 1430 0.010 equiL_259 1440 0.010 equiL_260 1450 0.010 equil_261 1460 0.010 equil_262 1470 0.010 equiL_263 1480 0.010 equiL_264 1490 0.010 equiL_265 1500 0.010 equiL_266 1510 0.010 equiL_267 1520 0.010 equiL_268 1530 0.010 equiL_269 1540 0.010 equiL_270 1550 0.010 equiL_271 1560 0.010 equiL_272 1570 0.010 equiL_273 1580 0.010 equiL_274 1590 0.010 equiL_275 1600 0.010 equiL_276 1610 0.010 equiL_277 1620 0.010 equiL_278 1630 0.010 equiL_279 1640 0.010 equiL_280 1650 0.010 @$ equil_301 760 0.011 equil_302 770 0.011 equil_303 780 0.011 equil_304 790 0.011 equil_305 800 0.011 equil_306 810 0.011 equil_307 820 0.011 equil_308 830 0.011 equil_309 840 0.011 equil_310 850 0.011 equil_311 860 0.011 equil_312 870 0.011 equil_313 880 0.011 equil_314 900 0.011 equil_315 920 0.011 equil_316 930 0.011 equil_317 940 0.011 equil_318 950 0.011 equil_319 960 0.011 equil_320 970 0.011 equil_321 980 0.011 equiL_322 990 0.011 equiL_323 1000 0.011 equiL_324 1070 0.011 equiL_325 1080 0.011 equiL_326 1110 0.011 equiL_327 1120 0.011 equiL_328 1130 0.011 equiL_329 1140 0.011 equiL_330 1150 0.011 equiL_331 1160 0.011 equiL_332 1170 0.011 equiL_333 1180 0.011 equiL_334 1190 0.011 equiL_335 1200 0.011 equiL_336 1220 0.011 equiL_337 1230 0.011 equiL_338 1240 0.011 equil_339 1250 0.011 equil_340 1260 0.011 equiL_341 1270 0.011 equiL_342 1280 0.011 equiL_343 1290 0.011 equiL_344 1300 0.011 equiL_345 1310 0.012 equiL_346 1320 0.011 equiL_347 1330 0.011 equiL_348 1340 0.011 equiL_349 1350 0.011 equiL_350 1360 0.011 equiL_351 1370 0.011 equiL_352 1380 0.011 equiL_353 1390 0.011 equiL_354 1400 0.011 equiL_355 1410 0.011 equiL_356 1420 0.011 equiL_357 1430 0.011 equiL_358 1440 0.011 equiL_359 1450 0.011 equil_360 1460 0.011 equil_361 1470 0.011 equiL_362 1480 0.011 equiL_363 1490 0.011 equiL_364 1500 0.011 equiL_365 1510 0.011 equiL_366 1520 0.011 equiL_367 1530 0.011 equiL_368 1540 0.011 equiL_369 1550 0.011 equiL_370 1560 0.011 equiL_371 1570 0.011 equiL_372 1580 0.011 equiL_373 1590 0.011 equiL_374 1600 0.011 equiL_375 1610 0.011 equiL_376 1620 0.011 equiL_377 1630 0.011 equiL_378 1640 0.011 equiL_379 1650 0.011 equil_380 1660 0.011 @$ equil_401 760 0.012 equil_402 770 0.012 equil_403 780 0.012 equil_404 790 0.012 equil_405 800 0.012 equil_406 810 0.012 equil_407 820 0.012 equil_408 830 0.012 equil_409 840 0.012 equil_410 850 0.012 equil_411 860 0.012 equil_412 870 0.012 equil_413 880 0.012 equil_414 900 0.012 equil_415 910 0.012 equil_416 920 0.012 equil_417 930 0.012 equil_418 940 0.012 equil_419 950 0.012 equil_420 970 0.012 equiL_421 980 0.012 equiL_422 990 0.012 equiL_423 1100 0.012 equiL_424 1110 0.012 equiL_425 1120 0.012 equiL_426 1130 0.012 equiL_427 1070 0.012 equiL_428 1080 0.012 equiL_429 1140 0.012 equiL_430 1150 0.012 equiL_431 1160 0.012 equiL_432 1170 0.012 equiL_433 1190 0.012 equiL_434 1200 0.012 equiL_435 1210 0.012 equiL_436 1210 0.011 equiL_437 1220 0.012 equiL_438 1230 0.012 equil_439 1250 0.012 equiL_440 1260 0.012 equiL_441 1270 0.012 equiL_442 1280 0.012 equiL_443 1290 0.012 equiL_444 1320 0.012 equiL_445 1330 0.012 equiL_446 1340 0.012 equiL_447 1350 0.012 equiL_448 1360 0.012 equiL_449 1370 0.012 equiL_450 1380 0.012 equiL_451 1390 0.012 equiL_452 1400 0.012 equiL_453 1410 0.012 equiL_454 1420 0.012 equiL_455 1430 0.012 equiL_456 1440 0.012 equil_457 1460 0.012 equiL_458 1470 0.012 equiL_459 1480 0.012 equiL_460 1490 0.012 equiL_461 1500 0.012 equiL_462 1510 0.012 equiL_463 1520 0.012 equiL_464 1530 0.012 equiL_465 1540 0.012 equiL_466 1550 0.012 equiL_467 1560 0.012 equiL_468 1570 0.012 equiL_469 1580 0.012 equiL_470 1590 0.012 equiL_471 1600 0.012 equiL_472 1610 0.012 equiL_473 1620 0.012 equiL_474 1630 0.012 equiL_475 1640 0.012 equiL_476 1650 0.011 equiL_477 1660 0.012 table_end @& @$ Just list the equilibria l eq @& @$ Set range so they can be calculated by the "calculate all" command set range 2 401 @& @$ Calculate once with gridminimizer, we may create composition sets @$ Calculate with gridminimizer disables parallel calculation @$ To speed up this a little we select the smaller grid set adv grid 0 @& @$ Note the composition of x(fcc,c) is in most cases the cubic carbide, @$ it is difficult to specify the austenite. Evidently redundant composition @$ sets are not removed after the equilibrium calculation. @$ There are also problems to make sure user defined composition sets @$ have the most similar stable composition. @$ Some work is needed with the grid minimizer and the cleanup process. @$ I have added that if the phase specified for a state variable is not stable @$ the program searches for another stable composition set, @$ thus TC(BCC) is sometimes TC(BCC#2) calc all Y 1 @& @$ calculate and write the output on a file ... -1 means info about threads calc /out=outpara all N -1 @& @$ Calculate without gridminimizer, note the speed @$ When calculated in parallel even more @$ calc all N -1 <<<<<<<<<<< problem ? too slow output on screen?? @& @$ Run without parallel with output on file for comparison @$ First I must declare me as an expert, then use bit 15 to turns off parallel set advanced level N Y @$ set bit 15 which prevents parallel execution set bit glo 15 @$ ------------------------ BE PATIENT ----------------------------- calc /out=outseq all N 1 @$ prepare for more tests in parallel @$ clear bit 15 set bit glo 15 no @& @& @$ Check data for one equilibrium sel eq 103 c e debug symbol cp 51.1372166 debug symbol x(fcc,c) 0.463272739 debug symbol tc(bcc) 1033.90240 @& @$ @$ ================================================================= @$ 2026-03-19 with OC6-108 @$ on my Mac Pro with 14 threads calculating 400 equilibria @$ 0.4 seconds CPU and 410 clockcykles with 1 thread @$ 0.8 seconds CPU and 71 clockcykles with 14 threads, @$ factor 5.77 faster @$ ================================================================= @$ end of parallel2 macro @$ ================================================================= @$ set inter @$ =============== measuring ==================== @$ Running OC5-49 2019-08-17 looping "c a n 10" @$ on my MacPro with 4 CPU 2.2 GHz Intel Core i7, 16 GB 1600 MHz DDR3: @$ 13.65 seconds CPU and 13654 clockycles with 1 thread @$ 23.98 seconds CPU and 3140 clockycles with 8 threads, factor 4.37 faster! @$ @$ on my DELL with 2 CPU 2.80/2.90 GHz Intel Core i7-7600U, 16 GB RAM @$ 10.33 seconds CPU and 10453 clockcycles with 1 thread @$ 17.14 seconds CPU and 4407 clockcycles with 4 threads, factor 2.37 faster @$ @$ This loop calculates 4000 equilibria, each requires 9 iterations @$ which means 0.379 miliseconds/iteration on MAC @$ which means 0.286 miliseconds/iteration on DELL, 1.3 times faster CPU @$ @$ This system has 6 component system with 40 phases, 503 TPfuns and parameters @$ (the times also includes listing some results on a file) @$ ============================================== @$ Running OC6-14 2020-10-04 looping "c a n 10" @$ on my DELL 5511 Latitude with Intel core i7-1085H 10 gen 2.27 GHz, 16 GB RAM @$ 6.94 seconds CPU and 6938 clockcykles with 1 thread @$ 12.97 seconds CPU and 1234 clockcykles with 12 threads, factor 5.62 faster @$ New DELL is 1.48 times faster than the old DELL (single CPU) @$ New DELL is 1.97 times faster than the MAC (single CPU) @$ ============================================== @$ Running OC6-28 2021-05-08 looping "c a n 10" @$ on my DELL 5511 Latitude with Intel core i7-1085H 10 gen 2.27 GHz, 16 GB RAM @$ 8.16 seconds CPU and 8156 clockcykles with 1 thread @$ 18.83 seconds CPU and 1671 clockcykles with 12 threads, factor 4.88 faster @$ ============================================== @$ Running OC6-108 2026-03-19 @$ on my Mac Pro with 14 threads calculating 400 equilibria @$ 0.4 seconds CPU and 410 clockcykles with 1 thread @$ 0.8 seconds CPU and 71 clockcykles with 14 threads, factor 5.77 faster @$ ============================================== ================================================ FILE: examples/macros/saf2507.TDB ================================================ $ Database file written 2014-10- 1 $ From database: SSOL2 DATABASE_INFO about the SAF2507 database It contains an extract of the SGTE SSOL2 database from 2001 for 6 elements. Most binaries and ternary systems have been assessed and bibliographic references are provided. Most assessments has been made at MSE, KTH, Sweden for the development of duplex stainless steels like Sandvik 2507! $ ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01! ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! ELEMENT MN CBCC_A12 5.4938E+01 4.9960E+03 3.2008E+01! ELEMENT MO BCC_A2 9.5940E+01 4.5890E+03 2.8560E+01! ELEMENT N 1/2_MOLE_N2(G) 1.4007E+01 4.3350E+03 9.5751E+01! ELEMENT NI FCC_A1 5.8690E+01 4.7870E+03 2.9796E+01! SPECIES N2 N2! FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T) +.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2.18000E+03 Y -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6.00000E+03 N ! FUNCTION GPCRLIQ 2.98150E+02 +YCRLIQ#*EXP(ZCRLIQ#); 6.00000E+03 N ! FUNCTION GFELIQ 2.98150E+02 +12040.17-6.55843*T-3.6751551E-21*T**7 +GHSERFE#; 1.81100E+03 Y -10839.7+291.302*T-46*T*LN(T); 6.00000E+03 N ! FUNCTION GPFELIQ 2.98150E+02 +YFELIQ#*EXP(ZFELIQ#); 6.00000E+03 N ! FUNCTION GHSERMN 2.98150E+02 -8115.28+130.059*T-23.4582*T*LN(T) -.00734768*T**2+69827*T**(-1); 1.51900E+03 Y -28733.41+312.2648*T-48*T*LN(T)+1.656847E+30*T**(-9); 2.00000E+03 N ! FUNCTION GHSERMO 2.98150E+02 -7746.302+131.9197*T-23.56414*T*LN(T) -.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)-1.30927E-10*T**4; 2.89600E+03 Y -30556.41+283.559746*T-42.63829*T*LN(T)-4.849315E+33*T**(-9); 5.00000E+03 N ! FUNCTION GPMOLIQ 2.98150E+02 +YMOLIQ#*EXP(ZMOLIQ#); 6.00000E+03 N ! FUNCTION GHSERNN 2.98150E+02 -3750.675-9.45425*T-12.7819*T*LN(T) -.00176686*T**2+2.681E-09*T**3-32374*T**(-1); 9.50000E+02 Y -7358.85+17.2003*T-16.3699*T*LN(T)-6.5107E-04*T**2+3.0097E-08*T**3 +563070*T**(-1); 3.35000E+03 Y -16392.8+50.26*T-20.4695*T*LN(T)+2.39754E-04*T**2-8.333E-09*T**3 +4596375*T**(-1); 6.00000E+03 N ! FUNCTION GHCPNI 2.98150E+02 +6610.72+GHSERNI#; 6.00000E+03 N ! FUNCTION GHSERNI 2.98150E+02 -5179.159+117.854*T-22.096*T*LN(T) -.0048407*T**2; 1.72800E+03 Y -27840.655+279.135*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 3.00000E+03 N ! FUNCTION GHSERFE 2.98150E+02 +1225.7+124.134*T-23.5143*T*LN(T) -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6.00000E+03 N ! FUNCTION GPCRBCC 2.98150E+02 +YCRBCC#*EXP(ZCRBCC#); 6.00000E+03 N ! FUNCTION GPFEBCC 2.98150E+02 +YFEBCC#*EXP(ZFEBCC#); 6.00000E+03 N ! FUNCTION GMNBCC 2.98150E+02 -3235.3+127.85*T-23.7*T*LN(T) -.00744271*T**2+60000*T**(-1); 1.51900E+03 Y -23188.83+307.7043*T-48*T*LN(T)+1.265152E+30*T**(-9); 2.00000E+03 N ! FUNCTION GPMOBCC 2.98150E+02 +YMOBCC#*EXP(ZMOBCC#); 6.00000E+03 N ! FUNCTION GNIBCC 2.98150E+02 +8715.084-3.556*T+GHSERNI#; 6.00000E+03 N ! FUNCTION GCRFCC 2.98150E+02 +7284+.163*T+GHSERCR#; 6.00000E+03 N ! FUNCTION GFEFCC 2.98150E+02 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2 +GHSERFE#; 1.81100E+03 Y -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6.00000E+03 N ! FUNCTION GMOFCC 2.98150E+02 +15200+.63*T+GHSERMO#; 6.00000E+03 N ! FUNCTION GPFEFCC 2.98150E+02 +YFEFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! FUNCTION GMNFCC 2.98150E+02 -3439.3+131.884*T-24.5177*T*LN(T) -.006*T**2+69600*T**(-1); 1.51900E+03 Y -26070.1+309.6664*T-48*T*LN(T)+3.86196E+30*T**(-9); 2.00000E+03 N ! FUNCTION GPFEHCP 2.98150E+02 +YFEHCP#*EXP(ZFEHCP#); 6.00000E+03 N ! FUNCTION GPMU1 2.98150E+02 +8.72E-05*P; 6.00000E+03 N ! FUNCTION GPMU2 2.98150E+02 +1.04E-04*P; 6.00000E+03 N ! FUNCTION GPR1 2.98150E+02 +3.81E-04*P; 6.00000E+03 N ! FUNCTION GPR2 2.98150E+02 +4.33E-04*P; 6.00000E+03 N ! FUNCTION GPSIG1 2.98150E+02 +1.09E-04*P; 6.00000E+03 N ! FUNCTION GPSIG2 2.98150E+02 +1.117E-04*P; 6.00000E+03 N ! FUNCTION YCRLIQ 2.98150E+02 +VCRLIQ#*EXP(-ECRLIQ#); 6.00000E+03 N ! FUNCTION ZCRLIQ 2.98150E+02 +1*LN(XCRLIQ#); 6.00000E+03 N ! FUNCTION YFELIQ 2.98150E+02 +VFELIQ#*EXP(-EFELIQ#); 6.00000E+03 N ! FUNCTION ZFELIQ 2.98150E+02 +1*LN(XFELIQ#); 6.00000E+03 N ! FUNCTION YMOLIQ 2.98150E+02 +VMOLIQ#*EXP(-EMOLIQ#); 6.00000E+03 N ! FUNCTION ZMOLIQ 2.98150E+02 +1*LN(XMOLIQ#); 6.00000E+03 N ! FUNCTION YCRBCC 2.98150E+02 +VCRBCC#*EXP(-ECRBCC#); 6.00000E+03 N ! FUNCTION ZCRBCC 2.98150E+02 +1*LN(XCRBCC#); 6.00000E+03 N ! FUNCTION YFEBCC 2.98150E+02 +VFEBCC#*EXP(-EFEBCC#); 6.00000E+03 N ! FUNCTION ZFEBCC 2.98150E+02 +1*LN(XFEBCC#); 6.00000E+03 N ! FUNCTION YMOBCC 2.98150E+02 +VMOBCC#*EXP(-EMOBCC#); 6.00000E+03 N ! FUNCTION ZMOBCC 2.98150E+02 +1*LN(XMOBCC#); 6.00000E+03 N ! FUNCTION YFEFCC 2.98150E+02 +VFEFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! FUNCTION ZFEFCC 2.98150E+02 +1*LN(XFEFCC#); 6.00000E+03 N ! FUNCTION YFEHCP 2.98150E+02 +VFEHCP#*EXP(-EFEHCP#); 6.00000E+03 N ! FUNCTION ZFEHCP 2.98150E+02 +1*LN(XFEHCP#); 6.00000E+03 N ! FUNCTION VCRLIQ 2.98150E+02 +7.653E-06*EXP(ACRLIQ#); 6.00000E+03 N ! FUNCTION ECRLIQ 2.98150E+02 +1*LN(CCRLIQ#); 6.00000E+03 N ! FUNCTION XCRLIQ 2.98150E+02 +1*EXP(.8*DCRLIQ#)-1; 6.00000E+03 N ! FUNCTION VFELIQ 2.98150E+02 +6.46677E-06*EXP(AFELIQ#); 6.00000E+03 N ! FUNCTION EFELIQ 2.98150E+02 +1*LN(CFELIQ#); 6.00000E+03 N ! FUNCTION XFELIQ 2.98150E+02 +1*EXP(.8484467*DFELIQ#)-1; 6.00000E+03 N ! FUNCTION VMOLIQ 2.98150E+02 +9.75079E-06*EXP(AMOLIQ#); 6.00000E+03 N ! FUNCTION EMOLIQ 2.98150E+02 +1*LN(CMOLIQ#); 6.00000E+03 N ! FUNCTION XMOLIQ 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 N ! FUNCTION VCRBCC 2.98150E+02 +7.188E-06*EXP(ACRBCC#); 6.00000E+03 N ! FUNCTION ECRBCC 2.98150E+02 +1*LN(CCRBCC#); 6.00000E+03 N ! FUNCTION XCRBCC 2.98150E+02 +1*EXP(.8*DCRBCC#)-1; 6.00000E+03 N ! FUNCTION VFEBCC 2.98150E+02 +7.042095E-06*EXP(AFEBCC#); 6.00000E+03 N ! FUNCTION EFEBCC 2.98150E+02 +1*LN(CFEBCC#); 6.00000E+03 N ! FUNCTION XFEBCC 2.98150E+02 +1*EXP(.7874195*DFEBCC#)-1; 6.00000E+03 N ! FUNCTION VMOBCC 2.98150E+02 +9.34372E-06*EXP(AMOBCC#); 6.00000E+03 N ! FUNCTION EMOBCC 2.98150E+02 +1*LN(CMOBCC#); 6.00000E+03 N ! FUNCTION XMOBCC 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 N ! FUNCTION VFEFCC 2.98150E+02 +6.688726E-06*EXP(AFEFCC#); 6.00000E+03 N ! FUNCTION EFEFCC 2.98150E+02 +1*LN(CFEFCC#); 6.00000E+03 N ! FUNCTION XFEFCC 2.98150E+02 +1*EXP(.8064454*DFEFCC#)-1; 6.00000E+03 N ! FUNCTION VFEHCP 2.98150E+02 +6.59121E-06*EXP(AFEHCP#); 6.00000E+03 N ! FUNCTION EFEHCP 2.98150E+02 +1*LN(CFEHCP#); 6.00000E+03 N ! FUNCTION XFEHCP 2.98150E+02 +1*EXP(.8064454*DFEHCP#)-1; 6.00000E+03 N ! FUNCTION ACRLIQ 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N ! FUNCTION CCRLIQ 2.98150E+02 3.72E-11; 6.00000E+03 N ! FUNCTION DCRLIQ 2.98150E+02 +1*LN(BCRLIQ#); 6.00000E+03 N ! FUNCTION AFELIQ 2.98150E+02 +1.135E-04*T; 6.00000E+03 N ! FUNCTION CFELIQ 2.98150E+02 +4.22534787E-12+2.71569924E-14*T; 6.00000E+03 N ! FUNCTION DFELIQ 2.98150E+02 +1*LN(BFELIQ#); 6.00000E+03 N ! FUNCTION AMOLIQ 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2 +1.14687E-12*T**3; 6.00000E+03 N ! FUNCTION CMOLIQ 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; 6.00000E+03 N ! FUNCTION DMOBCC 2.98150E+02 +1*LN(BMOBCC#); 6.00000E+03 N ! FUNCTION ACRBCC 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N ! FUNCTION CCRBCC 2.98150E+02 2.08E-11; 6.00000E+03 N ! FUNCTION DCRBCC 2.98150E+02 +1*LN(BCRBCC#); 6.00000E+03 N ! FUNCTION AFEBCC 2.98150E+02 +2.3987E-05*T+1.2845E-08*T**2; 6.00000E+03 N ! FUNCTION CFEBCC 2.98150E+02 +2.20949565E-11+2.41329523E-16*T; 6.00000E+03 N ! FUNCTION DFEBCC 2.98150E+02 +1*LN(BFEBCC#); 6.00000E+03 N ! FUNCTION AMOBCC 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2 +1.14687E-12*T**3; 6.00000E+03 N ! FUNCTION CMOBCC 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; 6.00000E+03 N ! FUNCTION AFEFCC 2.98150E+02 +7.3097E-05*T; 6.00000E+03 N ! FUNCTION CFEFCC 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; 6.00000E+03 N ! FUNCTION DFEFCC 2.98150E+02 +1*LN(BFEFCC#); 6.00000E+03 N ! FUNCTION AFEHCP 2.98150E+02 +7.3646E-05*T; 6.00000E+03 N ! FUNCTION CFEHCP 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; 6.00000E+03 N ! FUNCTION DFEHCP 2.98150E+02 +1*LN(BFEHCP#); 6.00000E+03 N ! FUNCTION BCRLIQ 2.98150E+02 +1+4.65E-11*P; 6.00000E+03 N ! FUNCTION BFELIQ 2.98150E+02 +1+4.98009787E-12*P+3.20078924E-14*T*P; 6.00000E+03 N ! FUNCTION BMOBCC 2.98150E+02 +1+1.13837E-11*P+4.875E-16*T*P +1.2675E-19*T**2*P; 6.00000E+03 N ! FUNCTION BCRBCC 2.98150E+02 +1+2.6E-11*P; 6.00000E+03 N ! FUNCTION BFEBCC 2.98150E+02 +1+2.80599565E-11*P+3.06481523E-16*T*P; 6.00000E+03 N ! FUNCTION BFEFCC 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; 6.00000E+03 N ! FUNCTION BFEHCP 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; 6.00000E+03 N ! FUNCTION UN_ASS 298.15 0; 300 N ! TYPE_DEFINITION % SEQ *! DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! PHASE LIQUID:L % 1 1.0 ! CONSTITUENT LIQUID:L :CR,FE,MN,MO,N,NI : ! PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T +2.37615E-21*T**7+GHSERCR#+GPCRLIQ#; 2.18000E+03 Y +18409.36-8.563683*T+2.88526E+32*T**(-9)+GHSERCR#+GPCRLIQ#; 6.00000E+03 N REF283 ! PARAMETER G(LIQUID,FE;0) 2.98150E+02 +GFELIQ#+GPFELIQ#; 6.00000E+03 N REF283 ! PARAMETER G(LIQUID,MN;0) 2.98150E+02 +17859.91-12.6208*T -4.41929E-21*T**7+GHSERMN#; 1.51900E+03 Y +18739.51-13.2288*T-1.656847E+30*T**(-9)+GHSERMN#; 2.00000E+03 N REF283 ! PARAMETER G(LIQUID,MO;0) 2.98150E+02 +41831.347-14.694912*T +4.24519E-22*T**7+GHSERMO#+GPMOLIQ#; 2.89600E+03 Y +34095.373-11.890046*T+4.849315E+33*T**(-9)+GHSERMO#+GPMOLIQ#; 5.00000E+03 N REF283 ! PARAMETER G(LIQUID,N;0) 2.98150E+02 +29950+59.02*T+GHSERNN#; 6.00000E+03 N REF283 ! PARAMETER G(LIQUID,NI;0) 2.98150E+02 +11235.527+108.457*T -22.096*T*LN(T)-.0048407*T**2-3.82318E-21*T**7; 1.72800E+03 Y -9549.775+268.598*T-43.1*T*LN(T); 3.00000E+03 N REF283 ! PARAMETER G(LIQUID,CR,FE;0) 2.98150E+02 -14550+6.65*T; 6.00000E+03 N REF107 ! PARAMETER G(LIQUID,CR,FE,N;0) 2.98150E+02 -340750+187.4*T; 6.00000E+03 N REF126 ! PARAMETER G(LIQUID,CR,FE,N,NI;0) 2.98150E+02 -261500; 6.00000E+03 N REF129 ! PARAMETER G(LIQUID,CR,FE,NI;0) 2.98150E+02 14510; 6.00000E+03 N REF322 ! PARAMETER G(LIQUID,CR,FE,NI;1) 2.98150E+02 11977; 6.00000E+03 N REF322 ! PARAMETER G(LIQUID,CR,FE,NI;2) 2.98150E+02 5147; 6.00000E+03 N REF322 ! PARAMETER G(LIQUID,CR,MN;0) 2.98150E+02 -15009+13.6587*T; 6.00000E+03 N REF326 ! PARAMETER G(LIQUID,CR,MN;1) 2.98150E+02 +504+.9479*T; 6.00000E+03 N REF326 ! PARAMETER G(LIQUID,CR,MO;0) 2.98150E+02 +15810-6.714*T; 6.00000E+03 N REF123 ! PARAMETER G(LIQUID,CR,MO;1) 2.98150E+02 -6220; 6.00000E+03 N REF123 ! PARAMETER G(LIQUID,CR,N;0) 2.98150E+02 -161800-16.11*T; 6.00000E+03 N REF128 ! PARAMETER G(LIQUID,CR,N;1) 2.98150E+02 65508; 6.00000E+03 N REF128 ! PARAMETER G(LIQUID,CR,N,NI;0) 2.98150E+02 -89400; 6.00000E+03 N REF129 ! PARAMETER G(LIQUID,CR,NI;0) 2.98150E+02 +318-7.3318*T; 6.00000E+03 N REF322 ! PARAMETER G(LIQUID,CR,NI;1) 2.98150E+02 +16941-6.3696*T; 6.00000E+03 N REF322 ! PARAMETER G(LIQUID,FE,MN;0) 2.98150E+02 -3950+.489*T; 6.00000E+03 N REF261 ! PARAMETER G(LIQUID,FE,MN;1) 2.98150E+02 1145; 6.00000E+03 N REF261 ! PARAMETER G(LIQUID,FE,MO;0) 2.98150E+02 -6973-.37*T; 6.00000E+03 N REF10 ! PARAMETER G(LIQUID,FE,MO;1) 2.98150E+02 -9424+4.502*T; 6.00000E+03 N REF10 ! PARAMETER G(LIQUID,FE,MO,NI;0) 2.98150E+02 50000; 6.00000E+03 N REF132 ! PARAMETER G(LIQUID,FE,N;0) 2.98150E+02 -19930-12.01*T; 6.00000E+03 N REF128 ! PARAMETER G(LIQUID,FE,NI;0) 2.98150E+02 -18378.86+6.03912*T; 6.00000E+03 N REF158 ! PARAMETER G(LIQUID,FE,NI;1) 2.98150E+02 +9228.1-3.54642*T; 6.00000E+03 N REF158 ! PARAMETER G(LIQUID,MN,N;0) 2.98150E+02 -142308+6.0759*T; 2.50000E+03 N REF317 ! PARAMETER G(LIQUID,MN,N;1) 2.98150E+02 32906; 2.50000E+03 N REF317 ! PARAMETER G(LIQUID,MN,NI;0) 2.98150E+02 -69233.16+10.54315*T; 6.00000E+03 N REF182 ! PARAMETER G(LIQUID,MN,NI;1) 2.98150E+02 7258.05; 6.00000E+03 N REF182 ! PARAMETER G(LIQUID,MO,N;0) 2.98150E+02 -198280+37.49*T; 6.00000E+03 N REF128 ! PARAMETER G(LIQUID,MO,NI;0) 2.98150E+02 -46540+19.53*T; 6.00000E+03 N REF125 ! PARAMETER G(LIQUID,MO,NI;1) 2.98150E+02 2915; 6.00000E+03 N REF125 ! PARAMETER G(LIQUID,N,NI;0) 2.98150E+02 14981; 6.00000E+03 N REF129 ! PHASE AL3NI2 % 2 .6 .4 ! CONSTITUENT AL3NI2 :NI : NI% : ! PARAMETER G(AL3NI2,NI:NI;0) 2.98150E+02 +GHCPNI#; 6.00000E+03 N REF95 ! PHASE ALNI_B2 % 2 .5 .5 ! CONSTITUENT ALNI_B2 :NI%,VA : NI : ! PARAMETER G(ALNI_B2,NI:NI;0) 2.98150E+02 +3109+4.721*T-.0043572*T**2 +1.06896E-06*T**3+GHSERNI#; 6.00000E+03 N REF95 ! PARAMETER G(ALNI_B2,VA:NI;0) 2.98150E+02 +108736-5.062*T+.5*GHSERNI#; 6.00000E+03 N REF95 ! TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! PHASE BCC_A2 %& 2 1 3 ! CONSTITUENT BCC_A2 :CR%,FE%,MN,MO%,NI : N,VA% : ! PARAMETER G(BCC_A2,CR:N;0) 2.98150E+02 +GHSERCR#+3*GHSERNN#+311870 +29.12*T; 6.00000E+03 N REF128 ! PARAMETER TC(BCC_A2,CR:N;0) 2.98150E+02 -311.5; 6.00000E+03 N REF128 ! PARAMETER BMAGN(BCC_A2,CR:N;0) 2.98150E+02 -.008; 6.00000E+03 N REF128 ! PARAMETER G(BCC_A2,FE:N;0) 2.98150E+02 +93562+165.07*T+GHSERFE# +3*GHSERNN#; 6.00000E+03 N REF128 ! PARAMETER TC(BCC_A2,FE:N;0) 2.98150E+02 1043; 6.00000E+03 N REF128 ! PARAMETER BMAGN(BCC_A2,FE:N;0) 2.98150E+02 2.22; 6.00000E+03 N REF128 ! PARAMETER G(BCC_A2,MN:N;0) 2.98150E+02 -55600+606.648*T-100.41*T*LN(T) +844897*T**(-1); 2.50000E+03 N REF317 ! PARAMETER G(BCC_A2,MO:N;0) 2.98150E+02 +GHSERMO#+3*GHSERNN#+299700 +79.73*T; 6.00000E+03 N REF128 ! PARAMETER G(BCC_A2,NI:N;0) 2.98150E+02 +200000+200*T+GHSERNI# +3*GHSERNN#; 6.00000E+03 N REF123 ! PARAMETER TC(BCC_A2,NI:N;0) 2.98150E+02 575; 6.00000E+03 N REF123 ! PARAMETER BMAGN(BCC_A2,NI:N;0) 2.98150E+02 .85; 6.00000E+03 N REF123 ! PARAMETER G(BCC_A2,CR:VA;0) 2.98150E+02 +GHSERCR#+GPCRBCC#; 6.00000E+03 N REF283 ! PARAMETER TC(BCC_A2,CR:VA;0) 2.98150E+02 -311.5; 6.00000E+03 N REF281 ! PARAMETER BMAGN(BCC_A2,CR:VA;0) 2.98150E+02 -.01; 6.00000E+03 N REF281 ! PARAMETER G(BCC_A2,FE:VA;0) 2.98150E+02 +GHSERFE#+GPFEBCC#; 6.00000E+03 N REF283 ! PARAMETER TC(BCC_A2,FE:VA;0) 2.98150E+02 1043; 6.00000E+03 N REF281 ! PARAMETER BMAGN(BCC_A2,FE:VA;0) 2.98150E+02 2.22; 6.00000E+03 N REF281 ! PARAMETER G(BCC_A2,MN:VA;0) 2.98150E+02 +GMNBCC#; 6.00000E+03 N REF283 ! PARAMETER TC(BCC_A2,MN:VA;0) 2.98150E+02 -580; 2.00000E+03 N REF281 ! PARAMETER BMAGN(BCC_A2,MN:VA;0) 2.98150E+02 -.27; 2.00000E+03 N REF281 ! PARAMETER G(BCC_A2,MO:VA;0) 2.98150E+02 +GHSERMO#+GPMOBCC#; 5.00000E+03 N REF283 ! PARAMETER G(BCC_A2,NI:VA;0) 2.98150E+02 +GNIBCC#; 3.00000E+03 N REF283 ! PARAMETER TC(BCC_A2,NI:VA;0) 2.98150E+02 575; 6.00000E+03 N REF281 ! PARAMETER BMAGN(BCC_A2,NI:VA;0) 2.98150E+02 .85; 6.00000E+03 N REF281 ! PARAMETER G(BCC_A2,CR,FE:N;0) 2.98150E+02 -799379+293*T; 6.00000E+03 N REF126 ! PARAMETER TC(BCC_A2,CR,FE:N;0) 2.98150E+02 1650; 6.00000E+03 N REF126 ! PARAMETER TC(BCC_A2,CR,FE:N;1) 2.98150E+02 550; 6.00000E+03 N REF126 ! PARAMETER BMAGN(BCC_A2,CR,FE:N;0) 2.98150E+02 -.85; 6.00000E+03 N REF126 ! PARAMETER BMAGN(BCC_A2,CR,NI:N;0) 2.98150E+02 4; 6.00000E+03 N REF129 ! PARAMETER TC(BCC_A2,CR,NI:N;0) 2.98150E+02 2373; 6.00000E+03 N REF128 ! PARAMETER TC(BCC_A2,CR,NI:N;1) 2.98150E+02 617; 6.00000E+03 N REF128 ! PARAMETER G(BCC_A2,CR:N,VA;0) 2.98150E+02 -200000; 6.00000E+03 N REF128 ! PARAMETER G(BCC_A2,FE,MO:N;0) 2.98150E+02 -151200; 6.00000E+03 N REF134 ! PARAMETER G(BCC_A2,MN:N,VA;0) 2.98150E+02 -185000; 2.50000E+03 N REF317 ! PARAMETER G(BCC_A2,CR,FE:VA;0) 2.98150E+02 +20500-9.68*T; 6.00000E+03 N REF107 ! PARAMETER TC(BCC_A2,CR,FE:VA;0) 2.98150E+02 1650; 6.00000E+03 N REF107 ! PARAMETER TC(BCC_A2,CR,FE:VA;1) 2.98150E+02 550; 6.00000E+03 N REF107 ! PARAMETER BMAGN(BCC_A2,CR,FE:VA;0) 2.98150E+02 -.85; 6.00000E+03 N REF107 ! PARAMETER G(BCC_A2,CR,FE,MN:VA;0) 2.98150E+02 -8374; 6.00000E+03 N REF326 ! PARAMETER G(BCC_A2,CR,FE,NI:VA;0) 2.98150E+02 -2673+2.0415*T; 6.00000E+03 N REF322 ! PARAMETER G(BCC_A2,CR,MN:VA;0) 2.98150E+02 -20328+18.7339*T; 6.00000E+03 N REF326 ! PARAMETER G(BCC_A2,CR,MN:VA;1) 2.98150E+02 -9162+4.4183*T; 6.00000E+03 N REF326 ! PARAMETER TC(BCC_A2,CR,MN:VA;0) 2.98150E+02 -1325; 6.00000E+03 N REF326 ! PARAMETER TC(BCC_A2,CR,MN:VA;2) 2.98150E+02 -1133; 6.00000E+03 N REF326 ! PARAMETER TC(BCC_A2,CR,MN:VA;4) 2.98150E+02 -10294; 6.00000E+03 N REF326 ! PARAMETER TC(BCC_A2,CR,MN:VA;6) 2.98150E+02 26706; 6.00000E+03 N REF326 ! PARAMETER TC(BCC_A2,CR,MN:VA;8) 2.98150E+02 -28117; 6.00000E+03 N REF326 ! PARAMETER BMAGN(BCC_A2,CR,MN:VA;0) 2.98150E+02 .48643; 6.00000E+03 N REF326 ! PARAMETER BMAGN(BCC_A2,CR,MN:VA;2) 2.98150E+02 -.72035; 6.00000E+03 N REF326 ! PARAMETER BMAGN(BCC_A2,CR,MN:VA;4) 2.98150E+02 -1.93265; 6.00000E+03 N REF326 ! PARAMETER G(BCC_A2,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; 6.00000E+03 N REF123 ! PARAMETER G(BCC_A2,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 N REF123 ! PARAMETER G(BCC_A2,CR,NI:VA;0) 2.98150E+02 +17170-11.8199*T; 6.00000E+03 N REF322 ! PARAMETER G(BCC_A2,CR,NI:VA;1) 2.98150E+02 +34418-11.8577*T; 6.00000E+03 N REF322 ! PARAMETER TC(BCC_A2,CR,NI:VA;0) 2.98150E+02 2373; 6.00000E+03 N REF162 ! PARAMETER TC(BCC_A2,CR,NI:VA;1) 2.98150E+02 617; 6.00000E+03 N REF162 ! PARAMETER BMAGN(BCC_A2,CR,NI:VA;0) 2.98150E+02 4; 6.00000E+03 N REF162 ! PARAMETER G(BCC_A2,FE,MN:VA;0) 2.98150E+02 -2759+1.237*T; 6.00000E+03 N REF261 ! PARAMETER TC(BCC_A2,FE,MN:VA;0) 2.98150E+02 123; 6.00000E+03 N REF261 ! PARAMETER G(BCC_A2,FE,MO:VA;0) 2.98150E+02 +36818-9.141*T; 6.00000E+03 N REF10 ! PARAMETER G(BCC_A2,FE,MO:VA;1) 2.98150E+02 -362-5.724*T; 6.00000E+03 N REF10 ! PARAMETER TC(BCC_A2,FE,MO:VA;0) 2.98150E+02 335; 6.00000E+03 N REF10 ! PARAMETER TC(BCC_A2,FE,MO:VA;1) 2.98150E+02 526; 6.00000E+03 N REF10 ! PARAMETER G(BCC_A2,FE,MO,NI:VA;0) 2.98150E+02 -35743; 6.00000E+03 N REF132 ! PARAMETER G(BCC_A2,FE,NI:VA;0) 2.98150E+02 -956.63-1.28726*T; 6.00000E+03 N REF158 ! PARAMETER G(BCC_A2,FE,NI:VA;1) 2.98150E+02 +1789.03-1.92912*T; 6.00000E+03 N REF158 ! PARAMETER G(BCC_A2,MN,NI:VA;0) 2.98150E+02 -51638.31+3.64*T; 6.00000E+03 N REF182 ! PARAMETER G(BCC_A2,MN,NI:VA;1) 2.98150E+02 6276; 6.00000E+03 N REF182 ! PARAMETER G(BCC_A2,MO,NI:VA;0) 2.98150E+02 46422; 6.00000E+03 N REF125 ! TYPE_DEFINITION ' GES A_P_D CBCC_A12 MAGNETIC -3.0 2.80000E-01 ! PHASE CBCC_A12 %' 2 1 1 ! CONSTITUENT CBCC_A12 :CR,FE,MN%,NI : N,VA% : ! PARAMETER G(CBCC_A12,CR:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(CBCC_A12,FE:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(CBCC_A12,MN:N;0) 2.98150E+02 -53114+299.266*T -50.216*T*LN(T)+358309*T**(-1); 2.50000E+03 N REF317 ! PARAMETER G(CBCC_A12,NI:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(CBCC_A12,CR:VA;0) 2.98150E+02 +11087+2.7196*T+GHSERCR#; 6.00000E+03 N REF283 ! PARAMETER G(CBCC_A12,FE:VA;0) 2.98150E+02 +4745+GHSERFE#; 6.00000E+03 N REF283 ! PARAMETER G(CBCC_A12,MN:VA;0) 2.98150E+02 +GHSERMN#; 2.00000E+03 N REF283 ! PARAMETER TC(CBCC_A12,MN:VA;0) 2.98150E+02 -285; 2.00000E+03 N REF281 ! PARAMETER BMAGN(CBCC_A12,MN:VA;0) 2.98150E+02 -.66; 2.00000E+03 N REF281 ! PARAMETER G(CBCC_A12,NI:VA;0) 2.98150E+02 +3556+GHSERNI#; 3.00000E+03 N REF283 ! PARAMETER G(CBCC_A12,MN:N,VA;0) 2.98150E+02 -58869; 2.50000E+03 N REF317 ! PARAMETER G(CBCC_A12,CR,MN:VA;0) 2.98150E+02 -36796+20.385*T; 6.00000E+03 N REF326 ! PARAMETER G(CBCC_A12,FE,MN:VA;0) 2.98150E+02 -10184; 6.00000E+03 N REF261 ! PARAMETER G(CBCC_A12,MN,NI:VA;0) 2.98150E+02 -54754.84+17.991*T; 6.00000E+03 N REF0 ! PARAMETER G(CBCC_A12,MN,NI:VA;1) 2.98150E+02 -11924; 6.00000E+03 N REF0 ! PHASE CEMENTITE % 2 3 1 ! CONSTITUENT CEMENTITE :CR,FE%,MN,MO,NI : N : ! PARAMETER G(CEMENTITE,CR:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(CEMENTITE,FE:N;0) 2.98150E+02 -20060+538.7902*T -99.7371*T*LN(T)+226735*T**(-1); 6.00000E+03 N REF319 ! PARAMETER G(CEMENTITE,MN:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(CEMENTITE,MO:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(CEMENTITE,NI:N;0) 298.15 UN_ASS; 300 N REF0 ! PHASE CHI_A12 % 3 24 10 24 ! CONSTITUENT CHI_A12 :CR,FE : CR,MO : CR,FE,MO : ! PARAMETER G(CHI_A12,CR:CR:CR;0) 2.98150E+02 +48*GCRFCC#+10*GHSERCR# +109000+123*T; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,FE:CR:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR# +24*GCRFCC#+18300-100*T; 6.00000E+03 N REF115 ! PARAMETER G(CHI_A12,CR:MO:CR;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# +24*GCRFCC#-26000; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,FE:MO:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO# +24*GCRFCC#+32555-385*T; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,CR:CR:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR# +24*GFEFCC#+500000; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,FE:CR:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERCR# +57300-100*T; 6.00000E+03 N REF115 ! PARAMETER G(CHI_A12,CR:MO:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# +24*GFEFCC#+500000; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,FE:MO:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERMO# +305210-270*T; 6.00000E+03 N REF115 ! PARAMETER G(CHI_A12,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR# +24*GMOFCC#+500000; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,FE:CR:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR# +24*GMOFCC#+100000; 6.00000E+03 N REF115 ! PARAMETER G(CHI_A12,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# +24*GMOFCC#+500000; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO# +24*GMOFCC#+97300-100*T; 6.00000E+03 N REF115 ! PHASE CR3MN5 % 2 3 5 ! CONSTITUENT CR3MN5 :CR : MN : ! PARAMETER G(CR3MN5,CR:MN;0) 2.98150E+02 +3*GHSERCR#+5*GHSERMN#-72550 +21.1732*T; 6.00000E+03 N REF326 ! PHASE CR3SI % 2 3 1 ! CONSTITUENT CR3SI :CR% : CR : ! PARAMETER G(CR3SI,CR:CR;0) 2.98150E+02 +17008.82+4*T+4*GHSERCR#; 6.00000E+03 N REF90 ! PHASE CRSI2 % 2 1 2 ! CONSTITUENT CRSI2 :CR% : CR : ! PARAMETER G(CRSI2,CR:CR;0) 2.98150E+02 +10000+10*T+3*GHSERCR#; 6.00000E+03 N REF90 ! PHASE CUB_A13 % 2 1 1 ! CONSTITUENT CUB_A13 :CR,FE,MN%,NI : N,VA% : ! PARAMETER G(CUB_A13,CR:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(CUB_A13,FE:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(CUB_A13,MN:N;0) 2.98150E+02 -67484+299.266*T-50.216*T*LN(T) +358309*T**(-1); 2.50000E+03 N REF317 ! PARAMETER G(CUB_A13,NI:N;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(CUB_A13,CR:VA;0) 2.98150E+02 +15899+.6276*T+GHSERCR#; 6.00000E+03 N REF283 ! PARAMETER G(CUB_A13,FE:VA;0) 2.98150E+02 +3745+GHSERFE#; 6.00000E+03 N REF283 ! PARAMETER G(CUB_A13,MN:VA;0) 2.98150E+02 -5800.4+135.995*T -24.8785*T*LN(T)-.00583359*T**2+70269*T**(-1); 1.51900E+03 Y -28290.76+311.2933*T-48*T*LN(T)+3.96757E+30*T**(-9); 2.00000E+03 N REF283 ! PARAMETER G(CUB_A13,NI:VA;0) 2.98150E+02 +2092+GHSERNI#; 3.00000E+03 N REF283 ! PARAMETER G(CUB_A13,MN:N,VA;0) 2.98150E+02 -58869; 2.50000E+03 N REF317 ! PARAMETER G(CUB_A13,CR,MN:VA;0) 2.98150E+02 -31260+16.4919*T; 6.00000E+03 N REF326 ! PARAMETER G(CUB_A13,FE,MN:VA;0) 2.98150E+02 -11518+2.819*T; 6.00000E+03 N REF261 ! PARAMETER G(CUB_A13,MN,NI:VA;0) 2.98150E+02 -62040.75+26.82825*T; 6.00000E+03 N REF182 ! PARAMETER G(CUB_A13,MN,NI:VA;1) 2.98150E+02 -12370.01; 6.00000E+03 N REF182 ! TYPE_DEFINITION ( GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! PHASE FCC_A1 %( 2 1 1 ! CONSTITUENT FCC_A1 :CR,FE%,MN,MO,NI% : N,VA% : ! PARAMETER G(FCC_A1,CR:N;0) 2.98150E+02 -124460+142.16*T-8.5*T*LN(T) +GHSERCR#+GHSERNN#; 6.00000E+03 N REF128 ! PARAMETER G(FCC_A1,FE:N;0) 2.98150E+02 -20277+245.3931*T -21.2984*T*LN(T)+GHSERFE#+GHSERNN#; 6.00000E+03 N REF319 ! PARAMETER G(FCC_A1,MN:N;0) 2.98150E+02 -75940+292.226*T-50.294*T*LN(T) +265051*T**(-1); 2.50000E+03 N REF317 ! PARAMETER G(FCC_A1,MO:N;0) 2.98150E+02 +GHSERMO#+GHSERNN#-65344+149.7*T -9.78*T*LN(T); 6.00000E+03 N REF128 ! PARAMETER G(FCC_A1,NI:N;0) 2.98150E+02 +38680+143.09*T-10.9*T*LN(T) +.00438*T**2+GHSERNI#+GHSERNN#; 6.00000E+03 N REF123 ! PARAMETER G(FCC_A1,CR:VA;0) 2.98150E+02 +GCRFCC#+GPCRBCC#; 6.00000E+03 N REF281 ! PARAMETER TC(FCC_A1,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N REF281 ! PARAMETER BMAGN(FCC_A1,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N REF281 ! PARAMETER G(FCC_A1,FE:VA;0) 2.98150E+02 +GFEFCC#+GPFEFCC#; 6.00000E+03 N REF283 ! PARAMETER TC(FCC_A1,FE:VA;0) 2.98150E+02 -201; 6.00000E+03 N REF281 ! PARAMETER BMAGN(FCC_A1,FE:VA;0) 2.98150E+02 -2.1; 6.00000E+03 N REF281 ! PARAMETER G(FCC_A1,MN:VA;0) 2.98150E+02 +GMNFCC#; 6.00000E+03 N REF283 ! PARAMETER TC(FCC_A1,MN:VA;0) 2.98150E+02 -1620; 2.00000E+03 N REF281 ! PARAMETER BMAGN(FCC_A1,MN:VA;0) 2.98150E+02 -1.86; 2.00000E+03 N REF281 ! PARAMETER G(FCC_A1,MO:VA;0) 2.98150E+02 +15200+.63*T+GHSERMO#+GPMOBCC#; 5.00000E+03 N REF283 ! PARAMETER G(FCC_A1,NI:VA;0) 2.98150E+02 +GHSERNI#; 3.00000E+03 N REF283 ! PARAMETER TC(FCC_A1,NI:VA;0) 2.98150E+02 633; 6.00000E+03 N REF281 ! PARAMETER BMAGN(FCC_A1,NI:VA;0) 2.98150E+02 .52; 6.00000E+03 N REF281 ! PARAMETER G(FCC_A1,CR,FE:N;0) 2.98150E+02 -128930+86.49*T; 6.00000E+03 N REF126 ! PARAMETER G(FCC_A1,CR,FE:N;1) 2.98150E+02 24330; 6.00000E+03 N REF126 ! PARAMETER G(FCC_A1,CR,FE:N,VA;0) 2.98150E+02 -162516; 6.00000E+03 N REF126 ! PARAMETER G(FCC_A1,CR,MO:N;0) 2.98150E+02 -40000; 6.00000E+03 N REF128 ! PARAMETER G(FCC_A1,CR,NI:N,VA;0) 2.98150E+02 -661270+305*T; 6.00000E+03 N REF129 ! PARAMETER G(FCC_A1,CR:N,VA;0) 2.98150E+02 20000; 6.00000E+03 N REF128 ! PARAMETER G(FCC_A1,FE,NI:N;0) 2.98150E+02 -22710+5.19*T; 6.00000E+03 N REF129 ! PARAMETER G(FCC_A1,FE,NI:N;1) 2.98150E+02 3334; 6.00000E+03 N REF129 ! PARAMETER G(FCC_A1,FE:N,VA;0) 2.98150E+02 -26150; 6.00000E+03 N REF128 ! PARAMETER G(FCC_A1,MN:N,VA;0) 2.98150E+02 -69698+11.5845*T; 2.50000E+03 N REF317 ! PARAMETER G(FCC_A1,MO:N,VA;0) 2.98150E+02 -52565; 6.00000E+03 N REF128 ! PARAMETER G(FCC_A1,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; 6.00000E+03 N REF107 ! PARAMETER G(FCC_A1,CR,FE:VA;1) 2.98150E+02 1410; 6.00000E+03 N REF107 ! PARAMETER G(FCC_A1,CR,FE,MN:VA;0) 2.98150E+02 -6815; 6.00000E+03 N REF326 ! PARAMETER G(FCC_A1,CR,FE,NI:VA;0) 2.98150E+02 +16580-9.783*T; 6.00000E+03 N REF322 ! PARAMETER G(FCC_A1,CR,MN:VA;0) 2.98150E+02 -19088+17.5423*T; 6.00000E+03 N REF326 ! PARAMETER G(FCC_A1,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; 6.00000E+03 N REF58 ! PARAMETER G(FCC_A1,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 N REF58 ! PARAMETER G(FCC_A1,CR,MO,NI:VA;0) 2.98150E+02 -30000; 6.00000E+03 N REF58 ! PARAMETER G(FCC_A1,CR,NI:VA;0) 2.98150E+02 +8030-12.8801*T; 6.00000E+03 N REF322 ! PARAMETER G(FCC_A1,CR,NI:VA;1) 2.98150E+02 +33080-16.0362*T; 6.00000E+03 N REF322 ! PARAMETER TC(FCC_A1,CR,NI:VA;0) 2.98150E+02 -3605; 6.00000E+03 N REF162 ! PARAMETER BMAGN(FCC_A1,CR,NI:VA;0) 2.98150E+02 -1.91; 6.00000E+03 N REF162 ! PARAMETER G(FCC_A1,FE,MN:VA;0) 2.98150E+02 -7762+3.865*T; 6.00000E+03 N REF261 ! PARAMETER G(FCC_A1,FE,MN:VA;1) 2.98150E+02 -259; 6.00000E+03 N REF261 ! PARAMETER TC(FCC_A1,FE,MN:VA;0) 2.98150E+02 -2282; 6.00000E+03 N REF261 ! PARAMETER TC(FCC_A1,FE,MN:VA;1) 2.98150E+02 -2068; 6.00000E+03 N REF261 ! PARAMETER G(FCC_A1,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; 6.00000E+03 N REF10 ! PARAMETER G(FCC_A1,FE,MO,NI:VA;0) 2.98150E+02 -204791+163.93*T; 6.00000E+03 N REF132 ! PARAMETER G(FCC_A1,FE,MO,NI:VA;1) 2.98150E+02 +11555-55.81*T; 6.00000E+03 N REF132 ! PARAMETER G(FCC_A1,FE,MO,NI:VA;2) 2.98150E+02 77975; 6.00000E+03 N REF132 ! PARAMETER G(FCC_A1,FE,NI:VA;0) 2.98150E+02 -12054.355+3.27413*T; 6.00000E+03 N REF158 ! PARAMETER G(FCC_A1,FE,NI:VA;1) 2.98150E+02 +11082.1315-4.45077*T; 6.00000E+03 N REF158 ! PARAMETER G(FCC_A1,FE,NI:VA;2) 2.98150E+02 -725.805174; 6.00000E+03 N REF158 ! PARAMETER TC(FCC_A1,FE,NI:VA;0) 2.98150E+02 2133; 6.00000E+03 N REF158 ! PARAMETER TC(FCC_A1,FE,NI:VA;1) 2.98150E+02 -682; 6.00000E+03 N REF158 ! PARAMETER BMAGN(FCC_A1,FE,NI:VA;0) 2.98150E+02 9.55; 6.00000E+03 N REF158 ! PARAMETER BMAGN(FCC_A1,FE,NI:VA;1) 2.98150E+02 7.23; 6.00000E+03 N REF158 ! PARAMETER BMAGN(FCC_A1,FE,NI:VA;2) 2.98150E+02 5.93; 6.00000E+03 N REF158 ! PARAMETER BMAGN(FCC_A1,FE,NI:VA;3) 2.98150E+02 6.18; 6.00000E+03 N REF158 ! PARAMETER G(FCC_A1,MN,NI:VA;0) 2.98150E+02 -58158+10.878*T; 6.00000E+03 N REF182 ! PARAMETER G(FCC_A1,MN,NI:VA;1) 2.98150E+02 6276; 6.00000E+03 N REF182 ! PARAMETER G(FCC_A1,MO,NI:VA;0) 2.98150E+02 +4803.7-5.96*T; 6.00000E+03 N REF125 ! PARAMETER G(FCC_A1,MO,NI:VA;1) 2.98150E+02 10880; 6.00000E+03 N REF125 ! PHASE FE4N % 2 4 1 ! CONSTITUENT FE4N :FE,NI : N,VA : ! PARAMETER G(FE4N,FE:N;0) 2.98150E+02 -37514+72.6235*T+4*GHSERFE# +GHSERNN#; 6.00000E+03 N REF319 ! PARAMETER G(FE4N,NI:N;0) 2.98150E+02 -5393+142.97*T-15.65*T*LN(T) +.0154*T**2+4*GHSERNI#+GHSERNN#; 6.00000E+03 N REF129 ! PARAMETER G(FE4N,FE:VA;0) 2.98150E+02 +4*GFEFCC#+10; 6.00000E+03 N REF319 ! PARAMETER G(FE4N,NI:VA;0) 2.98150E+02 +4*GHSERNI#+10; 6.00000E+03 N REF59 ! PARAMETER G(FE4N,FE:N,VA;0) 2.98150E+02 +64679-21.9574*T; 6.00000E+03 N REF319 ! PARAMETER G(FE4N,FE:N,VA;1) 2.98150E+02 -27905-3.0409*T; 6.00000E+03 N REF319 ! PHASE FECN_CHI % 2 5 2 ! CONSTITUENT FECN_CHI :FE : N : ! PARAMETER G(FECN_CHI,FE:N;0) 2.98150E+02 -53838+952.0774*T -174.5248*T*LN(T)+438672*T**(-1); 6.00000E+03 N REF319 ! TYPE_DEFINITION ) GES A_P_D HCP_A3 MAGNETIC -3.0 2.80000E-01 ! PHASE HCP_A3 %) 2 1 .5 ! CONSTITUENT HCP_A3 :CR,FE,MN,MO,NI : N,VA% : ! PARAMETER G(HCP_A3,CR:N;0) 2.98150E+02 -65760+64.69*T-3.93*T*LN(T) +GHSERCR#+.5*GHSERNN#; 6.00000E+03 N REF128 ! PARAMETER G(HCP_A3,FE:N;0) 2.98150E+02 -13863+40.2123*T+GHSERFE# +.5*GHSERNN#; 6.00000E+03 N REF319 ! PARAMETER G(HCP_A3,MN:N;0) 2.98150E+02 -60607+211.1804*T -37.7331*T*LN(T)+129442*T**(-1); 2.50000E+03 N REF317 ! PARAMETER G(HCP_A3,MO:N;0) 2.98150E+02 +GHSERMO#+.5*GHSERNN#-29450 +28.7*T; 6.00000E+03 N REF128 ! PARAMETER G(HCP_A3,NI:N;0) 2.98150E+02 -4409.6+72.93*T-7.36*T*LN(T) +.00614*T**2+GHSERNI#+.5*GHSERNN#; 6.00000E+03 N REF123 ! PARAMETER G(HCP_A3,CR:VA;0) 2.98150E+02 +4438+GHSERCR#+GPCRBCC#; 6.00000E+03 N REF283 ! PARAMETER TC(HCP_A3,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N REF281 ! PARAMETER BMAGN(HCP_A3,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N REF281 ! PARAMETER G(HCP_A3,FE:VA;0) 2.98150E+02 -3705.78+12.591*T-1.15*T*LN(T) +6.4E-04*T**2+GHSERFE#+GPFEHCP#; 1.81100E+03 Y -3957.199+5.24951*T+4.9251E+30*T**(-9)+GHSERFE#+GPFEHCP#; 6.00000E+03 N REF283 ! PARAMETER G(HCP_A3,MN:VA;0) 2.98150E+02 -4439.3+133.007*T -24.5177*T*LN(T)-.006*T**2+69600*T**(-1); 1.51900E+03 Y -27070.1+310.7894*T-48*T*LN(T)+3.86196E+30*T**(-9); 2.00000E+03 N REF283 ! PARAMETER TC(HCP_A3,MN:VA;0) 2.98150E+02 -1620; 2.00000E+03 N REF281 ! PARAMETER BMAGN(HCP_A3,MN:VA;0) 2.98150E+02 -1.86; 2.00000E+03 N REF281 ! PARAMETER G(HCP_A3,MO:VA;0) 2.98150E+02 +11550+GHSERMO#+GPMOBCC#; 5.00000E+03 N REF283 ! PARAMETER G(HCP_A3,NI:VA;0) 2.98150E+02 +1046+1.255*T+GHSERNI#; 3.00000E+03 N REF283 ! PARAMETER TC(HCP_A3,NI:VA;0) 2.98150E+02 633; 6.00000E+03 N REF26 ! PARAMETER BMAGN(HCP_A3,NI:VA;0) 2.98150E+02 .52; 6.00000E+03 N REF26 ! PARAMETER G(HCP_A3,CR,FE:N;0) 2.98150E+02 +12826-19.48*T; 6.00000E+03 N REF126 ! PARAMETER G(HCP_A3,CR,MO:N;0) 2.98150E+02 -8754; 6.00000E+03 N REF128 ! PARAMETER G(HCP_A3,CR,NI:N;0) 2.98150E+02 1443; 6.00000E+03 N REF129 ! PARAMETER G(HCP_A3,CR:N,VA;0) 2.98150E+02 +21120-10.61*T; 6.00000E+03 N REF128 ! PARAMETER G(HCP_A3,CR:N,VA;1) 2.98150E+02 -6204; 6.00000E+03 N REF128 ! PARAMETER G(HCP_A3,FE:N,VA;0) 2.98150E+02 +10012-19.9853*T; 6.00000E+03 N REF319 ! PARAMETER G(HCP_A3,FE:N,VA;1) 2.98150E+02 -9446+9.3472*T; 6.00000E+03 N REF319 ! PARAMETER G(HCP_A3,MN:N,VA;0) 2.98150E+02 -7194-5.2075*T; 2.50000E+03 N REF317 ! PARAMETER G(HCP_A3,MN:N,VA;1) 2.98150E+02 -11810+6.9538*T; 2.50000E+03 N REF317 ! PARAMETER G(HCP_A3,MO,NI:N;0) 2.98150E+02 -80000; 6.00000E+03 N REF134 ! PARAMETER G(HCP_A3,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; 6.00000E+03 N REF126 ! PARAMETER G(HCP_A3,CR,MN:VA;0) 2.98150E+02 41800; 6.00000E+03 N REF326 ! PARAMETER G(HCP_A3,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; 6.00000E+03 N REF117 ! PARAMETER G(HCP_A3,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 N REF117 ! PARAMETER G(HCP_A3,FE,MN:VA;0) 2.98150E+02 -5582+3.865*T; 6.00000E+03 N REF261 ! PARAMETER G(HCP_A3,FE,MN:VA;1) 2.98150E+02 273; 6.00000E+03 N REF261 ! PARAMETER G(HCP_A3,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; 6.00000E+03 N REF10 ! PARAMETER G(HCP_A3,FE,NI:VA;0) 2.98150E+02 -12054.355+3.27413*T; 6.00000E+03 N REF158 ! PARAMETER G(HCP_A3,FE,NI:VA;1) 2.98150E+02 +11082-4.45077*T; 6.00000E+03 N REF158 ! PARAMETER G(HCP_A3,FE,NI:VA;2) 2.98150E+02 -725.8; 6.00000E+03 N REF158 ! PHASE HIGH_SIGMA % 3 8 4 18 ! CONSTITUENT HIGH_SIGMA :MN : CR : CR,MN : ! PARAMETER G(HIGH_SIGMA,MN:CR:CR;0) 2.98150E+02 +8*GMNFCC#+22*GHSERCR# -192369+152.4742*T; 6.00000E+03 N REF326 ! PARAMETER G(HIGH_SIGMA,MN:CR:MN;0) 2.98150E+02 +8*GMNFCC#+4*GHSERCR# +18*GMNBCC#-74263-10.7082*T; 6.00000E+03 N REF326 ! PARAMETER G(HIGH_SIGMA,MN:CR:CR,MN;0) 2.98150E+02 90000; 6.00000E+03 N REF326 ! PHASE LAVES_PHASE % 2 2 1 ! CONSTITUENT LAVES_PHASE :CR,FE : MO : ! PARAMETER G(LAVES_PHASE,CR:MO;0) 2.98150E+02 +2*GCRFCC#+GHSERMO#-8000 -6*T; 6.00000E+03 N REF214 ! PARAMETER G(LAVES_PHASE,FE:MO;0) 2.98150E+02 -10798-.132*T+2*GFEFCC# +GHSERMO#; 6.00000E+03 N REF10 ! PHASE MC_ETA % 2 1 1 ! CONSTITUENT MC_ETA :MO% : VA : ! PARAMETER G(MC_ETA,MO:VA;0) 2.98150E+02 +GHSERMO#+15200+.63*T; 6.00000E+03 N REF113 ! PHASE MN4N % 2 4 1 ! CONSTITUENT MN4N :MN : N : ! PARAMETER G(MN4N,MN:N;0) 2.98150E+02 -155790+691.0638*T -126.9328*T*LN(T)+307417*T**(-1); 2.50000E+03 N REF317 ! PHASE MN6N4 % 2 6 4 ! CONSTITUENT MN6N4 :MN : N : ! PARAMETER G(MN6N4,MN:N;0) 2.98150E+02 -465614+1428.332*T -251.337*T*LN(T)+1027898*T**(-1); 2.50000E+03 N REF317 ! PHASE MN6N5 % 2 6 5 ! CONSTITUENT MN6N5 :MN : N : ! PARAMETER G(MN6N5,MN:N;0) 2.98150E+02 -546880+1591.607*T -276.668*T*LN(T)+1297983*T**(-1); 2.50000E+03 N REF317 ! PHASE MONI3_GAMMA % 2 1 3 ! CONSTITUENT MONI3_GAMMA :MO : NI : ! PARAMETER G(MONI3_GAMMA,MO:NI;0) 2.98150E+02 +3*GHSERNI#+GHSERMO#-4199 -7*T; 6.00000E+03 N REF125 ! PHASE MONI4_BETA % 2 1 4 ! CONSTITUENT MONI4_BETA :MO : NI : ! PARAMETER G(MONI4_BETA,MO:NI;0) 2.98150E+02 +4*GHSERNI#+GHSERMO#-4330 -9.21*T; 6.00000E+03 N REF125 ! PHASE MONI_DELTA % 3 24 20 12 ! CONSTITUENT MONI_DELTA :CR,FE,NI : CR,FE,MO,NI : MO : ! PARAMETER G(MONI_DELTA,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR# +12*GHSERMO#+50000; 6.00000E+03 N REF133 ! PARAMETER G(MONI_DELTA,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(MONI_DELTA,NI:CR:MO;0) 2.98150E+02 +24*GHSERNI#+20*GHSERCR# +12*GHSERMO#-200000; 6.00000E+03 N REF133 ! PARAMETER G(MONI_DELTA,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(MONI_DELTA,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE# +12*GHSERMO#+100000; 6.00000E+03 N REF132 ! PARAMETER G(MONI_DELTA,NI:FE:MO;0) 2.98150E+02 +24*GHSERNI#+20*GHSERFE# +12*GHSERMO#; 6.00000E+03 N REF132 ! PARAMETER G(MONI_DELTA,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO# +100000; 6.00000E+03 N REF133 ! PARAMETER G(MONI_DELTA,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO# +100000; 6.00000E+03 N REF132 ! PARAMETER G(MONI_DELTA,NI:MO:MO;0) 2.98150E+02 +24*GHSERNI#+32*GHSERMO# -212100+1089*T-142*T*LN(T); 6.00000E+03 N REF125 ! PARAMETER G(MONI_DELTA,CR:NI:MO;0) 2.98150E+02 +24*GCRFCC#+20*GNIBCC# +12*GHSERMO#-200000; 6.00000E+03 N REF133 ! PARAMETER G(MONI_DELTA,FE:NI:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERNI# +12*GHSERMO#; 6.00000E+03 N REF132 ! PARAMETER G(MONI_DELTA,NI:NI:MO;0) 2.98150E+02 +24*GHSERNI#+20*GNIBCC# +12*GHSERMO#-1030-93.5*T+13.5*T*LN(T); 6.00000E+03 N REF125 ! PHASE MU_PHASE % 3 7 2 4 ! CONSTITUENT MU_PHASE :CR,FE,NI : MO : CR,FE,MO,NI : ! PARAMETER G(MU_PHASE,CR:MO:CR;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO# +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 ! PARAMETER G(MU_PHASE,FE:MO:CR;0) 2.98150E+02 +7*GFEFCC#+2*GHSERMO# +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 ! PARAMETER G(MU_PHASE,NI:MO:CR;0) 2.98150E+02 +7*GHSERNI#+2*GHSERMO# +4*GHSERCR#; 6.00000E+03 N REF136 ! PARAMETER G(MU_PHASE,CR:MO:FE;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO# +4*GHSERFE#+130000-100*T; 6.00000E+03 N REF115 ! PARAMETER G(MU_PHASE,FE:MO:FE;0) 2.98150E+02 +39475-6.032*T+7*GFEFCC# +2*GHSERMO#+4*GHSERFE#+GPMU1#; 6.00000E+03 N REF10 ! PARAMETER G(MU_PHASE,NI:MO:FE;0) 2.98150E+02 +7*GHSERNI#+2*GHSERMO# +4*GHSERFE#+784294-249.607*T; 6.00000E+03 N REF132 ! PARAMETER G(MU_PHASE,CR:MO:MO;0) 2.98150E+02 +7*GCRFCC#+6*GHSERMO# +130000-100*T; 6.00000E+03 N REF115 ! PARAMETER G(MU_PHASE,FE:MO:MO;0) 2.98150E+02 -46663-5.891*T+7*GFEFCC# +6*GHSERMO#+GPMU2#; 6.00000E+03 N REF10 ! PARAMETER G(MU_PHASE,NI:MO:MO;0) 2.98150E+02 +7*GHSERNI#+6*GHSERMO# +28506-47.3*T; 6.00000E+03 N REF132 ! PARAMETER G(MU_PHASE,CR:MO:NI;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO# +4*GNIBCC#; 6.00000E+03 N REF136 ! PARAMETER G(MU_PHASE,FE:MO:NI;0) 2.98150E+02 +7*GFEFCC#+2*GHSERMO# +4*GHSERNI#+354030-229.4*T; 6.00000E+03 N REF132 ! PARAMETER G(MU_PHASE,NI:MO:NI;0) 2.98150E+02 +7*GHSERNI#+2*GHSERMO# +4*GNIBCC#+398566-200*T; 6.00000E+03 N REF132 ! PARAMETER G(MU_PHASE,CR,FE:MO:MO;0) 2.98150E+02 -45000; 6.00000E+03 N REF115 ! PHASE PI % 3 12.8 7.2 4 ! CONSTITUENT PI :CR : FE,NI : N : ! PARAMETER G(PI,CR:FE:N;0) 2.98150E+02 -160994+12.8*GHSERCR# +7.2*GHSERFE#+4*GHSERNN#; 6.00000E+03 N REF129 ! PARAMETER G(PI,CR:NI:N;0) 2.98150E+02 -651800+316*T+12.8*GHSERCR# +7.2*GHSERNI#+4*GHSERNN#; 6.00000E+03 N REF129 ! PHASE P_PHASE % 3 24 20 12 ! CONSTITUENT P_PHASE :CR,FE,NI : CR,FE,MO,NI : MO : ! PARAMETER G(P_PHASE,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR# +12*GHSERMO#+252300-100*T; 6.00000E+03 N REF133 ! PARAMETER G(P_PHASE,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(P_PHASE,NI:CR:MO;0) 2.98150E+02 +24*GHSERNI#+20*GHSERCR# +12*GHSERMO#-341858; 6.00000E+03 N REF133 ! PARAMETER G(P_PHASE,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(P_PHASE,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE# +12*GHSERMO#+111361; 6.00000E+03 N REF132 ! PARAMETER G(P_PHASE,NI:FE:MO;0) 2.98150E+02 +24*GHSERNI#+20*GHSERFE# +12*GHSERMO#-170245+100*T; 6.00000E+03 N REF132 ! PARAMETER G(P_PHASE,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO# +95573-200*T; 6.00000E+03 N REF133 ! PARAMETER G(P_PHASE,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO# +362525-332.7*T; 6.00000E+03 N REF132 ! PARAMETER G(P_PHASE,NI:MO:MO;0) 2.98150E+02 +24*GHSERNI#+32*GHSERMO# +26739-100*T; 6.00000E+03 N REF132 ! PARAMETER G(P_PHASE,CR:NI:MO;0) 2.98150E+02 +24*GCRFCC#+20*GNIBCC# +12*GHSERMO#-434085; 6.00000E+03 N REF133 ! PARAMETER G(P_PHASE,FE:NI:MO;0) 2.98150E+02 +24*GFEFCC#+20*GNIBCC# +12*GHSERMO#; 6.00000E+03 N REF132 ! PARAMETER G(P_PHASE,NI:NI:MO;0) 2.98150E+02 +24*GHSERNI#+20*GNIBCC# +12*GHSERMO#+208845-100*T; 6.00000E+03 N REF132 ! PHASE R_PHASE % 3 27 14 12 ! CONSTITUENT R_PHASE :CR,FE,NI : MO : CR,FE,MO,NI : ! PARAMETER G(R_PHASE,CR:MO:CR;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO# +12*GHSERCR#-20000; 6.00000E+03 N REF115 ! PARAMETER G(R_PHASE,FE:MO:CR;0) 2.98150E+02 +27*GFEFCC#+14*GHSERMO# +12*GHSERCR#+600260-620*T; 6.00000E+03 N REF115 ! PARAMETER G(R_PHASE,NI:MO:CR;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(R_PHASE,CR:MO:FE;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO# +12*GHSERFE#+645260-620*T; 6.00000E+03 N REF115 ! PARAMETER G(R_PHASE,FE:MO:FE;0) 2.98150E+02 -77487-50.486*T+27*GFEFCC# +14*GHSERMO#+12*GHSERFE#+GPR1#; 6.00000E+03 N REF10 ! PARAMETER G(R_PHASE,NI:MO:FE;0) 2.98150E+02 +27*GHSERNI#+14*GHSERMO# +12*GHSERFE#; 6.00000E+03 N REF132 ! PARAMETER G(R_PHASE,CR:MO:MO;0) 2.98150E+02 +27*GCRFCC#+26*GHSERMO# -20000; 6.00000E+03 N REF115 ! PARAMETER G(R_PHASE,FE:MO:MO;0) 2.98150E+02 +313474-289.472*T +27*GFEFCC#+26*GHSERMO#+GPR2#; 6.00000E+03 N REF10 ! PARAMETER G(R_PHASE,NI:MO:MO;0) 2.98150E+02 +27*GHSERNI#+26*GHSERMO# -18000; 6.00000E+03 N REF132 ! PARAMETER G(R_PHASE,CR:MO:NI;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(R_PHASE,FE:MO:NI;0) 2.98150E+02 +27*GFEFCC#+14*GHSERMO# +12*GNIBCC#; 6.00000E+03 N REF132 ! PARAMETER G(R_PHASE,NI:MO:NI;0) 2.98150E+02 +27*GHSERNI#+14*GHSERMO# +12*GNIBCC#+100000; 6.00000E+03 N REF132 ! PHASE SIGMA % 3 8 4 18 ! CONSTITUENT SIGMA :FE,MN,NI : CR,MO : CR,FE,MN,MO,NI : ! PARAMETER G(SIGMA,FE:CR:CR;0) 2.98150E+02 +8*GFEFCC#+22*GHSERCR#+92300 -95.96*T+GPSIG1#; 6.00000E+03 N REF107 ! PARAMETER G(SIGMA,MN:CR:CR;0) 2.98150E+02 +8*GMNFCC#+22*GHSERCR# +65859.5; 6.00000E+03 N REF326 ! PARAMETER G(SIGMA,NI:CR:CR;0) 2.98150E+02 +8*GHSERNI#+22*GHSERCR# +221157-227*T; 6.00000E+03 N REF322 ! PARAMETER G(SIGMA,FE:MO:CR;0) 2.98150E+02 +8*GFEFCC#+4*GHSERMO# +18*GHSERCR#+488480-360*T; 6.00000E+03 N REF115 ! PARAMETER G(SIGMA,MN:MO:CR;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(SIGMA,NI:MO:CR;0) 2.98150E+02 +8*GHSERNI#+4*GHSERMO# +18*GHSERCR#+386423; 6.00000E+03 N REF133 ! PARAMETER G(SIGMA,FE:CR:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# +18*GHSERFE#+117300-95.96*T+GPSIG2#; 6.00000E+03 N REF107 ! PARAMETER G(SIGMA,MN:CR:FE;0) 2.98150E+02 +8*GMNFCC#+4*GHSERCR# +18*GHSERFE#-95576-45.2*T; 6.00000E+03 N REF0 ! PARAMETER G(SIGMA,NI:CR:FE;0) 2.98150E+02 +8*GHSERNI#+4*GHSERCR# +18*GHSERFE#; 6.00000E+03 N REF136 ! PARAMETER G(SIGMA,FE:MO:FE;0) 2.98150E+02 -1813-27.272*T+8*GFEFCC# +18*GHSERFE#+4*GHSERMO#; 6.00000E+03 N REF10 ! PARAMETER G(SIGMA,MN:MO:FE;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(SIGMA,NI:MO:FE;0) 2.98150E+02 +8*GHSERNI#+18*GHSERFE# +4*GHSERMO#+658600-200*T; 6.00000E+03 N REF132 ! PARAMETER G(SIGMA,FE:CR:MN;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# +18*GMNBCC#-83640+18.26*T; 6.00000E+03 N REF0 ! PARAMETER G(SIGMA,MN:CR:MN;0) 2.98150E+02 +8*GMNFCC#+4*GHSERCR# +18*GMNBCC#-172946+69.0245*T; 6.00000E+03 N REF326 ! PARAMETER G(SIGMA,NI:CR:MN;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(SIGMA,FE:MO:MN;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(SIGMA,MN:MO:MN;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(SIGMA,NI:MO:MN;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(SIGMA,FE:CR:MO;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# +18*GHSERMO#+312580-260*T; 6.00000E+03 N REF115 ! PARAMETER G(SIGMA,MN:CR:MO;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(SIGMA,NI:CR:MO;0) 2.98150E+02 +8*GHSERNI#+18*GHSERMO# +4*GHSERCR#-131651; 6.00000E+03 N REF133 ! PARAMETER G(SIGMA,FE:MO:MO;0) 2.98150E+02 +83326-69.618*T+8*GFEFCC# +22*GHSERMO#; 6.00000E+03 N REF10 ! PARAMETER G(SIGMA,MN:MO:MO;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(SIGMA,NI:MO:MO;0) 2.98150E+02 +8*GHSERNI#+22*GHSERMO#+85662; 6.00000E+03 N REF133 ! PARAMETER G(SIGMA,FE:CR:NI;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# +18*GNIBCC#; 6.00000E+03 N REF136 ! PARAMETER G(SIGMA,MN:CR:NI;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(SIGMA,NI:CR:NI;0) 2.98150E+02 +8*GHSERNI#+4*GHSERCR# +18*GNIBCC#+175400; 6.00000E+03 N REF200 ! PARAMETER G(SIGMA,FE:MO:NI;0) 2.98150E+02 +8*GFEFCC#+18*GNIBCC# +4*GHSERMO#+408600-200*T; 6.00000E+03 N REF132 ! PARAMETER G(SIGMA,MN:MO:NI;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(SIGMA,NI:MO:NI;0) 2.98150E+02 +8*GHSERNI#+4*GHSERMO# +18*GNIBCC#-16385; 6.00000E+03 N REF133 ! PARAMETER G(SIGMA,FE:CR:CR,MN;0) 2.98150E+02 -1095771+862.0312*T; 6.00000E+03 N REF326 ! PARAMETER G(SIGMA,FE:CR:CR,MO;0) 2.98150E+02 -148000; 6.00000E+03 N REF115 ! PARAMETER G(SIGMA,MN:CR:CR,MN;0) 2.98150E+02 -1095771+862.0312*T; 6.00000E+03 N REF326 ! PARAMETER G(SIGMA,FE:MO:CR,MO;0) 2.98150E+02 121000; 6.00000E+03 N REF115 ! PARAMETER G(SIGMA,FE:CR:FE,MO;0) 2.98150E+02 570000; 6.00000E+03 N REF115 ! PARAMETER G(SIGMA,FE:MO:FE,MO;0) 2.98150E+02 222909; 6.00000E+03 N REF10 ! PARAMETER G(SIGMA,FE,NI:MO:MO;0) 2.98150E+02 -164570-10*T; 6.00000E+03 N REF132 ! LIST_OF_REFERENCES NUMBER SOURCE REF283 'Alan Dinsdale, SGTE Data for Pure Elements, Calphad Vol 15(1991) p 317-425, also in NPL Report DMA(A)195 Rev. August 1990' REF95 'I Ansara, P Willemin B Sundman (1988); Al-Ni' REF128 'K. Frisk, TRITA-MAC 393 (1989); CR-N,FE-N,MO-N,CR-MO-N' REF317 'Caian Qui and Armando Fernandez Guillermet, Trita-MAC 472 (1991); Mn-N' REF123 'K. Frisk, Report D 60, KTH, (1984); CR-MO' REF319 'H. Du and M. Hillert, revision; C-Fe-N' REF213 'P. Gustafson, TRITA-MAC 342, (1987); CR-FE-W' REF115 'J-O Andersson, Met Trans A, Vol 19A, (1988) p 1385-1394 TRITA 0322 (1986); CR-FE-MO' REF326 'Byeong-Joo Lee, unpublished revision (1991), Cr-Mn' REF90 'I Ansara, unpublished work (1991); Cr-Si' REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 September 1989' REF129 'K. Frisk, TRITA-MAC 422 (1990); CR-FE-N-NI' REF59 'B. Sundman, fix' REF214 'P. Gustafson, TRITA-MAC 354 (1987); C-Cr-Fe-Mo-W' REF10 'A. Fernandez Guillermet, CALPHAD Vol 6 (1982), p 127-140 (sigma phase revised 1986), TRITA-MAC 200 (1982); FE-MO' REF113 'J-O Andersson, Calphad Vol 12 (1988), p 9-23 TRITA 0321 (1986); C-FE-MO' REF125 'K. Frisk, Calphad (1990), Vol 14, p 311-320; MO-NI' REF133 'K. Frisk, TRITA-MAC 429 (1990); CR-MO-NI' REF132 'K. Frisk, TRITA-MAC 428 (1990); FE-MO-NI' REF136 'Unassessed parameter, linear combination of unary data. (MU, SIGMA)' REF107 'J-O Andersson, B. Sundman, CALPHAD Vol 11, (1987), p 83-92 TRITA 0270 (1986); CR-FE' REF322 'Byeong-Joo Lee, unpublished revision (1991); C-Cr-Fe-Ni' REF200 'P. Gustafson, Calphad Vol 11 (1987) p 277-292, TRITA-MAC 320 (1986); CR-NI-W ' REF261 'W. Huang, Calphad Vol 13 (1989) pp 243-252, TRITA-MAC 388 (rev 1989); FE-MN' REF158 'A. Dinsdale, T. Chart, MTDS NPL, unpublished work (1986); FE-NI' REF182 'NPL, unpublished work (1989); Mn-Ni' REF126 'K. Frisk, Metall. Trans. Vol 21A (1990) p 2477-2488, TRITA 0409 (1989); CR-FE-N' REF134 'K. Frisk, TRITA-MAC 433 (1990); FE-CR-MO-NI-N' REF58 'B. Sundman, TEST' REF117 'J-O Andersson, TRITA-MAC 323 (1986); C-CR-FE-MO' REF162 'A. Dinsdale, T. Chart, MTDS NPL, Unpublished work (1986); CR-NI' REF26 'A. Fernandez Guillermet, Z. Metallkde. Vol 79(1988) p.524-536, TRITA-MAC 362 (1988); C-CO-NI AND C-CO-FE-NI' ! ================================================ FILE: examples/macros/save.OCM ================================================ new YES @$ ==================================================================== @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ save.OCM @$ testing unformatted save and read @$ ==================================================================== @$ @& @$ read a TDB file and make a calculation set echo Y r t ./steel7 @& l sh a @& @$ Set reference state for Cr set ref cr bcc * 1e5 set c t=1200 p=1e5 n=1 x(c)=.05 x(cr)=.05 x(mo)=.05 x(si)=.003 x(v)=.01 c e @& l,,,, @$ We will check this again after save/read unformatted debug symbol gs -5.9405966E4 @& @$ enter some state variable functions enter symb cp = h.t; calc sym cp enter symb htr = hm(liq)-hm(bcc); enter symb gcr = ac(cr)/x(bcc,cr); @& list symb calc symb @& @$ list the equilibrium status code l sh p @& @$ Save workspaces unformatted on a file, final Y to overwrite!! save unf steel7unf Y @$ NOTE steel7unf.OCU will be saved on the WORKING DIRECTORY @$ which may not be the same as the directory of the macro! @$ This means we must not use "./" as prefix when we read the file ... @& @$ Reinitiate the program and delete all data and results new Y l d,,, @& @$ Read the the unformatted file with data and the last calculation @$ DO NOT USE the prefix ./ as this file was written on the working directory read unf steel7unf @& @$ Check we can list the equilibrium l r,,,, @& @$ Check the equilibrium status code l sh p @& @$ Check the symbols are there l sym @& @$ and all the model parameters l d @& @$ We can recalculate the equilibrium c n l,,,, @$ Check we have the same results as before save/read debug symbol gs -5.9405966E4 @& @$ and change conditions and calculate again set c t=800 c e l,,,,, @& @$ Just to test that one can set the fraction of any component @$ as the "rest" or "balance" c ph liq 1 n .02 .05 rest .08 .005 .01 all new Y @& @$ =================================================================== @$ testing unformatted save and read using an XTDB file @$ NOT YET IMPLEMENTED use the TDB file .... @$ with disordered fraction set and a second equilibrium r t ./MoRe @& l sh a @$ Calculate an equilibrium set c t=1000 p=1e5 n=1 x(re)=.3 c e l r 2 @& @$ Create a second equilibrium with different conditions enter equil second y l c @& set c t=3000 p=1e5 n=1 x(re)=.7 c e l,,, @$ check the Gibbs energy of this equilibrium debug symbol g -2.2969105E5 @& @$ Save workspaces unformatted on a file, final Y to overwrite!! l d @& save unf more1unf Y @$ NOTE FILE SAVED in WORKING DIRECTORY !! @& @$ Reinitiate the program and delete all data and results new Y l d,,, @& @$ Read the the unformatted file with data and the last calculation read unf more1unf @$ NOTE FILE is in working directory @& @$ list the equilibria l eq @& @$ list the results for default equilibrium l r @& @$ list the results for the second equilibrium sel eq l,,,, @$ Is the G value saved? The value has been calculated before save/read debug symbol g -2.2969105E5 @& @$ Set a new condition and calculate without grid minimizer set c t=2800 c n l r 2 @& @$========================================================================== @$ end of save macro @$========================================================================== set inter ================================================ FILE: examples/macros/sro-cef.OCM ================================================ new Y set echo Y @$ ==================================================================== @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ FCC prototype ordering using CEF SRO model @$ The data interactively and @$ a phase diagram for FCC prototype ordering is calculated @$ using partition and permutations @$ @$ NOTE in this case we use the option to set FCC_PERMUTATIONS @$ so each unique parameters is entered only once (compare with map4.OCM) @$ @$ ========================================================================= @& set echo Y @$ Enter the elements and their reference states enter element A A FCC 55. 0 0 enter element B B FCC 58 0 0 @$ the bond energy is -100*R at T=100 K, enter it as T dependent enter tp-sym UAB fun 1 -100*R; ,,,, @$ These functions describe the end-member energies at A3B1, A2B2 and A1B3 enter tp-sym GA3B1 fun 1 3*UAB; ,,,, enter tp-sym GA2B2 fun 1 4*UAB; ,,,, enter tp-sym GA1B3 fun 1 3*UAB; ,,,, @$ We set a regular solution parameter to avoid the F' phase @$ It also forces the ordered phases to be perfectly ordered at T=0 enter tp-sym L0 fun 1 200; ,,,,, @$ The SRO contribution is UAB enter tp-sym GSRO fun 1 UAB; ,,,,, @$ Using the partitioned model the contribition from the ordered parameters @$ will cancel when the phase is disordered. If we want them to contribute @$ we must add them to the disordered part enter tp-sym LD0 fun 1 -0.25*UAB; ,,,, enter tp-sym LD1 fun 1 0; ,,,, enter tp-sym LD2 fun 1 0.25*UAB; ,,,, @$ ================================================== @$ This is an fcc phase with lro but no explicit sro @$ described with the sublattice model enter phase FCC_4SL CEF 4 .25 A B; .25 A B; .25 A B; .25 A B; @$ we must set that this has FCC permutations before entering parameters amend phase fcc-4sl ? fcc-perm @& @$ we must add disordered set before entering parameters amend phase fcc-4sl dis 4 NO @& @$ enter the parameter, note permutations taken into account enter param G(FCC_4SL,A:A:A:B) 1 GA3B1; 6000 N test enter param G(FCC_4SL,A:B:B:B) 1 GA1B3; 6000 N test enter param G(FCC_4SL,A:A:B:B) 1 GA2B2; 6000 N test enter param G(FCC_4SL,A,B:A,B:*:*) 1 GSRO; 6000 N test amend biblio test prototype FCC ordering; @$ The disordered paramaters has a suffix D (This may be changed!!) @$ This is the SRO parameter for the disordered FCC_4SL enter param GD(FCC_4SL,A,B;0) 1 L0+LD0; 6000 N test enter param GD(FCC_4SL,A,B;2) 1 LD2; 6000 N test list data ,, @& @$ We have to help the mapping in OC, it is not very good @$ Here 3 composition sets are added for the two L1_2 and the L1_0 ordering @$ this default constitution is A3B_L12 amend phase fcc_4sl comp-set y , , <.2 >.5 >.2 <.5 >.2 <.5 >.5 <.2 @$ this default constitution is AB_L10 amend phase fcc_4sl comp-set y , , <.2 >.5 <.2 >.5 >.5 <.2 >.5 <.2 @$ this default constitution is AB3_L12 amend phase fcc_4sl comp-set y , , <.2 >.5 <.2 >.5 <.2 >.5 >.5 <.2 @$ However, the L12 can have max B or A on any sublattice, there is no @$ check that it is always the first or last sublattice with the highest @$ fraction of the minor element. This should be arranged in todo_after ... l sh a set c t=70 p=1e5 n=1 x(b)=.37 c e l , 2 @& set ax 1 x(b) 0 .5 0.01 set ax 2 t 1 100 2 map @& plot title Fig 1, SRO-CEF fcc prototype phase diagram @$ Sometimes parts are missing, one may have to add a second start point @$ although that can be complicated to find. @& @$ Calculate and plot Cp and y at the equiatomic composition with T axis @$ The L1_0 ordered phase not stable above 92.23 K set ax 2 none set ax 1 t 1 200 1 set c x(b)=.5 c e step enter sym cp=hm.t; plot t cp title Fig 2, SRO-CEF heat capacity at equiatomic composition @$ There is a lot of error messages as cp calculation failes for @$ the unstable composition sets @$ Note the peak of the heat capacity is above the order/disorder T @$ when the ordered phase is actually metatsble @& @$ Plot also the constitution plot t y(fcc#2,*) title Fig 3, SRO-CEF constituent fractions @$ @& @$ Calculate at 50 K how the G, S and H varies with the composition @$ set c t=50 set c x(b)=.4 c e l ,,, @$ Normally this calculation just gives the F' phase with two @$ sublattices with mainly A, one mainly B and one intermediate @$ Fix that by using calculate phase! c ph fcc 1 N .99 .99 .01 .01 @$ Then calculate without gridminimizer c n l ,,, @$ and simsalabim, we should now have a two-phase equilibrium with @$ L12 and L10 phases with lower Gibbs energy than the previous F' phase @$ OC has a rather primitive gridminimizer @& @$ now vary the composition from 0 to 0.5 set ax 1 x(b) 0 .5 .005 step sep Y plot x(b) gm(*) title Fig 4, SRO-CEF Gibbs energy for A1,L12 and L10 at T=50 @$ The Gibbs energy curves for the A1, L12 and L10 phases acress the @$ composition range @& pl x(b) sm(*) title Fig 5, SRO-CEF Entropy curves for A1,L12 and L10 at T=50 @$ The entropy curves for the A1, L12 and L10 phases acress the @$ composition range @$ Note the entropy is zero at the ideal ordering composition. @& pl x(b) hm(*) title Fig 6, SRO CEF Entropy curves for A1,L12 and L10 at T=50 @$ The enthalpy curves for the A1, L12 and L10 phases acress the @$ composition range @& pl x(b) y(fcc#3,*) title Fig 7, SRO-CEF fraction curves for one of the phases at T=50 @$ One can also plot the individual phase fractions and figure out @$ which composition set is A1, L12 or L10 @& enter symbol cp1 hm(fcc#1).T; pl cp1 title Fig 8, Heat capacity for L1_2 including metastable ranges @$ This is the heat capacity of the L1_2 phase. It remains metatsble @$ up to 50% B but disorder to A1 arount 10% B (also as metastable) @$ There is a small peak of the heat capacity at x(b)=0.25, the ideal ordering @$========================================================================== @$ end of sro-cef macro @$========================================================================== set inter ================================================ FILE: examples/macros/steel1.TDB ================================================ $ Database file written 2012- 2-11 $ From database: SSOL2 DATABASE_INFO about the steel1 database It is an extract from the SGTE SSOL2 database from 2001 for 6 elements. Most binary and ternary systems have been assessed and bibliographic references are provided. Most assessments has been made at MSE, KTH, Sweden. for the developent of steels.! $ ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT C GRAPHITE 1.2011E+01 1.0540E+03 5.7400E+00! ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01! ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! ELEMENT MO BCC_A2 9.5940E+01 4.5890E+03 2.8560E+01! ELEMENT SI DIAMOND_A4 2.8085E+01 3.2175E+03 1.8820E+01! ELEMENT V BCC_A2 5.0941E+01 4.5070E+03 3.0890E+01! SPECIES C1 C! SPECIES C2 C2! SPECIES C3 C3! SPECIES C4 C4! SPECIES C5 C5! SPECIES C6 C6! SPECIES C7 C7! SPECIES V1C1 V1C1! FUNCTION GHSERCC 2.98150E+02 -17368.441+170.73*T-24.3*T*LN(T) -4.723E-04*T**2+2562600*T**(-1)-2.643E+08*T**(-2)+1.2E+10*T**(-3); 6.00000E+03 N ! FUNCTION GPCLIQ 2.98150E+02 +YCLIQ#*EXP(ZCLIQ#); 6.00000E+03 N ! FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T) +.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2.18000E+03 Y -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6.00000E+03 N ! FUNCTION GPCRLIQ 2.98150E+02 +YCRLIQ#*EXP(ZCRLIQ#); 6.00000E+03 N ! FUNCTION GFELIQ 2.98150E+02 +12040.17-6.55843*T-3.6751551E-21*T**7 +GHSERFE#; 1.81100E+03 Y -10839.7+291.302*T-46*T*LN(T); 6.00000E+03 N ! FUNCTION GPFELIQ 2.98150E+02 +YFELIQ#*EXP(ZFELIQ#); 6.00000E+03 N ! FUNCTION GHSERMO 2.98150E+02 -7746.302+131.9197*T-23.56414*T*LN(T) -.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)-1.30927E-10*T**4; 2.89600E+03 Y -30556.41+283.559746*T-42.63829*T*LN(T)-4.849315E+33*T**(-9); 5.00000E+03 N ! FUNCTION GPMOLIQ 2.98150E+02 +YMOLIQ#*EXP(ZMOLIQ#); 6.00000E+03 N ! FUNCTION GHSERSI 2.98150E+02 -8162.609+137.227259*T-22.8317533*T*LN(T) -.001912904*T**2-3.552E-09*T**3+176667*T**(-1); 1.68700E+03 Y -9457.642+167.271767*T-27.196*T*LN(T)-4.20369E+30*T**(-9); 3.60000E+03 N ! FUNCTION GHSERVV 2.98150E+02 -7930.43+133.346053*T-24.134*T*LN(T) -.003098*T**2+1.2175E-07*T**3+69460*T**(-1); 7.90000E+02 Y -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; 2.18300E+03 Y -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); 4.00000E+03 N ! FUNCTION GPCRBCC 2.98150E+02 +YCRBCC#*EXP(ZCRBCC#); 6.00000E+03 N ! FUNCTION GPCGRA 2.98150E+02 +YCGRA#*EXP(ZCGRA#); 6.00000E+03 N ! FUNCTION GHSERFE 2.98150E+02 +1225.7+124.134*T-23.5143*T*LN(T) -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6.00000E+03 N ! FUNCTION GPFEBCC 2.98150E+02 +YFEBCC#*EXP(ZFEBCC#); 6.00000E+03 N ! FUNCTION GSIBCC 2.98150E+02 +47000-22.5*T+GHSERSI#; 6.00000E+03 N ! FUNCTION GPMOBCC 2.98150E+02 +YMOBCC#*EXP(ZMOBCC#); 6.00000E+03 N ! FUNCTION GFECEM 2.98150E+02 -10745+706.04*T-120.6*T*LN(T)+GPCEM1#; 6.00000E+03 N ! FUNCTION GCRFCC 2.98150E+02 +7284+.163*T+GHSERCR#; 6.00000E+03 N ! FUNCTION GFEFCC 2.98150E+02 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2 +GHSERFE#; 1.81100E+03 Y -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6.00000E+03 N ! FUNCTION GMOFCC 2.98150E+02 +15200+.63*T+GHSERMO#; 6.00000E+03 N ! FUNCTION GPCDIA 2.98150E+02 +YCDIA#*EXP(ZCDIA#); 6.00000E+03 N ! FUNCTION GPCFCC 2.98150E+02 +YCFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! FUNCTION GPFEFCC 2.98150E+02 +YFEFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! FUNCTION GHSERVZ 2.98150E+02 -7930.43+133.346053*T-24.134*T*LN(T) -.003098*T**2+1.2175E-07*T**3+69460*T**(-1); 7.90000E+02 Y -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; 4.00000E+03 Y -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); 6.00000E+03 N ! FUNCTION GPFEHCP 2.98150E+02 +YFEHCP#*EXP(ZFEHCP#); 6.00000E+03 N ! FUNCTION GCRM23C6 2.98150E+02 -521983+3622.24*T-620.965*T*LN(T) -.126431*T**2; 6.00000E+03 N ! FUNCTION GFEM23C6 2.98150E+02 +7.666667*GFECEM#-1.666667*GHSERCC#+66920 -40*T; 6.00000E+03 N ! FUNCTION GVM23C6 2.98150E+02 -990367+4330.63*T-728.829*T*LN(T) +5003425*T**(-1); 6.00000E+03 N ! FUNCTION GCRM3C2 2.98150E+02 -100823.8+530.66989*T-89.6694*T*LN(T) -.0301188*T**2; 6.00000E+03 N ! FUNCTION GCRM7C3 2.98150E+02 -201690+1103.128*T-190.177*T*LN(T) -.0578207*T**2; 6.00000E+03 N ! FUNCTION GPMU1 2.98150E+02 +8.72E-05*P; 6.00000E+03 N ! FUNCTION GPMU2 2.98150E+02 +1.04E-04*P; 6.00000E+03 N ! FUNCTION GPR1 2.98150E+02 +3.81E-04*P; 6.00000E+03 N ! FUNCTION GPR2 2.98150E+02 +4.33E-04*P; 6.00000E+03 N ! FUNCTION GPSIG1 2.98150E+02 +1.09E-04*P; 6.00000E+03 N ! FUNCTION GPSIG2 2.98150E+02 +1.117E-04*P; 6.00000E+03 N ! FUNCTION L0BCC 2.98150E+02 -27809+11.62*T; 6.00000E+03 N ! FUNCTION FESIW1 2.98150E+02 +1260*R#; 6.00000E+03 N ! FUNCTION L1BCC 2.98150E+02 -11544; 6.00000E+03 N ! FUNCTION L2BCC 2.98150E+02 3890; 6.00000E+03 N ! FUNCTION ETCFESI 2.98150E+02 63; 6.00000E+03 N ! FUNCTION YCLIQ 2.98150E+02 +VCLIQ#*EXP(-ECLIQ#); 6.00000E+03 N ! FUNCTION ZCLIQ 2.98150E+02 +1*LN(XCLIQ#); 6.00000E+03 N ! FUNCTION YCRLIQ 2.98150E+02 +VCRLIQ#*EXP(-ECRLIQ#); 6.00000E+03 N ! FUNCTION ZCRLIQ 2.98150E+02 +1*LN(XCRLIQ#); 6.00000E+03 N ! FUNCTION YFELIQ 2.98150E+02 +VFELIQ#*EXP(-EFELIQ#); 6.00000E+03 N ! FUNCTION ZFELIQ 2.98150E+02 +1*LN(XFELIQ#); 6.00000E+03 N ! FUNCTION YMOLIQ 2.98150E+02 +VMOLIQ#*EXP(-EMOLIQ#); 6.00000E+03 N ! FUNCTION ZMOLIQ 2.98150E+02 +1*LN(XMOLIQ#); 6.00000E+03 N ! FUNCTION YCRBCC 2.98150E+02 +VCRBCC#*EXP(-ECRBCC#); 6.00000E+03 N ! FUNCTION ZCRBCC 2.98150E+02 +1*LN(XCRBCC#); 6.00000E+03 N ! FUNCTION YCGRA 2.98150E+02 +VCGRA#*EXP(-ECGRA#); 6.00000E+03 N ! FUNCTION ZCGRA 2.98150E+02 +1*LN(XCGRA#); 6.00000E+03 N ! FUNCTION YFEBCC 2.98150E+02 +VFEBCC#*EXP(-EFEBCC#); 6.00000E+03 N ! FUNCTION ZFEBCC 2.98150E+02 +1*LN(XFEBCC#); 6.00000E+03 N ! FUNCTION YMOBCC 2.98150E+02 +VMOBCC#*EXP(-EMOBCC#); 6.00000E+03 N ! FUNCTION ZMOBCC 2.98150E+02 +1*LN(XMOBCC#); 6.00000E+03 N ! FUNCTION GPCEM1 2.98150E+02 +VCEM1#*P; 6.00000E+03 N ! FUNCTION YCDIA 2.98150E+02 +VCDIA#*EXP(-ECDIA#); 6.00000E+03 N ! FUNCTION ZCDIA 2.98150E+02 +1*LN(XCDIA#); 6.00000E+03 N ! FUNCTION YCFCC 2.98150E+02 +VCFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! FUNCTION ZFEFCC 2.98150E+02 +1*LN(XFEFCC#); 6.00000E+03 N ! FUNCTION YFEFCC 2.98150E+02 +VFEFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! FUNCTION YFEHCP 2.98150E+02 +VFEHCP#*EXP(-EFEHCP#); 6.00000E+03 N ! FUNCTION ZFEHCP 2.98150E+02 +1*LN(XFEHCP#); 6.00000E+03 N ! FUNCTION VCLIQ 2.98150E+02 +7.626E-06*EXP(ACLIQ#); 6.00000E+03 N ! FUNCTION ECLIQ 2.98150E+02 +1*LN(CCLIQ#); 6.00000E+03 N ! FUNCTION XCLIQ 2.98150E+02 +1*EXP(.5*DCLIQ#)-1; 6.00000E+03 N ! FUNCTION VCRLIQ 2.98150E+02 +7.653E-06*EXP(ACRLIQ#); 6.00000E+03 N ! FUNCTION ECRLIQ 2.98150E+02 +1*LN(CCRLIQ#); 6.00000E+03 N ! FUNCTION XCRLIQ 2.98150E+02 +1*EXP(.8*DCRLIQ#)-1; 6.00000E+03 N ! FUNCTION VFELIQ 2.98150E+02 +6.46677E-06*EXP(AFELIQ#); 6.00000E+03 N ! FUNCTION EFELIQ 2.98150E+02 +1*LN(CFELIQ#); 6.00000E+03 N ! FUNCTION XFELIQ 2.98150E+02 +1*EXP(.8484467*DFELIQ#)-1; 6.00000E+03 N ! FUNCTION VMOLIQ 2.98150E+02 +9.75079E-06*EXP(AMOLIQ#); 6.00000E+03 N ! FUNCTION EMOLIQ 2.98150E+02 +1*LN(CMOLIQ#); 6.00000E+03 N ! FUNCTION XMOLIQ 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 N ! FUNCTION VCRBCC 2.98150E+02 +7.188E-06*EXP(ACRBCC#); 6.00000E+03 N ! FUNCTION ECRBCC 2.98150E+02 +1*LN(CCRBCC#); 6.00000E+03 N ! FUNCTION XCRBCC 2.98150E+02 +1*EXP(.8*DCRBCC#)-1; 6.00000E+03 N ! FUNCTION VCGRA 2.98150E+02 +5.259E-06*EXP(ACGRA#); 6.00000E+03 N ! FUNCTION ECGRA 2.98150E+02 +1*LN(CCGRA#); 6.00000E+03 N ! FUNCTION XCGRA 2.98150E+02 +1*EXP(.9166667*DCGRA#)-1; 6.00000E+03 N ! FUNCTION VFEBCC 2.98150E+02 +7.042095E-06*EXP(AFEBCC#); 6.00000E+03 N ! FUNCTION EFEBCC 2.98150E+02 +1*LN(CFEBCC#); 6.00000E+03 N ! FUNCTION XFEBCC 2.98150E+02 +1*EXP(.7874195*DFEBCC#)-1; 6.00000E+03 N ! FUNCTION VMOBCC 2.98150E+02 +9.34372E-06*EXP(AMOBCC#); 6.00000E+03 N ! FUNCTION EMOBCC 2.98150E+02 +1*LN(CMOBCC#); 6.00000E+03 N ! FUNCTION XMOBCC 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 N ! FUNCTION VCEM1 2.98150E+02 +2.339E-05*EXP(ACEM1#); 6.00000E+03 N ! FUNCTION VCDIA 2.98150E+02 +3.412E-06*EXP(ACDIA#); 6.00000E+03 N ! FUNCTION ECDIA 2.98150E+02 +1*LN(CCDIA#); 6.00000E+03 N ! FUNCTION XCDIA 2.98150E+02 +1*EXP(.8*DCDIA#)-1; 6.00000E+03 N ! FUNCTION VCFCC 2.98150E+02 +1.031E-05*EXP(ACFCC#); 6.00000E+03 N ! FUNCTION EFEFCC 2.98150E+02 +1*LN(CFEFCC#); 6.00000E+03 N ! FUNCTION XFEFCC 2.98150E+02 +1*EXP(.8064454*DFEFCC#)-1; 6.00000E+03 N ! FUNCTION VFEFCC 2.98150E+02 +6.688726E-06*EXP(AFEFCC#); 6.00000E+03 N ! FUNCTION VFEHCP 2.98150E+02 +6.59121E-06*EXP(AFEHCP#); 6.00000E+03 N ! FUNCTION EFEHCP 2.98150E+02 +1*LN(CFEHCP#); 6.00000E+03 N ! FUNCTION XFEHCP 2.98150E+02 +1*EXP(.8064454*DFEHCP#)-1; 6.00000E+03 N ! FUNCTION ACLIQ 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 N ! FUNCTION CCLIQ 2.98150E+02 1.6E-10; 6.00000E+03 N ! FUNCTION DCLIQ 2.98150E+02 +1*LN(BCLIQ#); 6.00000E+03 N ! FUNCTION ACRLIQ 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N ! FUNCTION CCRLIQ 2.98150E+02 3.72E-11; 6.00000E+03 N ! FUNCTION DCRLIQ 2.98150E+02 +1*LN(BCRLIQ#); 6.00000E+03 N ! FUNCTION AFELIQ 2.98150E+02 +1.135E-04*T; 6.00000E+03 N ! FUNCTION CFELIQ 2.98150E+02 +4.22534787E-12+2.71569924E-14*T; 6.00000E+03 N ! FUNCTION DFELIQ 2.98150E+02 +1*LN(BFELIQ#); 6.00000E+03 N ! FUNCTION AMOLIQ 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2 +1.14687E-12*T**3; 6.00000E+03 N ! FUNCTION CMOLIQ 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; 6.00000E+03 N ! FUNCTION DMOBCC 2.98150E+02 +1*LN(BMOBCC#); 6.00000E+03 N ! FUNCTION ACRBCC 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N ! FUNCTION CCRBCC 2.98150E+02 2.08E-11; 6.00000E+03 N ! FUNCTION DCRBCC 2.98150E+02 +1*LN(BCRBCC#); 6.00000E+03 N ! FUNCTION ACGRA 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 N ! FUNCTION CCGRA 2.98150E+02 3.3E-10; 6.00000E+03 N ! FUNCTION DCGRA 2.98150E+02 +1*LN(BCGRA#); 6.00000E+03 N ! FUNCTION AFEBCC 2.98150E+02 +2.3987E-05*T+1.2845E-08*T**2; 6.00000E+03 N ! FUNCTION CFEBCC 2.98150E+02 +2.20949565E-11+2.41329523E-16*T; 6.00000E+03 N ! FUNCTION DFEBCC 2.98150E+02 +1*LN(BFEBCC#); 6.00000E+03 N ! FUNCTION AMOBCC 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2 +1.14687E-12*T**3; 6.00000E+03 N ! FUNCTION CMOBCC 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; 6.00000E+03 N ! FUNCTION ACEM1 2.98150E+02 -1.36E-05*T+4E-08*T**2; 6.00000E+03 N ! FUNCTION ACDIA 2.98150E+02 +2.43E-06*T+5E-09*T**2; 6.00000E+03 N ! FUNCTION CCDIA 2.98150E+02 6.8E-12; 6.00000E+03 N ! FUNCTION DCDIA 2.98150E+02 +1*LN(BCDIA#); 6.00000E+03 N ! FUNCTION ACFCC 2.98150E+02 +1.44E-04*T; 6.00000E+03 N ! FUNCTION CFEFCC 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; 6.00000E+03 N ! FUNCTION DFEFCC 2.98150E+02 +1*LN(BFEFCC#); 6.00000E+03 N ! FUNCTION AFEFCC 2.98150E+02 +7.3097E-05*T; 6.00000E+03 N ! FUNCTION AFEHCP 2.98150E+02 +7.3646E-05*T; 6.00000E+03 N ! FUNCTION CFEHCP 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; 6.00000E+03 N ! FUNCTION DFEHCP 2.98150E+02 +1*LN(BFEHCP#); 6.00000E+03 N ! FUNCTION BCLIQ 2.98150E+02 +1+3.2E-10*P; 6.00000E+03 N ! FUNCTION BCRLIQ 2.98150E+02 +1+4.65E-11*P; 6.00000E+03 N ! FUNCTION BFELIQ 2.98150E+02 +1+4.98009787E-12*P+3.20078924E-14*T*P; 6.00000E+03 N ! FUNCTION BMOBCC 2.98150E+02 +1+1.13837E-11*P+4.875E-16*T*P +1.2675E-19*T**2*P; 6.00000E+03 N ! FUNCTION BCRBCC 2.98150E+02 +1+2.6E-11*P; 6.00000E+03 N ! FUNCTION BCGRA 2.98150E+02 +1+3.6E-10*P; 6.00000E+03 N ! FUNCTION BFEBCC 2.98150E+02 +1+2.80599565E-11*P+3.06481523E-16*T*P; 6.00000E+03 N ! FUNCTION BCDIA 2.98150E+02 +1+8.5E-12*P; 6.00000E+03 N ! FUNCTION BFEFCC 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; 6.00000E+03 N ! FUNCTION BFEHCP 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; 6.00000E+03 N ! FUNCTION UN_ASS 298.15 0; 300 N ! TYPE_DEFINITION % SEQ *! DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! PHASE LIQUID:L % 1 1.0 ! CONSTITUENT LIQUID:L :C,CR,FE,MO,SI,V : ! PARAMETER G(LIQUID,C;0) 2.98150E+02 +117369-24.63*T+GHSERCC#+GPCLIQ#; 6.00000E+03 N REF283 ! PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T +2.37615E-21*T**7+GHSERCR#+GPCRLIQ#; 2.18000E+03 Y +18409.36-8.563683*T+2.88526E+32*T**(-9)+GHSERCR#+GPCRLIQ#; 6.00000E+03 N REF283 ! PARAMETER G(LIQUID,FE;0) 2.98150E+02 +GFELIQ#+GPFELIQ#; 6.00000E+03 N REF283 ! PARAMETER G(LIQUID,MO;0) 2.98150E+02 +41831.347-14.694912*T +4.24519E-22*T**7+GHSERMO#+GPMOLIQ#; 2.89600E+03 Y +34095.373-11.890046*T+4.849315E+33*T**(-9)+GHSERMO#+GPMOLIQ#; 5.00000E+03 N REF283 ! PARAMETER G(LIQUID,SI;0) 2.98150E+02 +50696.36-30.099439*T +2.09307E-21*T**7+GHSERSI#; 1.68700E+03 Y +49828.165-29.559069*T+4.20369E+30*T**(-9)+GHSERSI#; 3.60000E+03 N REF283 ! PARAMETER G(LIQUID,V;0) 2.98150E+02 +20764.117-9.455552*T -5.19136E-22*T**7+GHSERVV#; 7.90000E+02 Y +20764.117-9.455552*T-5.19136E-22*T**7+GHSERVV#; 2.18300E+03 Y +22072.354-10.0848*T-6.44389E+31*T**(-9)+GHSERVV#; 4.00000E+03 N REF283 ! PARAMETER G(LIQUID,C,CR;0) 2.98150E+02 -90526-25.9116*T; 6.00000E+03 N REF101 ! PARAMETER G(LIQUID,C,CR;1) 2.98150E+02 80000; 6.00000E+03 N REF101 ! PARAMETER G(LIQUID,C,CR;2) 2.98150E+02 80000; 6.00000E+03 N REF101 ! PARAMETER G(LIQUID,C,CR,FE;0) 2.98150E+02 -496063; 6.00000E+03 N REF322 ! PARAMETER G(LIQUID,C,CR,FE;1) 2.98150E+02 57990; 6.00000E+03 N REF322 ! PARAMETER G(LIQUID,C,CR,FE;2) 2.98150E+02 61404; 6.00000E+03 N REF322 ! PARAMETER G(LIQUID,C,CR,V;0) 2.98150E+02 -769497; 6.00000E+03 N REF324 ! PARAMETER G(LIQUID,C,CR,V;1) 2.98150E+02 263981; 6.00000E+03 N REF324 ! PARAMETER G(LIQUID,C,CR,V;2) 2.98150E+02 3599; 6.00000E+03 N REF324 ! PARAMETER G(LIQUID,C,FE;0) 2.98150E+02 -124320+28.5*T; 6.00000E+03 N REF190 ! PARAMETER G(LIQUID,C,FE;1) 2.98150E+02 19300; 6.00000E+03 N REF190 ! PARAMETER G(LIQUID,C,FE;2) 2.98150E+02 +49260-19*T; 6.00000E+03 N REF190 ! PARAMETER G(LIQUID,C,FE,SI;0) 2.98150E+02 445740; 6.00000E+03 N REF99 ! PARAMETER G(LIQUID,C,FE,SI;1) 2.98150E+02 -6065-35.33*T; 6.00000E+03 N REF99 ! PARAMETER G(LIQUID,C,FE,SI;2) 2.98150E+02 +2545792-1450.6*T; 6.00000E+03 N REF99 ! PARAMETER G(LIQUID,C,FE,V;0) 2.98150E+02 -60000; 6.00000E+03 N REF270 ! PARAMETER G(LIQUID,C,FE,V;1) 2.98150E+02 -60000; 6.00000E+03 N REF270 ! PARAMETER G(LIQUID,C,FE,V;2) 2.98150E+02 100000; 6.00000E+03 N REF270 ! PARAMETER G(LIQUID,C,FE,MO;0) 2.98150E+02 -37800; 6.00000E+03 N REF113 ! PARAMETER G(LIQUID,C,MO;0) 2.98150E+02 -217800+38.41*T; 6.00000E+03 N REF104 ! PARAMETER G(LIQUID,C,MO;1) 2.98150E+02 30000; 6.00000E+03 N REF104 ! PARAMETER G(LIQUID,C,MO;2) 2.98150E+02 47000; 6.00000E+03 N REF104 ! PARAMETER G(LIQUID,C,SI;0) 2.98150E+02 -133000+30.97*T; 6.00000E+03 N REF99 ! PARAMETER G(LIQUID,C,V;0) 2.98150E+02 -284196+38.952*T; 6.00000E+03 N REF256 ! PARAMETER G(LIQUID,C,V;1) 2.98150E+02 +96335-17.775*T; 6.00000E+03 N REF256 ! PARAMETER G(LIQUID,C,V;2) 2.98150E+02 102050; 6.00000E+03 N REF256 ! PARAMETER G(LIQUID,CR,FE;0) 2.98150E+02 -14550+6.65*T; 6.00000E+03 N REF107 ! PARAMETER G(LIQUID,CR,FE,V;0) 2.98150E+02 14881; 6.00000E+03 N REF323 ! PARAMETER G(LIQUID,CR,FE,V;1) 2.98150E+02 17968; 6.00000E+03 N REF323 ! PARAMETER G(LIQUID,CR,FE,V;2) 2.98150E+02 -7692; 6.00000E+03 N REF323 ! PARAMETER G(LIQUID,CR,MO;0) 2.98150E+02 +15810-6.714*T; 6.00000E+03 N REF123 ! PARAMETER G(LIQUID,CR,MO;1) 2.98150E+02 -6220; 6.00000E+03 N REF123 ! PARAMETER G(LIQUID,CR,SI;0) 2.98150E+02 -120157.52+16.63891*T; 6.00000E+03 N REF90 ! PARAMETER G(LIQUID,CR,SI;1) 2.98150E+02 -49502.35+13.76967*T; 6.00000E+03 N REF90 ! PARAMETER G(LIQUID,CR,V;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 N REF323 ! PARAMETER G(LIQUID,CR,V;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 N REF323 ! PARAMETER G(LIQUID,FE,MO;0) 2.98150E+02 -6973-.37*T; 6.00000E+03 N REF10 ! PARAMETER G(LIQUID,FE,MO;1) 2.98150E+02 -9424+4.502*T; 6.00000E+03 N REF10 ! PARAMETER G(LIQUID,FE,SI;0) 2.98150E+02 -164435+41.977*T; 6.00000E+03 N REF99 ! PARAMETER G(LIQUID,FE,SI;1) 2.98150E+02 -21.523*T; 6.00000E+03 N REF99 ! PARAMETER G(LIQUID,FE,SI;2) 2.98150E+02 -18821+22.07*T; 6.00000E+03 N REF99 ! PARAMETER G(LIQUID,FE,SI;3) 2.98150E+02 9696; 6.00000E+03 N REF99 ! PARAMETER G(LIQUID,FE,V;0) 2.98150E+02 -34679+1.895*T; 6.00000E+03 N REF269 ! PARAMETER G(LIQUID,FE,V;1) 2.98150E+02 10209; 6.00000E+03 N REF269 ! TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! PHASE BCC_A2 %& 2 1 3 ! CONSTITUENT BCC_A2 :CR%,FE%,MO%,SI,V% : C,VA% : ! PARAMETER G(BCC_A2,CR:C;0) 2.98150E+02 +GHSERCR#+3*GHSERCC#+GPCRBCC# +3*GPCGRA#+416000; 6.00000E+03 N REF101 ! PARAMETER TC(BCC_A2,CR:C;0) 2.98150E+02 -311.5; 6.00000E+03 N REF101 ! PARAMETER BMAGN(BCC_A2,CR:C;0) 2.98150E+02 -.008; 6.00000E+03 N REF101 ! PARAMETER G(BCC_A2,FE:C;0) 2.98150E+02 +322050+75.667*T+GHSERFE# +GPFEBCC#+3*GHSERCC#+3*GPCGRA#; 6.00000E+03 N REF190 ! PARAMETER TC(BCC_A2,FE:C;0) 2.98150E+02 1043; 6.00000E+03 N REF190 ! PARAMETER BMAGN(BCC_A2,FE:C;0) 2.98150E+02 2.22; 6.00000E+03 N REF190 ! PARAMETER G(BCC_A2,MO:C;0) 2.98150E+02 +331000-75*T+GHSERMO#+3*GHSERCC#; 6.00000E+03 N REF104 ! PARAMETER G(BCC_A2,SI:C;0) 2.98150E+02 +322050-75.667*T+GSIBCC# +3*GHSERCC#+3*GPCGRA#; 6.00000E+03 N REF98 ! PARAMETER G(BCC_A2,V:C;0) 2.98150E+02 +108449+GHSERVV#+3*GHSERCC#; 6.00000E+03 N REF256 ! PARAMETER G(BCC_A2,CR:VA;0) 2.98150E+02 +GHSERCR#+GPCRBCC#; 6.00000E+03 N REF283 ! PARAMETER TC(BCC_A2,CR:VA;0) 2.98150E+02 -311.5; 6.00000E+03 N REF281 ! PARAMETER BMAGN(BCC_A2,CR:VA;0) 2.98150E+02 -.01; 6.00000E+03 N REF281 ! PARAMETER G(BCC_A2,FE:VA;0) 2.98150E+02 +GHSERFE#+GPFEBCC#; 6.00000E+03 N REF283 ! PARAMETER TC(BCC_A2,FE:VA;0) 2.98150E+02 1043; 6.00000E+03 N REF281 ! PARAMETER BMAGN(BCC_A2,FE:VA;0) 2.98150E+02 2.22; 6.00000E+03 N REF281 ! PARAMETER G(BCC_A2,MO:VA;0) 2.98150E+02 +GHSERMO#+GPMOBCC#; 5.00000E+03 N REF283 ! PARAMETER G(BCC_A2,SI:VA;0) 2.98150E+02 +GSIBCC#; 3.60000E+03 N REF283 ! PARAMETER G(BCC_A2,V:VA;0) 2.98150E+02 +GHSERVV#; 4.00000E+03 N REF283 ! PARAMETER G(BCC_A2,CR,FE:C;0) 2.98150E+02 -1250000+667.7*T; 6.00000E+03 N REF322 ! PARAMETER TC(BCC_A2,CR,FE:C;0) 2.98150E+02 1650; 6.00000E+03 N REF102 ! PARAMETER TC(BCC_A2,CR,FE:C;1) 2.98150E+02 550; 6.00000E+03 N REF102 ! PARAMETER BMAGN(BCC_A2,CR,FE:C;0) 2.98150E+02 -.85; 6.00000E+03 N REF102 ! PARAMETER G(BCC_A2,CR:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N REF101 ! PARAMETER G(BCC_A2,FE,MO:C;0) 2.98150E+02 -1250000+667.7*T; 6.00000E+03 N REF325 ! PARAMETER TC(BCC_A2,FE,MO:C;0) 2.98150E+02 335; 6.00000E+03 N REF104 ! PARAMETER TC(BCC_A2,FE,MO:C;1) 2.98150E+02 526; 6.00000E+03 N REF104 ! PARAMETER G(BCC_A2,FE,SI:C;0) 2.98150E+02 78866; 6.00000E+03 N REF99 ! PARAMETER G(BCC_A2,FE,V:C;0) 2.98150E+02 -23674+.465*T; 6.00000E+03 N REF270 ! PARAMETER G(BCC_A2,FE,V:C;1) 2.98150E+02 8283; 6.00000E+03 N REF270 ! PARAMETER G(BCC_A2,FE:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N REF190 ! PARAMETER G(BCC_A2,V:C,VA;0) 2.98150E+02 -297868; 6.00000E+03 N REF256 ! PARAMETER G(BCC_A2,CR,FE:VA;0) 2.98150E+02 +20500-9.68*T; 6.00000E+03 N REF107 ! PARAMETER TC(BCC_A2,CR,FE:VA;0) 2.98150E+02 1650; 6.00000E+03 N REF107 ! PARAMETER TC(BCC_A2,CR,FE:VA;1) 2.98150E+02 550; 6.00000E+03 N REF107 ! PARAMETER BMAGN(BCC_A2,CR,FE:VA;0) 2.98150E+02 -.85; 6.00000E+03 N REF107 ! PARAMETER G(BCC_A2,CR,FE,V:VA;0) 2.98150E+02 14881; 6.00000E+03 N REF323 ! PARAMETER G(BCC_A2,CR,FE,V:VA;1) 2.98150E+02 17968; 6.00000E+03 N REF323 ! PARAMETER G(BCC_A2,CR,FE,V:VA;2) 2.98150E+02 -7692; 6.00000E+03 N REF323 ! PARAMETER G(BCC_A2,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; 6.00000E+03 N REF123 ! PARAMETER G(BCC_A2,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 N REF123 ! PARAMETER G(BCC_A2,CR,SI:VA;0) 2.98150E+02 -102850.19+9.85457*T; 6.00000E+03 N REF90 ! PARAMETER G(BCC_A2,CR,SI:VA;1) 2.98150E+02 -49502.35+13.76967*T; 6.00000E+03 N REF90 ! PARAMETER G(BCC_A2,CR,V:VA;0) 2.98150E+02 -9875-2.6964*T; 6.00000E+03 N REF323 ! PARAMETER G(BCC_A2,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 N REF323 ! PARAMETER G(BCC_A2,FE,MO:VA;0) 2.98150E+02 +36818-9.141*T; 6.00000E+03 N REF10 ! PARAMETER G(BCC_A2,FE,MO:VA;1) 2.98150E+02 -362-5.724*T; 6.00000E+03 N REF10 ! PARAMETER TC(BCC_A2,FE,MO:VA;0) 2.98150E+02 335; 6.00000E+03 N REF10 ! PARAMETER TC(BCC_A2,FE,MO:VA;1) 2.98150E+02 526; 6.00000E+03 N REF10 ! PARAMETER G(BCC_A2,FE,SI:VA;0) 2.98150E+02 +4*L0BCC#-4*FESIW1#; 6.00000E+03 N REF98 ! PARAMETER G(BCC_A2,FE,SI:VA;1) 2.98150E+02 +8*L1BCC#; 6.00000E+03 N REF98 ! PARAMETER G(BCC_A2,FE,SI:VA;2) 2.98150E+02 +16*L2BCC#; 6.00000E+03 N REF98 ! PARAMETER TC(BCC_A2,FE,SI:VA;1) 2.98150E+02 +8*ETCFESI#; 6.00000E+03 N REF98 ! PARAMETER G(BCC_A2,FE,V:VA;0) 2.98150E+02 -23674+.465*T; 6.00000E+03 N REF269 ! PARAMETER G(BCC_A2,FE,V:VA;1) 2.98150E+02 8283; 6.00000E+03 N REF269 ! PARAMETER TC(BCC_A2,FE,V:VA;0) 2.98150E+02 -110; 6.00000E+03 N REF111 ! PARAMETER TC(BCC_A2,FE,V:VA;1) 2.98150E+02 3075; 6.00000E+03 N REF111 ! PARAMETER TC(BCC_A2,FE,V:VA;2) 2.98150E+02 808; 6.00000E+03 N REF111 ! PARAMETER TC(BCC_A2,FE,V:VA;3) 2.98150E+02 -2169; 6.00000E+03 N REF111 ! PARAMETER BMAGN(BCC_A2,FE,V:VA;0) 2.98150E+02 -2.26; 6.00000E+03 N REF111 ! TYPE_DEFINITION ' GES A_P_D CBCC_A12 MAGNETIC -3.0 2.80000E-01 ! PHASE CBCC_A12 %' 2 1 1 ! CONSTITUENT CBCC_A12 :CR,FE,SI,V : C,VA% : ! PARAMETER G(CBCC_A12,CR:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(CBCC_A12,FE:C;0) 2.98150E+02 +80000+GHSERFE#+GHSERCC#; 6.00000E+03 N REF267 ! PARAMETER G(CBCC_A12,SI:C;0) 2.98150E+02 +1000000+566.0326*T -85.955678*T*LN(T)-.007814909*T**2+3.7239E-07*T**3+1688653*T**(-1); 3.00000E+03 N REF177 ! PARAMETER G(CBCC_A12,V:C;0) 2.98150E+02 +10000+GHSERVV#+GHSERCC#; 6.00000E+03 N REF275 ! PARAMETER G(CBCC_A12,CR:VA;0) 2.98150E+02 +11087+2.7196*T+GHSERCR#; 6.00000E+03 N REF283 ! PARAMETER G(CBCC_A12,FE:VA;0) 2.98150E+02 +4745+GHSERFE#; 6.00000E+03 N REF283 ! PARAMETER G(CBCC_A12,SI:VA;0) 2.98150E+02 +50208-20.377*T+GHSERSI#; 3.60000E+03 N REF283 ! PARAMETER G(CBCC_A12,V:VA;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(CBCC_A12,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N REF267 ! PARAMETER G(CBCC_A12,FE,SI:VA;0) 2.98150E+02 -153141+46.48*T; 6.00000E+03 N REF42 ! PARAMETER G(CBCC_A12,FE,SI:VA;1) 2.98150E+02 -92352; 6.00000E+03 N REF42 ! PARAMETER G(CBCC_A12,FE,SI:VA;2) 2.98150E+02 62240; 6.00000E+03 N REF42 ! PARAMETER G(CBCC_A12,FE,V:VA;0) 2.98150E+02 -10000; 6.00000E+03 N REF275 ! PHASE CEMENTITE % 2 3 1 ! CONSTITUENT CEMENTITE :CR,FE%,MO,V : C : ! PARAMETER G(CEMENTITE,CR:C;0) 2.98150E+02 +3*GHSERCR#+GHSERCC#-48000 -9.2888*T; 6.00000E+03 N REF322 ! PARAMETER G(CEMENTITE,FE:C;0) 2.98150E+02 +GFECEM#; 6.00000E+03 N REF190 ! PARAMETER G(CEMENTITE,MO:C;0) 2.98150E+02 +3*GHSERMO#+GHSERCC#+77000 -57.4*T; 6.00000E+03 N REF104 ! PARAMETER G(CEMENTITE,V:C;0) 2.98150E+02 -156971+601.922*T -100.438*T*LN(T)+765557*T**(-1); 6.00000E+03 N REF275 ! PARAMETER G(CEMENTITE,CR,FE:C;0) 2.98150E+02 +25278-17.5*T; 6.00000E+03 N REF322 ! PARAMETER G(CEMENTITE,CR,MO:C;0) 2.98150E+02 40000; 6.00000E+03 N REF316 ! PARAMETER G(CEMENTITE,CR,V:C;0) 2.98150E+02 -29622-8.0892*T; 6.00000E+03 N REF324 ! PARAMETER G(CEMENTITE,CR,V:C;1) 2.98150E+02 -5160-7.5711*T; 6.00000E+03 N REF324 ! PARAMETER G(CEMENTITE,FE,V:C;0) 2.98150E+02 -45873-12.414*T; 6.00000E+03 N REF270 ! PHASE CHI_A12 % 3 24 10 24 ! CONSTITUENT CHI_A12 :CR,FE : CR,MO : CR,FE,MO : ! PARAMETER G(CHI_A12,CR:CR:CR;0) 2.98150E+02 +48*GCRFCC#+10*GHSERCR# +109000+123*T; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,FE:CR:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR# +24*GCRFCC#+18300-100*T; 6.00000E+03 N REF115 ! PARAMETER G(CHI_A12,CR:MO:CR;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# +24*GCRFCC#-26000; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,FE:MO:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO# +24*GCRFCC#+32555-385*T; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,CR:CR:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR# +24*GFEFCC#+500000; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,FE:CR:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERCR# +57300-100*T; 6.00000E+03 N REF115 ! PARAMETER G(CHI_A12,CR:MO:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# +24*GFEFCC#+500000; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,FE:MO:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERMO# +305210-270*T; 6.00000E+03 N REF115 ! PARAMETER G(CHI_A12,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR# +24*GMOFCC#+500000; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,FE:CR:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR# +24*GMOFCC#+100000; 6.00000E+03 N REF115 ! PARAMETER G(CHI_A12,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# +24*GMOFCC#+500000; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO# +24*GMOFCC#+97300-100*T; 6.00000E+03 N REF115 ! PHASE CR2VC2 % 3 2 1 2 ! CONSTITUENT CR2VC2 :CR : V : C : ! PARAMETER G(CR2VC2,CR:V:C;0) 2.98150E+02 -105987-38.2069*T+2*GHSERCR# +GHSERVV#+2*GHSERCC#; 6.00000E+03 N REF324 ! PHASE CR3SI % 2 3 1 ! CONSTITUENT CR3SI :CR%,SI : CR,SI% : ! PARAMETER G(CR3SI,CR:CR;0) 2.98150E+02 +17008.82+4*T+4*GHSERCR#; 6.00000E+03 N REF90 ! PARAMETER G(CR3SI,SI:CR;0) 2.98150E+02 +167008.8+4*T+GHSERCR# +3*GHSERSI#; 6.00000E+03 N REF90 ! PARAMETER G(CR3SI,CR:SI;0) 2.98150E+02 -125456.6+4*T+3*GHSERCR# +GHSERSI#; 6.00000E+03 N REF90 ! PARAMETER G(CR3SI,SI:SI;0) 2.98150E+02 +24543.3+4*T+4*GHSERSI#; 6.00000E+03 N REF90 ! PHASE CR5SI3 % 2 5 3 ! CONSTITUENT CR5SI3 :CR : SI : ! PARAMETER G(CR5SI3,CR:SI;0) 2.98150E+02 -318953.76+1067.49776*T -182.57818*T*LN(T)-.02391968*T**2-2.31728E-06*T**3; 6.00000E+03 N REF90 ! PHASE CR1SI1 % 2 1 1 ! CONSTITUENT CR1SI1 :CR : SI : ! PARAMETER G(CR1SI1,CR:SI;0) 2.98150E+02 -79041.68+311.75228*T -51.62865*T*LN(T)-.00447355*T**2+391330*T**(-1); 6.00000E+03 N REF90 ! PHASE CRSI2 % 2 1 2 ! CONSTITUENT CRSI2 :CR%,SI : CR,SI% : ! PARAMETER G(CRSI2,CR:CR;0) 2.98150E+02 +10000+10*T+3*GHSERCR#; 6.00000E+03 N REF90 ! PARAMETER G(CRSI2,SI:CR;0) 2.98150E+02 +150000-T+2*GHSERCR#+GHSERSI#; 6.00000E+03 N REF90 ! PARAMETER G(CRSI2,CR:SI;0) 2.98150E+02 -96793.65+333.25242*T -57.85575*T*LN(T)-.01322769*T**2-4.3203E-07*T**3; 6.00000E+03 N REF90 ! PARAMETER G(CRSI2,SI:SI;0) 2.98150E+02 +77711.85-15.05638*T+3*GHSERSI#; 6.00000E+03 N REF90 ! PARAMETER G(CRSI2,CR:CR,SI;0) 2.98150E+02 -57532.96+11.37201*T; 6.00000E+03 N REF90 ! PARAMETER G(CRSI2,SI:CR,SI;0) 2.98150E+02 -57532.96+11.37201*T; 6.00000E+03 N REF90 ! PHASE CUB_A13 % 2 1 1 ! CONSTITUENT CUB_A13 :CR,FE,SI,V : C,VA% : ! PARAMETER G(CUB_A13,CR:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(CUB_A13,FE:C;0) 2.98150E+02 +90000+GHSERFE#+GHSERCC#; 6.00000E+03 N REF267 ! PARAMETER G(CUB_A13,SI:C;0) 2.98150E+02 +1000000+566.0326*T -85.955678*T*LN(T)-.007814909*T**2+3.7239E-07*T**3+1688653*T**(-1); 3.00000E+03 N REF177 ! PARAMETER G(CUB_A13,V:C;0) 2.98150E+02 +10000+GHSERVV#+GHSERCC#; 6.00000E+03 N REF275 ! PARAMETER G(CUB_A13,CR:VA;0) 2.98150E+02 +15899+.6276*T+GHSERCR#; 6.00000E+03 N REF283 ! PARAMETER G(CUB_A13,FE:VA;0) 2.98150E+02 +3745+GHSERFE#; 6.00000E+03 N REF283 ! PARAMETER G(CUB_A13,SI:VA;0) 2.98150E+02 +47279-20.377*T+GHSERSI#; 3.60000E+03 N REF283 ! PARAMETER G(CUB_A13,V:VA;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(CUB_A13,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N REF267 ! PARAMETER G(CUB_A13,FE,SI:VA;0) 2.98150E+02 -153141+46.48*T; 6.00000E+03 N REF42 ! PARAMETER G(CUB_A13,FE,SI:VA;1) 2.98150E+02 -92352; 6.00000E+03 N REF42 ! PARAMETER G(CUB_A13,FE,SI:VA;2) 2.98150E+02 62240; 6.00000E+03 N REF42 ! PARAMETER G(CUB_A13,FE,V:VA;0) 2.98150E+02 -10000; 6.00000E+03 N REF275 ! PHASE DIAMOND_A4 % 1 1.0 ! CONSTITUENT DIAMOND_A4 :C,SI% : ! PARAMETER G(DIAMOND_A4,C;0) 2.98150E+02 -16359.441+175.61*T -24.31*T*LN(T)-4.723E-04*T**2+2698000*T**(-1)-2.61E+08*T**(-2) +1.11E+10*T**(-3)+GPCDIA#; 6.00000E+03 N REF283 ! PARAMETER G(DIAMOND_A4,SI;0) 2.98150E+02 +GHSERSI#; 3.60000E+03 N REF283 ! TYPE_DEFINITION ( GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! PHASE FCC_A1 %( 2 1 1 ! CONSTITUENT FCC_A1 :CR,FE%,MO,SI,V : C,VA% : ! PARAMETER G(FCC_A1,CR:C;0) 2.98150E+02 +GHSERCR#+GHSERCC#+1200-1.94*T; 6.00000E+03 N REF322 ! PARAMETER G(FCC_A1,FE:C;0) 2.98150E+02 +77207-15.877*T+GFEFCC#+GHSERCC# +GPCFCC#; 6.00000E+03 N REF190 ! PARAMETER TC(FCC_A1,FE:C;0) 2.98150E+02 -201; 6.00000E+03 N REF190 ! PARAMETER BMAGN(FCC_A1,FE:C;0) 2.98150E+02 -2.1; 6.00000E+03 N REF190 ! PARAMETER G(FCC_A1,MO:C;0) 2.98150E+02 -7500-8.3*T-750000*T**(-1) +GHSERMO#+GHSERCC#; 6.00000E+03 N REF104 ! PARAMETER G(FCC_A1,SI:C;0) 2.98150E+02 +GHSERSI#+GHSERCC#-20510+38.7*T; 6.00000E+03 N REF98 ! PARAMETER G(FCC_A1,V:C;0) 2.98150E+02 -117302+262.57*T-41.756*T*LN(T) -.00557101*T**2+590546*T**(-1); 6.00000E+03 N REF256 ! PARAMETER G(FCC_A1,CR:VA;0) 2.98150E+02 +GCRFCC#+GPCRBCC#; 6.00000E+03 N REF281 ! PARAMETER TC(FCC_A1,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N REF281 ! PARAMETER BMAGN(FCC_A1,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N REF281 ! PARAMETER G(FCC_A1,FE:VA;0) 2.98150E+02 +GFEFCC#+GPFEFCC#; 6.00000E+03 N REF283 ! PARAMETER TC(FCC_A1,FE:VA;0) 2.98150E+02 -201; 6.00000E+03 N REF281 ! PARAMETER BMAGN(FCC_A1,FE:VA;0) 2.98150E+02 -2.1; 6.00000E+03 N REF281 ! PARAMETER G(FCC_A1,MO:VA;0) 2.98150E+02 +15200+.63*T+GHSERMO#+GPMOBCC#; 5.00000E+03 N REF283 ! PARAMETER G(FCC_A1,SI:VA;0) 2.98150E+02 +51000-21.8*T+GHSERSI#; 3.60000E+03 N REF283 ! PARAMETER G(FCC_A1,V:VA;0) 2.98150E+02 +7500+1.7*T+GHSERVZ#; 4.00000E+03 N REF283 ! PARAMETER G(FCC_A1,CR,FE:C;0) 2.98150E+02 -74319+3.2353*T; 6.00000E+03 N REF322 ! PARAMETER G(FCC_A1,CR,V:C;0) 2.98150E+02 +35698-50.0981*T; 6.00000E+03 N REF324 ! PARAMETER G(FCC_A1,CR:C,VA;0) 2.98150E+02 -11977+6.8194*T; 6.00000E+03 N REF322 ! PARAMETER G(FCC_A1,FE,MO:C;0) 2.98150E+02 6000; 6.00000E+03 N REF113 ! PARAMETER G(FCC_A1,FE,SI:C;0) 2.98150E+02 +143220+39.31*T; 6.00000E+03 N REF99 ! PARAMETER G(FCC_A1,FE,SI:C;1) 2.98150E+02 -216321; 6.00000E+03 N REF99 ! PARAMETER G(FCC_A1,FE,V:C;0) 2.98150E+02 -7645.5-2.069*T; 6.00000E+03 N REF270 ! PARAMETER G(FCC_A1,FE,V:C;1) 2.98150E+02 -7645.5-2.069*T; 6.00000E+03 N REF270 ! PARAMETER G(FCC_A1,FE,V:C,VA;0) 2.98150E+02 -40000; 6.00000E+03 N REF270 ! PARAMETER G(FCC_A1,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N REF190 ! PARAMETER G(FCC_A1,MO,V:C;0) 2.98150E+02 -18000; 6.00000E+03 N REF220 ! PARAMETER G(FCC_A1,MO:C,VA;0) 2.98150E+02 -41300; 6.00000E+03 N REF104 ! PARAMETER G(FCC_A1,V:C,VA;0) 2.98150E+02 -74811+10.201*T; 6.00000E+03 N REF256 ! PARAMETER G(FCC_A1,V:C,VA;1) 2.98150E+02 -30394; 6.00000E+03 N REF256 ! PARAMETER G(FCC_A1,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; 6.00000E+03 N REF107 ! PARAMETER G(FCC_A1,CR,FE:VA;1) 2.98150E+02 1410; 6.00000E+03 N REF107 ! PARAMETER G(FCC_A1,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; 6.00000E+03 N REF58 ! PARAMETER G(FCC_A1,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 N REF58 ! PARAMETER G(FCC_A1,CR,SI:VA;0) 2.98150E+02 -122850+9.85457*T; 6.00000E+03 N REF58 ! PARAMETER G(FCC_A1,CR,SI:VA;1) 2.98150E+02 -49502+13.76967*T; 6.00000E+03 N REF58 ! PARAMETER G(FCC_A1,CR,V:VA;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 N REF323 ! PARAMETER G(FCC_A1,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 N REF323 ! PARAMETER G(FCC_A1,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; 6.00000E+03 N REF10 ! PARAMETER G(FCC_A1,FE,SI:VA;0) 2.98150E+02 -125248+41.116*T; 6.00000E+03 N REF98 ! PARAMETER G(FCC_A1,FE,SI:VA;1) 2.98150E+02 -142708; 6.00000E+03 N REF98 ! PARAMETER G(FCC_A1,FE,SI:VA;2) 2.98150E+02 89907; 6.00000E+03 N REF98 ! PARAMETER G(FCC_A1,FE,V:VA;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 N REF269 ! PHASE FE1SI1 % 2 .5 .5 ! CONSTITUENT FE1SI1 :FE : SI : ! PARAMETER G(FE1SI1,FE:SI;0) 2.98150E+02 +.5*GHSERFE#+.5*GHSERSI#-36381 +2.22*T; 6.00000E+03 N REF98 ! PHASE FE2SI % 2 .666667 .333333 ! CONSTITUENT FE2SI :FE : SI : ! PARAMETER G(FE2SI,FE:SI;0) 2.98150E+02 +.6666667*GHSERFE# +.3333333*GHSERSI#-23752-3.54*T; 6.00000E+03 N REF98 ! PHASE FE4N % 2 4 1 ! CONSTITUENT FE4N :FE : C,VA : ! PARAMETER G(FE4N,FE:C;0) 2.98150E+02 +15965+4*GHSERFE#+GHSERCC#; 6.00000E+03 N REF319 ! PARAMETER G(FE4N,FE:VA;0) 2.98150E+02 +4*GFEFCC#+10; 6.00000E+03 N REF319 ! PHASE FE5SI3 % 2 .625 .375 ! CONSTITUENT FE5SI3 :FE : SI : ! PARAMETER G(FE5SI3,FE:SI;0) 2.98150E+02 +.625*GHSERFE#+.375*GHSERSI# -30143+.27*T; 6.00000E+03 N REF98 ! PHASE FE8SI2C % 3 8 2 1 ! CONSTITUENT FE8SI2C :FE : SI : C : ! PARAMETER G(FE8SI2C,FE:SI:C;0) 2.98150E+02 +8*GHSERFE#+2*GHSERSI# +GHSERCC#-231047+5.566*T; 6.00000E+03 N REF99 ! PHASE FECN_CHI % 2 5 2 ! CONSTITUENT FECN_CHI :FE : C : ! PARAMETER G(FECN_CHI,FE:C;0) 2.98150E+02 -11287.4+1013.78*T -176.412*T*LN(T)+810869*T**(-1); 6.00000E+03 N REF319 ! PHASE FESI2_H % 2 .3 .7 ! CONSTITUENT FESI2_H :FE : SI : ! PARAMETER G(FESI2_H,FE:SI;0) 2.98150E+02 +.3*GHSERFE#+.7*GHSERSI#-19649 -.92*T; 6.00000E+03 N REF98 ! PHASE FESI2_L % 2 .333333 .666667 ! CONSTITUENT FESI2_L :FE : SI : ! PARAMETER G(FESI2_L,FE:SI;0) 2.98150E+02 +.333333*GHSERFE# +.666667*GHSERSI#-27383+3.48*T; 6.00000E+03 N REF98 ! PHASE GRAPHITE % 1 1.0 ! CONSTITUENT GRAPHITE :C : ! PARAMETER G(GRAPHITE,C;0) 2.98150E+02 +GHSERCC#+GPCGRA#; 6.00000E+03 N REF283 ! TYPE_DEFINITION ) GES A_P_D HCP_A3 MAGNETIC -3.0 2.80000E-01 ! PHASE HCP_A3 %) 2 1 .5 ! CONSTITUENT HCP_A3 :CR,FE,MO,SI,V : C,VA% : ! PARAMETER G(HCP_A3,CR:C;0) 2.98150E+02 +GHSERCR#+.5*GHSERCC#-18504 +9.4173*T-2.4997*T*LN(T)+.001386*T**2; 6.00000E+03 N REF322 ! PARAMETER G(HCP_A3,FE:C;0) 2.98150E+02 +52905-11.9075*T+GFEFCC# +.5*GHSERCC#+GPCFCC#; 6.00000E+03 N REF190 ! PARAMETER G(HCP_A3,MO:C;0) 2.98150E+02 -24150-3.625*T-163000*T**(-1) +GHSERMO#+.5*GHSERCC#; 6.00000E+03 N REF104 ! PARAMETER G(HCP_A3,SI:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,V:C;0) 2.98150E+02 -85473+182.441*T-30.551*T*LN(T) -.00538998*T**2+229029*T**(-1); 6.00000E+03 N REF256 ! PARAMETER G(HCP_A3,CR:VA;0) 2.98150E+02 +4438+GHSERCR#+GPCRBCC#; 6.00000E+03 N REF283 ! PARAMETER TC(HCP_A3,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N REF281 ! PARAMETER BMAGN(HCP_A3,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N REF281 ! PARAMETER G(HCP_A3,FE:VA;0) 2.98150E+02 -3705.78+12.591*T-1.15*T*LN(T) +6.4E-04*T**2+GHSERFE#+GPFEHCP#; 1.81100E+03 Y -3957.199+5.24951*T+4.9251E+30*T**(-9)+GHSERFE#+GPFEHCP#; 6.00000E+03 N REF283 ! PARAMETER G(HCP_A3,MO:VA;0) 2.98150E+02 +11550+GHSERMO#+GPMOBCC#; 5.00000E+03 N REF283 ! PARAMETER G(HCP_A3,SI:VA;0) 2.98150E+02 +49200-20.8*T+GHSERSI#; 3.60000E+03 N REF283 ! PARAMETER G(HCP_A3,V:VA;0) 2.98150E+02 +4000+2.4*T+GHSERVZ#; 4.00000E+03 N REF283 ! PARAMETER G(HCP_A3,CR,FE,MO:C;0) 2.98150E+02 -57062; 6.00000E+03 N REF316 ! PARAMETER G(HCP_A3,CR,MO:C;0) 2.98150E+02 -3905+18.5304*T; 6.00000E+03 N REF316 ! PARAMETER G(HCP_A3,CR,V:C;0) 2.98150E+02 +17165-9.9072*T; 6.00000E+03 N REF323 ! PARAMETER G(HCP_A3,CR:C,VA;0) 2.98150E+02 4165; 6.00000E+03 N REF207 ! PARAMETER G(HCP_A3,FE,MO:C;0) 2.98150E+02 +13030-33.8*T; 6.00000E+03 N REF113 ! PARAMETER G(HCP_A3,FE,V:C;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 N REF270 ! PARAMETER G(HCP_A3,FE:C,VA;0) 2.98150E+02 -22126; 6.00000E+03 N REF319 ! PARAMETER G(HCP_A3,MO:C,VA;0) 2.98150E+02 4150; 6.00000E+03 N REF104 ! PARAMETER G(HCP_A3,V:C,VA;0) 2.98150E+02 +12430-3.986*T; 6.00000E+03 N REF256 ! PARAMETER G(HCP_A3,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; 6.00000E+03 N REF126 ! PARAMETER G(HCP_A3,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; 6.00000E+03 N REF117 ! PARAMETER G(HCP_A3,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 N REF117 ! PARAMETER G(HCP_A3,CR,V:VA;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 N REF323 ! PARAMETER G(HCP_A3,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 N REF323 ! PARAMETER G(HCP_A3,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; 6.00000E+03 N REF10 ! PARAMETER G(HCP_A3,FE,SI:VA;0) 2.98150E+02 -123468+41.116*T; 6.00000E+03 N REF42 ! PARAMETER G(HCP_A3,FE,SI:VA;1) 2.98150E+02 -142708; 6.00000E+03 N REF42 ! PARAMETER G(HCP_A3,FE,SI:VA;2) 2.98150E+02 89907; 6.00000E+03 N REF42 ! PARAMETER G(HCP_A3,FE,V:VA;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 N REF270 ! PHASE KSI_CARBIDE % 2 3 1 ! CONSTITUENT KSI_CARBIDE :CR,FE,MO% : C : ! PARAMETER G(KSI_CARBIDE,CR:C;0) 2.98150E+02 +3*GHSERCR#+GHSERCC#+114060 -47.2519*T; 6.00000E+03 N REF316 ! PARAMETER G(KSI_CARBIDE,FE:C;0) 2.98150E+02 +14540+20*T+3*GHSERFE# +GHSERCC#; 6.00000E+03 N REF113 ! PARAMETER G(KSI_CARBIDE,MO:C;0) 2.98150E+02 +167009-33*T+3*GHSERMO# +GHSERCC#; 6.00000E+03 N REF113 ! PARAMETER G(KSI_CARBIDE,CR,FE:C;0) 2.98150E+02 -139900; 6.00000E+03 N REF316 ! PARAMETER G(KSI_CARBIDE,CR,MO:C;0) 2.98150E+02 -348033; 6.00000E+03 N REF316 ! PARAMETER G(KSI_CARBIDE,FE,MO:C;0) 2.98150E+02 -380000; 6.00000E+03 N REF113 ! PHASE LAVES_PHASE % 2 2 1 ! CONSTITUENT LAVES_PHASE :CR,FE : MO : ! PARAMETER G(LAVES_PHASE,CR:MO;0) 2.98150E+02 +2*GCRFCC#+GHSERMO#-8000 -6*T; 6.00000E+03 N REF214 ! PARAMETER G(LAVES_PHASE,FE:MO;0) 2.98150E+02 -10798-.132*T+2*GFEFCC# +GHSERMO#; 6.00000E+03 N REF10 ! PHASE M23C6 % 3 20 3 6 ! CONSTITUENT M23C6 :CR%,FE%,V : CR%,FE%,MO%,V : C : ! PARAMETER G(M23C6,CR:CR:C;0) 2.98150E+02 +GCRM23C6#; 6.00000E+03 N REF102 ! PARAMETER G(M23C6,FE:CR:C;0) 2.98150E+02 +.1304348*GCRM23C6# +.8695652*GFEM23C6#; 6.00000E+03 N REF102 ! PARAMETER G(M23C6,V:CR:C;0) 2.98150E+02 +.869565*GVM23C6# +.130435*GCRM23C6#; 6.00000E+03 N REF323 ! PARAMETER G(M23C6,CR:FE:C;0) 2.98150E+02 +.8695652*GCRM23C6# +.1304348*GFEM23C6#; 6.00000E+03 N REF102 ! PARAMETER G(M23C6,FE:FE:C;0) 2.98150E+02 +GFEM23C6#; 6.00000E+03 N REF102 ! PARAMETER G(M23C6,V:FE:C;0) 2.98150E+02 +.869565*GVM23C6# +.130435*GFEM23C6#; 6.00000E+03 N REF323 ! PARAMETER G(M23C6,CR:MO:C;0) 2.98150E+02 +20*GHSERCR#+3*GHSERMO# +6*GHSERCC#-439117-50.0535*T; 6.00000E+03 N REF316 ! PARAMETER G(M23C6,FE:MO:C;0) 2.98150E+02 +20*GHSERFE#+3*GHSERMO# +6*GHSERCC#-76351-5.095*T; 6.00000E+03 N REF316 ! PARAMETER G(M23C6,V:MO:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(M23C6,CR:V:C;0) 2.98150E+02 +.869565*GCRM23C6# +.130435*GVM23C6#; 6.00000E+03 N REF323 ! PARAMETER G(M23C6,FE:V:C;0) 2.98150E+02 +.869565*GFEM23C6# +.130435*GVM23C6#; 6.00000E+03 N REF323 ! PARAMETER G(M23C6,V:V:C;0) 2.98150E+02 +GVM23C6#; 6.00000E+03 N REF323 ! PARAMETER G(M23C6,CR,FE:CR:C;0) 2.98150E+02 -205342+141.6667*T; 6.00000E+03 N REF322 ! PARAMETER G(M23C6,CR,FE,V:CR:C;0) 2.98150E+02 -1499585; 6.00000E+03 N REF324 ! PARAMETER G(M23C6,CR,V:CR:C;0) 2.98150E+02 -385502; 6.00000E+03 N REF324 ! PARAMETER G(M23C6,CR,FE:FE:C;0) 2.98150E+02 -205342+141.6667*T; 6.00000E+03 N REF322 ! PARAMETER G(M23C6,CR,FE,V:FE:C;0) 2.98150E+02 -1499585; 6.00000E+03 N REF324 ! PARAMETER G(M23C6,CR,V:FE:C;0) 2.98150E+02 -385502; 6.00000E+03 N REF324 ! PARAMETER G(M23C6,CR,FE:MO:C;0) 2.98150E+02 -177850+153.905*T; 6.00000E+03 N REF316 ! PARAMETER G(M23C6,CR,FE:V:C;0) 2.98150E+02 -205342+141.6667*T; 6.00000E+03 N REF324 ! PARAMETER G(M23C6,CR,FE,V:V:C;0) 2.98150E+02 -1499585; 6.00000E+03 N REF324 ! PARAMETER G(M23C6,CR,V:V:C;0) 2.98150E+02 -385502; 6.00000E+03 N REF324 ! PHASE M3C2 % 2 3 2 ! CONSTITUENT M3C2 :CR,MO,V : C : ! PARAMETER G(M3C2,CR:C;0) 2.98150E+02 +GCRM3C2#; 6.00000E+03 N REF322 ! PARAMETER G(M3C2,MO:C;0) 2.98150E+02 +3*GHSERMO#+2*GHSERCC#+27183; 6.00000E+03 N REF316 ! PARAMETER G(M3C2,V:C;0) 2.98150E+02 -222500+16.6545*T+3*GHSERVV# +2*GHSERCC#; 6.00000E+03 N REF324 ! PARAMETER G(M3C2,CR,MO:C;0) 2.98150E+02 40000; 6.00000E+03 N REF316 ! PARAMETER G(M3C2,CR,V:C;0) 2.98150E+02 21072; 6.00000E+03 N REF324 ! PHASE M3SI % 2 3 1 ! CONSTITUENT M3SI :FE : SI : ! PARAMETER G(M3SI,FE:SI;0) 2.98150E+02 +3*GHSERFE#+GHSERSI#-94274-3.56*T; 6.00000E+03 N REF42 ! PHASE M5C2 % 2 5 2 ! CONSTITUENT M5C2 :FE,V : C : ! PARAMETER G(M5C2,FE:C;0) 2.98150E+02 +5*GHSERFE#+2*GHSERCC#+54852 -33.7518*T; 6.00000E+03 N REF322 ! PARAMETER G(M5C2,V:C;0) 2.98150E+02 -307123.3+1059.7*T-175.66*T*LN(T) +1453274*T**(-1); 6.00000E+03 N REF275 ! PHASE M6C % 4 2 2 2 1 ! CONSTITUENT M6C :FE : MO : CR,FE,MO,V : C : ! PARAMETER G(M6C,FE:MO:CR:C;0) 2.98150E+02 +2*GHSERFE#+2*GHSERCR# +2*GHSERMO#+GHSERCC#-25298-54.8698*T; 6.00000E+03 N REF316 ! PARAMETER G(M6C,FE:MO:FE:C;0) 2.98150E+02 +4*GHSERFE#+2*GHSERMO# +GHSERCC#+77705-101.5*T; 6.00000E+03 N REF113 ! PARAMETER G(M6C,FE:MO:MO:C;0) 2.98150E+02 +2*GHSERFE#+4*GHSERMO# +GHSERCC#-122410+30.25*T; 6.00000E+03 N REF113 ! PARAMETER G(M6C,FE:MO:V:C;0) 2.98150E+02 +2*GHSERFE#+2*GHSERMO# +2*GHSERVV#+GHSERCC#-173000; 6.00000E+03 N REF220 ! PARAMETER G(M6C,FE:MO:FE,MO:C;0) 2.98150E+02 -37700; 6.00000E+03 N REF113 ! PHASE M7C3 % 2 7 3 ! CONSTITUENT M7C3 :CR%,FE,MO,V : C : ! PARAMETER G(M7C3,CR:C;0) 2.98150E+02 +GCRM7C3#; 6.00000E+03 N REF322 ! PARAMETER G(M7C3,FE:C;0) 2.98150E+02 +7*GHSERFE#+3*GHSERCC#+75000 -48.2168*T; 6.00000E+03 N REF322 ! PARAMETER G(M7C3,MO:C;0) 2.98150E+02 +7*GHSERMO#+3*GHSERCC#-140415 +24.24*T; 6.00000E+03 N REF316 ! PARAMETER G(M7C3,V:C;0) 2.98150E+02 -454245+1518.48*T-250.981*T*LN(T) +2148691*T**(-1); 6.00000E+03 N REF324 ! PARAMETER G(M7C3,CR,FE:C;0) 2.98150E+02 -4520-10*T; 6.00000E+03 N REF322 ! PARAMETER G(M7C3,CR,FE,V:C;0) 2.98150E+02 -250158; 6.00000E+03 N REF324 ! PARAMETER G(M7C3,CR,MO:C;0) 2.98150E+02 165280; 6.00000E+03 N REF316 ! PARAMETER G(M7C3,CR,V:C;0) 2.98150E+02 -110271; 6.00000E+03 N REF324 ! PHASE MC_ETA % 2 1 1 ! CONSTITUENT MC_ETA :MO% : C%,VA : ! PARAMETER G(MC_ETA,MO:C;0) 2.98150E+02 -9100-5.35*T-750000*T**(-1) +GHSERMO#+GHSERCC#; 6.00000E+03 N REF113 ! PARAMETER G(MC_ETA,MO:VA;0) 2.98150E+02 +GHSERMO#+15200+.63*T; 6.00000E+03 N REF113 ! PARAMETER G(MC_ETA,MO:C,VA;0) 2.98150E+02 -59500; 6.00000E+03 N REF104 ! PHASE MC_SHP % 2 1 1 ! CONSTITUENT MC_SHP :MO : C : ! PARAMETER G(MC_SHP,MO:C;0) 2.98150E+02 -32983+2.5*T+GHSERMO#+GHSERCC#; 6.00000E+03 N REF104 ! PHASE MONI_DELTA % 3 24 20 12 ! CONSTITUENT MONI_DELTA :CR,FE : CR,FE,MO : MO : ! PARAMETER G(MONI_DELTA,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR# +12*GHSERMO#+50000; 6.00000E+03 N REF133 ! PARAMETER G(MONI_DELTA,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(MONI_DELTA,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(MONI_DELTA,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE# +12*GHSERMO#+100000; 6.00000E+03 N REF132 ! PARAMETER G(MONI_DELTA,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO# +100000; 6.00000E+03 N REF133 ! PARAMETER G(MONI_DELTA,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO# +100000; 6.00000E+03 N REF132 ! PHASE MU_PHASE % 3 7 2 4 ! CONSTITUENT MU_PHASE :CR,FE : MO : CR,FE,MO : ! PARAMETER G(MU_PHASE,CR:MO:CR;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO# +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 ! PARAMETER G(MU_PHASE,FE:MO:CR;0) 2.98150E+02 +7*GFEFCC#+2*GHSERMO# +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 ! PARAMETER G(MU_PHASE,CR:MO:FE;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO# +4*GHSERFE#+130000-100*T; 6.00000E+03 N REF115 ! PARAMETER G(MU_PHASE,FE:MO:FE;0) 2.98150E+02 +39475-6.032*T+7*GFEFCC# +2*GHSERMO#+4*GHSERFE#+GPMU1#; 6.00000E+03 N REF10 ! PARAMETER G(MU_PHASE,CR:MO:MO;0) 2.98150E+02 +7*GCRFCC#+6*GHSERMO# +130000-100*T; 6.00000E+03 N REF115 ! PARAMETER G(MU_PHASE,FE:MO:MO;0) 2.98150E+02 -46663-5.891*T+7*GFEFCC# +6*GHSERMO#+GPMU2#; 6.00000E+03 N REF10 ! PARAMETER G(MU_PHASE,CR,FE:MO:MO;0) 2.98150E+02 -45000; 6.00000E+03 N REF115 ! PHASE P_PHASE % 3 24 20 12 ! CONSTITUENT P_PHASE :CR,FE : CR,FE,MO : MO : ! PARAMETER G(P_PHASE,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR# +12*GHSERMO#+252300-100*T; 6.00000E+03 N REF133 ! PARAMETER G(P_PHASE,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(P_PHASE,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(P_PHASE,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE# +12*GHSERMO#+111361; 6.00000E+03 N REF132 ! PARAMETER G(P_PHASE,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO# +95573-200*T; 6.00000E+03 N REF133 ! PARAMETER G(P_PHASE,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO# +362525-332.7*T; 6.00000E+03 N REF132 ! PHASE R_PHASE % 3 27 14 12 ! CONSTITUENT R_PHASE :CR,FE : MO : CR,FE,MO : ! PARAMETER G(R_PHASE,CR:MO:CR;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO# +12*GHSERCR#-20000; 6.00000E+03 N REF115 ! PARAMETER G(R_PHASE,FE:MO:CR;0) 2.98150E+02 +27*GFEFCC#+14*GHSERMO# +12*GHSERCR#+600260-620*T; 6.00000E+03 N REF115 ! PARAMETER G(R_PHASE,CR:MO:FE;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO# +12*GHSERFE#+645260-620*T; 6.00000E+03 N REF115 ! PARAMETER G(R_PHASE,FE:MO:FE;0) 2.98150E+02 -77487-50.486*T+27*GFEFCC# +14*GHSERMO#+12*GHSERFE#+GPR1#; 6.00000E+03 N REF10 ! PARAMETER G(R_PHASE,CR:MO:MO;0) 2.98150E+02 +27*GCRFCC#+26*GHSERMO# -20000; 6.00000E+03 N REF115 ! PARAMETER G(R_PHASE,FE:MO:MO;0) 2.98150E+02 +313474-289.472*T +27*GFEFCC#+26*GHSERMO#+GPR2#; 6.00000E+03 N REF10 ! PHASE SIC % 2 1 1 ! CONSTITUENT SIC :SI : C : ! PARAMETER G(SIC,SI:C;0) 2.98150E+02 -85572.2636+173.200518*T -25.856*T*LN(T)-.02106825*T**2+3.2153E-06*T**3+438415*T**(-1); 7.00000E+02 Y -95145.9018+300.345769*T-45.093*T*LN(T)-.00366815*T**2 +2.19983333E-07*T**3+1341065*T**(-1); 2.10000E+03 Y -105007.971+360.308813*T-53.073*T*LN(T)-7.4525E-04*T**2 +1.73166667E-08*T**3+3693345*T**(-1); 4.00000E+03 N REF286 ! PHASE SIGMA % 3 8 4 18 ! CONSTITUENT SIGMA :FE : CR,MO,V : CR,FE,MO,V : ! PARAMETER G(SIGMA,FE:CR:CR;0) 2.98150E+02 +8*GFEFCC#+22*GHSERCR#+92300 -95.96*T+GPSIG1#; 6.00000E+03 N REF107 ! PARAMETER G(SIGMA,FE:MO:CR;0) 2.98150E+02 +8*GFEFCC#+4*GHSERMO# +18*GHSERCR#+488480-360*T; 6.00000E+03 N REF115 ! PARAMETER G(SIGMA,FE:V:CR;0) 2.98150E+02 +155735-89.5976*T+8*GFEFCC# +4*GHSERVV#+18*GHSERCR#; 6.00000E+03 N REF323 ! PARAMETER G(SIGMA,FE:CR:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# +18*GHSERFE#+117300-95.96*T+GPSIG2#; 6.00000E+03 N REF107 ! PARAMETER G(SIGMA,FE:MO:FE;0) 2.98150E+02 -1813-27.272*T+8*GFEFCC# +18*GHSERFE#+4*GHSERMO#; 6.00000E+03 N REF10 ! PARAMETER G(SIGMA,FE:V:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERVV# +18*GHSERFE#-157961+60.729*T; 6.00000E+03 N REF269 ! PARAMETER G(SIGMA,FE:CR:MO;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# +18*GHSERMO#+312580-260*T; 6.00000E+03 N REF115 ! PARAMETER G(SIGMA,FE:MO:MO;0) 2.98150E+02 +83326-69.618*T+8*GFEFCC# +22*GHSERMO#; 6.00000E+03 N REF10 ! PARAMETER G(SIGMA,FE:V:MO;0) 2.98150E+02 +8*GFEFCC#+4*GHSERVV# +18*GHSERMO#; 6.00000E+03 N REF136 ! PARAMETER G(SIGMA,FE:CR:V;0) 2.98150E+02 -245761-67.3294*T+8*GFEFCC# +4*GHSERCR#+18*GHSERVV#; 6.00000E+03 N REF323 ! PARAMETER G(SIGMA,FE:MO:V;0) 2.98150E+02 +8*GFEFCC#+4*GHSERMO# +18*GHSERVV#; 6.00000E+03 N REF136 ! PARAMETER G(SIGMA,FE:V:V;0) 2.98150E+02 +8*GFEFCC#+22*GHSERVV#-205321 -60.967*T; 6.00000E+03 N REF269 ! PARAMETER G(SIGMA,FE:CR:CR,MO;0) 2.98150E+02 -148000; 6.00000E+03 N REF115 ! PARAMETER G(SIGMA,FE:MO:CR,MO;0) 2.98150E+02 121000; 6.00000E+03 N REF115 ! PARAMETER G(SIGMA,FE:CR:FE,MO;0) 2.98150E+02 570000; 6.00000E+03 N REF115 ! PARAMETER G(SIGMA,FE:CR:FE,V;0) 2.98150E+02 -235158; 6.00000E+03 N REF323 ! PARAMETER G(SIGMA,FE:MO:FE,MO;0) 2.98150E+02 222909; 6.00000E+03 N REF10 ! PARAMETER G(SIGMA,FE:V:FE,V;0) 2.98150E+02 -305784; 6.00000E+03 N REF269 ! PHASE V3C2 % 2 3 2 ! CONSTITUENT V3C2 :FE,V : C : ! PARAMETER G(V3C2,FE:C;0) 2.98150E+02 +7250+741.566*T-125.833*T*LN(T) +779485*T**(-1); 6.00000E+03 N REF275 ! PARAMETER G(V3C2,V:C;0) 2.98150E+02 -260341+16.897*T+3*GHSERVV# +2*GHSERCC#; 6.00000E+03 N REF256 ! LIST_OF_REFERENCES NUMBER SOURCE REF283 'Alan Dinsdale, SGTE Data for Pure Elements, Calphad Vol 15(1991) p 317-425, also in NPL Report DMA(A)195 Rev. August 1990' REF101 'J-O Andersson, Calphad Vol 11 (1987) p 271-276, TRITA 0314; C-CR' REF190 'P. Gustafson, Scan. J. Metall. vol 14, (1985) p 259-267 TRITA 0237 (1984); C-FE' REF104 'J-O Andersson, Calphad Vol 12 (1988) p 1-8 TRITA 0317 (1986); C -MO' REF98 'J. Lacaze and B. Sundman, provisional; Fe-Si' REF256 'W. Huang, TRITA-MAC 431 (1990); C-V' REF267 'W. Huang, Metall. Trans. Vol 21A(1990) p 2115-2123, TRITA-MAC 411 (Rev 1989); C-FE-MN' REF177 'NPL, unpublished work (1989); C-Mn-Si' REF275 'W. Huang, TRITA-MAC 441 (1990), Fe-Mn-V-C *' REF322 'Byeong-Joo Lee, unpublished revision (1991); C-Cr-Fe-Ni' REF213 'P. Gustafson, TRITA-MAC 342, (1987); CR-FE-W' REF115 'J-O Andersson, Met Trans A, Vol 19A, (1988) p 1385-1394 TRITA 0322 (1986); CR-FE-MO' REF324 'Byeong-Joo Lee, TRITA-MAC 475 (1991), C-Cr-Fe-V' REF90 'I Ansara, unpublished work (1991); Cr-Si' REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 September 1989' REF319 'H. Du and M. Hillert, revision; C-Fe-N' REF99 'J. Lacaze and B. Sundman, Met. Trans A, Vol 22A (1991) pp 2211-2223; C-Fe-Si' REF316 'Caian Qui, Trita-MAC 482 (1992) Revision ; C-Cr-Fe-Mo' REF113 'J-O Andersson, Calphad Vol 12 (1988), p 9-23 TRITA 0321 (1986); C-FE-MO' REF214 'P. Gustafson, TRITA-MAC 354 (1987); C-Cr-Fe-Mo-W' REF10 'A. Fernandez Guillermet, CALPHAD Vol 6 (1982), p 127-140 (sigma phase revised 1986), TRITA-MAC 200 (1982); FE-MO' REF102 'J-O Andersson, Met. Trans A, Vol 19A, (1988) p 627-636 TRITA 0207 (1986); C-CR-FE' REF323 'Byeong-Joo Lee, TRITA-MAC 474 (1991), Cr-Fe-V' REF42 'Annika Forsberg and John ]gren, TRITA-MAC 483 (1992); Fe-Mn-Si' REF220 'P Gustafson, Inst. Met. Res. (Sweden) (1990); Estimations of C-CR-FE-V, C-CR-FE-MO-V-W, FE-N-W, FE-MN-N, FE-N-SI, CR-N-V, C-CR -N, FE-MO-N, CR-N-W, CR-TI-N' REF133 'K. Frisk, TRITA-MAC 429 (1990); CR-MO-NI' REF132 'K. Frisk, TRITA-MAC 428 (1990); FE-MO-NI' REF286 'SGTE Substance database, AUG 1989.' REF107 'J-O Andersson, B. Sundman, CALPHAD Vol 11, (1987), p 83-92 TRITA 0270 (1986); CR-FE' REF269 'W. Huang, TRITA-MAC 432 (Rev 1989,1990); FE-V' REF136 'Unassessed parameter, linear combination of unary data. (MU, SIGMA)' REF123 'K. Frisk, Report D 60, KTH, (1984); CR-MO' REF325 'Byeong-Joo Lee, unpublished revision (1991), C-Cr-Fe-Mo-Ni' REF270 'W. Huang, TRITA-MAC 432 (1990); C-Fe-V' REF58 'B. Sundman, TEST' REF207 'P. Gustafson, Metall. Trans. 19A(1988) p 2547-2554, TRITA-MAC 348, (1987); C-CR-FE-W' REF126 'K. Frisk, Metall. Trans. Vol 21A (1990) p 2477-2488, TRITA 0409 (1989); CR-FE-N' REF117 'J-O Andersson, TRITA-MAC 323 (1986); C-CR-FE-MO' REF111 'J-O Andersson, CALPHAD Vol 7, (1983), p 305-315 (parameters revised 1986 due to new decription of V) TRITA 0201 (1982); FE-V' ! ================================================ FILE: examples/macros/steel7.TDB ================================================ $ Database file written 2012- 2-11 $ From database: SSOL2 DATABASE_INFO about the steel1 database It is an extract from the SGTE SSOL2 database from 2001 for 6 elements. Most binary and ternary systems have been assessed and bibliographic references are provided. Most assessments has been made at MSE, KTH, Sweden. for the developent of steels.! $ ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! ELEMENT C GRAPHITE 1.2011E+01 1.0540E+03 5.7400E+00! ELEMENT MO BCC_A2 9.5940E+01 4.5890E+03 2.8560E+01! ELEMENT V BCC_A2 5.0941E+01 4.5070E+03 3.0890E+01! ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01! ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! ELEMENT SI DIAMOND_A4 2.8085E+01 3.2175E+03 1.8820E+01! SPECIES C1 C! SPECIES C2 C2! SPECIES C6 C6! SPECIES C3 C3! SPECIES C7 C7! SPECIES V1C1 V1C1! SPECIES C4 C4! SPECIES C5 C5! FUNCTION GHSERCC 2.98150E+02 -17368.441+170.73*T-24.3*T*LN(T) -4.723E-04*T**2+2562600*T**(-1)-2.643E+08*T**(-2)+1.2E+10*T**(-3); 6.00000E+03 N ! FUNCTION GPCLIQ 2.98150E+02 +YCLIQ#*EXP(ZCLIQ#); 6.00000E+03 N ! FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T) +.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2.18000E+03 Y -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6.00000E+03 N ! FUNCTION GPCRLIQ 2.98150E+02 +YCRLIQ#*EXP(ZCRLIQ#); 6.00000E+03 N ! FUNCTION GFELIQ 2.98150E+02 +12040.17-6.55843*T-3.6751551E-21*T**7 +GHSERFE#; 1.81100E+03 Y -10839.7+291.302*T-46*T*LN(T); 6.00000E+03 N ! FUNCTION GPFELIQ 2.98150E+02 +YFELIQ#*EXP(ZFELIQ#); 6.00000E+03 N ! FUNCTION GHSERMO 2.98150E+02 -7746.302+131.9197*T-23.56414*T*LN(T) -.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)-1.30927E-10*T**4; 2.89600E+03 Y -30556.41+283.559746*T-42.63829*T*LN(T)-4.849315E+33*T**(-9); 5.00000E+03 N ! FUNCTION GPMOLIQ 2.98150E+02 +YMOLIQ#*EXP(ZMOLIQ#); 6.00000E+03 N ! FUNCTION GHSERSI 2.98150E+02 -8162.609+137.227259*T-22.8317533*T*LN(T) -.001912904*T**2-3.552E-09*T**3+176667*T**(-1); 1.68700E+03 Y -9457.642+167.271767*T-27.196*T*LN(T)-4.20369E+30*T**(-9); 3.60000E+03 N ! FUNCTION GHSERVV 2.98150E+02 -7930.43+133.346053*T-24.134*T*LN(T) -.003098*T**2+1.2175E-07*T**3+69460*T**(-1); 7.90000E+02 Y -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; 2.18300E+03 Y -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); 4.00000E+03 N ! FUNCTION GPCRBCC 2.98150E+02 +YCRBCC#*EXP(ZCRBCC#); 6.00000E+03 N ! FUNCTION GPCGRA 2.98150E+02 +YCGRA#*EXP(ZCGRA#); 6.00000E+03 N ! FUNCTION GHSERFE 2.98150E+02 +1225.7+124.134*T-23.5143*T*LN(T) -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6.00000E+03 N ! FUNCTION GPFEBCC 2.98150E+02 +YFEBCC#*EXP(ZFEBCC#); 6.00000E+03 N ! FUNCTION GSIBCC 2.98150E+02 +47000-22.5*T+GHSERSI#; 6.00000E+03 N ! FUNCTION GPMOBCC 2.98150E+02 +YMOBCC#*EXP(ZMOBCC#); 6.00000E+03 N ! FUNCTION GFECEM 2.98150E+02 -10745+706.04*T-120.6*T*LN(T)+GPCEM1#; 6.00000E+03 N ! FUNCTION GCRFCC 2.98150E+02 +7284+.163*T+GHSERCR#; 6.00000E+03 N ! FUNCTION GFEFCC 2.98150E+02 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2 +GHSERFE#; 1.81100E+03 Y -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6.00000E+03 N ! FUNCTION GMOFCC 2.98150E+02 +15200+.63*T+GHSERMO#; 6.00000E+03 N ! FUNCTION GPCDIA 2.98150E+02 +YCDIA#*EXP(ZCDIA#); 6.00000E+03 N ! FUNCTION GPCFCC 2.98150E+02 +YCFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! FUNCTION GPFEFCC 2.98150E+02 +YFEFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! FUNCTION GHSERVZ 2.98150E+02 -7930.43+133.346053*T-24.134*T*LN(T) -.003098*T**2+1.2175E-07*T**3+69460*T**(-1); 7.90000E+02 Y -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; 4.00000E+03 Y -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); 6.00000E+03 N ! FUNCTION GPFEHCP 2.98150E+02 +YFEHCP#*EXP(ZFEHCP#); 6.00000E+03 N ! FUNCTION GCRM23C6 2.98150E+02 -521983+3622.24*T-620.965*T*LN(T) -.126431*T**2; 6.00000E+03 N ! FUNCTION GFEM23C6 2.98150E+02 +7.666667*GFECEM#-1.666667*GHSERCC#+66920 -40*T; 6.00000E+03 N ! FUNCTION GVM23C6 2.98150E+02 -990367+4330.63*T-728.829*T*LN(T) +5003425*T**(-1); 6.00000E+03 N ! FUNCTION GCRM3C2 2.98150E+02 -100823.8+530.66989*T-89.6694*T*LN(T) -.0301188*T**2; 6.00000E+03 N ! FUNCTION GCRM7C3 2.98150E+02 -201690+1103.128*T-190.177*T*LN(T) -.0578207*T**2; 6.00000E+03 N ! FUNCTION GPMU1 2.98150E+02 +8.72E-05*P; 6.00000E+03 N ! FUNCTION GPMU2 2.98150E+02 +1.04E-04*P; 6.00000E+03 N ! FUNCTION GPR1 2.98150E+02 +3.81E-04*P; 6.00000E+03 N ! FUNCTION GPR2 2.98150E+02 +4.33E-04*P; 6.00000E+03 N ! FUNCTION GPSIG1 2.98150E+02 +1.09E-04*P; 6.00000E+03 N ! FUNCTION GPSIG2 2.98150E+02 +1.117E-04*P; 6.00000E+03 N ! FUNCTION L0BCC 2.98150E+02 -27809+11.62*T; 6.00000E+03 N ! FUNCTION FESIW1 2.98150E+02 +1260*R#; 6.00000E+03 N ! FUNCTION L1BCC 2.98150E+02 -11544; 6.00000E+03 N ! FUNCTION L2BCC 2.98150E+02 3890; 6.00000E+03 N ! FUNCTION ETCFESI 2.98150E+02 63; 6.00000E+03 N ! FUNCTION YCLIQ 2.98150E+02 +VCLIQ#*EXP(-ECLIQ#); 6.00000E+03 N ! FUNCTION ZCLIQ 2.98150E+02 +1*LN(XCLIQ#); 6.00000E+03 N ! FUNCTION YCRLIQ 2.98150E+02 +VCRLIQ#*EXP(-ECRLIQ#); 6.00000E+03 N ! FUNCTION ZCRLIQ 2.98150E+02 +1*LN(XCRLIQ#); 6.00000E+03 N ! FUNCTION YFELIQ 2.98150E+02 +VFELIQ#*EXP(-EFELIQ#); 6.00000E+03 N ! FUNCTION ZFELIQ 2.98150E+02 +1*LN(XFELIQ#); 6.00000E+03 N ! FUNCTION YMOLIQ 2.98150E+02 +VMOLIQ#*EXP(-EMOLIQ#); 6.00000E+03 N ! FUNCTION ZMOLIQ 2.98150E+02 +1*LN(XMOLIQ#); 6.00000E+03 N ! FUNCTION YCRBCC 2.98150E+02 +VCRBCC#*EXP(-ECRBCC#); 6.00000E+03 N ! FUNCTION ZCRBCC 2.98150E+02 +1*LN(XCRBCC#); 6.00000E+03 N ! FUNCTION YCGRA 2.98150E+02 +VCGRA#*EXP(-ECGRA#); 6.00000E+03 N ! FUNCTION ZCGRA 2.98150E+02 +1*LN(XCGRA#); 6.00000E+03 N ! FUNCTION YFEBCC 2.98150E+02 +VFEBCC#*EXP(-EFEBCC#); 6.00000E+03 N ! FUNCTION ZFEBCC 2.98150E+02 +1*LN(XFEBCC#); 6.00000E+03 N ! FUNCTION YMOBCC 2.98150E+02 +VMOBCC#*EXP(-EMOBCC#); 6.00000E+03 N ! FUNCTION ZMOBCC 2.98150E+02 +1*LN(XMOBCC#); 6.00000E+03 N ! FUNCTION GPCEM1 2.98150E+02 +VCEM1#*P; 6.00000E+03 N ! FUNCTION YCDIA 2.98150E+02 +VCDIA#*EXP(-ECDIA#); 6.00000E+03 N ! FUNCTION ZCDIA 2.98150E+02 +1*LN(XCDIA#); 6.00000E+03 N ! FUNCTION YCFCC 2.98150E+02 +VCFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! FUNCTION ZFEFCC 2.98150E+02 +1*LN(XFEFCC#); 6.00000E+03 N ! FUNCTION YFEFCC 2.98150E+02 +VFEFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! FUNCTION YFEHCP 2.98150E+02 +VFEHCP#*EXP(-EFEHCP#); 6.00000E+03 N ! FUNCTION ZFEHCP 2.98150E+02 +1*LN(XFEHCP#); 6.00000E+03 N ! FUNCTION VCLIQ 2.98150E+02 +7.626E-06*EXP(ACLIQ#); 6.00000E+03 N ! FUNCTION ECLIQ 2.98150E+02 +1*LN(CCLIQ#); 6.00000E+03 N ! FUNCTION XCLIQ 2.98150E+02 +1*EXP(.5*DCLIQ#)-1; 6.00000E+03 N ! FUNCTION VCRLIQ 2.98150E+02 +7.653E-06*EXP(ACRLIQ#); 6.00000E+03 N ! FUNCTION ECRLIQ 2.98150E+02 +1*LN(CCRLIQ#); 6.00000E+03 N ! FUNCTION XCRLIQ 2.98150E+02 +1*EXP(.8*DCRLIQ#)-1; 6.00000E+03 N ! FUNCTION VFELIQ 2.98150E+02 +6.46677E-06*EXP(AFELIQ#); 6.00000E+03 N ! FUNCTION EFELIQ 2.98150E+02 +1*LN(CFELIQ#); 6.00000E+03 N ! FUNCTION XFELIQ 2.98150E+02 +1*EXP(.8484467*DFELIQ#)-1; 6.00000E+03 N ! FUNCTION VMOLIQ 2.98150E+02 +9.75079E-06*EXP(AMOLIQ#); 6.00000E+03 N ! FUNCTION EMOLIQ 2.98150E+02 +1*LN(CMOLIQ#); 6.00000E+03 N ! FUNCTION XMOLIQ 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 N ! FUNCTION VCRBCC 2.98150E+02 +7.188E-06*EXP(ACRBCC#); 6.00000E+03 N ! FUNCTION ECRBCC 2.98150E+02 +1*LN(CCRBCC#); 6.00000E+03 N ! FUNCTION XCRBCC 2.98150E+02 +1*EXP(.8*DCRBCC#)-1; 6.00000E+03 N ! FUNCTION VCGRA 2.98150E+02 +5.259E-06*EXP(ACGRA#); 6.00000E+03 N ! FUNCTION ECGRA 2.98150E+02 +1*LN(CCGRA#); 6.00000E+03 N ! FUNCTION XCGRA 2.98150E+02 +1*EXP(.9166667*DCGRA#)-1; 6.00000E+03 N ! FUNCTION VFEBCC 2.98150E+02 +7.042095E-06*EXP(AFEBCC#); 6.00000E+03 N ! FUNCTION EFEBCC 2.98150E+02 +1*LN(CFEBCC#); 6.00000E+03 N ! FUNCTION XFEBCC 2.98150E+02 +1*EXP(.7874195*DFEBCC#)-1; 6.00000E+03 N ! FUNCTION VMOBCC 2.98150E+02 +9.34372E-06*EXP(AMOBCC#); 6.00000E+03 N ! FUNCTION EMOBCC 2.98150E+02 +1*LN(CMOBCC#); 6.00000E+03 N ! FUNCTION XMOBCC 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 N ! FUNCTION VCEM1 2.98150E+02 +2.339E-05*EXP(ACEM1#); 6.00000E+03 N ! FUNCTION VCDIA 2.98150E+02 +3.412E-06*EXP(ACDIA#); 6.00000E+03 N ! FUNCTION ECDIA 2.98150E+02 +1*LN(CCDIA#); 6.00000E+03 N ! FUNCTION XCDIA 2.98150E+02 +1*EXP(.8*DCDIA#)-1; 6.00000E+03 N ! FUNCTION VCFCC 2.98150E+02 +1.031E-05*EXP(ACFCC#); 6.00000E+03 N ! FUNCTION EFEFCC 2.98150E+02 +1*LN(CFEFCC#); 6.00000E+03 N ! FUNCTION XFEFCC 2.98150E+02 +1*EXP(.8064454*DFEFCC#)-1; 6.00000E+03 N ! FUNCTION VFEFCC 2.98150E+02 +6.688726E-06*EXP(AFEFCC#); 6.00000E+03 N ! FUNCTION VFEHCP 2.98150E+02 +6.59121E-06*EXP(AFEHCP#); 6.00000E+03 N ! FUNCTION EFEHCP 2.98150E+02 +1*LN(CFEHCP#); 6.00000E+03 N ! FUNCTION XFEHCP 2.98150E+02 +1*EXP(.8064454*DFEHCP#)-1; 6.00000E+03 N ! FUNCTION ACLIQ 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 N ! FUNCTION CCLIQ 2.98150E+02 1.6E-10; 6.00000E+03 N ! FUNCTION DCLIQ 2.98150E+02 +1*LN(BCLIQ#); 6.00000E+03 N ! FUNCTION ACRLIQ 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N ! FUNCTION CCRLIQ 2.98150E+02 3.72E-11; 6.00000E+03 N ! FUNCTION DCRLIQ 2.98150E+02 +1*LN(BCRLIQ#); 6.00000E+03 N ! FUNCTION AFELIQ 2.98150E+02 +1.135E-04*T; 6.00000E+03 N ! FUNCTION CFELIQ 2.98150E+02 +4.22534787E-12+2.71569924E-14*T; 6.00000E+03 N ! FUNCTION DFELIQ 2.98150E+02 +1*LN(BFELIQ#); 6.00000E+03 N ! FUNCTION AMOLIQ 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2 +1.14687E-12*T**3; 6.00000E+03 N ! FUNCTION CMOLIQ 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; 6.00000E+03 N ! FUNCTION DMOBCC 2.98150E+02 +1*LN(BMOBCC#); 6.00000E+03 N ! FUNCTION ACRBCC 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N ! FUNCTION CCRBCC 2.98150E+02 2.08E-11; 6.00000E+03 N ! FUNCTION DCRBCC 2.98150E+02 +1*LN(BCRBCC#); 6.00000E+03 N ! FUNCTION ACGRA 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 N ! FUNCTION CCGRA 2.98150E+02 3.3E-10; 6.00000E+03 N ! FUNCTION DCGRA 2.98150E+02 +1*LN(BCGRA#); 6.00000E+03 N ! FUNCTION AFEBCC 2.98150E+02 +2.3987E-05*T+1.2845E-08*T**2; 6.00000E+03 N ! FUNCTION CFEBCC 2.98150E+02 +2.20949565E-11+2.41329523E-16*T; 6.00000E+03 N ! FUNCTION DFEBCC 2.98150E+02 +1*LN(BFEBCC#); 6.00000E+03 N ! FUNCTION AMOBCC 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2 +1.14687E-12*T**3; 6.00000E+03 N ! FUNCTION CMOBCC 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; 6.00000E+03 N ! FUNCTION ACEM1 2.98150E+02 -1.36E-05*T+4E-08*T**2; 6.00000E+03 N ! FUNCTION ACDIA 2.98150E+02 +2.43E-06*T+5E-09*T**2; 6.00000E+03 N ! FUNCTION CCDIA 2.98150E+02 6.8E-12; 6.00000E+03 N ! FUNCTION DCDIA 2.98150E+02 +1*LN(BCDIA#); 6.00000E+03 N ! FUNCTION ACFCC 2.98150E+02 +1.44E-04*T; 6.00000E+03 N ! FUNCTION CFEFCC 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; 6.00000E+03 N ! FUNCTION DFEFCC 2.98150E+02 +1*LN(BFEFCC#); 6.00000E+03 N ! FUNCTION AFEFCC 2.98150E+02 +7.3097E-05*T; 6.00000E+03 N ! FUNCTION AFEHCP 2.98150E+02 +7.3646E-05*T; 6.00000E+03 N ! FUNCTION CFEHCP 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; 6.00000E+03 N ! FUNCTION DFEHCP 2.98150E+02 +1*LN(BFEHCP#); 6.00000E+03 N ! FUNCTION BCLIQ 2.98150E+02 +1+3.2E-10*P; 6.00000E+03 N ! FUNCTION BCRLIQ 2.98150E+02 +1+4.65E-11*P; 6.00000E+03 N ! FUNCTION BFELIQ 2.98150E+02 +1+4.98009787E-12*P+3.20078924E-14*T*P; 6.00000E+03 N ! FUNCTION BMOBCC 2.98150E+02 +1+1.13837E-11*P+4.875E-16*T*P +1.2675E-19*T**2*P; 6.00000E+03 N ! FUNCTION BCRBCC 2.98150E+02 +1+2.6E-11*P; 6.00000E+03 N ! FUNCTION BCGRA 2.98150E+02 +1+3.6E-10*P; 6.00000E+03 N ! FUNCTION BFEBCC 2.98150E+02 +1+2.80599565E-11*P+3.06481523E-16*T*P; 6.00000E+03 N ! FUNCTION BCDIA 2.98150E+02 +1+8.5E-12*P; 6.00000E+03 N ! FUNCTION BFEFCC 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; 6.00000E+03 N ! FUNCTION BFEHCP 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; 6.00000E+03 N ! FUNCTION UN_ASS 298.15 0; 300 N ! TYPE_DEFINITION % SEQ *! DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! PHASE SIC % 2 1 1 ! CONSTITUENT SIC :SI : C : ! PARAMETER G(SIC,SI:C;0) 2.98150E+02 -85572.2636+173.200518*T -25.856*T*LN(T)-.02106825*T**2+3.2153E-06*T**3+438415*T**(-1); 7.00000E+02 Y -95145.9018+300.345769*T-45.093*T*LN(T)-.00366815*T**2 +2.19983333E-07*T**3+1341065*T**(-1); 2.10000E+03 Y -105007.971+360.308813*T-53.073*T*LN(T)-7.4525E-04*T**2 +1.73166667E-08*T**3+3693345*T**(-1); 4.00000E+03 N REF286 ! TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! PHASE BCC_A2 %& 2 1 3 ! CONSTITUENT BCC_A2 :CR%,FE%,MO%,SI,V% : C,VA% : ! PARAMETER G(BCC_A2,CR:C;0) 2.98150E+02 +GHSERCR#+3*GHSERCC#+GPCRBCC# +3*GPCGRA#+416000; 6.00000E+03 N REF101 ! PARAMETER TC(BCC_A2,CR:C;0) 2.98150E+02 -311.5; 6.00000E+03 N REF101 ! PARAMETER BMAGN(BCC_A2,CR:C;0) 2.98150E+02 -.008; 6.00000E+03 N REF101 ! PARAMETER G(BCC_A2,FE:C;0) 2.98150E+02 +322050+75.667*T+GHSERFE# +GPFEBCC#+3*GHSERCC#+3*GPCGRA#; 6.00000E+03 N REF190 ! PARAMETER TC(BCC_A2,FE:C;0) 2.98150E+02 1043; 6.00000E+03 N REF190 ! PARAMETER BMAGN(BCC_A2,FE:C;0) 2.98150E+02 2.22; 6.00000E+03 N REF190 ! PARAMETER G(BCC_A2,MO:C;0) 2.98150E+02 +331000-75*T+GHSERMO#+3*GHSERCC#; 6.00000E+03 N REF104 ! PARAMETER G(BCC_A2,SI:C;0) 2.98150E+02 +322050-75.667*T+GSIBCC# +3*GHSERCC#+3*GPCGRA#; 6.00000E+03 N REF98 ! PARAMETER G(BCC_A2,V:C;0) 2.98150E+02 +108449+GHSERVV#+3*GHSERCC#; 6.00000E+03 N REF256 ! PARAMETER G(BCC_A2,CR:VA;0) 2.98150E+02 +GHSERCR#+GPCRBCC#; 6.00000E+03 N REF283 ! PARAMETER TC(BCC_A2,CR:VA;0) 2.98150E+02 -311.5; 6.00000E+03 N REF281 ! PARAMETER BMAGN(BCC_A2,CR:VA;0) 2.98150E+02 -.01; 6.00000E+03 N REF281 ! PARAMETER G(BCC_A2,FE:VA;0) 2.98150E+02 +GHSERFE#+GPFEBCC#; 6.00000E+03 N REF283 ! PARAMETER TC(BCC_A2,FE:VA;0) 2.98150E+02 1043; 6.00000E+03 N REF281 ! PARAMETER BMAGN(BCC_A2,FE:VA;0) 2.98150E+02 2.22; 6.00000E+03 N REF281 ! PARAMETER G(BCC_A2,MO:VA;0) 2.98150E+02 +GHSERMO#+GPMOBCC#; 5.00000E+03 N REF283 ! PARAMETER G(BCC_A2,SI:VA;0) 2.98150E+02 +GSIBCC#; 3.60000E+03 N REF283 ! PARAMETER G(BCC_A2,V:VA;0) 2.98150E+02 +GHSERVV#; 4.00000E+03 N REF283 ! PARAMETER G(BCC_A2,CR,FE:C;0) 2.98150E+02 -1250000+667.7*T; 6.00000E+03 N REF322 ! PARAMETER TC(BCC_A2,CR,FE:C;0) 2.98150E+02 1650; 6.00000E+03 N REF102 ! PARAMETER TC(BCC_A2,CR,FE:C;1) 2.98150E+02 550; 6.00000E+03 N REF102 ! PARAMETER BMAGN(BCC_A2,CR,FE:C;0) 2.98150E+02 -.85; 6.00000E+03 N REF102 ! PARAMETER G(BCC_A2,CR:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N REF101 ! PARAMETER G(BCC_A2,FE,MO:C;0) 2.98150E+02 -1250000+667.7*T; 6.00000E+03 N REF325 ! PARAMETER TC(BCC_A2,FE,MO:C;0) 2.98150E+02 335; 6.00000E+03 N REF104 ! PARAMETER TC(BCC_A2,FE,MO:C;1) 2.98150E+02 526; 6.00000E+03 N REF104 ! PARAMETER G(BCC_A2,FE,SI:C;0) 2.98150E+02 78866; 6.00000E+03 N REF99 ! PARAMETER G(BCC_A2,FE,V:C;0) 2.98150E+02 -23674+.465*T; 6.00000E+03 N REF270 ! PARAMETER G(BCC_A2,FE,V:C;1) 2.98150E+02 8283; 6.00000E+03 N REF270 ! PARAMETER G(BCC_A2,FE:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N REF190 ! PARAMETER G(BCC_A2,V:C,VA;0) 2.98150E+02 -297868; 6.00000E+03 N REF256 ! PARAMETER G(BCC_A2,CR,FE:VA;0) 2.98150E+02 +20500-9.68*T; 6.00000E+03 N REF107 ! PARAMETER TC(BCC_A2,CR,FE:VA;0) 2.98150E+02 1650; 6.00000E+03 N REF107 ! PARAMETER TC(BCC_A2,CR,FE:VA;1) 2.98150E+02 550; 6.00000E+03 N REF107 ! PARAMETER BMAGN(BCC_A2,CR,FE:VA;0) 2.98150E+02 -.85; 6.00000E+03 N REF107 ! PARAMETER G(BCC_A2,CR,FE,V:VA;0) 2.98150E+02 14881; 6.00000E+03 N REF323 ! PARAMETER G(BCC_A2,CR,FE,V:VA;1) 2.98150E+02 17968; 6.00000E+03 N REF323 ! PARAMETER G(BCC_A2,CR,FE,V:VA;2) 2.98150E+02 -7692; 6.00000E+03 N REF323 ! PARAMETER G(BCC_A2,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; 6.00000E+03 N REF123 ! PARAMETER G(BCC_A2,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 N REF123 ! PARAMETER G(BCC_A2,CR,SI:VA;0) 2.98150E+02 -102850.19+9.85457*T; 6.00000E+03 N REF90 ! PARAMETER G(BCC_A2,CR,SI:VA;1) 2.98150E+02 -49502.35+13.76967*T; 6.00000E+03 N REF90 ! PARAMETER G(BCC_A2,CR,V:VA;0) 2.98150E+02 -9875-2.6964*T; 6.00000E+03 N REF323 ! PARAMETER G(BCC_A2,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 N REF323 ! PARAMETER G(BCC_A2,FE,MO:VA;0) 2.98150E+02 +36818-9.141*T; 6.00000E+03 N REF10 ! PARAMETER G(BCC_A2,FE,MO:VA;1) 2.98150E+02 -362-5.724*T; 6.00000E+03 N REF10 ! PARAMETER TC(BCC_A2,FE,MO:VA;0) 2.98150E+02 335; 6.00000E+03 N REF10 ! PARAMETER TC(BCC_A2,FE,MO:VA;1) 2.98150E+02 526; 6.00000E+03 N REF10 ! PARAMETER G(BCC_A2,FE,SI:VA;0) 2.98150E+02 +4*L0BCC#-4*FESIW1#; 6.00000E+03 N REF98 ! PARAMETER G(BCC_A2,FE,SI:VA;1) 2.98150E+02 +8*L1BCC#; 6.00000E+03 N REF98 ! PARAMETER G(BCC_A2,FE,SI:VA;2) 2.98150E+02 +16*L2BCC#; 6.00000E+03 N REF98 ! PARAMETER TC(BCC_A2,FE,SI:VA;1) 2.98150E+02 +8*ETCFESI#; 6.00000E+03 N REF98 ! PARAMETER G(BCC_A2,FE,V:VA;0) 2.98150E+02 -23674+.465*T; 6.00000E+03 N REF269 ! PARAMETER G(BCC_A2,FE,V:VA;1) 2.98150E+02 8283; 6.00000E+03 N REF269 ! PARAMETER TC(BCC_A2,FE,V:VA;0) 2.98150E+02 -110; 6.00000E+03 N REF111 ! PARAMETER TC(BCC_A2,FE,V:VA;1) 2.98150E+02 3075; 6.00000E+03 N REF111 ! PARAMETER TC(BCC_A2,FE,V:VA;2) 2.98150E+02 808; 6.00000E+03 N REF111 ! PARAMETER TC(BCC_A2,FE,V:VA;3) 2.98150E+02 -2169; 6.00000E+03 N REF111 ! PARAMETER BMAGN(BCC_A2,FE,V:VA;0) 2.98150E+02 -2.26; 6.00000E+03 N REF111 ! PHASE CEMENTITE % 2 3 1 ! CONSTITUENT CEMENTITE :CR,FE%,MO,V : C : ! PARAMETER G(CEMENTITE,CR:C;0) 2.98150E+02 +3*GHSERCR#+GHSERCC#-48000 -9.2888*T; 6.00000E+03 N REF322 ! PARAMETER G(CEMENTITE,FE:C;0) 2.98150E+02 +GFECEM#; 6.00000E+03 N REF190 ! PARAMETER G(CEMENTITE,MO:C;0) 2.98150E+02 +3*GHSERMO#+GHSERCC#+77000 -57.4*T; 6.00000E+03 N REF104 ! PARAMETER G(CEMENTITE,V:C;0) 2.98150E+02 -156971+601.922*T -100.438*T*LN(T)+765557*T**(-1); 6.00000E+03 N REF275 ! PARAMETER G(CEMENTITE,CR,FE:C;0) 2.98150E+02 +25278-17.5*T; 6.00000E+03 N REF322 ! PARAMETER G(CEMENTITE,CR,MO:C;0) 2.98150E+02 40000; 6.00000E+03 N REF316 ! PARAMETER G(CEMENTITE,CR,V:C;0) 2.98150E+02 -29622-8.0892*T; 6.00000E+03 N REF324 ! PARAMETER G(CEMENTITE,CR,V:C;1) 2.98150E+02 -5160-7.5711*T; 6.00000E+03 N REF324 ! PARAMETER G(CEMENTITE,FE,V:C;0) 2.98150E+02 -45873-12.414*T; 6.00000E+03 N REF270 ! PHASE CHI_A12 % 3 24 10 24 ! CONSTITUENT CHI_A12 :CR,FE : CR,MO : CR,FE,MO : ! PARAMETER G(CHI_A12,CR:CR:CR;0) 2.98150E+02 +48*GCRFCC#+10*GHSERCR# +109000+123*T; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,FE:CR:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR# +24*GCRFCC#+18300-100*T; 6.00000E+03 N REF115 ! PARAMETER G(CHI_A12,CR:MO:CR;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# +24*GCRFCC#-26000; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,FE:MO:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO# +24*GCRFCC#+32555-385*T; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,CR:CR:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR# +24*GFEFCC#+500000; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,FE:CR:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERCR# +57300-100*T; 6.00000E+03 N REF115 ! PARAMETER G(CHI_A12,CR:MO:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# +24*GFEFCC#+500000; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,FE:MO:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERMO# +305210-270*T; 6.00000E+03 N REF115 ! PARAMETER G(CHI_A12,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR# +24*GMOFCC#+500000; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,FE:CR:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR# +24*GMOFCC#+100000; 6.00000E+03 N REF115 ! PARAMETER G(CHI_A12,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# +24*GMOFCC#+500000; 6.00000E+03 N REF213 ! PARAMETER G(CHI_A12,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO# +24*GMOFCC#+97300-100*T; 6.00000E+03 N REF115 ! PHASE CR2VC2 % 3 2 1 2 ! CONSTITUENT CR2VC2 :CR : V : C : ! PARAMETER G(CR2VC2,CR:V:C;0) 2.98150E+02 -105987-38.2069*T+2*GHSERCR# +GHSERVV#+2*GHSERCC#; 6.00000E+03 N REF324 ! PHASE CR3SI % 2 3 1 ! CONSTITUENT CR3SI :CR%,SI : CR,SI% : ! PARAMETER G(CR3SI,CR:CR;0) 2.98150E+02 +17008.82+4*T+4*GHSERCR#; 6.00000E+03 N REF90 ! PARAMETER G(CR3SI,SI:CR;0) 2.98150E+02 +167008.8+4*T+GHSERCR# +3*GHSERSI#; 6.00000E+03 N REF90 ! PARAMETER G(CR3SI,CR:SI;0) 2.98150E+02 -125456.6+4*T+3*GHSERCR# +GHSERSI#; 6.00000E+03 N REF90 ! PARAMETER G(CR3SI,SI:SI;0) 2.98150E+02 +24543.3+4*T+4*GHSERSI#; 6.00000E+03 N REF90 ! PHASE CR5SI3 % 2 5 3 ! CONSTITUENT CR5SI3 :CR : SI : ! PARAMETER G(CR5SI3,CR:SI;0) 2.98150E+02 -318953.76+1067.49776*T -182.57818*T*LN(T)-.02391968*T**2-2.31728E-06*T**3; 6.00000E+03 N REF90 ! PHASE CR1SI1 % 2 1 1 ! CONSTITUENT CR1SI1 :CR : SI : ! PARAMETER G(CR1SI1,CR:SI;0) 2.98150E+02 -79041.68+311.75228*T -51.62865*T*LN(T)-.00447355*T**2+391330*T**(-1); 6.00000E+03 N REF90 ! PHASE CRSI2 % 2 1 2 ! CONSTITUENT CRSI2 :CR%,SI : CR,SI% : ! PARAMETER G(CRSI2,CR:CR;0) 2.98150E+02 +10000+10*T+3*GHSERCR#; 6.00000E+03 N REF90 ! PARAMETER G(CRSI2,SI:CR;0) 2.98150E+02 +150000-T+2*GHSERCR#+GHSERSI#; 6.00000E+03 N REF90 ! PARAMETER G(CRSI2,CR:SI;0) 2.98150E+02 -96793.65+333.25242*T -57.85575*T*LN(T)-.01322769*T**2-4.3203E-07*T**3; 6.00000E+03 N REF90 ! PARAMETER G(CRSI2,SI:SI;0) 2.98150E+02 +77711.85-15.05638*T+3*GHSERSI#; 6.00000E+03 N REF90 ! PARAMETER G(CRSI2,CR:CR,SI;0) 2.98150E+02 -57532.96+11.37201*T; 6.00000E+03 N REF90 ! PARAMETER G(CRSI2,SI:CR,SI;0) 2.98150E+02 -57532.96+11.37201*T; 6.00000E+03 N REF90 ! PHASE CUB_A13 % 2 1 1 ! CONSTITUENT CUB_A13 :CR,FE,SI,V : C,VA% : ! PARAMETER G(CUB_A13,CR:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(CUB_A13,FE:C;0) 2.98150E+02 +90000+GHSERFE#+GHSERCC#; 6.00000E+03 N REF267 ! PARAMETER G(CUB_A13,SI:C;0) 2.98150E+02 +1000000+566.0326*T -85.955678*T*LN(T)-.007814909*T**2+3.7239E-07*T**3+1688653*T**(-1); 3.00000E+03 N REF177 ! PARAMETER G(CUB_A13,V:C;0) 2.98150E+02 +10000+GHSERVV#+GHSERCC#; 6.00000E+03 N REF275 ! PARAMETER G(CUB_A13,CR:VA;0) 2.98150E+02 +15899+.6276*T+GHSERCR#; 6.00000E+03 N REF283 ! PARAMETER G(CUB_A13,FE:VA;0) 2.98150E+02 +3745+GHSERFE#; 6.00000E+03 N REF283 ! PARAMETER G(CUB_A13,SI:VA;0) 2.98150E+02 +47279-20.377*T+GHSERSI#; 3.60000E+03 N REF283 ! PARAMETER G(CUB_A13,V:VA;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(CUB_A13,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N REF267 ! PARAMETER G(CUB_A13,FE,SI:VA;0) 2.98150E+02 -153141+46.48*T; 6.00000E+03 N REF42 ! PARAMETER G(CUB_A13,FE,SI:VA;1) 2.98150E+02 -92352; 6.00000E+03 N REF42 ! PARAMETER G(CUB_A13,FE,SI:VA;2) 2.98150E+02 62240; 6.00000E+03 N REF42 ! PARAMETER G(CUB_A13,FE,V:VA;0) 2.98150E+02 -10000; 6.00000E+03 N REF275 ! PHASE DIAMOND_A4 % 1 1.0 ! CONSTITUENT DIAMOND_A4 :C,SI% : ! PARAMETER G(DIAMOND_A4,C;0) 2.98150E+02 -16359.441+175.61*T -24.31*T*LN(T)-4.723E-04*T**2+2698000*T**(-1)-2.61E+08*T**(-2) +1.11E+10*T**(-3)+GPCDIA#; 6.00000E+03 N REF283 ! PARAMETER G(DIAMOND_A4,SI;0) 2.98150E+02 +GHSERSI#; 3.60000E+03 N REF283 ! TYPE_DEFINITION ( GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! PHASE FCC_A1 %( 2 1 1 ! CONSTITUENT FCC_A1 :CR,FE%,MO,SI,V : C,VA% : ! PARAMETER G(FCC_A1,CR:C;0) 2.98150E+02 +GHSERCR#+GHSERCC#+1200-1.94*T; 6.00000E+03 N REF322 ! PARAMETER G(FCC_A1,FE:C;0) 2.98150E+02 +77207-15.877*T+GFEFCC#+GHSERCC# +GPCFCC#; 6.00000E+03 N REF190 ! PARAMETER TC(FCC_A1,FE:C;0) 2.98150E+02 -201; 6.00000E+03 N REF190 ! PARAMETER BMAGN(FCC_A1,FE:C;0) 2.98150E+02 -2.1; 6.00000E+03 N REF190 ! PARAMETER G(FCC_A1,MO:C;0) 2.98150E+02 -7500-8.3*T-750000*T**(-1) +GHSERMO#+GHSERCC#; 6.00000E+03 N REF104 ! PARAMETER G(FCC_A1,SI:C;0) 2.98150E+02 +GHSERSI#+GHSERCC#-20510+38.7*T; 6.00000E+03 N REF98 ! PARAMETER G(FCC_A1,V:C;0) 2.98150E+02 -117302+262.57*T-41.756*T*LN(T) -.00557101*T**2+590546*T**(-1); 6.00000E+03 N REF256 ! PARAMETER G(FCC_A1,CR:VA;0) 2.98150E+02 +GCRFCC#+GPCRBCC#; 6.00000E+03 N REF281 ! PARAMETER TC(FCC_A1,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N REF281 ! PARAMETER BMAGN(FCC_A1,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N REF281 ! PARAMETER G(FCC_A1,FE:VA;0) 2.98150E+02 +GFEFCC#+GPFEFCC#; 6.00000E+03 N REF283 ! PARAMETER TC(FCC_A1,FE:VA;0) 2.98150E+02 -201; 6.00000E+03 N REF281 ! PARAMETER BMAGN(FCC_A1,FE:VA;0) 2.98150E+02 -2.1; 6.00000E+03 N REF281 ! PARAMETER G(FCC_A1,MO:VA;0) 2.98150E+02 +15200+.63*T+GHSERMO#+GPMOBCC#; 5.00000E+03 N REF283 ! PARAMETER G(FCC_A1,SI:VA;0) 2.98150E+02 +51000-21.8*T+GHSERSI#; 3.60000E+03 N REF283 ! PARAMETER G(FCC_A1,V:VA;0) 2.98150E+02 +7500+1.7*T+GHSERVZ#; 4.00000E+03 N REF283 ! PARAMETER G(FCC_A1,CR,FE:C;0) 2.98150E+02 -74319+3.2353*T; 6.00000E+03 N REF322 ! PARAMETER G(FCC_A1,CR,V:C;0) 2.98150E+02 +35698-50.0981*T; 6.00000E+03 N REF324 ! PARAMETER G(FCC_A1,CR:C,VA;0) 2.98150E+02 -11977+6.8194*T; 6.00000E+03 N REF322 ! PARAMETER G(FCC_A1,FE,MO:C;0) 2.98150E+02 6000; 6.00000E+03 N REF113 ! PARAMETER G(FCC_A1,FE,SI:C;0) 2.98150E+02 +143220+39.31*T; 6.00000E+03 N REF99 ! PARAMETER G(FCC_A1,FE,SI:C;1) 2.98150E+02 -216321; 6.00000E+03 N REF99 ! PARAMETER G(FCC_A1,FE,V:C;0) 2.98150E+02 -7645.5-2.069*T; 6.00000E+03 N REF270 ! PARAMETER G(FCC_A1,FE,V:C;1) 2.98150E+02 -7645.5-2.069*T; 6.00000E+03 N REF270 ! PARAMETER G(FCC_A1,FE,V:C,VA;0) 2.98150E+02 -40000; 6.00000E+03 N REF270 ! PARAMETER G(FCC_A1,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N REF190 ! PARAMETER G(FCC_A1,MO,V:C;0) 2.98150E+02 -18000; 6.00000E+03 N REF220 ! PARAMETER G(FCC_A1,MO:C,VA;0) 2.98150E+02 -41300; 6.00000E+03 N REF104 ! PARAMETER G(FCC_A1,V:C,VA;0) 2.98150E+02 -74811+10.201*T; 6.00000E+03 N REF256 ! PARAMETER G(FCC_A1,V:C,VA;1) 2.98150E+02 -30394; 6.00000E+03 N REF256 ! PARAMETER G(FCC_A1,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; 6.00000E+03 N REF107 ! PARAMETER G(FCC_A1,CR,FE:VA;1) 2.98150E+02 1410; 6.00000E+03 N REF107 ! PARAMETER G(FCC_A1,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; 6.00000E+03 N REF58 ! PARAMETER G(FCC_A1,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 N REF58 ! PARAMETER G(FCC_A1,CR,SI:VA;0) 2.98150E+02 -122850+9.85457*T; 6.00000E+03 N REF58 ! PARAMETER G(FCC_A1,CR,SI:VA;1) 2.98150E+02 -49502+13.76967*T; 6.00000E+03 N REF58 ! PARAMETER G(FCC_A1,CR,V:VA;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 N REF323 ! PARAMETER G(FCC_A1,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 N REF323 ! PARAMETER G(FCC_A1,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; 6.00000E+03 N REF10 ! PARAMETER G(FCC_A1,FE,SI:VA;0) 2.98150E+02 -125248+41.116*T; 6.00000E+03 N REF98 ! PARAMETER G(FCC_A1,FE,SI:VA;1) 2.98150E+02 -142708; 6.00000E+03 N REF98 ! PARAMETER G(FCC_A1,FE,SI:VA;2) 2.98150E+02 89907; 6.00000E+03 N REF98 ! PARAMETER G(FCC_A1,FE,V:VA;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 N REF269 ! PHASE FE1SI1 % 2 .5 .5 ! CONSTITUENT FE1SI1 :FE : SI : ! PARAMETER G(FE1SI1,FE:SI;0) 2.98150E+02 +.5*GHSERFE#+.5*GHSERSI#-36381 +2.22*T; 6.00000E+03 N REF98 ! PHASE FE2SI % 2 .666667 .333333 ! CONSTITUENT FE2SI :FE : SI : ! PARAMETER G(FE2SI,FE:SI;0) 2.98150E+02 +.6666667*GHSERFE# +.3333333*GHSERSI#-23752-3.54*T; 6.00000E+03 N REF98 ! PHASE FE4N % 2 4 1 ! CONSTITUENT FE4N :FE : C,VA : ! PARAMETER G(FE4N,FE:C;0) 2.98150E+02 +15965+4*GHSERFE#+GHSERCC#; 6.00000E+03 N REF319 ! PARAMETER G(FE4N,FE:VA;0) 2.98150E+02 +4*GFEFCC#+10; 6.00000E+03 N REF319 ! PHASE FE5SI3 % 2 .625 .375 ! CONSTITUENT FE5SI3 :FE : SI : ! PARAMETER G(FE5SI3,FE:SI;0) 2.98150E+02 +.625*GHSERFE#+.375*GHSERSI# -30143+.27*T; 6.00000E+03 N REF98 ! PHASE FE8SI2C % 3 8 2 1 ! CONSTITUENT FE8SI2C :FE : SI : C : ! PARAMETER G(FE8SI2C,FE:SI:C;0) 2.98150E+02 +8*GHSERFE#+2*GHSERSI# +GHSERCC#-231047+5.566*T; 6.00000E+03 N REF99 ! PHASE FECN_CHI % 2 5 2 ! CONSTITUENT FECN_CHI :FE : C : ! PARAMETER G(FECN_CHI,FE:C;0) 2.98150E+02 -11287.4+1013.78*T -176.412*T*LN(T)+810869*T**(-1); 6.00000E+03 N REF319 ! PHASE FESI2_H % 2 .3 .7 ! CONSTITUENT FESI2_H :FE : SI : ! PARAMETER G(FESI2_H,FE:SI;0) 2.98150E+02 +.3*GHSERFE#+.7*GHSERSI#-19649 -.92*T; 6.00000E+03 N REF98 ! PHASE FESI2_L % 2 .333333 .666667 ! CONSTITUENT FESI2_L :FE : SI : ! PARAMETER G(FESI2_L,FE:SI;0) 2.98150E+02 +.333333*GHSERFE# +.666667*GHSERSI#-27383+3.48*T; 6.00000E+03 N REF98 ! PHASE GRAPHITE % 1 1.0 ! CONSTITUENT GRAPHITE :C : ! PARAMETER G(GRAPHITE,C;0) 2.98150E+02 +GHSERCC#+GPCGRA#; 6.00000E+03 N REF283 ! TYPE_DEFINITION ) GES A_P_D HCP_A3 MAGNETIC -3.0 2.80000E-01 ! PHASE HCP_A3 %) 2 1 .5 ! CONSTITUENT HCP_A3 :CR,FE,MO,SI,V : C,VA% : ! PARAMETER G(HCP_A3,CR:C;0) 2.98150E+02 +GHSERCR#+.5*GHSERCC#-18504 +9.4173*T-2.4997*T*LN(T)+.001386*T**2; 6.00000E+03 N REF322 ! PARAMETER G(HCP_A3,FE:C;0) 2.98150E+02 +52905-11.9075*T+GFEFCC# +.5*GHSERCC#+GPCFCC#; 6.00000E+03 N REF190 ! PARAMETER G(HCP_A3,MO:C;0) 2.98150E+02 -24150-3.625*T-163000*T**(-1) +GHSERMO#+.5*GHSERCC#; 6.00000E+03 N REF104 ! PARAMETER G(HCP_A3,SI:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(HCP_A3,V:C;0) 2.98150E+02 -85473+182.441*T-30.551*T*LN(T) -.00538998*T**2+229029*T**(-1); 6.00000E+03 N REF256 ! PARAMETER G(HCP_A3,CR:VA;0) 2.98150E+02 +4438+GHSERCR#+GPCRBCC#; 6.00000E+03 N REF283 ! PARAMETER TC(HCP_A3,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N REF281 ! PARAMETER BMAGN(HCP_A3,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N REF281 ! PARAMETER G(HCP_A3,FE:VA;0) 2.98150E+02 -3705.78+12.591*T-1.15*T*LN(T) +6.4E-04*T**2+GHSERFE#+GPFEHCP#; 1.81100E+03 Y -3957.199+5.24951*T+4.9251E+30*T**(-9)+GHSERFE#+GPFEHCP#; 6.00000E+03 N REF283 ! PARAMETER G(HCP_A3,MO:VA;0) 2.98150E+02 +11550+GHSERMO#+GPMOBCC#; 5.00000E+03 N REF283 ! PARAMETER G(HCP_A3,SI:VA;0) 2.98150E+02 +49200-20.8*T+GHSERSI#; 3.60000E+03 N REF283 ! PARAMETER G(HCP_A3,V:VA;0) 2.98150E+02 +4000+2.4*T+GHSERVZ#; 4.00000E+03 N REF283 ! PARAMETER G(HCP_A3,CR,FE,MO:C;0) 2.98150E+02 -57062; 6.00000E+03 N REF316 ! PARAMETER G(HCP_A3,CR,MO:C;0) 2.98150E+02 -3905+18.5304*T; 6.00000E+03 N REF316 ! PARAMETER G(HCP_A3,CR,V:C;0) 2.98150E+02 +17165-9.9072*T; 6.00000E+03 N REF323 ! PARAMETER G(HCP_A3,CR:C,VA;0) 2.98150E+02 4165; 6.00000E+03 N REF207 ! PARAMETER G(HCP_A3,FE,MO:C;0) 2.98150E+02 +13030-33.8*T; 6.00000E+03 N REF113 ! PARAMETER G(HCP_A3,FE,V:C;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 N REF270 ! PARAMETER G(HCP_A3,FE:C,VA;0) 2.98150E+02 -22126; 6.00000E+03 N REF319 ! PARAMETER G(HCP_A3,MO:C,VA;0) 2.98150E+02 4150; 6.00000E+03 N REF104 ! PARAMETER G(HCP_A3,V:C,VA;0) 2.98150E+02 +12430-3.986*T; 6.00000E+03 N REF256 ! PARAMETER G(HCP_A3,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; 6.00000E+03 N REF126 ! PARAMETER G(HCP_A3,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; 6.00000E+03 N REF117 ! PARAMETER G(HCP_A3,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 N REF117 ! PARAMETER G(HCP_A3,CR,V:VA;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 N REF323 ! PARAMETER G(HCP_A3,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 N REF323 ! PARAMETER G(HCP_A3,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; 6.00000E+03 N REF10 ! PARAMETER G(HCP_A3,FE,SI:VA;0) 2.98150E+02 -123468+41.116*T; 6.00000E+03 N REF42 ! PARAMETER G(HCP_A3,FE,SI:VA;1) 2.98150E+02 -142708; 6.00000E+03 N REF42 ! PARAMETER G(HCP_A3,FE,SI:VA;2) 2.98150E+02 89907; 6.00000E+03 N REF42 ! PARAMETER G(HCP_A3,FE,V:VA;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 N REF270 ! PHASE KSI_CARBIDE % 2 3 1 ! CONSTITUENT KSI_CARBIDE :CR,FE,MO% : C : ! PARAMETER G(KSI_CARBIDE,CR:C;0) 2.98150E+02 +3*GHSERCR#+GHSERCC#+114060 -47.2519*T; 6.00000E+03 N REF316 ! PARAMETER G(KSI_CARBIDE,FE:C;0) 2.98150E+02 +14540+20*T+3*GHSERFE# +GHSERCC#; 6.00000E+03 N REF113 ! PARAMETER G(KSI_CARBIDE,MO:C;0) 2.98150E+02 +167009-33*T+3*GHSERMO# +GHSERCC#; 6.00000E+03 N REF113 ! PARAMETER G(KSI_CARBIDE,CR,FE:C;0) 2.98150E+02 -139900; 6.00000E+03 N REF316 ! PARAMETER G(KSI_CARBIDE,CR,MO:C;0) 2.98150E+02 -348033; 6.00000E+03 N REF316 ! PARAMETER G(KSI_CARBIDE,FE,MO:C;0) 2.98150E+02 -380000; 6.00000E+03 N REF113 ! PHASE LAVES_PHASE % 2 2 1 ! CONSTITUENT LAVES_PHASE :CR,FE : MO : ! PARAMETER G(LAVES_PHASE,CR:MO;0) 2.98150E+02 +2*GCRFCC#+GHSERMO#-8000 -6*T; 6.00000E+03 N REF214 ! PARAMETER G(LAVES_PHASE,FE:MO;0) 2.98150E+02 -10798-.132*T+2*GFEFCC# +GHSERMO#; 6.00000E+03 N REF10 ! PHASE M23C6 % 3 20 3 6 ! CONSTITUENT M23C6 :CR%,FE%,V : CR%,FE%,MO%,V : C : ! PARAMETER G(M23C6,CR:CR:C;0) 2.98150E+02 +GCRM23C6#; 6.00000E+03 N REF102 ! PARAMETER G(M23C6,FE:CR:C;0) 2.98150E+02 +.1304348*GCRM23C6# +.8695652*GFEM23C6#; 6.00000E+03 N REF102 ! PARAMETER G(M23C6,V:CR:C;0) 2.98150E+02 +.869565*GVM23C6# +.130435*GCRM23C6#; 6.00000E+03 N REF323 ! PARAMETER G(M23C6,CR:FE:C;0) 2.98150E+02 +.8695652*GCRM23C6# +.1304348*GFEM23C6#; 6.00000E+03 N REF102 ! PARAMETER G(M23C6,FE:FE:C;0) 2.98150E+02 +GFEM23C6#; 6.00000E+03 N REF102 ! PARAMETER G(M23C6,V:FE:C;0) 2.98150E+02 +.869565*GVM23C6# +.130435*GFEM23C6#; 6.00000E+03 N REF323 ! PARAMETER G(M23C6,CR:MO:C;0) 2.98150E+02 +20*GHSERCR#+3*GHSERMO# +6*GHSERCC#-439117-50.0535*T; 6.00000E+03 N REF316 ! PARAMETER G(M23C6,FE:MO:C;0) 2.98150E+02 +20*GHSERFE#+3*GHSERMO# +6*GHSERCC#-76351-5.095*T; 6.00000E+03 N REF316 ! PARAMETER G(M23C6,V:MO:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(M23C6,CR:V:C;0) 2.98150E+02 +.869565*GCRM23C6# +.130435*GVM23C6#; 6.00000E+03 N REF323 ! PARAMETER G(M23C6,FE:V:C;0) 2.98150E+02 +.869565*GFEM23C6# +.130435*GVM23C6#; 6.00000E+03 N REF323 ! PARAMETER G(M23C6,V:V:C;0) 2.98150E+02 +GVM23C6#; 6.00000E+03 N REF323 ! PARAMETER G(M23C6,CR,FE:CR:C;0) 2.98150E+02 -205342+141.6667*T; 6.00000E+03 N REF322 ! PARAMETER G(M23C6,CR,FE,V:CR:C;0) 2.98150E+02 -1499585; 6.00000E+03 N REF324 ! PARAMETER G(M23C6,CR,V:CR:C;0) 2.98150E+02 -385502; 6.00000E+03 N REF324 ! PARAMETER G(M23C6,CR,FE:FE:C;0) 2.98150E+02 -205342+141.6667*T; 6.00000E+03 N REF322 ! PARAMETER G(M23C6,CR,FE,V:FE:C;0) 2.98150E+02 -1499585; 6.00000E+03 N REF324 ! PARAMETER G(M23C6,CR,V:FE:C;0) 2.98150E+02 -385502; 6.00000E+03 N REF324 ! PARAMETER G(M23C6,CR,FE:MO:C;0) 2.98150E+02 -177850+153.905*T; 6.00000E+03 N REF316 ! PARAMETER G(M23C6,CR,FE:V:C;0) 2.98150E+02 -205342+141.6667*T; 6.00000E+03 N REF324 ! PARAMETER G(M23C6,CR,FE,V:V:C;0) 2.98150E+02 -1499585; 6.00000E+03 N REF324 ! PARAMETER G(M23C6,CR,V:V:C;0) 2.98150E+02 -385502; 6.00000E+03 N REF324 ! PHASE M3C2 % 2 3 2 ! CONSTITUENT M3C2 :CR,MO,V : C : ! PARAMETER G(M3C2,CR:C;0) 2.98150E+02 +GCRM3C2#; 6.00000E+03 N REF322 ! PARAMETER G(M3C2,MO:C;0) 2.98150E+02 +3*GHSERMO#+2*GHSERCC#+27183; 6.00000E+03 N REF316 ! PARAMETER G(M3C2,V:C;0) 2.98150E+02 -222500+16.6545*T+3*GHSERVV# +2*GHSERCC#; 6.00000E+03 N REF324 ! PARAMETER G(M3C2,CR,MO:C;0) 2.98150E+02 40000; 6.00000E+03 N REF316 ! PARAMETER G(M3C2,CR,V:C;0) 2.98150E+02 21072; 6.00000E+03 N REF324 ! PHASE M3SI % 2 3 1 ! CONSTITUENT M3SI :FE : SI : ! PARAMETER G(M3SI,FE:SI;0) 2.98150E+02 +3*GHSERFE#+GHSERSI#-94274-3.56*T; 6.00000E+03 N REF42 ! PHASE M5C2 % 2 5 2 ! CONSTITUENT M5C2 :FE,V : C : ! PARAMETER G(M5C2,FE:C;0) 2.98150E+02 +5*GHSERFE#+2*GHSERCC#+54852 -33.7518*T; 6.00000E+03 N REF322 ! PARAMETER G(M5C2,V:C;0) 2.98150E+02 -307123.3+1059.7*T-175.66*T*LN(T) +1453274*T**(-1); 6.00000E+03 N REF275 ! PHASE M6C % 4 2 2 2 1 ! CONSTITUENT M6C :FE : MO : CR,FE,MO,V : C : ! PARAMETER G(M6C,FE:MO:CR:C;0) 2.98150E+02 +2*GHSERFE#+2*GHSERCR# +2*GHSERMO#+GHSERCC#-25298-54.8698*T; 6.00000E+03 N REF316 ! PARAMETER G(M6C,FE:MO:FE:C;0) 2.98150E+02 +4*GHSERFE#+2*GHSERMO# +GHSERCC#+77705-101.5*T; 6.00000E+03 N REF113 ! PARAMETER G(M6C,FE:MO:MO:C;0) 2.98150E+02 +2*GHSERFE#+4*GHSERMO# +GHSERCC#-122410+30.25*T; 6.00000E+03 N REF113 ! PARAMETER G(M6C,FE:MO:V:C;0) 2.98150E+02 +2*GHSERFE#+2*GHSERMO# +2*GHSERVV#+GHSERCC#-173000; 6.00000E+03 N REF220 ! PARAMETER G(M6C,FE:MO:FE,MO:C;0) 2.98150E+02 -37700; 6.00000E+03 N REF113 ! PHASE M7C3 % 2 7 3 ! CONSTITUENT M7C3 :CR%,FE,MO,V : C : ! PARAMETER G(M7C3,CR:C;0) 2.98150E+02 +GCRM7C3#; 6.00000E+03 N REF322 ! PARAMETER G(M7C3,FE:C;0) 2.98150E+02 +7*GHSERFE#+3*GHSERCC#+75000 -48.2168*T; 6.00000E+03 N REF322 ! PARAMETER G(M7C3,MO:C;0) 2.98150E+02 +7*GHSERMO#+3*GHSERCC#-140415 +24.24*T; 6.00000E+03 N REF316 ! PARAMETER G(M7C3,V:C;0) 2.98150E+02 -454245+1518.48*T-250.981*T*LN(T) +2148691*T**(-1); 6.00000E+03 N REF324 ! PARAMETER G(M7C3,CR,FE:C;0) 2.98150E+02 -4520-10*T; 6.00000E+03 N REF322 ! PARAMETER G(M7C3,CR,FE,V:C;0) 2.98150E+02 -250158; 6.00000E+03 N REF324 ! PARAMETER G(M7C3,CR,MO:C;0) 2.98150E+02 165280; 6.00000E+03 N REF316 ! PARAMETER G(M7C3,CR,V:C;0) 2.98150E+02 -110271; 6.00000E+03 N REF324 ! PHASE MC_ETA % 2 1 1 ! CONSTITUENT MC_ETA :MO% : C%,VA : ! PARAMETER G(MC_ETA,MO:C;0) 2.98150E+02 -9100-5.35*T-750000*T**(-1) +GHSERMO#+GHSERCC#; 6.00000E+03 N REF113 ! PARAMETER G(MC_ETA,MO:VA;0) 2.98150E+02 +GHSERMO#+15200+.63*T; 6.00000E+03 N REF113 ! PARAMETER G(MC_ETA,MO:C,VA;0) 2.98150E+02 -59500; 6.00000E+03 N REF104 ! PHASE MC_SHP % 2 1 1 ! CONSTITUENT MC_SHP :MO : C : ! PARAMETER G(MC_SHP,MO:C;0) 2.98150E+02 -32983+2.5*T+GHSERMO#+GHSERCC#; 6.00000E+03 N REF104 ! PHASE MONI_DELTA % 3 24 20 12 ! CONSTITUENT MONI_DELTA :CR,FE : CR,FE,MO : MO : ! PARAMETER G(MONI_DELTA,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR# +12*GHSERMO#+50000; 6.00000E+03 N REF133 ! PARAMETER G(MONI_DELTA,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(MONI_DELTA,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(MONI_DELTA,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE# +12*GHSERMO#+100000; 6.00000E+03 N REF132 ! PARAMETER G(MONI_DELTA,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO# +100000; 6.00000E+03 N REF133 ! PARAMETER G(MONI_DELTA,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO# +100000; 6.00000E+03 N REF132 ! PHASE MU_PHASE % 3 7 2 4 ! CONSTITUENT MU_PHASE :CR,FE : MO : CR,FE,MO : ! PARAMETER G(MU_PHASE,CR:MO:CR;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO# +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 ! PARAMETER G(MU_PHASE,FE:MO:CR;0) 2.98150E+02 +7*GFEFCC#+2*GHSERMO# +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 ! PARAMETER G(MU_PHASE,CR:MO:FE;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO# +4*GHSERFE#+130000-100*T; 6.00000E+03 N REF115 ! PARAMETER G(MU_PHASE,FE:MO:FE;0) 2.98150E+02 +39475-6.032*T+7*GFEFCC# +2*GHSERMO#+4*GHSERFE#+GPMU1#; 6.00000E+03 N REF10 ! PARAMETER G(MU_PHASE,CR:MO:MO;0) 2.98150E+02 +7*GCRFCC#+6*GHSERMO# +130000-100*T; 6.00000E+03 N REF115 ! PARAMETER G(MU_PHASE,FE:MO:MO;0) 2.98150E+02 -46663-5.891*T+7*GFEFCC# +6*GHSERMO#+GPMU2#; 6.00000E+03 N REF10 ! PARAMETER G(MU_PHASE,CR,FE:MO:MO;0) 2.98150E+02 -45000; 6.00000E+03 N REF115 ! PHASE P_PHASE % 3 24 20 12 ! CONSTITUENT P_PHASE :CR,FE : CR,FE,MO : MO : ! PARAMETER G(P_PHASE,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR# +12*GHSERMO#+252300-100*T; 6.00000E+03 N REF133 ! PARAMETER G(P_PHASE,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(P_PHASE,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(P_PHASE,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE# +12*GHSERMO#+111361; 6.00000E+03 N REF132 ! PARAMETER G(P_PHASE,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO# +95573-200*T; 6.00000E+03 N REF133 ! PARAMETER G(P_PHASE,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO# +362525-332.7*T; 6.00000E+03 N REF132 ! PHASE R_PHASE % 3 27 14 12 ! CONSTITUENT R_PHASE :CR,FE : MO : CR,FE,MO : ! PARAMETER G(R_PHASE,CR:MO:CR;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO# +12*GHSERCR#-20000; 6.00000E+03 N REF115 ! PARAMETER G(R_PHASE,FE:MO:CR;0) 2.98150E+02 +27*GFEFCC#+14*GHSERMO# +12*GHSERCR#+600260-620*T; 6.00000E+03 N REF115 ! PARAMETER G(R_PHASE,CR:MO:FE;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO# +12*GHSERFE#+645260-620*T; 6.00000E+03 N REF115 ! PARAMETER G(R_PHASE,FE:MO:FE;0) 2.98150E+02 -77487-50.486*T+27*GFEFCC# +14*GHSERMO#+12*GHSERFE#+GPR1#; 6.00000E+03 N REF10 ! PARAMETER G(R_PHASE,CR:MO:MO;0) 2.98150E+02 +27*GCRFCC#+26*GHSERMO# -20000; 6.00000E+03 N REF115 ! PARAMETER G(R_PHASE,FE:MO:MO;0) 2.98150E+02 +313474-289.472*T +27*GFEFCC#+26*GHSERMO#+GPR2#; 6.00000E+03 N REF10 ! PHASE LIQUID:L % 1 1.0 ! CONSTITUENT LIQUID:L :C,CR,FE,MO,SI,V : ! PARAMETER G(LIQUID,C;0) 2.98150E+02 +117369-24.63*T+GHSERCC#+GPCLIQ#; 6.00000E+03 N REF283 ! PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T +2.37615E-21*T**7+GHSERCR#+GPCRLIQ#; 2.18000E+03 Y +18409.36-8.563683*T+2.88526E+32*T**(-9)+GHSERCR#+GPCRLIQ#; 6.00000E+03 N REF283 ! PARAMETER G(LIQUID,FE;0) 2.98150E+02 +GFELIQ#+GPFELIQ#; 6.00000E+03 N REF283 ! PARAMETER G(LIQUID,MO;0) 2.98150E+02 +41831.347-14.694912*T +4.24519E-22*T**7+GHSERMO#+GPMOLIQ#; 2.89600E+03 Y +34095.373-11.890046*T+4.849315E+33*T**(-9)+GHSERMO#+GPMOLIQ#; 5.00000E+03 N REF283 ! PARAMETER G(LIQUID,SI;0) 2.98150E+02 +50696.36-30.099439*T +2.09307E-21*T**7+GHSERSI#; 1.68700E+03 Y +49828.165-29.559069*T+4.20369E+30*T**(-9)+GHSERSI#; 3.60000E+03 N REF283 ! PARAMETER G(LIQUID,V;0) 2.98150E+02 +20764.117-9.455552*T -5.19136E-22*T**7+GHSERVV#; 7.90000E+02 Y +20764.117-9.455552*T-5.19136E-22*T**7+GHSERVV#; 2.18300E+03 Y +22072.354-10.0848*T-6.44389E+31*T**(-9)+GHSERVV#; 4.00000E+03 N REF283 ! PARAMETER G(LIQUID,C,CR;0) 2.98150E+02 -90526-25.9116*T; 6.00000E+03 N REF101 ! PARAMETER G(LIQUID,C,CR;1) 2.98150E+02 80000; 6.00000E+03 N REF101 ! PARAMETER G(LIQUID,C,CR;2) 2.98150E+02 80000; 6.00000E+03 N REF101 ! PARAMETER G(LIQUID,C,CR,FE;0) 2.98150E+02 -496063; 6.00000E+03 N REF322 ! PARAMETER G(LIQUID,C,CR,FE;1) 2.98150E+02 57990; 6.00000E+03 N REF322 ! PARAMETER G(LIQUID,C,CR,FE;2) 2.98150E+02 61404; 6.00000E+03 N REF322 ! PARAMETER G(LIQUID,C,CR,V;0) 2.98150E+02 -769497; 6.00000E+03 N REF324 ! PARAMETER G(LIQUID,C,CR,V;1) 2.98150E+02 263981; 6.00000E+03 N REF324 ! PARAMETER G(LIQUID,C,CR,V;2) 2.98150E+02 3599; 6.00000E+03 N REF324 ! PARAMETER G(LIQUID,C,FE;0) 2.98150E+02 -124320+28.5*T; 6.00000E+03 N REF190 ! PARAMETER G(LIQUID,C,FE;1) 2.98150E+02 19300; 6.00000E+03 N REF190 ! PARAMETER G(LIQUID,C,FE;2) 2.98150E+02 +49260-19*T; 6.00000E+03 N REF190 ! PARAMETER G(LIQUID,C,FE,SI;0) 2.98150E+02 445740; 6.00000E+03 N REF99 ! PARAMETER G(LIQUID,C,FE,SI;1) 2.98150E+02 -6065-35.33*T; 6.00000E+03 N REF99 ! PARAMETER G(LIQUID,C,FE,SI;2) 2.98150E+02 +2545792-1450.6*T; 6.00000E+03 N REF99 ! PARAMETER G(LIQUID,C,FE,V;0) 2.98150E+02 -60000; 6.00000E+03 N REF270 ! PARAMETER G(LIQUID,C,FE,V;1) 2.98150E+02 -60000; 6.00000E+03 N REF270 ! PARAMETER G(LIQUID,C,FE,V;2) 2.98150E+02 100000; 6.00000E+03 N REF270 ! PARAMETER G(LIQUID,C,FE,MO;0) 2.98150E+02 -37800; 6.00000E+03 N REF113 ! PARAMETER G(LIQUID,C,MO;0) 2.98150E+02 -217800+38.41*T; 6.00000E+03 N REF104 ! PARAMETER G(LIQUID,C,MO;1) 2.98150E+02 30000; 6.00000E+03 N REF104 ! PARAMETER G(LIQUID,C,MO;2) 2.98150E+02 47000; 6.00000E+03 N REF104 ! PARAMETER G(LIQUID,C,SI;0) 2.98150E+02 -133000+30.97*T; 6.00000E+03 N REF99 ! PARAMETER G(LIQUID,C,V;0) 2.98150E+02 -284196+38.952*T; 6.00000E+03 N REF256 ! PARAMETER G(LIQUID,C,V;1) 2.98150E+02 +96335-17.775*T; 6.00000E+03 N REF256 ! PARAMETER G(LIQUID,C,V;2) 2.98150E+02 102050; 6.00000E+03 N REF256 ! PARAMETER G(LIQUID,CR,FE;0) 2.98150E+02 -14550+6.65*T; 6.00000E+03 N REF107 ! PARAMETER G(LIQUID,CR,FE,V;0) 2.98150E+02 14881; 6.00000E+03 N REF323 ! PARAMETER G(LIQUID,CR,FE,V;1) 2.98150E+02 17968; 6.00000E+03 N REF323 ! PARAMETER G(LIQUID,CR,FE,V;2) 2.98150E+02 -7692; 6.00000E+03 N REF323 ! PARAMETER G(LIQUID,CR,MO;0) 2.98150E+02 +15810-6.714*T; 6.00000E+03 N REF123 ! PARAMETER G(LIQUID,CR,MO;1) 2.98150E+02 -6220; 6.00000E+03 N REF123 ! PARAMETER G(LIQUID,CR,SI;0) 2.98150E+02 -120157.52+16.63891*T; 6.00000E+03 N REF90 ! PARAMETER G(LIQUID,CR,SI;1) 2.98150E+02 -49502.35+13.76967*T; 6.00000E+03 N REF90 ! PARAMETER G(LIQUID,CR,V;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 N REF323 ! PARAMETER G(LIQUID,CR,V;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 N REF323 ! PARAMETER G(LIQUID,FE,MO;0) 2.98150E+02 -6973-.37*T; 6.00000E+03 N REF10 ! PARAMETER G(LIQUID,FE,MO;1) 2.98150E+02 -9424+4.502*T; 6.00000E+03 N REF10 ! PARAMETER G(LIQUID,FE,SI;0) 2.98150E+02 -164435+41.977*T; 6.00000E+03 N REF99 ! PARAMETER G(LIQUID,FE,SI;1) 2.98150E+02 -21.523*T; 6.00000E+03 N REF99 ! PARAMETER G(LIQUID,FE,SI;2) 2.98150E+02 -18821+22.07*T; 6.00000E+03 N REF99 ! PARAMETER G(LIQUID,FE,SI;3) 2.98150E+02 9696; 6.00000E+03 N REF99 ! PARAMETER G(LIQUID,FE,V;0) 2.98150E+02 -34679+1.895*T; 6.00000E+03 N REF269 ! PARAMETER G(LIQUID,FE,V;1) 2.98150E+02 10209; 6.00000E+03 N REF269 ! PHASE SIGMA % 3 8 4 18 ! CONSTITUENT SIGMA :FE : CR,MO,V : CR,FE,MO,V : ! PARAMETER G(SIGMA,FE:CR:CR;0) 2.98150E+02 +8*GFEFCC#+22*GHSERCR#+92300 -95.96*T+GPSIG1#; 6.00000E+03 N REF107 ! PARAMETER G(SIGMA,FE:MO:CR;0) 2.98150E+02 +8*GFEFCC#+4*GHSERMO# +18*GHSERCR#+488480-360*T; 6.00000E+03 N REF115 ! PARAMETER G(SIGMA,FE:V:CR;0) 2.98150E+02 +155735-89.5976*T+8*GFEFCC# +4*GHSERVV#+18*GHSERCR#; 6.00000E+03 N REF323 ! PARAMETER G(SIGMA,FE:CR:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# +18*GHSERFE#+117300-95.96*T+GPSIG2#; 6.00000E+03 N REF107 ! PARAMETER G(SIGMA,FE:MO:FE;0) 2.98150E+02 -1813-27.272*T+8*GFEFCC# +18*GHSERFE#+4*GHSERMO#; 6.00000E+03 N REF10 ! PARAMETER G(SIGMA,FE:V:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERVV# +18*GHSERFE#-157961+60.729*T; 6.00000E+03 N REF269 ! PARAMETER G(SIGMA,FE:CR:MO;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# +18*GHSERMO#+312580-260*T; 6.00000E+03 N REF115 ! PARAMETER G(SIGMA,FE:MO:MO;0) 2.98150E+02 +83326-69.618*T+8*GFEFCC# +22*GHSERMO#; 6.00000E+03 N REF10 ! PARAMETER G(SIGMA,FE:V:MO;0) 2.98150E+02 +8*GFEFCC#+4*GHSERVV# +18*GHSERMO#; 6.00000E+03 N REF136 ! PARAMETER G(SIGMA,FE:CR:V;0) 2.98150E+02 -245761-67.3294*T+8*GFEFCC# +4*GHSERCR#+18*GHSERVV#; 6.00000E+03 N REF323 ! PARAMETER G(SIGMA,FE:MO:V;0) 2.98150E+02 +8*GFEFCC#+4*GHSERMO# +18*GHSERVV#; 6.00000E+03 N REF136 ! PARAMETER G(SIGMA,FE:V:V;0) 2.98150E+02 +8*GFEFCC#+22*GHSERVV#-205321 -60.967*T; 6.00000E+03 N REF269 ! PARAMETER G(SIGMA,FE:CR:CR,MO;0) 2.98150E+02 -148000; 6.00000E+03 N REF115 ! PARAMETER G(SIGMA,FE:MO:CR,MO;0) 2.98150E+02 121000; 6.00000E+03 N REF115 ! PARAMETER G(SIGMA,FE:CR:FE,MO;0) 2.98150E+02 570000; 6.00000E+03 N REF115 ! PARAMETER G(SIGMA,FE:CR:FE,V;0) 2.98150E+02 -235158; 6.00000E+03 N REF323 ! PARAMETER G(SIGMA,FE:MO:FE,MO;0) 2.98150E+02 222909; 6.00000E+03 N REF10 ! PARAMETER G(SIGMA,FE:V:FE,V;0) 2.98150E+02 -305784; 6.00000E+03 N REF269 ! TYPE_DEFINITION ' GES A_P_D CBCC_A12 MAGNETIC -3.0 2.80000E-01 ! PHASE CBCC_A12 %' 2 1 1 ! CONSTITUENT CBCC_A12 :CR,FE,SI,V : C,VA% : ! PARAMETER G(CBCC_A12,CR:C;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(CBCC_A12,FE:C;0) 2.98150E+02 +80000+GHSERFE#+GHSERCC#; 6.00000E+03 N REF267 ! PARAMETER G(CBCC_A12,SI:C;0) 2.98150E+02 +1000000+566.0326*T -85.955678*T*LN(T)-.007814909*T**2+3.7239E-07*T**3+1688653*T**(-1); 3.00000E+03 N REF177 ! PARAMETER G(CBCC_A12,V:C;0) 2.98150E+02 +10000+GHSERVV#+GHSERCC#; 6.00000E+03 N REF275 ! PARAMETER G(CBCC_A12,CR:VA;0) 2.98150E+02 +11087+2.7196*T+GHSERCR#; 6.00000E+03 N REF283 ! PARAMETER G(CBCC_A12,FE:VA;0) 2.98150E+02 +4745+GHSERFE#; 6.00000E+03 N REF283 ! PARAMETER G(CBCC_A12,SI:VA;0) 2.98150E+02 +50208-20.377*T+GHSERSI#; 3.60000E+03 N REF283 ! PARAMETER G(CBCC_A12,V:VA;0) 298.15 UN_ASS; 300 N REF0 ! PARAMETER G(CBCC_A12,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N REF267 ! PARAMETER G(CBCC_A12,FE,SI:VA;0) 2.98150E+02 -153141+46.48*T; 6.00000E+03 N REF42 ! PARAMETER G(CBCC_A12,FE,SI:VA;1) 2.98150E+02 -92352; 6.00000E+03 N REF42 ! PARAMETER G(CBCC_A12,FE,SI:VA;2) 2.98150E+02 62240; 6.00000E+03 N REF42 ! PARAMETER G(CBCC_A12,FE,V:VA;0) 2.98150E+02 -10000; 6.00000E+03 N REF275 ! PHASE V3C2 % 2 3 2 ! CONSTITUENT V3C2 :FE,V : C : ! PARAMETER G(V3C2,FE:C;0) 2.98150E+02 +7250+741.566*T-125.833*T*LN(T) +779485*T**(-1); 6.00000E+03 N REF275 ! PARAMETER G(V3C2,V:C;0) 2.98150E+02 -260341+16.897*T+3*GHSERVV# +2*GHSERCC#; 6.00000E+03 N REF256 ! LIST_OF_REFERENCES NUMBER SOURCE REF283 'Alan Dinsdale, SGTE Data for Pure Elements, Calphad Vol 15(1991) p 317-425, also in NPL Report DMA(A)195 Rev. August 1990' REF101 'J-O Andersson, Calphad Vol 11 (1987) p 271-276, TRITA 0314; C-CR' REF190 'P. Gustafson, Scan. J. Metall. vol 14, (1985) p 259-267 TRITA 0237 (1984); C-FE' REF104 'J-O Andersson, Calphad Vol 12 (1988) p 1-8 TRITA 0317 (1986); C -MO' REF98 'J. Lacaze and B. Sundman, provisional; Fe-Si' REF256 'W. Huang, TRITA-MAC 431 (1990); C-V' REF267 'W. Huang, Metall. Trans. Vol 21A(1990) p 2115-2123, TRITA-MAC 411 (Rev 1989); C-FE-MN' REF177 'NPL, unpublished work (1989); C-Mn-Si' REF275 'W. Huang, TRITA-MAC 441 (1990), Fe-Mn-V-C *' REF322 'Byeong-Joo Lee, unpublished revision (1991); C-Cr-Fe-Ni' REF213 'P. Gustafson, TRITA-MAC 342, (1987); CR-FE-W' REF115 'J-O Andersson, Met Trans A, Vol 19A, (1988) p 1385-1394 TRITA 0322 (1986); CR-FE-MO' REF324 'Byeong-Joo Lee, TRITA-MAC 475 (1991), C-Cr-Fe-V' REF90 'I Ansara, unpublished work (1991); Cr-Si' REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 September 1989' REF319 'H. Du and M. Hillert, revision; C-Fe-N' REF99 'J. Lacaze and B. Sundman, Met. Trans A, Vol 22A (1991) pp 2211-2223; C-Fe-Si' REF316 'Caian Qui, Trita-MAC 482 (1992) Revision ; C-Cr-Fe-Mo' REF113 'J-O Andersson, Calphad Vol 12 (1988), p 9-23 TRITA 0321 (1986); C-FE-MO' REF214 'P. Gustafson, TRITA-MAC 354 (1987); C-Cr-Fe-Mo-W' REF10 'A. Fernandez Guillermet, CALPHAD Vol 6 (1982), p 127-140 (sigma phase revised 1986), TRITA-MAC 200 (1982); FE-MO' REF102 'J-O Andersson, Met. Trans A, Vol 19A, (1988) p 627-636 TRITA 0207 (1986); C-CR-FE' REF323 'Byeong-Joo Lee, TRITA-MAC 474 (1991), Cr-Fe-V' REF42 'Annika Forsberg and John ]gren, TRITA-MAC 483 (1992); Fe-Mn-Si' REF220 'P Gustafson, Inst. Met. Res. (Sweden) (1990); Estimations of C-CR-FE-V, C-CR-FE-MO-V-W, FE-N-W, FE-MN-N, FE-N-SI, CR-N-V, C-CR -N, FE-MO-N, CR-N-W, CR-TI-N' REF133 'K. Frisk, TRITA-MAC 429 (1990); CR-MO-NI' REF132 'K. Frisk, TRITA-MAC 428 (1990); FE-MO-NI' REF286 'SGTE Substance database, AUG 1989.' REF107 'J-O Andersson, B. Sundman, CALPHAD Vol 11, (1987), p 83-92 TRITA 0270 (1986); CR-FE' REF269 'W. Huang, TRITA-MAC 432 (Rev 1989,1990); FE-V' REF136 'Unassessed parameter, linear combination of unary data. (MU, SIGMA)' REF123 'K. Frisk, Report D 60, KTH, (1984); CR-MO' REF325 'Byeong-Joo Lee, unpublished revision (1991), C-Cr-Fe-Mo-Ni' REF270 'W. Huang, TRITA-MAC 432 (1990); C-Fe-V' REF58 'B. Sundman, TEST' REF207 'P. Gustafson, Metall. Trans. 19A(1988) p 2547-2554, TRITA-MAC 348, (1987); C-CR-FE-W' REF126 'K. Frisk, Metall. Trans. Vol 21A (1990) p 2477-2488, TRITA 0409 (1989); CR-FE-N' REF117 'J-O Andersson, TRITA-MAC 323 (1986); C-CR-FE-MO' REF111 'J-O Andersson, CALPHAD Vol 7, (1983), p 305-315 (parameters revised 1986 due to new decription of V) TRITA 0201 (1982); FE-V' ! ================================================ FILE: examples/macros/step-epz.OCM ================================================ @$ new Y set echo Y @$=============================================================== @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ Macro showing calculation of equilibrium diagram, @$ paraequilibrium and tzero line for the same system @$ @$ Same as TC example 23 (but not same database) @$ @$ macro file at oc/oc6/ @& @$=============================================================== @$ @$ Use Bengt Hallstedt's special database for cast iron @$ Using read selected to avoid graphite and all carbides except cementite @$ read selected tdb ./iron4cd @$ fe mn c si @$ fcc bcc cementit read tdb ./iron4cd fe mn c si @$ ignore the warnings ... @& l sh a @$ Normally graphite is never formed in steel set st ph gra=dor @& @$ Conditions for a low alloyed steel set c t=1000 p=1e5 n=1 w(mn)=0.015 w(si)=.003 w(c)=.001 c e l , 4 @$ Set reference states for C and Fe set ref c gra * 1e5 set ref fe bcc * 1e5 @$ Set axis to calculate the equilibrium isopleth set ax 1 w(c) 0 0.02 0.0005 set ax 2 t 750 1200 10 @& map @& plot title map Fe-Mn-Si-C Fig 1a @& @$ For plotting one can use T_C, in degrees Celsius plot w%(c) T_C scale x n 0 1 scale y n 500 900 title map-epz Fig 1b @$ label the FCC region text .4 840 2 0 N FCC @$ Label the FCC+BCC+CEMENTITE text N .65 710 .8 2 N FCC+BCC+CEMENTITE text N .65 600 .8 0 N BCC+CEMENTITE out ./map-epz1 y @$=========================================== @$ @$ Calculate a paraequilibrium diagram between fcc and bcc @$ Suspend all phases except fcc and bcc @$ set st ph *=sus set st ph fcc bcc=ent 0 @$ Use "c n" using previous results and @$ to avoid creating additional composition sets c n l,,,, @$ @& @$ Prepare to calculate a paraequilibrium fcc/bcc at this T set st ph *=sus set st ph fcc bcc=ent 1 c n l,,,,, @& @$ Now calculate the para equilibrium just for C @$ because C can diffuse must faster than Mn and Si calc para fcc bcc c @& l,,,, @$ The composition of the two phases is listed @$ Compare with the full equilibrium above (sometimes called ortho-equil) @$ Note the content of Mn and Si are the same in bcc and fcc @$ The Gibbs energy is higher, -43869.0 J/mol @$ as it is not the stable equilibrium. @& @$ set an axis to calculate the paraequilibrium for various T @$ Remove the second axis set ax 1 t 750 1200 5 set ax 2 none @& @$ First y is to delete previous map results, @$ second y that we have done all necessary things step para y y fcc bcc C @$ The step command calculates the carbon contenet @$ in bcc and fcc with same carbon activity and @$ same fractions of Mn and Si, i.e. the para-equilibrium @& plot Title step-epz Fig 2a @& @$ Scale the x-axis plot w%(*,c) T_C scale x n 0 1 scale y n 500 900 text .15 800 .8 -23 FCC paraequilibrium line Title step-epz Fig 2b @$ ============================================================== @$ Overlay the carbon solubility curves, in fcc and bcc with the phase diagram @& @$ Append this on the previous diagram plot app ./map-epz1 Title step-epz Fig 3 out ./epzpdpara y @$ This is the paraequilibrium lines together with the equilibrium diagram @$ The paraequilibrium solubility lines are inside @$ the stable two-phase region fcc/bcc @& @$================================================ @$ Finally calculate the tzero line with equal @$ Gibbs energy for FCC and BCC @$ This is the limit for diffusionless transformation (martensite) l c c tz fcc bcc 1 @$ The last line with "1" means release the condition on T @& @$ For the tzero diagram the axis must be w(c) !! set ax 1 w(c) 0 .008 .0001 step tz y y fcc bcc @& plot w%(c) T_C text .39 620 .8 -33 T-zero line Title T-zero Fig 4 out ./tzero-noG-nucleation @$ We have plotted the Tzero line with a label @$ ************************************* @& @$ @$ Now plot all together, the phase diagram, @$ the paraequilibrium lines and the tzero line plot scale x n 0 1 scale y n 500 900 Title step-epz Fig 5 app ./epzpdpara @$ This diagran gives some indication of possible transitions @$ because carbon can diffuse rapidly even at low T @$========================================================================== @$ end of step-epz macro @$========================================================================== set inter ================================================ FILE: examples/macros/step-scheil.OCM ================================================ @$ new Y set echo Y @$=============================================================== @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ step-scheil_Gulliver.OCM @$ @$ Step in carbon contenr to follow T-zero line between BCC and FCC @$ The tzero line is the limit of diffusionless transformation @$ Below the tzero line FCC may transform to metastable BCC @$ without carbon diffusion. @& @$=============================================================== @$ set echo r t ./cost507R al mg si zn set c t=1000 p=1e5 n=1 x(mg)=.02 x(si)=.03 x(zn)=0.02 c e l,,, @& @$ Slow cooling will maintain equilibrium and can be simulated @$ by a step command with axis T set ax 1 t 600 1000 2 step plot np(*) T title step-scheil Fig 1 text .15 830 .8 24 Equilibrium liquid fraction output ./equil-solidific Y render @$ This is a solidification assuming full equilibrium in the system @$ But as diffusion in the solid is slow a normal solidification @$ frequently create non-equilibrium structures. @& @$==================================== @$ In a Scheil-Gulliver simulation the liquid is assumed to be @$ homogeneous and in equilibrium with the most recently formed solid. @$ The at each step in T the solid formed is removed @$ and the liquid composition modified according to the quilibrium @$ This means the liquid composition will vary until we reach @$ an invariant equilibrium where the last liquid will disappear. step scheil Y y @$ The output during the step command is temporary but indicates @$ how the fraction liquid and its composition changes with T. @& plot PFL T title step-scheil Fig 2 @$ PFL is a special symbol for the "phase fraction liquid" @$ Which is the most interesting result of the simulation. @$ Note that the liquid is stable to very much lower T than @$ when the equilibrium is assumed. We can overlay the figures @& @$ set inter some plotting problems here @$ @$ GNUPLOT has modified reading from datafiles with different @$ number od columns. The plot is not totaly coherent plot title step-scheil Fig 3 append ./equil-solidific.plt @$---------------------------------------------------------------------- @$ With gnuplot 5.2 from 2019 there are no messages from gnuplot @$ but with gnuplot 6 from 2024 there are messages but the plot the same @$---------------------------------------------------------------------- @& @$ Segregation is also important, we can plot the liquid composition @$ in the Scheil simulation plot x(liq,*) T title step-scheil Fig 4 @$ and note the last liquid is 70% Zn @$ This can be very bad for the mechanical properties @$ and require complex heat treatments to homogenize the alloy @$========================================================================== @$ end of step-scheil macro @$========================================================================== set inter ================================================ FILE: examples/macros/step-tzero.OCM ================================================ new Y set echo Y @$=============================================================== @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ step-tzero.OCM @$ @$ This example show the T limit of diffusionless transformation @$ from austenite (FCC) to ferrite (FCC) depending on the @$ alloy composition. @$ @$ This transformation is important as rapidly quenched austenite @$ can transform to martensite and various forms of eutectoid @$ structures like perlite and bainite with high strength @$ @& @$=============================================================== @$ set echo r t ./steel1 c cr fe si set c t=1173 p=1e5 n=1 w%(c)=.3 w%(cr)=5 w%(si)=1 c e l , 4 @$ At 1173 K (900 degree C) we have only austenite (FCC) @& set ref fe bcc * 1e5 @$ set the reference state for Fe as BCC @& @$ @$ Use CALCULATE TRANSITION to find the T when BCC is formed @$ c tran BCC l,,,, @$ We release condition 1 (T) and at 1106 K we form BCC @$ but also M7C3 @$ Note the condition for T is set to the new T (1106.18 K) @& @$ At present ignore carbide formation, thus suspend all phases but FCC and BCC set status ph *=sus set status ph fcc bcc=ent 1 @$ Calculate without the grid minimizer to avoid creating new composition sets c n l,,,, @$ We have now just fcc at 1106 because we have higher C content in FCC @& @$ Calculate again when BCC is formed c tran bcc l,,,, @$ The BCC is formed at 1079 when M7C3 is ignored @& @$ The T-zero line is at a carbon content in between BCC and FCC @$ Thus at a lower T c tzero FCC BCC 1 l,,,, debug symbol T 946.4939 @$ The tzero T is 946 K (673 degree C). @$===================================================================== @$ This is not an equilibrium but the limit for diffusionless transformation @$ from FCC to BCC @$===================================================================== @$ At this T FCC and BCC have the same Gibbs energy @$ at the same alloy composition. @& @$ Calculate how the TZERO temperature varies with the carbon content @$ Set the carbon content as axis set ax 1 w%(c) 0 1 .01 @$ During this STEP command the C content is varied @$ to find the T (condition 1) @$ when FCC and BCC have the same Gibbs energy for the same alloy content step tzero y FCC BCC 1 @& plot w%(c) T Title step-tzero Fig 1 out ./tzero-noG-nucleation Y @& @$ To nucleate the BCC phase there an additional energy is needed and @$ we can add an estimated nucleation energy to the BCC phase @$ @$ This can be achieved by adding an energy independent on composition and T enter para g(bcc,*:*) 298.15 100; 6000 N nucleation @& l phase bcc data @$ The parameter G(BCC,*:*) give a shift of the BCC Gibbs energy @$ which is independent of the composition and T @& @$ Now calculate the tzero T again, previous value was 946 K: l eq c tz fcc bcc 1 @$ With a 300 J/mol nucleation barrier the Tzero temperature is 873 K @$ lowered by about 70 degrees at this carbon content. @& @$ And calculate the new T-zero curve step tz y Y fcc bcc 1 plot w%(c) T Title step-tzero Fig 2 append ./tzero-noG-nucleation scale Y N 700 1200 @$ The second Tzero curve is lower than the first as expected @$ The largest difference is when the carbon content is zero. @& plot w%(c) T Title step-tzero Fig 3 text .4 930 1 -30 T-zero text n .4 870 1 -27 T-zero plus nucleation barrier @$ In this figure the curves are labelled @& @$ Finally let us verify that the Gibbs energy curves at 950 K @$ actually cross at at some C content. @$ First suspend again all other phases set status ph *=sus set st ph fcc bcc=ent 0 l c @& c n l,,,,, @& step sep Y @& plot w%(C) GM(*) scale Y N -6500 -5000 Title step-tzero Fig 4 text .1 -5200 2 0 NOTE: No tie-line in the plane of the diagram! @$ We can see the Gibbs energy curves cross around w%(C)=0.3 @$ inside the two-phase region FCC and BCC. @$ The equilibrium tie-line is not in the plane @$ because the alloy also has Cr and Si @& c e l,,,,, @& @$========================================================================== @$ end of step-tzero macro @$========================================================================== set inter ================================================ FILE: examples/macros/step1.OCM ================================================ new Y set echo Y @$ ========================================================== @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ step1.OCM @$ Calculating property diagrams for a High Speed Steel (HSS) @$ ========================================================== @$ @& set echo r t ./steel1 set c t=1200 p=1e5 n=1 w(c)=.009 w(cr)=.045, w(mo)=.1,w(si)=.001 w(v)=.009 @$ Enter a composition set for the MC carbide (FCC) @$ This is convenient to specify an additional pre/suffix amend phase fcc comp_set y MC NONE <.1 NONE <.1 NONE >.5 <.2 @$ Set the default constitution for the FCC to be austenite amend phase fcc default <.2 NONE <.2 <.1 <.2 <.2 >.5 @$ Enter a composition set for the M2C carbide (HCP) amend phase hcp comp_set y M2C , NONE NONE NONE NONE NONE >.5 <.2 @$ We will later plot the heat capacity, enter this as a @$ "dot derivative" ent sym cp=hm.t; @& @$-------------------------------------------------------- c e l r 1 @$ Note that there are two FCC phases and the second, @$ with prefix MC, is a cubic carbide with mainly VC @& @$-------------------------------------------------------------- l r 4 @$ list the results using mass fractions @& @$ The next command will make several additional equilibrium @$ calculation and with +/-5% variation of the contitiona @$ to give an estimate the uncertainties of the result l est-acc @$ First a list of phases which are close to beoome stebl @$ The a list of phases if the condition is changed @$ Then a list of the variation of chemical potentials/RT @$ and the max/min values of the Gibbs energy and entropy @$ Finall the min/max values of the amount of each phase. @$ A negative value means the phase may not be stable @& @$ Now we calculate how the system changes with T set axis 1 T 800 1800 10 l ax @& step @$ The step command indicates whenever there is a phase change @& @$--------------------------------------------------------- l line @$ Listing of all equilibria calculated by step @& l eq @$ list of all node points with phase changes @& @$ Plot the phase amounts plot T NP(*) title step 1 fig 1 render @& @$ move the line identification (keys) outside the plot plot ? position outside right text 1200 0.6 2 0 High Speed Steel title step 1 fig 2 @$ Change the font! font garamond 16 @$ Add symbols on lines, 1o means a symbol plotted at every 9th calculation extra line 10 render @& @$ Plot the Cr content in all stable phases plot T w(*,cr) title step 1 fig 3 @$ restore font to default font arial 16 render @& @$ Plot the fractions in the MC_FCC phase @$ NOTE fractions plotted only in the stable range!!! plot T w(mc_fcc,*) text 1000 0.2 1 0 Plotted only in stable range of the MC carbide title step 1 fig 4 render @$ Fractions plotted only in the stable range of the MC carbide @& @$ Plot the fractions in the BCC phase plot T w(bcc,*) text 1000 0.4 1 0 Plotted in stable ranges of the bcc phase only pos left title step 1 fig 5 render @$ NOTE fractions plotted only in the stable range!!! @$ I will try to add the composition as dashed i metastable range @& @$ Plot the enthalpy variation plot T H title step 1 fig 6 render @& @$ Plot the heat capacity @$ There is a problem with the heat capacity calculation @$ when there is a phase chage. plot T cp title step 1 fig 7 render @& @$ scaling of y axis and setting larger axis text plot T cp axis y Heat capacity J/mol/K scale y N 0 300 title step 1 fig 8 @$ The plotted cp include latent heat @& @$ Plotting as PDF or PNG can be done in the gnuplot window @$ The list the available graphic devices are redundant @$ @$ enter gnu @$ @$ Finally plot the driving force of all phases. Stable phases has @$ driving force zero, those closest to become stable are close to zero plot dgm(#) title step 1 fig 9 @& plot title step1 fig 10 scale y n -0.3 0 set inter @$ This is clearly too many phases, only a few are interesting @$ However, to select them we have to recalculate the step with just the phases @$ we think are interesting, the other set as suspended. @$ That means more or less all phases except the different carbides @$ and maybe some intermetallic phases. set stat ph *=sus set stat ph liq fcc bcc hcp m23c6 m7c3 m6c ksi m3c2 m5c2 mc_eta mc_shp=e 0 @$ Note that FCC is the austenite and FCC#2 is the MC cubic carbide. @$ HCP is the M2C hexagonal carbide. @& l c c e l,,,, @& step @& plot dgm(#) @$ Move the position of the line keys to bottom left position bottom left 12 @$ Add symbols on the lines to make them easier to identify extra line 10 title step 1 fig 11 @$ There are some irregularites for the FCC phase at high T @$ as it switches between metallic austenite and cubic carbide phase @& @$ Scale up to see those closest to be stable plot scale Y N -0.2 0 title step 1 fig 12 @$ Note the DGM of the BCC phase, it is stable at high T @$ and comes back at low T @& @$ We still have the same set of stable phases plot np(*) title step 1 fig 13 @$========================================================================== @$ end of step1 macro @$========================================================================== set inter ================================================ FILE: examples/macros/step2.OCM ================================================ new Y set echo Y @$ =================================================================== @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ step2.COM @$ Calculating G curves for the phases in Ag-Cu @$ =================================================================== @& set echo r t ./agcu @& @$ -------------------------------------------------------- set cond t=1000 p=1e5 n=1 x(cu)=.2 c e l r 1 @& @$ -------------------------------------------------------- set ref ag fcc,,,,, set ref cu fcc,,,,,, set ax 1 x(cu) 0 1 ,,, l ax l sh @& @$ -------------------------------------------------------- step sep @& @$ -------------------------------------------------------- @$ Plot of the Gibbe energy curves at 1000 K plot x(cu) G(*) title step 2 fig 1 render @& @$ -------------------------------------------------------- @$ Plot of enthalpy curves for components in each phase at 1000 K plot x(cu) HM(*) title step 2 fig 2 render @& @$ plot the stability function, the lowest eigenvalue plot x(cu) Q(*) title step 2 fig 3 @$ High positive values at the edges, scale ! @& plot title step2 fig 4 scale y n -4 4 text .4 -.2 1 0 Negative Q means phase is unstable render @$========================================================================== @$ end of step2 macro @$========================================================================== set inter ================================================ FILE: examples/macros/step3.OCM ================================================ new Y set echo Y @$ =================================================================== @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ step3.OCM @$ Calculating speciation in a gas phase and plot y, H and Cp @$ =================================================================== @& set echo r t ./hogas l d,,,,, @$ Listing of the gas data @$------------------------------------------------------- @& @$ Set conditions set c t=3000 p=1e5 n(h)=2 n(o)=1 c e l,,,,, @$------------------------------------------------------- @& @$ Set T as axis set ax 1 t 1000 6000 25 step @$------------------------------------------------------- @$ Plot the constitution of the gas plot T y(gas,*) title step 3 fig 1 render @& @$------------------------------------------------------- @$ Move the position of the identification plot position bottom left title step 3 fig 2 render @& @$------------------------------------------------------- @$ Plot the enthalpy content, scale the value plot T 0.001*H set xax Enthalpy kJ title step 3 fig 3 render @& @$------------------------------------------------------- @$ Enter symbol for heat capacity and plot the heat capacity ent symb cp=h.t; plot T cp title step 3 fig 4 render @& @$ Note the strong contribution to the heat capacity from the variation @$ of the constituent fractions @$------------------------------------------------------- @& @$========================================================================== @$ end of step3 macro @$========================================================================== set inter ================================================ FILE: examples/macros/step4.OCM ================================================ new Y set echo Y @$ ================================================================ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ step4.OCM @$ Enter data interactively and @$ calculate G curves in the ordered FCC in the Fe-Ni system @$ ================================================================ @$ @& set echo @$ Enter the elements and their reference states enter element Fe Iron BCC 55.847 0 0 enter element Ni Nickel FCC 58.69 0 0 @$ These functions describe the end-member energies at Fe3Ni, Fe2Ni2 and FeNi3 @$ respectivly. The VASP energies relative to pure Fe amd Ni as fcc are: @$ Fe3Ni1 -0.071689 eV for 1 atom?? @$ Fe2Ni2 -0.138536 eV for 1 atom?? @$ Fe1Ni3 -0.125748 eV for 1 atom?? @$ To modify to J/mol atoms multiply with 96500 @$ bond energy multiplied with 3, 4 and 3 respectively. enter tp-sym evtoj constant 96500 enter tp-sym GA3B1 fun 1 -0.071689*evtoj;,,,,, enter tp-sym GA2B2 fun 1 -0.138536*evtoj;,,,,, enter tp-sym GA1B3 fun 1 -0.125748*evtoj;,,,,, @$ We set a positive regular solution parameter enter tp-sym L0 fun 1 12000; ,,,,, @$ this is an approximate SRO contribution to the LRO phase. It is @$ set to about a quater of the L1_0 ordering energy, @$ equal to the Fe-Ni bond energy enter tp-sym GSRO fun 1 -0.034*evtoj;,,,,, @$ Using the partitioned model the contribition from the ordered parameters @$ will cancel when the phase is disordered. If we want them to contribute @$ we must add them to the disordered part enter tp-sym LD0 fun 1 GA3B1+1.5*GA2B2+GA1B3+1.5*GSRO;,,,,,, enter tp-sym LD1 fun 1 2*GA3B1-2*GA1B3;,,,,,, enter tp-sym LD2 fun 1 GA3B1-1.5*GA2B2+GA1B3-1.5*GSRO;,,,,,, @$ ================================================== @$ This is an fcc phase with lro but no explicit sro @$ described with the sublattice model enter phase PARTITIONED_FCC CEF 4 .25 Fe NI; .25 Fe NI; .25 Fe NI; .25 Fe NI; @& @$ we must add disordered set before entering parameters amend phase part dis 4 yes @$ We do not use the F option which would reduce the number of parameters enter param G(part,Fe:Fe:Fe:Ni),,GA3B1; 6000 N test enter param G(part,Fe:Fe:Ni:Fe),,GA3B1; 6000 N test enter param G(part,Fe:Ni:Fe:Fe),,GA3B1; 6000 N test enter param G(part,Ni:Fe:Fe:Fe),,GA3B1; 6000 N test enter param G(part,Fe:Ni:Ni:Ni),,GA1B3; 6000 N test enter param G(part,Ni:Fe:Ni:Ni),,GA1B3; 6000 N test enter param G(part,Ni:Ni:Fe:Ni),,GA1B3; 6000 N test enter param G(part,Ni:Ni:Ni:Fe),,GA1B3; 6000 N test enter param G(part,Fe:Fe:Ni:Ni),,GA2B2; 6000 N test enter param G(part,Fe:Ni:Fe:Ni),,GA2B2; 6000 N test enter param G(part,Ni:Fe:Fe:Ni),,GA2B2; 6000 N test enter param G(part,Fe:Ni:Ni:Fe),,GA2B2; 6000 N test enter param G(part,Ni:Fe:Ni:Fe),,GA2B2; 6000 N test enter param G(part,Ni:Ni:Fe:Fe),,GA2B2; 6000 N test enter param G(part,Fe,Ni:Fe,Ni:*:*),,GSRO; 6000 N test enter param G(part,Fe,Ni:*:Fe,Ni:*),,GSRO; 6000 N test enter param G(part,Fe,Ni:*:*:Fe,Ni),,GSRO; 6000 N test enter param G(part,*:Fe,Ni:Fe,Ni:*),,GSRO; 6000 N test enter param G(part,*:Fe,Ni:*:Fe,Ni),,GSRO; 6000 N test enter param G(part,*:*:Fe,Ni:Fe,Ni),,GSRO; 6000 N test amend biblio test VASP calculation by test; @$ These are possible disordered parameters enter param GD(part,Fe,Ni;0),,LD0+L0; 6000 N test enter param GD(part,Fe,Ni;1),,LD1; 6000 N test enter param GD(part,Fe,Ni;2),,LD2; 6000 N test @$ enter param GD(part,Fe,Ni;0),,+L0; 6000 N test list data ,, @$ we have to create composition sets manually @$ this is by default Fe3Ni_L12 amend phase part comp-set y , , <.2 >.5 >.5 <.2 >.5 <.2 >.5 <.2 @$ this is by default FeNi_L10 amend phase part comp-set y , , <.2 >.5 <.2 >.5 >.5 <.2 >.5 <.2 @$ this is by default FeNi3_L12 amend phase part comp-set y , , <.2 >.5 <.2 >.5 <.2 >.5 >.5 <.2 set c t=400 p=1e5 n=1 x(fe)=.3 c e l r 2 @& @$ Calculating the metastable regions are very sensitive to the step increment set ax 1 x(fe) 0 1 0.02 step sep @& plot x(ni) GM(*) title step 4 fig 1 @& @$ the constitution of FeNi3 plot x(ni) y(part#4,*) title step 4 fig 2 L1_2 @& plot title step 4 fig 3 L1_2 position top left render @& @$ The constitution of the L1_0 phase (AlNi) plot y(part#3,*) title step4 fig 4 L1_0 position top left render @& @$ The calculation has sometimes failed for compositions @$ where the L1_2 or L1_0 ordering is not stable @& @$ ======================================================== @$ Now something different @$ @$ During a phase field simulation one may use mole fractions @$ to calculate diffusion also for ordered phases. To find @$ how the CONSTITUTION changes in an ordered phase when @$ the MOLE FRACTION changes one must minimize the @$ Gibbs energy for that phase. @$ There is a special command (and subroutine) to calculate @$ the constitution of a phase for a given set of mole fractions @$ which could be useid when for a gridpoint with just one @$ stable phase. This command also gives the chemical potentials. @$ @$ This is a way to avoid a full equilibrium calculation @$ but if there are two or more phases stable at the gridpoint @$ one must do that in order to determine the phase amounts. @$ However, an equilibrium calculation is sometimes needed to @$ find the most stable configuration ... @& @$ We use the current ordered FCC as an example, first @$ calculate a full equilibrium at T=400 K and x(fe)=.27 l sh a set c x(fe)=.27 l c c e l,,,, @$ @$ At this composition and T we have an L1_2 ordered fcc phase @& @$ ============================================================ @$ Now calculate for a single phase with mole fraction Fe 0.26 calc phase part 1 y con .26 @$ @$ Note the chemical potentials/RT above @$ they are different the equilibrium listing higher up @$ The value of G is also different but as it is divided by RT @$ it is not so easy to compare @& @$ If we list the full equilibrium we get a warning l,,, @$ @$ because the constitution and composition listed is from the @$ single phase calculation whereas the conditions on the @$ composition and chemical potentials and the Gibbs energy @$ has not changed and are inconsistent. @& @$ If we set the condition of Fe and calculate set c x(fe)=.26 c e l,,,,, @$ then we get the same chemical potentials/RT @& @$ ============================================================ @$ Try a calculate phase with a different composition, x(fe)=.49 @$ calc phase part 1 y con .49 l,,, @$ @$ The phase is still L1_2 ordered as the calculation @$ used the previous constitution as start values. @$ Note the Gibbs energy/RT= -3.0747 @& @$ ============================================================ @$ To have the fcc L1_0 ordered we have to give a start constitution @$ NOTE it is important to start from extreme ordering calc phase part 1 n .01 .01 .99 .99 con .49 l,,, @$ @$ Now the fcc phase is L1_0 ordered @$ and the Gibbs energy/RT is more negative, -3.1546 @$ @$ NOTE: If you start from a less ordered state like 0.1/0.9 @$ you may find a less stable L1_2 phase. @& @$ ============================================================ @$ Calculate also setting start constitution as disordered calc phase part 1 n .5 .5 .5 .5 con .49 l,,, @$ @$ The Gibbs energy/RT is -3.1150 @$ so the L1_0 ordered state is more stable than the @$ disordered which is more stable than the L1_2 @& @$ ============================================================ @$ A full equilibrium calculation is sometimes necessary to @$ determine the most stable configuration of a single phase @$ using the grid minimizer (or manually set start constitutions) @$ We can check what the grid minimizer gives for x(Fe)=0.49 set c x(fe)=.49 c e l,,,, @$ But again, @$ sometimes one may want to use a metastable state... @& @$========================================================================== @$ end of step4 macro @$========================================================================== set inter ================================================ FILE: examples/macros/step5.OCM ================================================ new Y set etco Y @$ =================================================================== @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ step5.OCM @$ Calculate y and Cp as function of T for the ordered FCC FeNi3 @$ =================================================================== @& set echo @$ Enter the elements and their reference states enter element Fe Iron BCC 55.847 0 0 enter element Ni Nickel FCC 58.69 0 0 @$ These functions describe the end-member energies at Fe3Ni, Fe2Ni2 and FeNi3 @$ respectivly. The VASP energies relative to pure Fe amd Ni as fcc are: @$ Fe3Ni1 -0.071689 eV for 1 atom?? @$ Fe2Ni2 -0.138536 eV for 1 atom?? @$ Fe1Ni3 -0.125748 eV for 1 atom?? @$ To modify to J/mol atoms multiply with 96500 @$ bond energy multiplied with 3, 4 and 3 respectively. enter tp-sym evtoj constant 96500 enter tp-sym GA3B1 fun 1 -0.071689*evtoj;,,,,, enter tp-sym GA2B2 fun 1 -0.138536*evtoj;,,,,, enter tp-sym GA1B3 fun 1 -0.125748*evtoj;,,,,, @$ We can use a disordered regular solution parameter enter tp-sym L0 fun 1 12000; ,,,,, @$ this is an approximate SRO contribution to the LRO phase. It is @$ set to about a quater of the L1_0 ordering energy, @$ equal to the Fe-Ni bond energy enter tp-sym GSRO fun 1 -0.034*evtoj;,,,,, @$ Using the partitioned model the contribition from the ordered parameters @$ will cancel when the phase is disordered. If we want them to contribute @$ we must add them to the disordered part enter tp-sym LD0 fun 1 GA3B1+1.5*GA2B2+GA1B3+1.5*GSRO;,,,,,, enter tp-sym LD1 fun 1 2*GA3B1-2*GA1B3;,,,,,, enter tp-sym LD2 fun 1 GA3B1-1.5*GA2B2+GA1B3-1.5*GSRO;,,,,,, @$ ================================================== @$ This is an fcc phase with lro but no explicit sro @$ described with the sublattice model enter phase PARTITIONED_FCC CEF 4 .25 Fe NI; .25 Fe NI; .25 Fe NI; .25 Fe NI; @& @$ we must add disordered set before entering parameters amend phase part dis 4 yes enter param G(part,Fe:Fe:Fe:Ni),,GA3B1; 6000 N test enter param G(part,Fe:Fe:Ni:Fe),,GA3B1; 6000 N test enter param G(part,Fe:Ni:Fe:Fe),,GA3B1; 6000 N test enter param G(part,Ni:Fe:Fe:Fe),,GA3B1; 6000 N test enter param G(part,Fe:Ni:Ni:Ni),,GA1B3; 6000 N test enter param G(part,Ni:Fe:Ni:Ni),,GA1B3; 6000 N test enter param G(part,Ni:Ni:Fe:Ni),,GA1B3; 6000 N test enter param G(part,Ni:Ni:Ni:Fe),,GA1B3; 6000 N test enter param G(part,Fe:Fe:Ni:Ni),,GA2B2; 6000 N test enter param G(part,Fe:Ni:Fe:Ni),,GA2B2; 6000 N test enter param G(part,Ni:Fe:Fe:Ni),,GA2B2; 6000 N test enter param G(part,Fe:Ni:Ni:Fe),,GA2B2; 6000 N test enter param G(part,Ni:Fe:Ni:Fe),,GA2B2; 6000 N test enter param G(part,Ni:Ni:Fe:Fe),,GA2B2; 6000 N test enter param G(part,Fe,Ni:Fe,Ni:*:*),,GSRO; 6000 N test enter param G(part,Fe,Ni:*:Fe,Ni:*),,GSRO; 6000 N test enter param G(part,Fe,Ni:*:*:Fe,Ni),,GSRO; 6000 N test enter param G(part,*:Fe,Ni:Fe,Ni:*),,GSRO; 6000 N test enter param G(part,*:Fe,Ni:*:Fe,Ni),,GSRO; 6000 N test enter param G(part,*:*:Fe,Ni:Fe,Ni),,GSRO; 6000 N test amend biblio test VASP calculation by test; @$ These are possible disordered parameters enter param GD(part,Fe,Ni;0),,LD0+L0; 6000 N test enter param GD(part,Fe,Ni;1),,LD1; 6000 N test enter param GD(part,Fe,Ni;2),,LD2; 6000 N test list data ,, @& @$ set a slightly off-ideal composition as the griminimiser prefers that ... set c t=300 p=1e5 n=1 x(ni)=.751 @$ To avoid confusion I do no calculate with 2 composition sets @$ I do not want to use the gridminimizer. If I just use "c n" c n l res 2 @$ I get the disordered phase. Its G=-8089 J/mol @$ To set the constitution to be ordered I use the calculate phase comamnd calc phase part 1 N .1 .1 .1 .9 @$ There should be low fraction Fe in 3 sublattices and high in the 4th @$ After this we can use the "c n" again which will start from current y c n l,,,,, @$ Now the phase is ordered with a lower G=-9858 J, 1 kJ more negative! @& @$ Set a T axis to calculate how the ordering varies wih T set ax 1 T 10 800 5 step @& plot T y(part,*) title step 5 fig 1 render @& @$ Plot also the heat capacity ent sym cp=h.t; c sym cp @& plot T cp title step 5 fig 2a @& @$ We may need scaling ... plot T cp scale y N 0 10 title step 5 fig 2b render @& @$========================================================================== @$ end of step5 macro @$========================================================================== set inter ================================================ FILE: examples/macros/step6.OCM ================================================ new Y set echo y @$ ================================================================== @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ step6.OCM @$ Calculate G curves for Fe-Mo at 1400K @$ ================================================================== @& set echo r t ./steel1 fe mo set c t=1400 p=1e5 n=1 x(mo)=.2 c e l r 1 @& set axis 1 x(mo) 0 1 .02 @& set ref fe bcc ,,,,,,, set ref mo bcc ,,,,,,, @& step sep plot title step 6 fig 1 render @& plot x(mo) gm(*) scale y N -5000 1000 position right bottom title step 6 fig 2 render @& @$ Plot with wildcards on x axis and factor plot gm(*) x(mo) title step 6 fig 3 @& plot x(mo) gm(*) @$ This adds a scaling factor extra axis y axis y Gibbs energy kJ/mol title step 6 fig 4 @$========================================================================== @$ end of step6 macro @$========================================================================== set inter ================================================ FILE: examples/macros/step7.OCM ================================================ new Y set echo Y @$ =========================================================== @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ step7.OCM @$ Calculate phase fractions and other property diagrams for SAF2507 @$ =========================================================== @& set echo r t ./saf2507 set c t=1273.15 p=1e5 n=1 W(cr)=.25 w(ni)=.07, w(mo)=.03 w(mn)=.015 w(n)=.002 @$ set c t=1273 p=1e5 n=1 x(cr)=.266 x(ni)=.066, x(mo)=.017 x(mn)=.015 x(n)=.008 c e l r 1 set axis 1 T 800 1800 10 l ax @& step @& plot title step 7 fig 1 render @& save plot plot position top left title step 7 fig 2 render @& @$ enter symbols for the PRE (Pitting Resistance Equivalence) ent sym prefcc=100*w(fcc,cr)+300*w(fcc,mo)+1600*w(fcc,n); ent sym prebcc=100*w(bcc,cr)+300*w(bcc,mo)+1600*w(bcc,n); l sym @& @$ Sometimes a dense grid is needed here set adv grid 2 set c t=1350 w(n)=.002 c e l,,,,, @& set ax 1 w(n) 0 .005 step plot w%(n) np(*) title step 7 fig 3 render @& plot w%(n) prefcc position off title step 7 fig 4 @& plot w%(n) prebcc title step 7 fig 5 render @& @$ step with 50% ferrite set stat ph bcc=fix 0.5 set c t=none set c w(n)=.0002 l c @& c e step @& plot w%(n) T title step 7 fig 6 render @& @$========================================================================== @$ end of step7 macro @$========================================================================== set inter ================================================ FILE: examples/macros/step8.OCM ================================================ new Y set echo Y @$ ============================================================= @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ step8.OCM @$ Adiabatic flame temperature for propane, C3H8 @$ Also a P-V diagram for the gas @$ and setting various conditions like the constituent fraction in the gas @$ ============================================================= @& set echo r t ./CHO-gas @& @$------------------------------------------------------------------- @$ A pure C3H8 gas has enthalpy content -99288 J at 300 K @$ adding 7 moles of O at T=300K gives an adiabatic flame T of 3071 K @$ remove all other phases except gas set status phase *=sus set status phase gas=ent 1 @$ set c t=300 p=1e5 n(c)=3 n(h)=8 n(o)=1e-8 @$ Set that the system has 1 mole C3H8 set input n(c3h8)=1 set c t=300 p=1e5 n(o)=1e-8 @$ Also set the reference state of O to be gas at current T set ref O gas @$ We must be careful setting gas as reference state if there are @$ several possible species like O, O2 or O3 in this case @$ The program will automatically select the species (endmember) that @$ has the lowest Gibbs energy at the current T. At very high T @$ that may be O and not O2 c e l,,,, @$ This is the stable state of a gas with 3 moles C and 8 moles H at 300 K @$ but there is no C3H8! @& @$------------------------------------------------------------ @$ This is a rather clumsy way to calculate the enthalpy content @$ of a pure propane gas at 300 K calc phase gas 1 N 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, @$ The enthalpy content is -103711 J @$ We will use this enthalpy as condition and calculate @$ the temperature when reacting C3H8 with 7 moles of O will give @$ the same enthalpy content (adiabatic conditions). @$ N(O)=7 assumes that the product will be 3 moles C1O1 4 moles and H2O1 @$ The enthalpy content of O2 gas at 298.15 K is 0 J by definition @& @$------------------------------------------------------------------- @$ We must use HS as we refer the enthalpy to 298.15 K set c HS -103711 set c t=none set c n(o)=7 c e l,,,, @$ The adiabatic flame temperature is 3069 K @$ Note the reaction to C1O1 and H2O is not complete, @$ there are some H2, C1O2 even H gas species @& @$------------------------------------------------------------------- @$ Check the temperature with N(O)=8 set cond n(o)=8 c e l,,,,,,,, @$ The temperature is now 3098 K, slightly higher. @$------------------------------------------------------------------- @& @$ Check how the temperature varies with N(O) set ax 1 n(o) 5 15 @& @$------------------------------------------------------------------- step plot n(o) T title step 8 fig 1 @$ The maximum T is about 8 moles of O @& plot ac(o) T title step 8 fig 2 @& @$ We can see how the T varies with the oxygen potential @$ It is rather constant for a large range of activities @$-------------------------------------------------------------------- @$ The next plot is very messy .... plot n(o) y(gas,*) extra log y title step 8 fig 3 @& @$ we can only plot the constitution of species one by one (or all) plot n(o) y(gas,h2o1) title step 8 fig 4 @& plot n(o) y(gas,c1o1) title step 8 fig 5 @& plot n(o) y(gas,c1o2) title step 8 fig 6 @& plot n(o) y(gas,o2) title step 8 fig 7 @& plot n(o) y(gas,h2) title step 8 fig 8 @& @$ How the H2O1 content depend on T plot T y(gas,h2o1) title step 8 fig 9 @$ ------------------------------------------------------ @$ Finally set the chemical potential of O as condition @$ First change the conditions to use the current value of T=3097.67876 @$ instead of H (open system so amount of O can change) @$ c e l,,,,,, @& @$ set c t @$ set c h=none l c c e l,,,,,,, @& @$ Replace N(O) by current value of AC(O)=0.19658 @$ (referred to O2 at current T) and calculate the same equilibrium set c ac(o) set c n(o)=none l c @& c e l,,,,,, @$ We have the same equilibrium with AC(O) instead on N(O) @& @$--------------------------------------------------------- @$ Change ac(o) to a higher value meaning more oxygen set c ac(o)=0.3 c e l,,,, @$ Higher oxygen activity means more N(O), here 9.7968 moles @$ and lower T, 3096 K @$ NOTE ALSO DALTON's LAW is valid!!! The constituent fraction of O2 is 0.09 @$ which is the square of ac(o) @& @$ Include the calculation of the driving force of graphite @$ by setting it as dormant set st ph gra=d c e l sh p @$ We can see graphite has very negative driving force, it is not stable @& @$--------------------------------------------------------- @$ Set the amount of O less than 3 set c ac(o)=none set c n(o)=2 c e l,,,,, @$ Now graphite has a positive driving force, @$ and we have a much lower T 1204 K @$ We get soot and a lot of H2 gas burning C3H8 without enough oxygen @& @$ Calculate minimum O to avoid soot set st ph gra=fix 0 set c n(o)=none c e l,,,,, @$ As expected we must have at least 3 moles of O (1.5 O2) to avoid soot. @$ and we have a low T, 1366 K, as there is a lot of H2 to burn. @& @$================================================================ @$ Now something different again @$ Testing variable P and using V as condition @$ First set condtions using T, P and N @$ set stat ph gra=e 0 set c h=none set c t=3000 n(o)=7 @& c e l,,,,, @& @$ Now release P as condition at same V set c v set c p=none c e l,,,, @$ Same equilibrium with V as condition, next change V @& set c v=2 c e l,,,, @$ With a bigger volume P has decreased to 94963 Pa @$ or 0.94963 bar @& set c v=1 c e l,,,,, @$ With a smaller volume the pressure increases, P=1.8499 bar @$ Check Boyles law: P1V1=P2V2 (N/m2 * m3) = Nm = J @$ right hand side: 2*94963=189926 J @$ left hand side: 1*184990 Pa @$ It is not same because the constitution of the gas has changed!! @$ Increasing the pressure increases the fraction of large molecules @$ @& @$ We can list the volume separately (unit is m3) l st v @$ Make a plot how P depend on V set ax 1 V .1 10 step normal Y @& plot V P title step 8 fig 10 @& @$ A nice hyperbolic curve @& @$ Try using logscale plot V 1.0E-5*P axis yax bar extra log y title step 8 fig 11 @& @$ On Linux the scaling of the P axis the automatic rage is bad plot V 1.0E-5*P title step 8 fig 12 scale y n 0 20 axis yax bar @$ @$=============================================================== @$ Yet another test @& @$ @$ We can use expressions for some state variables like N(C) @$ try that but first rearrange the other conditions set c v=none set c p=1e5 c e l,,,, @& @$ @$ This condition means there will be a constant ratio between C and H set c 8*n(c)-3*n(h)=0 set c n(h)=none c e l,,,,, @$ The equilibrium is the same, N(H)=8/3*N(C) ! @& @$ Now increase C set c n(c)=4 c e l,,,,, @$ The amount of h has also increased to keep the ratio @$ 3*n(c)-8*n(h)=0 @& @$ A feature added 2019.07.22: @$ Setting a constituent fraction of a phase @$ @$ We already have a fairly complicated set of conditions l c @& @$ But we may for some reason prescribe the amount of H2O molecules in @$ the gas (do not ask me why...) set cond y(gas,h2o1) @$ Note we have to specify H2O1 as there is a H2O2 molecule also! @$ At first just calculate with the current value, we have to remove @$ another condition, for example the amount of C set c n(c)=none l c @& c e @& l,,,, @$ We have just recalculated the same equilibrium with another @$ set of external conditions. @& @$ But now we can increase the fraction of H2O1 set c y(gas,h2o1) 0.3 c e @& l,,,, @$ The amount of both C and H has decreased to fullfull the condition @$ that the fraction of H2O1 in the gas should be 0.3. @& @$ Playing with condition on the constitution of a phase can easily @$ lead to failed calculations because it may be impossible to find @$ an equilibrium with a specified fraction of a molecule. set c y(gas,h2o1)=0.4 c e @$ This fails because it is impossible to have such a high fraction of H2O1 @$ in the gas at this T @& @$ We can try with a smaller value set c y(gas,h2o1)=.01 c e @& l,,,, @$ This works. @& @$ The amounts of both C and H has increased. l el @& @$ That is all for now !! @& @$========================================================================== @$ end of step8 macro @$========================================================================== set inter ================================================ FILE: examples/macros/step9.OCM ================================================ @$ ordering in a reciprocal system B2 with z=8 nn @$ Adding SRO by a T**(-1) dependent reciprocal parameter new Y set echo Y @$=============================================================== @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$=============================================================== enter element A A BCC 10 0 0 0 enter element B B BCC 10 0 0 0 @$ This is the bond energy. enter tp UAB fun 10 -250*R;,,,,, @$ UAB=-250*R gives T_o/d at T=1000 K without SRO @$ Adding UAB as a constant reciprocal parameter gives T_o/d=935 @$ But with constant reciprocal parameter there is no SRO contribution @$ to Cp in disordered state. Theoretically the parameter should be @$ UAB*T_o/d* T**(-1), i.e. 1000*UAB*T**(-1) @$ But adding 1000*UAB*T**(-1) gives and a Cp in disordered state @$ but the disordered state becomes stable at low T as T**(-1) goes to infinity @$ To avoid this we can approximate using the T-dependence as 0.2*T_o/d + T @$ This decrease the Cp in the disordered state but that is anyway a small @$ term and considering all other approximations reasonable. @$ @$ To have the value UAB at T=1000 we must use 0.2*T_o/d instead of just T_o/d enter tp TP1 fun 10 200+T;,,,,, enter tp USRO fun 10 1200*TP1**(-1);,,,,,,,, enter tp LSRO fun 19 UAB*USRO; ,,,,, @$ We want to plot the heat capacity enter symb CP=H.T; @$-------------------------- enter phase B2 CEF 2 0.5 A B; 0.5 A B enter parameter G(B2,A:B) 10 4*UAB; 6000 N ref0 enter parameter G(B2,B:A) 10 4*UAB; 6000 N ref0 @$ This is the same as LRSO2 above 200 K, below 150 K it gives negative entropy @$ for the disordered phase @$ enter parameter G(B2,A,B:A,B) 10 1000*UAB*T**(-1); 6000 N ref0 enter parameter G(B2,A,B:A,B) 10 LSRO; 6000 N ref0 @$ This should give save value at 1000~K @$ enter parameter G(B2,A,B:A,B) 10 BAD; 6000 N ref0 @& l d @& @$ First calculate the heat capacity at 50-50 set c t=300 p=1e5 n=1 x(b)=.5 c e l , 2 @$ We have an ordered constitution @& @$ Set a T axis with very small step set ax 1 T 10 1600 2 step plot t cp text 1000 1 1 0 This tail of Cp is due to SRO text N 410 3 1 60 This Cp comes from disappearing LRO text N 100 13.8 1 0 SRO from reciprocal parameter text N 100 13 1 0 L(B2,A,B:A,B)=1200*UAB/(T+200) title Step 9 fig 1 render @$ The tail of Cp in the disordered state comes from the T**(-1) term @$ in the reciprocal parameter. @& @$ Now we try to plot the 2nd order transition line @$ At the 2nd order transition the difference of the fractions @$ of the same element in the two sublattices vanishes. @$ We can approcimate this by having a very small difference @$ Calculate the equilibrium when we have LRO a bit off the 50-50 set c t=400 x(b)=.2 c e l,,, @$ We have LRO. We should decrease the difference between @$ the fractions of B in first and second sublattice @$ First replace the condition on x(b) by a difference in the @$ constituent fractions set c y(b2,b)-y(b2,b#2) set c x(b)=none c e l,,,, @$ We have the same equilibrium but with different conditions @& @$ Make the difference smaller, i.e. closer to order/diorder transition l c @$ set c y(b2,b)-y(b2,b#2)=.01 @$ This rather crypric command change the value of condition 4 set c 4:=0.01 l c @& c e l,,,,, @$ In priciple we could also release the condition on T @$ but the convergence is then very bad, better to keep T constant. @$ @$ use the save values on the T axis to calculate the 2nd order line @$ Start at a low value set c t=100 c n step plot x(b) T text 0.05 900 1 0 2nd order transition line title Step 9 fig 2 @& @$ Append a 2nd order line calculated with fix USRO plot x(b) T append ./step9UAB title Step 9 fig 3 @$========================================================================== @$ end of step9 macro @$========================================================================== set inter ================================================ FILE: examples/macros/testcond1.OCM ================================================ @$=============================================================== new Y set echo Y @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ testcond1.OCM @$ Testing combining combination of various condition @$ for a ternary system C-Cr-Fe @$ @$ There is a test to calculate T-zero point @$ @$ There is a test to calculate NPLE conditions @$ @$ There are also tests of entering, listing @$ and calculating mobility data @$ and to calculate the Darken stability matrix @$ to convert these to diffusion coefficients. @& @$=============================================================== @$ set echo ? @$ A single ? gives the menue @& ?? @$ Two ?? opens the user guide at an approriate place r t ./steel1 ? c fe cr @$ A single ? when asked a guestion also opens the user guide @& set c t=2000 p=1e5 n=1 x(c)=.1 x(cr)=.1 c e l,,,,, @$ Just calculate a first equilibrium and check G debug symbol G -128465.6 @& @$ Replace carbon mole fraction with lnac (=mu/RT) set c lnac(c) set c x(c)=none c e l,,,, @$ We have the same equilibrium with different conditions, @$ lnac(c)=-5.14107979 debug symbol lnac(c) -5.14107979 @& @$---------------------------------------------- @$ Change the value of the lnac condition set c lnac(c)=-6 c e l,,,,, @$ Lower carbon activity decreases carbon content, @$ x(c)=.05484 @& @$------------------------------------ @$ Change to condition on mass of Cr set c b(cr) set c x(cr)=none c e l,,,,, @$ Same equilibrium with different condition @& @$ And then again with the mass fraction condition set c w(cr) set c b(cr)=none c e l,,,,, @$ still the same equilibrium with different conditions, @$ w(cr)=0.0979989 and x(cr)=0.1 @& @$ Set the composition of the liquid as condition set c w(liquid,cr) set c w(cr)=none l,,,, c e l,,,,, @$ The calculated results should be identical with previous debug symbol w(liquid,cr) 0.0979989293 @& @$----------------------------------------- @$ Change the value of the mass fraction set cond w(liquid,cr)=0.1 c e l,,,,, @$ Note the carbon content changes also, x(c)=.05519 @& @$------------------------------------------ @$ Now change reference state for carbon chemical potential set ref c gra * ,,,, l c @$ Note that the condition on lnac(c) does not change!! @& l,,,, @$ Change of reference state does not @$ change the condition lnac(c)=-6 @$ but the listed value lnac(c)=-3.2347 @& @$--------------------------------------------- @$ When we calculate we get another equilibrium! c e l,,,, @$ At the calculation the conditon lnac(c)=-6 is used @$ Carbon content much lower as reference state is graphite, @$ x(c)=.00432 @& @$------------------------------------------------------- @$ We can set back the previous (listed) chemical potential, @$ referred to graphite at 2000 K set c lnac(c)=-3.2347 c e l ,,,, @$ And we get back the previous carbon content x(c)=0.05519 @& @$ ------------------------------------------------------- @$ Set graphite as fix set stat ph gra=fix 0 set cond lnac(c)=none c e l ,,,, @$ The carbon activity should be unity, IT IS!!! @$ And the Carbon content has increased, x(c)=.26637 @& @$-------------------------------------------------- l r 4 @$ listing also with mass fractions @$ Note the activity of Cr is 2.2858E-5 referred to SER @$ Next change reference state to BCC at current T @& @$-------------------------------------------------- @$ set reference state for Cr set ref cr bcc * ,,,, l,,,,, @$ The new chromium activity listed is @$ ac(cr)=1.4341E-2 referred to BCC at 2000 K @$ There is a warning that conditions may be inconsistent with listing @& c e l,,,,, @$ But nothing changes when we calculate as Cr activity is not a condition @& @$--------------------------------------------------- @$ Set activity of Cr as condition set c ac(cr) set c w(liquid,cr)=none l,,,,,, c e l,,,,, @$ The equilibrium is the same but with other conditions @$ Note we have now one single extensive condition on N=1. @$ All other conditions are potentials. We cannot have @$ all conditions as potentials. Why? @& @$--------------------------------------------------------- @$ list the (dimensionless) driving force for BCC, show dgm(bcc) @$ The value is -0.29495337, list the constitution of bcc debug symbol dgm(bcc) -0.29495337 @$ l ph bcc ? @& @$--------------------------------------------------- @$ Increase the activity of Cr set c ac(cr)=.1 c e l r 1 @$ The Cr content is now x(cr)=.51629 l st dgm(bcc) @$ The bcc has become less stable, -0.99442471 Why? l ph bcc,,,, @$ The Cr content of metastable bcc has increased !! @& @$----------------------------------------------------------------- @$ Now insulate the system for heat exchange @$ that is done by changing the condition on T to enthalpy set c h @$ This walue of H is referred to current reference states @$ but for enthalpies it is better to use SER as is result listing @$ That is called HS with the suffix S for SER set c hs set c t=none c e l,,,, @$ The calculated equilibrium is same as before @$ It is a BUG that OC does not add the suffix S for the condition on H. @$ That will be fixed in the future ... @& @$----------------------------------------------------------- @$ Increase the enthalpy, that should increase T set c hs 90000 c e l,,,, @$ Temperature becomes 2139.23 with this addition of heat debug symbol T 2139.2273 @& @$ @$ ============================================================== @$ @$ Something different @$ Calculate a T-zero point @$ where 2 phases has the same Gibbs energy @$ @$ ============================================================== @& @$ First clean up the last set of conditions @$ Remove all condotions and make sure all phases are entered set cond *:=none l c @& set status phase *=ent 0 l sh p @& @$ Set conditions for a two-phase equilibrium fcc+bcc set c t=1100 p=1e5 n=1 w%(c)=0.05 w%(cr)=5 c e l,,,, @$ We have a 2-phase equilibrium between FCC and BCC @& @$ Calculate the T0 (T zero) point where FCC and BCC have the same @$ Gibbs energy. This is a limit for diffusionless transformation @$ from FCC to BCC (such as martensite) calc ? calc tz ? fcc bcc 4 @$ The calculated mass percent of C at equal Gibbs energy is 0.0271 @$ We selected conditon 4 to be varied, i.e. the mass percent of C debug symbol w(c) 0.000271032666 @$ We could also have releast condition 1, the T @$ But not any of the other conditions. Why? @& c e l,,,, @$ The stable equilibrium at the T0 point is 70% BCC and 30% FCC @& @$ We can instead change T to find a T0 point @$ First set back the carbon composition set c w%(c)=0.05 c tz fcc bcc 1 @$ The T0 point is at 1077.84 K for the carbon content of 0.05. debug symbol T 1077.84124 @& @$ @$ ============================================================== @$ @$ Something related @$ Calculate NPLE (Negligible Partition Local Equilibrium) @$ The limit of fast FCC/BCC transformation when only carbon diffusion @$ and other alloying elements fractions same in both phases @$ @$ ============================================================== @& @$ First clean up the last set of conditions @$ and suspend all phases set cond *:=none set status phase *=sus @& @$ Set conditions for a tie-line between FCC and BCC with @$ x(cr)=.2 in BCC set status phase fcc_a1 bcc_a2 = ent 1 set c t=1000 p=1e5 n=1 x(c)=.02 x(bcc_a2,cr)=.2 l c c e l r 1 @$ This is the stable tie-line between FCC and BCC @$ (Ortho-equilibrium) when BCC has x(cr)=.2. FCC has less Cr @$ and its x(c)=.032961. Now we want to find the NPLE @$ composition of C in FCC (when FCC has the same Cr content @$ as BCC and the current chemical potential for C) @& @$-------------------------------------------------------------- @$ To calculate this remove the bcc phase and calculate with just @$ the FCC with the same Cr content as bcc, x(fcc,cr)=.2 for the @$ same carbon activity. That is NPLE conditions for growing FCC set status phase bcc_a2=d set status phase fcc_a1=ent 1 set c ac(c) set c x(c)=none x(bcc_a2,cr)=none set c x(fcc,cr)=.2 l c @& c n l,,,, @$ This is the content of C in an FCC with same Cr fraction @$ as BCC and with the same carbon activity as the tie-line. @$ The carbon content in FCC is now x(c)=.030725 @$ We are inside the two-phase region as BCC would like to be @$ stable (it has a small positive driving force, +4.90E-4) but @$ it is dormant and cannot be included in the stable phase set. @$ debug symbol dgm(bcc) 4.8934988E-4 @$ @$ The calculation kindly provided by Shaojie Song @$ who discovered a bug! @$ Report one yourself and get cited! @& set inter @$ ============================================================== @$ @$ The example below does not work at present @$ @$ ============================================================== @$ @$ Testing entering mobility data, list and calculate @$ First list all model_parameter_identifires l m-p-i @& @$ Use MQ, the values are just made up @$ You must specify the sublattice with the diffusing constituent enter parameter mq&c#2(fcc,fe:c) 298.15 -1000+5*T; 6000 N me @$ It is correct that you get a warning that @$ there is no addition handling these parameters @& enter parameter mq&c#2(fcc,cr:c) 298.15 -2000+7*T; 6000 N me enter parameter mq&c#2(fcc,fe:va) 298.15 -10000+3*T; 6000 N me enter parameter mq&c#2(fcc,cr:va) 298.15 -5000; 6000 N me list ph fcc data @$ @$ Note there are 4 parameters called MQ&C @& enter symbol mobc = exp(mq&c#2(fcc)/rt); l sym cal sym * @$ We cannot calculate the MOBC symbol unless the phase @$ has been calculated with the mobility parameters. @& l c @$ The current conditions are a bit odd, set an overall Cr and C content @$ and increase T set cond ac(c)=none x(fcc,cr)=none set c x(c)=.03 x(cr)=.1 t=1200 c e l,,,, @& @$ Now we can calculate all symbols cal ph fcc ,,,,, l sym cal sym * @$ the value of a parameter identifier can also be obtained directly @$ DO NOT FORGET THE PHASE! list model-para-val mq&c#2(fcc) debug symbol mq&c#2(fcc) -5.9030928E3 @$ The value should be -5903.0928. NOTE this is not an assessed value. @& @$ There is a command to calculate the equilibrium state of a single @$ adjusted to a specified compostion. This will adjust the fractions on @$ all sublattices to minimize the Gibbs energy for that phase. cal ph fcc Y const-adj @& @$ There is also a command to calculate the potential derivative @$ matrix (note it is symmetrical) which is needed to convert @$ the mobilities to diffusion coefficients. cal ph fcc Y diff @$ This command is quite powerful as it calculates the equilibrium for a @$ single phase (which may have the same component in several sublattices) @$ for a given composition and then returns @$ 1) The chemical potentials for the endmembers (Cr:C) (Cr:Va) (Fe:C) (Fe:VA) @$ (in that order) @$ 2) The Darken matrix for the endmembers @$ 3) The current mobiliy values for the components (in alphabetical order) @& @$ Just calculate the normal equilibrium c e l,,,, @$ Note that MU/RT for the 4th endmember, -5.7912, is the same as MU/RT for Fe @$ but not for the second (Cr) as we have defined a different reference state @$ The difference between the first and second is MU/RT for C @$ debug symbol mu(fe) -5.7780791E4 @& @$ That is all for now @& @$========================================================================== @$ end of testcond1 macro @$========================================================================== set inter ================================================ FILE: examples/macros/unary.OCM ================================================ @$========================================================================== new Y set echo Y @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ unary.OCM @$ This is calculation for a single element, pure Fe @$ Just to check it can change stable phase @$ step in T and P-T diagram does not work @& @$========================================================================== r t ./steel1 fe @$ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^- @& @$ list the data l data @$ Listing of all data above @$ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^- @& @$ Set condition to calculate an equilibrium set c t=1000 p=1e5 n=1 c e l,,,, @$ At T=1000 and 1 bar BCC is stable and G=-42.2718 kJ @$ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^- debug symbol G -42271.753 @& l sh @$ A short list @$ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^- @& @$ Change condition to total mass, B, corresponding to 1 mole set c b @$ remove condition on N set c n=none c e l,,,, @$ Same equilibrium with B instead of N as condition @$ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^- @& @$ Change T to ensure we can change stable phase set c t=2000 c e l,,,, @$ Now liquid is stable and G=-127.518 kJ @$ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^- @& @$ set condition on H and remove condition on T set c h set c t=none l c c e l,,,, @$ Same equilibrium with condition on H instead of T @$ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^- @& @$ Problem combining condition on H amd B, restore condition on N set c N=1 set c B=none c e l,,, @& @$ Change value of H and calculate the equilibrium set c h 50000 c e l,,,, @$ With this value of H we have FCC stable at 1615.28 K debug symbol T 1615.2788 @& @$========================================================================== @$ end of unary macro @$========================================================================== set inter ================================================ FILE: examples/macros/uniquac.OCM ================================================ new Y set echo Y @$================================================================== @$ @$ @$ @& @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ @$ Testing the implementation of the UNIQUAC model @$ @$============================================================== @$ @$ UNIQUAC model based on the 1975 paper by Abrams and Prausnitz @$ It has a particular liquid configurational entropy term to @$ account for the different sizes of the aonstituents. @$ @$ DATA is from 1978 Andersson and Prausnitz, part 1 and 2 @$ Ind Eng Chem Process Des Dev Vol 17, No 4, 1978, 552-567 @$ @$ First part binary system acenonitrile - n_heptane @$ @& @$ The molecules are entered as elements to simplify @$ The "mass" is irrelevant as no mass fraction plots enter element A A liquid 100 ,,,,, enter element B B liquid 100 ,,,,, enter species acetonitrile A enter species n_heptane B @$ enter species benzene C @& @$ The values of area "q" and segments "r" associated with the molecule @$ are entered as species properties @$ A is ACETONITRILE from 78And-part1 @$ First value is q, second is r, values from Table 1 in 78And amend species ACETONITRILE 1.72 1.87 @$ B is N_HEPTANE amend species N_HEPTANE 4.40 5.17 l d @& @$ Thus the values below are the negative from Table 1 in 78And-part2 @$ system 5 (Palmer 1972) enter tp tauAB fun 200 exp(-23.71*T**(-1)); 1000 N test enter tp tauBA fun 200 exp(-545.71*T**(-1)); 1000 N test @& @$ enter the liquid and set model to uniquac enter phase liquid uniquac 1 1 acetonitrile n_heptane @& @$ For the residual parameters denoted tau_ji or a_ij @$ the constitient representing the second index "j" @$ muset be part of the parameter identifier in UQT enter param UQT&ACETONITRILE(liquid,N_HEPTANE) 200 tauAB; 700 N bosse enter param UQT&N_HEPTANE(liquid,ACETONITRILE) 200 tauBA; 700 N bosse set cond t=320 p=1e5 n=1 x(b)=.5 c e l,,,, @& @$ enter symbols for the activity coefficients. Do not forget = !! enter symb gamma1=ac(a)/x(a); enter symb gamma2=ac(b)/x(b); show gamma1 gamma2 @& @$ Calculate Gibbs energy curves and other properties set ax 1 x(b) 0 1 .01 @$ use "step separate" as we have two liquids step sep plot gm(*) title uniquac fig 1 @$ The two minima is typical of a miscibility gasp @& plot mu(*) scale y n -10000 600 title uniquac fig 2 @& @$ lnac(*) is same as mu(*)/RT plot lnac(*) scale y n -5 1 title uniquac fig 3 @& plot ac(*) title uniquac fig 4 @& @$ Activity plots are nicest if one has a square diagram as all values @$ normally are between 0 1. We can obtain a square diagram on the screen @$ by changing the ratio_xy @$ But to have a square diagram on a PDF plot we have to modify the @$ GNUPLOT terminals enter gnu @$ There ate 5 predefined terminals, we can add one square Y pdf color solid size 4,4 enhanced font "arial,16" pdf @$ Check the terminal you defined is there enter gnu quit y plot title uniquac fig 5 gra 6 square Y @$ Check that you have a pdf file "square.pdf" with the square diagram! @$ It is not exactly a square but reasonably so. @$ The OC logo is also a bit distorded but you can edit the square.plt file @& @$ Activity coefficients plot gamma1 title uniquac fig 6 @& plot gamma2 title uniquac fig 7 @& @$ @$ Now calculate a binary phase diagram with the miscibility gap @$ set ax 2 t 270 500 5 list ax @& set c t=400 c e l,,,, @& map plot title uniquac fig 8 @& @$ @$ @$ @$ @$ @$ @$ @$================================================================= @$ Now calculate a ternary @$ NEW Y @$ @$ We must enter the parameters again @$ @$ Calculate 78And part 2: fig 4: acenonitrile - n_heptane - benzene @$ @$========================================================================== @$ problems with the calculation of this diagram, maybe NEW is not sufficient @$ set inter @$ @$================================================================= @$ @$ @$ @$ @$ @$ @$ @$ enter element A A liquid 100 ,,,,, enter element B B liquid 100 ,,,,, enter element C C liquid 100 ,,,,, enter species acetonitrile A enter species n_heptane B enter species benzene C @$ A is ACETONITRILE from 78And-part1 amend species ACETONITRILE 1.72 1.87 @$ B is N_HEPTANE from 78And-part1 amend species N_HEPTANE 4.40 5.17 @$ C is BENZENE from 75Abr amend species BENZENE 2.40 3.18 l d @& @$ Thus the values below are the negative from Table 1 in 78And-part2 @$ system 5 (Palmer 1972) enter tp tauAB fun 200 exp(-23.71*T**(-1)); 1000 N test enter tp tauBA fun 200 exp(-545.71*T**(-1)); 1000 N test enter tp tauAC fun 200 exp(-60.28*T**(-1)); 1000 N test enter tp tauCA fun 200 exp(-89.57*T**(-1)); 1000 N test enter tp tauBC fun 200 exp(-245.42*T**(-1)); 1000 N test enter tp tauCB fun 200 exp(+135.93*T**(-1)); 1000 N test @& @$ enter the liquid phase, now with 3 constituents enter phase liquid uniquac 1 1 acetonitrile n_heptane benzene @& l d @& @$ NOTE second index in tau_ji is used in parameter identifier @$ thus UQT&UA(LIQUID,UB) is tau_(ub,ua) enter param UQT&ACETONITRILE(liquid,N_HEPTANE) 200 tauAB; 700 N bosse enter param UQT&N_HEPTANE(liquid,ACETONITRILE) 200 tauBA; 700 N bosse enter param UQT&ACETONITRILE(liquid,BENZENE) 200 tauAC; 700 N bosse enter param UQT&BENZENE(liquid,ACETONITRILE) 200 tauCA; 700 N bosse enter param UQT&N_HEPTANE(liquid,BENZENE) 200 tauBC; 700 N bosse enter param UQT&BENZENE(liquid,N_HEPTANE) 200 tauCB; 700 N bosse @& l data @$ Check parameters OK @& @$ Set a ternary composition @$ NOTE Mapping is very sensitive to start point set c t=320 p=1e5 n=1 x(b)=.5 x(c)=.1 c e l,,,, @$ Sometimes there are problems, if so try again ... c e l,,,, @$ Check result @$ debug symbol g -9.4475313E2 @& show g @$ set the axis for an isothermal phase diagram ... set ax 1 x(b) 0 1 .01 set ax 2 x(c) 0 1 .01 l ax @& map plot extra gib y extra tie 5 title uniquac fig 9 @$ All well done ... @$========================================================================== @$ end of uniquac macro @$========================================================================== set inter ================================================ FILE: linkmake ================================================ REM This file must be given the extension .cmd to be run on Windows REM It compiles OC with openMP amd the popup window for opening files. REM ******************************************* REM ** OC graphics require GNUPLOT 5.2 or later REM ******************************************* del *.o del *.mod REM tinyfiledialog files and interface copy src\utilities\TINYFILEDIALOGS\tinyopen.c . copy src\utilities\TINYFILEDIALOGS\tinyfiledialogs.c . copy src\utilities\TINYFILEDIALOGS\tinyfiledialogs.h . copy src\utilities\TINYFILEDIALOGS\ftinyopen.F90 . gcc -c tinyopen.c gcc -c tinyfiledialogs.c gfortran -c ftinyopen.F90 del tinyopen.c del tinyfiledialogs.c del tinyfiledialogs.h del ftinyopen.F90 REM NEW global constants mm copy src\models\ocparam.F90 . gfortran -c -O2 ocparam.F90 del ocparam.F90 REM some utilites and the command line interface REM Changed to utiliy package metlib4 copy src\utilities\metlib4.F90 . gfortran -c -O2 -Dtinyfd metlib4.F90 del metlib4.F90 REM some routines from LAPACK and BLAS copy src\numlib\oclablas.F90 . gfortran -c -O2 oclablas.F90 del oclablas.F90 REM some more numerical routines REM NEW if no external LAPACK -DNOLAPACK needed copy src\numlib\ocnum.F90 . gfortran -c -DNOLAPACK -O2 ocnum.F90 del ocnum.F90 REM the MINPACK package for least square fitting and solving nonlinear eqs. copy src\numlib\minpack1.F90 gfortran -c -O2 minpack1.F90 del minpack1.F90 REM the model routines copy src\models\gtp3*.F90 . gfortran -c -O2 gtp3.F90 del gtp3*.F90 REM the equilibrium calculation routines copy src\minimizer\matsmin.F90 . gfortran -c -O2 matsmin.F90 del matsmin.F90 REM the routines diagrams using STEP or MAP copy src\stepmapplot\smp2*.F90 . gfortran -c -O2 smp2.F90 del smp2*.F90 REM the user interface REM set -Dqtplt to use the Qt terminal driver for screen REM -Dwinhlp needed for online help on Windows copy src\userif\pmon6.F90 . gfortran -c -Dwinhlp pmon6.F90 del pmon6.F90 REM First installation create the libs directory mkdir libs del libs\liboceq.a REM generating the library (needed also for TQ library) ar sq libs\liboceq.a metlib4.o oclablas.o gtp3.o matsmin.o minpack1.o ocnum.o REM What about the mod file liboceqplus.mod ? REM Add linkdate to main program REM New copy pmain1.F90 to pmain1-save.90 to modify linkdat, then delete it copy src\pmain1.F90 src\pmain1-save.F90 gfortran -o linkocdate src/linkocdate.F90 linkocdate del src\pmain1-save.F90 REM Finally linking all together gfortran -o oc6A src\pmain1.F90 pmon6.o smp2.o ftinyopen.o tinyopen.o tinyfiledialogs.o libs\liboceq.a -lcomdlg32 -lole32 copy oc6A.exe bin\ REM ******************************************* REM ** OC graphics require GNUPLOT 5.2 or later REM ******************************************* ================================================ FILE: linkpara ================================================ REM This file must be given the extension .cmd to be run on Windows REM It compiles OC with openMP amd the popup window for opening files. REM ******************************************* REM ** OC graphics require GNUPLOT 5.2 or later REM ******************************************* del *.o del *.mod REM tinyfiledialog files and interface copy src\utilities\TINYFILEDIALOGS\tinyopen.c . copy src\utilities\TINYFILEDIALOGS\tinyfiledialogs.c . copy src\utilities\TINYFILEDIALOGS\tinyfiledialogs.h . copy src\utilities\TINYFILEDIALOGS\ftinyopen.F90 . gcc -c tinyopen.c gcc -c tinyfiledialogs.c gfortran -c ftinyopen.F90 del tinyopen.c del tinyfiledialogs.c del tinyfiledialogs.h del ftinyopen.F90 REM NEW global constants mm copy src\models\ocparam.F90 . gfortran -c -O2 ocparam.F90 del ocparam.F90 REM some utilites and the command line interface REM Changed to utiliy package metlib4 copy src\utilities\metlib4.F90 . gfortran -c -O2 -Dtinyfd metlib4.F90 del metlib4.F90 REM some routines from LAPACK and BLAS copy src\numlib\oclablas.F90 . gfortran -c -fopenmp -O2 oclablas.F90 del oclablas.F90 REM some more numerical routines REM NEW if no external LAPACK -DNOLAPACK neededs copy src\numlib\ocnum.F90 . gfortran -c -DNOLAPACK -fopenmp -O2 ocnum.F90 del ocnum.F90 REM the MINPACK package for least square fitting and solving nonlinear eqs. copy src\numlib\minpack1.F90 gfortran -c -fopenmp -O2 minpack1.F90 del minpack1.F90 REM the model routines copy src\models\gtp3*.F90 . gfortran -c -fopenmp -O2 gtp3.F90 del gtp3*.F90 REM the equilibrium calculation routines copy src\minimizer\matsmin.F90 . gfortran -c -fopenmp -O2 matsmin.F90 del matsmin.F90 REM the routines diagrams using STEP or MAP copy src\stepmapplot\smp2*.F90 . gfortran -c -fopenmp -O2 smp2.F90 del smp2*.F90 REM the user interface REM set -Dqtplt to use the Qt terminal driver for screen REM -Dwinhlp needed for online help on Windows copy src\userif\pmon6.F90 . gfortran -c -fopenmp -Dwinhlp pmon6.F90 del pmon6.F90 REM First installation create the libs directory mkdir libs del libs\liboceq.a REM generating the library (needed also for TQ library) ar sq libs\liboceq.a metlib4.o oclablas.o gtp3.o matsmin.o minpack1.o ocnum.o REM What about the mod file liboceqplus.mod ? REM Add linkdate to main program REM New copy pmain1.F90 to pmain1-save.90 to modify linkdat, then delete it copy src\pmain1.F90 src\pmain1-save.F90 gfortran -o linkocdate src/linkocdate.F90 linkocdate del src\pmain1-save.F90 REM Finally linking all together gfortran -o oc6P -fopenmp -O2 src\pmain1.F90 pmon6.o smp2.o ftinyopen.o tinyopen.o tinyfiledialogs.o libs\liboceq.a -lcomdlg32 -lole32 REM Copy to AppData (Create first and insert in PaTH in ENVIRONMENT) REM copy oc6P.exe C:\Users\bosun\AppData\Local\OC\bin\ REM copy changes.txt C:\Users\bosun\Documents\ochome\ REM ******************************************* REM ** OC graphics require GNUPLOT 5.2 or later REM ******************************************* ================================================ FILE: src/linkocdate.F90 ================================================ program linkocdate ! extract current date and inserts it in the source code of the main program character date*20,mdate*12,line*60 call date_and_time(date) write(*,*)'Stored linking date: ',date mdate="'"//date(1:4)//'-'//date(5:6)//'-'//date(7:8)//"'" open(21,file='src/pmain1-save.F90',access='sequential',status='old') open(22,file='src/pmain1.F90',access='sequential',status='unknown') 100 continue read(21,110,end=200)line k=index(line,'linkdate=') if(k.gt.0) then line(k+9:)=mdate endif write(22,110)line(1:len_trim(line)) 110 format(a) goto 100 200 continue close(21) close(22) end program linkocdate ================================================ FILE: src/minimizer/matsmin.F90 ================================================ ! Hillert's Minimizer as implemented by Sundman (HMS) ! Based on Mats Hillert paper in Physica 1981 and Bo Janssons thesis 1984 ! Details of this implementation published in Computational Materials Science, ! vol 101, (2015) pp 127-137 ! ! MODULE liboceq ! MODULE liboceqplus ! use general_thermodynamic_package use minpack ! ! Copyright 2012-2021, Bo Sundman, France ! ! This program is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 2 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this program; if not, write to the Free Software ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! contact person: bo.sundman@gmail.com ! !--------------------------- ! ! To be implemented/improved ! - calculating dot derivatives (Cp, thermal expansion etc) PARTIALLY DONE ! - stability check (eigenvalues) ! - conditions for properties H, V, S etc. (partially done) ! - expressions as conditions (only for x(A) and N(A)) ! - calculate gridminimizer after equilibrium as check DONE ! - cleanup the use of chemical potentials. DONE ! ! ! For parallellization, also used in gtp3.F90 !$ use omp_lib ! implicit none character*8, parameter :: hmsversion='HMS-3.0' ! !------------------------------------------------------- ! for single equilibrium ! ! BITS in meqrec status word ! MMQUIET means no output for the equilibrium calculation ! MMNOSTARTVAL means grid minimizer not called at start integer, parameter :: MMQUIET=0, MMNOSTARTVAL=1,MMSTEPINV=2 ! NOTE in calceq7 status word is set to zero if more bits used because ! it seemed to have an arbitrary value and it created problems in macro map7 ! I have now correceted the main reason (creating linehead records in SMP) ! but I kept this check ! !\begin{verbatim} TYPE meq_phase ! parts of the data in this structure should be in the gtp_equilibrium_data ! it contains phase specific results from various subroutines during ! equilibrium calculation ! iph: phase number ! ics: composition set number ! idim: the dimension of phase matrix, ! ncc: the number of constituents (same as idim??) ! stable: is 1 for a stable phase ! xdone: set to 1 for stoichiometric phases after calculating xmol first time ! dormlink: link to next phase that has temporarily been set dormant ! eec_check for equi-entropy check ! phtupix phase tuple index integer iph,ics,idim,stable,ncc,xdone,dormlink,eeccheck,phtupix ! value of phase status (-1,0=ent, 1=stable, 2=fix, -2=dorm, -3=sus, -4 hidden) integer phasestatus ! inverted phase matrix double precision, dimension(:,:), allocatable :: invmat ! mole fractions of components and their sum double precision, dimension(:), allocatable :: xmol double precision :: sumxmol,sumwmol ! Derivatives of moles of component wrt all constituent fractions of the phase double precision, dimension(:,:), allocatable :: dxmol ! link to phase_varres record TYPE(gtp_phase_varres), pointer :: curd ! value of amount and driving force at previous iteration double precision prevam, prevdg ! iteration when phase was added/removed integer itadd, itrem ! chargebal is 1 if external charge balance needed, ionliq<0 unless ! ionic liquid when it is equal to nkl(1)=number of cations integer chargebal,ionliq,i2sly(2) double precision iliqcharge,yva ! end specific ionic liquids end TYPE meq_phase !\end{verbatim} ! !------------------------------------------------------------------- ! !\begin{verbatim} TYPE meq_setup ! one structure of this type is created when an equilibrium calculation ! is started and it holds all global data needed for handling the ! calculation of an equilibrium. The phase specific data is in meq_phase ! nv: initial guess of number of stable phases ! nphase: total number of phases and composition sets ! nstph: current number of stable phases ! dormlink: is start of list of phases temporarily set dormant ! noofits current number of iterations ! status for various things ! nrel number of elements (components) ! typesofcond: types of conditions, =1 only massbal, =2 any conditions ! nfixmu number of fixed chemical potentials ! nfixph number of conditions representing fix phases integer nv,nphase,nstph,dormlink,noofits,status integer nrel,typesofcond,maxsph,nfixmu,nfixph ! component numbers of fixed potentials, reference and value integer, dimension(:), allocatable :: mufixel integer, dimension(:), allocatable :: mufixref ! in this array the mu value as calculated from SER is stored double precision, dimension(:), allocatable :: mufixval ! in this array the mu value for user defined reference state is stored double precision, dimension(:), allocatable :: mufixvalref ! fix phases and amounts integer, dimension(:,:), allocatable :: fixph double precision, dimension(:), allocatable :: fixpham ! indices of axis conditions that has been inactivated ! integer, dimension(:), allocatable :: inactiveaxis ! iphl, icsl: phase and composition sets of intial guess of stable phases ! aphl: initial guess of amount of each stable phase integer iphl(maxel+2),icsl(maxel+2) double precision aphl(maxel+2) ! stphl: current list of stable phases, value is index in phr array integer, dimension(maxel+2) :: stphl ! current values of chemical potentials stored in gtp_equilibrium_data ! if variable T and P these are TRUE, otherwise FALSE logical tpindep(2) ! these are the maximum allowed changes in T and P during iterations double precision tpmaxdelta(2) ! individual phase information type(meq_phase), dimension(:), allocatable :: phr ! this is used for EEC, pointer to liquid phr record and highest liquid entropy type(meq_phase), pointer :: pmiliq double precision seecliq ! information about conditions should be stored here. Note that conditions ! may change during STEP and MAP end TYPE meq_setup !\end{verbatim} ! !------------------------------------------------------------------ ! ! This is a connection to step/map !\begin{verbatim} TYPE map_fixph ! provides information about phase sets for each line during mapping integer nfixph,nstabph,status type(gtp_phasetuple), dimension(:), allocatable :: fixph type(gtp_phasetuple), dimension(:), allocatable :: stableph ! most likely some of these variables are redundant stable_phr added 2020.03.05 integer, dimension(:), allocatable :: stable_phr double precision, dimension(:), allocatable :: stablepham ! new 180814 to have nonzero fix phase amounts ... not yet used double precision, dimension(:), allocatable :: fixphamap end TYPE map_fixph !\end{verbatim} ! declared as mapfix in call to calceq7 and some other routines ! ! Added for debugging converge problems TYPE meqdebug integer mconverged,nvs,typ(10) integer :: flag=0 double precision val(10),dif(10) end type meqdebug type(meqdebug) :: cerr ! !\begin{verbatim} ! This is for returning the calculated value of an experimental property ! as we need an array to store the calculated values of the experimental ! properties in order to calculate the Relative Standarad Deviation (RSD) double precision, allocatable, dimension(:) :: calcexp ! We cannot have EEC variabler here as it does bot work in parallel ! this is for EEC test ! type(meq_phase), pointer :: pmiliq ! if several liquids check for largest S ! type(meq_phase), pointer :: pmiliqsave ! double precision eecliqentropy ! this is set TRUE when entering meq_onephase and false after one solid checked? ! it is now check for EEC ! logical eecextrapol ! This is an (failed) attempt to limit Delta-T when having condition on y logical ycondTlimit double precision deltatycond ! TZERO, EET and PARAEQUIL calculation need these (CANNOT BE USED IN PARALLEL) type(gtp_equilibrium_data), pointer :: tzceq type(gtp_condition), pointer :: tzcond type(gtp_state_variable), target :: musvr,xsvr integer tzph1,tzph2 ! To prevent calculating a dot derivative at a given equilibrium integer :: special_circumstances=0 !\end{verbatim} ! !-------------------------------------------------------------- ! ! declared as part of phase_varres to be used in parallel ! integer, dimension (:,:), allocatable :: phaseremoved ! debug output indicator ! mmdotder indicate dot derivative calculation, phase set may be different ! from the static memory integer :: mmdebug=0,mmdotder=0 ! warning using B=value as condition logical bwarning !-------------------------------------------------------------- ! ! IMPORTANT ! phase_varres(lokcs)%amfu is the number of formula units of the phase ! phase_varres(lokcs)%netcharge is the current total charge of the phase ! phase_varres(lokcs)%abnorm(1) is the number of real atoms per formula unit ! (may vary with composition like in (Fe,Cr,...)(Va,C,N,...) ) ! phase_varres(lokcs)%abnorm(2) is the mass per formula unit ! NOTE: abnorm(1) and abnorm(2) are set by call to set_constitution ! CONTAINS !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calceq2(mode,ceq) !\begin{verbatim} subroutine calceq2(mode,ceq) ! calculates the equilibrium for the given set of conditions ! mode=0 means no global minimization ! ceq is a datastructure with all relevant thermodynamic data implicit none integer mode TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ TYPE(meq_setup), allocatable, target :: meqrec1 TYPE(meq_setup), pointer :: meqrec type(map_fixph), allocatable :: mapfix ! type(map_fixph), pointer :: mapfix double precision starting,finish2,gtot integer starttid,endoftime,ij,addtuple,errall character name*16 !-------------------------------- allocate(meqrec1,stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 1: ',errall gx%bmperr=4370; goto 1000 endif meqrec=>meqrec1 meqrec%status=0 if(allocated(mapfix)) deallocate(mapfix) call cpu_time(starting) call system_clock(count=starttid) ! we may return here if gridcheck found a gridpoint below 100 continue call calceq7(mode,meqrec,mapfix,ceq) call system_clock(count=endoftime) call cpu_time(finish2) 1000 continue if(gx%bmperr.eq.0) then ! Gibbs energy using SER as reference state call get_state_var_value('GS ',gtot,name,ceq) if(gx%bmperr.ne.0) gx%bmperr=0 if(.not.btest(globaldata%status,GSSILENT)) then if(ceq%eqno.ne.1) then write(*,1010)ceq%eqname(1:11),meqrec%noofits,& finish2-starting,endoftime-starttid,gtot else write(*,1010)'Equilibrium',meqrec%noofits,& finish2-starting,endoftime-starttid,gtot endif 1010 format(a,' result:',i4,' its, ',& 1pe11.4,' s, ',i6,' cc, GS=',1pe15.7,' J/mol') endif ! Here we have now an equilibrium calculated. Do a cleanup of the structure ! for phases with several compsets the call below shifts the stable one ! to the lowest compset number unless the default constitution fits another ! For example to ensure a fcc-carbonitrides is always the same compset. ij=1 ! if meqrec%status indicate no initial startvalues set ij<0 to indicate test ! DO not test if mode=0 if(mode.ne.0 .and. btest(meqrec%status,MMNOSTARTVAL)) ij=-ij ! OC went into a loop for a complex alloy calcumation here (once long ago ...) ! write(*,*)'MM calling todo_after: 2',& ! btest(meqrec%status,MMNOSTARTVAL),mode call todo_after_found_equilibrium(ij,addtuple,ceq) if(gx%bmperr.ne.0) then if(gx%bmperr.eq.4358) then ! gridpoint below current equilibrium found and set as stable (maybe new ! composition set). Recalculate gx%bmperr=0 write(*,*)'MM recalculating with this phase as stable 2: ',addtuple goto 100 endif endif ! write(*,*)'MM back in calceq2 after todo_after' endif !CCI ! save the number of iterations needed to calculate the equilibrium ceq%conv_iter=meqrec%noofits ! maybe memory leak 2 ! write(*,*)'MM deallocate 2' deallocate(meqrec1) ! write(*,*)'MM deallocated meqrec1' return end subroutine calceq2 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calceq3 !\begin{verbatim} %- subroutine calceq3(mode,confirm,ceq) ! calculates the equilibrium for the given set of conditions ! mode=0 means no global minimization ! confirm is TRUE if output of CPU time ! ceq is a datastructure with all relevant thermodynamic data implicit none integer mode logical confirm TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} TYPE(meq_setup), allocatable, target :: meqrec1 TYPE(meq_setup), pointer :: meqrec type(map_fixph), allocatable :: mapfix ! type(map_fixph), pointer :: mapfix double precision starting,finish2 integer starttid,endoftime,ij,addtuple,errall !-------------------------------- allocate(meqrec1,stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 2: ',errall gx%bmperr=4370; goto 1000 endif meqrec=>meqrec1 meqrec%status=0 if(.not.confirm) meqrec%status=ibset(meqrec%status,MMQUIET) if(allocated(mapfix)) deallocate(mapfix) ! nullify(mapfix) call cpu_time(starting) call system_clock(count=starttid) ! we may return here if gricheck found a new phase stable 100 continue call calceq7(mode,meqrec,mapfix,ceq) call system_clock(count=endoftime) call cpu_time(finish2) 1000 continue if(gx%bmperr.eq.0) then ! Here we have now an equilibrium calculated. Do a cleanup of the structure ! for phases with several compsets the call below shifts the stable one ! to the lowest compset number unless the default constitution fits another ! For example to ensure a fcc-carbonitrides is always the same compset. ij=1 ! if meqrec%status indicate no initial startvalues set ij<0 to indicate test if(mode.ne.0 .and. btest(meqrec%status,MMNOSTARTVAL)) ij=-ij ! write(*,*)'MM Calling todo_after calceq3' call todo_after_found_equilibrium(ij,addtuple,ceq) if(gx%bmperr.eq.4358) then ! gridcheck after found a new phase stable! recalculate gx%bmperr=0 ! write(*,*)'MM recalculate with new phase added as stable 3:',addtuple goto 100 endif if(confirm) then write(*,1010)meqrec%noofits,finish2-starting,endoftime-starttid 1010 format('Equilibrium calculation ',i4,', its, ',& 1pe12.4,' s and ',i7,' clockcycles') endif elseif(confirm) then write(*,1020)gx%bmperr 1020 format('Error return from equilibrium calculation ',i5) endif ! CCI save the number of iterations to calculate the equilibrium ceq%conv_iter=meqrec%noofits ! memory leak 2 ! write(*,*)'MM deallocate 3' deallocate(meqrec1) ! write(*,*)'MM deallocated' return end subroutine calceq3 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calceq7 !\begin{verbatim} subroutine calceq7(mode,meqrec,mapfix,ceq) ! calculates the equilibrium for the given set of conditions ! mode=0 means no global minimization ! mode=-1 means used during step/map, no gridmin and do not deallocate phr ! ceq is a datastructure with all relevant thermodynamic data ! calling this routine instead of calceq2 makes it possible to extract ! additional information about the equilibrium from meqrec. ! Meqrec is also used for calculation of derivatives of state vatiables implicit none integer mode TYPE(meq_setup), pointer :: meqrec type(map_fixph), allocatable :: mapfix TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} TYPE(gtp_condition), pointer :: condition,lastcond ! conditions on T and P and mole fractions of components double precision, dimension(2) :: tpval double precision, dimension(maxel) :: xknown,vmu ! antot is total number of moles of atoms. Needed to scale results from ! gridmin which assumes 1 mole of atoms double precision xxx,antot,cvalue,ccf(5) logical gridtest,formap ! for global minimization (change maybe to allocate dynamically) integer, dimension(maxph) :: nyphl double precision, dimension(maxconst) :: yarr integer np,iph,ics,jph,lokph,lokcs,mode2,errall integer mostcon,mph,nvf,mostconph(2,maxel),icc,jcc ! max number of potential conditions integer, parameter :: mmu=20 ! dimension cmix(22) allows 5 terms: 2+4*5 integer mjj,ij,cmix(22),cmode,mufixel(mmu),mufixref(mmu),errout integer fixph(2,maxel),oldorder(mmu),kst,jj ! just for debugging ! integer idum(1000) double precision fixpham(maxel),sumnp,props(5) logical ycond integer jq,ntup,saverr ! character statevar*40 ! ntup=nooftup() ! write(*,*)'MM in calceq7',ntup ycond=.FALSE. ! this will be set to false when warning shown once for each calculation bwarning=.TRUE. if(btest(globaldata%status,GSSILENT)) & meqrec%status=ibset(meqrec%status,MMQUIET) if(ocv()) write(*,*)"Entering calceq7",mode errout=0 ! clear bit that start values has not been calculated meqrec%status=ibclr(meqrec%status,MMNOSTARTVAL) if(gx%bmperr.ne.0) then if(gx%bmperr.eq.4203 .or. gx%bmperr.eq.4204) then ! this means system matrix error and too many iterations respectivly write(kou,3)gx%bmperr 3 format('Error code ',i5,' reset before calling global minimizer') gx%bmperr=0 errout=kou else write(kou,*)'Error code ',gx%bmperr,' prevents using global minimizer' goto 1000 endif endif if(mode.ge.0) then mode2=mode formap=.FALSE. else ! formap .TRUE. means that phr will not be deallocated ! and that phr(jj)%phasestatus will be set from meqrec%fixph .... mode2=0 formap=.TRUE. endif ! skip this if mode=-1, we may not have degrees of freedom equal to zero ! as the fix phase is not stored as condition ... if(mode.ge.0) then !--------------------------- ! extract conditions call extract_massbalcond(tpval,xknown,antot,ceq) ! write(*,7)'MM xk: ',gx%bmperr,(xknown(mjj),mjj=1,noel()) 7 format(a,i5,9(F8.4)) if(gx%bmperr.ne.0) then ! error 4143 means no conditions, 4144 wrong number of conditions if(gx%bmperr.eq.4143 .or. gx%bmperr.eq.4144) then ! write(*,*)'Degrees of freedom not zero',gx%bmperr goto 1000 endif ! 4151 not only massbalance conditions ! if(gx%bmperr.eq.4151) goto 1000 ! these are other errors that makes it impossible to use gridminimizer ! if(gx%bmperr.eq.4173 .or. & ! gx%bmperr.eq.4174 .or. & ! (gx%bmperr.ge.4176 .and. gx%bmperr.le.4185)) goto 1000 ! if mode=0 we should not use grid minimizer ! if(mode.ne.0 .or. .not.btest(meqrec%status,MMQUIET)) & if(mode.ne.0 .and. .not.btest(meqrec%status,MMQUIET)) & write(*,9) 9 format('Warning: global minimizer cannot be used for the current',& ' set of conditions') gx%bmperr=0 gridtest=.true. meqrec%typesofcond=2 else ! meqrec%antot=antot ! no need for final grid minimizer as we will do one as start gridtest=.false. meqrec%typesofcond=1 endif ! write(*,*)'MM checked massbalance' if(ocv()) write(*,*)'MM checked massbalance' !------------------------------------ endif ! write(*,*)'In Calceq7 2' meqrec%nrel=noel() ! set some initial values meqrec%maxsph=noel()+2 meqrec%nfixph=0 meqrec%nfixmu=0 meqrec%tpindep=.TRUE. ! limit change in T and P. For P it should be a factor ... meqrec%tpmaxdelta(1)=2.0D2 meqrec%tpmaxdelta(2)=1.0D2 ! now we calculate maxsph, nfixmu and maybe other things for later lastcond=>ceq%lastcondition if(.not.associated(lastcond)) then ! write(*,*)'No conditions' gx%bmperr=4143; goto 1000 endif condition=>lastcond cmix=0 np=0 mjj=0 ! set default values ! write(*,69)tpval,ceq%tpval !69 format('T&P: ',4(1pe12.4)) tpval(1)=ceq%tpval(1) tpval(2)=ceq%tpval(2) ceq%rtn=globaldata%rgas*tpval(1) !---------------- loop ! loop through all conditions, end when the pointer condition is empty ! loop to investigate conditions, apply_condition:value in gtp3D.F90 70 continue ! comode=-1 means just check type of condition ! NOTE SPECIAL: condition on Y returns cmix(1)=6 to inhibit grid minimizer cmode=-1 condition=>condition%next mjj=mjj+1 if(ocv()) write(*,*)'check condition' ! a condtion can have several terms, ccf is coefficient for each term, ! if just one term ccf (is assumed?) to be 1.0 call apply_condition_value(condition,cmode,cvalue,cmix,ccf,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,71)'MM apply 1: ',cmode,cvalue,cmix,ccf(1) !71 format(a,i3,1pe14.4,10i4/12i4,1pe12.4) !71 format(a,i3,1pe14.4,10i4/5(1pe12.4)) ! cmix(1)=0 for inactive conditions ! cmix(1)=1 fix T, =2, fix P, =3 fix MU/AC/LNAC, =4 fix phase, =5 anything else ! if condition on T, P, potential or fix phase reduce maxsph select case(cmix(1)) case default if(.not.associated(condition,lastcond)) goto 70 case(1) ! fix T if(cvalue.le.1.0D-2) then write(*,*)'Condition on T must be larger than 0.01 K' gx%bmperr=4187; goto 1000 endif meqrec%maxsph=meqrec%maxsph-1 meqrec%tpindep(1)=.FALSE. ceq%tpval(1)=cvalue case(2) ! fix P if(cvalue.le.1.0D-2) then write(*,*)'Condition on P must be larger than 0.01 Pa' gx%bmperr=4187; goto 1000 endif meqrec%maxsph=meqrec%maxsph-1 meqrec%tpindep(2)=.FALSE. ceq%tpval(2)=cvalue !------------------------- case(3) ! (MU,AC,LNAC) in cmix(2)=3,4,5 ! The component is in cmix(3) and reference state in cmix(4) ! Handling of the reference state ignored at present np=np+1 if(np.gt.mmu) then write(*,*)'Max conditions on potentials is ',mmu gx%bmperr=4189; goto 1000 endif mufixel(np)=cmix(3) mufixref(np)=cmix(4) ! temporarily use yarr for something else if(cmix(2).eq.3) then ! Divide MU by RT yarr(np)=cvalue/ceq%rtn elseif(cmix(2).eq.4) then ! AC=exp(MU/RT) converted to chemical potential/RT if(cvalue.le.zero) then write(*,*)'Conditions on activity must be larger than zero' gx%bmperr=4191; goto 1000 endif yarr(np)=LOG(cvalue) else ! LNAC=MU/RT which is the value used during minimization yarr(np)=cvalue endif ! write(*,*)'Chemical potential condition: ',yarr(np) meqrec%maxsph=meqrec%maxsph-1 ! write(*,72)'MM, chemp: ',cmix(1),cmix(2),cmix(3),cvalue !72 format(a,3i3,1pe12.4) !------------------------- case(4) ! fix phase ! cmix(2) is phase index; cmix(2) is composition set meqrec%nfixph=meqrec%nfixph+1 fixph(1,meqrec%nfixph)=cmix(2) fixph(2,meqrec%nfixph)=cmix(3) fixpham(meqrec%nfixph)=cvalue ! write(*,*)'Fix phase condition: ',cmix(2),cmix(3),cvalue ! debug output of fix phase composition ! call calc_phase_mol(cmix(1),yarr,ceq) case(5) ! mass balance condition ! write(*,*)'MM cmix(1..4): ',cmix(1),cmix(2),cmix(3),cmix(4) case(6) ! Condition on Y, no grid minimizer ycond=.TRUE. ! write(*,*)'MM condition on Y inhibit grid minimizer!' end select !----------------------------------------------- if(.not.associated(condition,lastcond)) goto 70 ! end loop of conditions !-------------------------------------------------------------- ! write(*,*)'variable potentials, max variable phases: ',& ! noel()-cmix(2),meqrec%maxphases meqrec%nfixmu=np if(np.gt.0) then ! number of fixed chemical potentials if(.not.allocated(meqrec%mufixel)) then allocate(meqrec%mufixel(np),stat=errall) allocate(meqrec%mufixref(np),stat=errall) allocate(meqrec%mufixval(np),stat=errall) allocate(meqrec%mufixvalref(np),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 3: ',errall gx%bmperr=4370; goto 1000 endif else ! this can happen if activity condition and calculating without gridmin ! write(*,*)'Warning: meqrec has already mufixel allocated!' write(*,'("MM Calculate with activity condition")') endif if(np.gt.1) then ! sort components with fix MU in increasing order to simplify below call sortin(mufixel,np,oldorder) do mjj=1,np nvf=mufixel(mjj) meqrec%mufixel(mjj)=nvf meqrec%mufixref(mjj)=mufixref(oldorder(mjj)) meqrec%mufixval(mjj)=yarr(oldorder(mjj)) meqrec%mufixvalref(mjj)=yarr(oldorder(mjj)) ! copy fixed chemical potential (divided by RT) to ceq%cmuval also ceq%cmuval(nvf)=yarr(oldorder(mjj)) ! in the component records multiply with RT ceq%complist(nvf)%chempot(1)=yarr(oldorder(mjj))*ceq%rtn enddo else nvf=mufixel(1) meqrec%mufixel(1)=nvf meqrec%mufixref(1)=mufixref(1) meqrec%mufixval(1)=yarr(1) meqrec%mufixvalref(1)=yarr(1) ! also copy fixed chemical potential to ceq%cmuval ceq%cmuval(nvf)=yarr(1) ceq%complist(nvf)%chempot(1)=ceq%cmuval(nvf)*ceq%rtn endif endif if(meqrec%nfixph.gt.0) then ! allocate 5 extra places for fix phase during mapping ... if(.not.allocated(meqrec%fixph)) then ! write(*,*)'Allocate meqrec%fixph' allocate(meqrec%fixph(2,meqrec%nfixph+5),stat=errall) allocate(meqrec%fixpham(meqrec%nfixph+5),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 4: ',errall gx%bmperr=4370; goto 1000 endif ! write(*,*)'Allocated meqrec%fixph' endif if(np.gt.1) then ! ?? sort phases in increasing order to simplify below write(*,*)'MM Cannot handle two fix phases ... ' gx%bmperr=4192; goto 1000 endif do mjj=1,meqrec%nfixph meqrec%fixph(1,mjj)=fixph(1,mjj) meqrec%fixph(2,mjj)=fixph(2,mjj) meqrec%fixpham(mjj)=fixpham(mjj) enddo else ! allocate 5 places for fix phase during mapping (one per axis) if(.not.allocated(meqrec%fixph)) then allocate(meqrec%fixph(2,5),stat=errall) allocate(meqrec%fixpham(5),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 5: ',errall gx%bmperr=4370; goto 1000 endif endif endif !---------------------------- ! call list_conditions(kou,ceq) ! skip if mode2=0 or global gridminimizer if bit set ! write(*,*)'In Calceq7 4' if(mode2.eq.0 .or. btest(globaldata%status,GSNOGLOB)) then ! if errout set then grimin probably called to handel bad start point if(errout.eq.0) goto 110 ! write(*,*)'errout 2: ',errout endif ! skip global gridminimizer if only one component but make sure one phase ! has positive amount if(meqrec%nrel.eq.1) then goto 110 endif ! skip global minimizer if ycond is true if(ycond) then ! write(*,*)'MM condition on y(phase,const), no global minimizer' goto 110 endif !--------------------------------------------------------------- ! Try global gridminimization. Returned values are: ! nv is number of stable phase, iphl, icsl list of stable phases, aphl amounts ! nyphl(j) is number of constituent fractions in phase j, yarr are the ! constituent fractions, vmu the chemical potentials ! THIS CALL MAY CREATE NEW COMPOSITION SETS unless GSNOACS set. ! loop through all phases and set amount=0 and CSABLE off ij=1 call todo_before(ij,ceq) if(gx%bmperr.ne.0) goto 1000 if(meqrec%typesofcond.eq.1) then ! with only massbalance condition make a global grid minimization ! call global_gridmin(1,tpval,xknown,meqrec%nv,& ! meqrec%iphl,meqrec%icsl,meqrec%aphl,nyphl,yarr,vmu,idum,ceq) ! write(*,*)'MM calling global gridmin' call global_gridmin(1,tpval,xknown,meqrec%nv,& meqrec%iphl,meqrec%icsl,meqrec%aphl,nyphl,vmu,ceq) if(ocv()) write(*,*)'MM back from gridmin' ! write(*,*)'MM back from gridmin' if(gx%bmperr.ne.0) then ! if global fails reset error code and try a default start set of phases ! if(gx%bmperr.ge.4000 .and. gx%bmperr.le.nooferm) then ! write(*,102)gx%bmperr,trim(bmperrmess(gx%bmperr)) !102 format('Error ',i5,': ',a/& ! 'Minimizer tries using current or default start values') ! write(kou,102)gx%bmperr,bmperrmess(gx%bmperr) ! write(kou,102)bmperrmess(gx%bmperr) !102 format(a/'Current constitution used as start values.') ! else ! write(kou,113)gx%bmperr !113 format('Cannot use grid minimazer, error: ',i5/& ! 'Current constitution used as start values.') ! endif ! no initial gridmin, make a gridtest at the end (not implemented ...) ! else ! write(*,*)'Grid minimizer cannot be used with these conditions' ! endif ! set that grid minimizer is called after the equilibrium calculation gridtest=.true. ! problems using gridmin ! use current constitution or set default constitution (does not work well) gx%bmperr=0; goto 110 endif ! multiply phase amounts with antot as global_grimin assumes 1 mole if(abs(antot-one).gt.1.0D-8) then ! write(*,*)'From gridmin: ',meqrec%nv,antot do mph=1,meqrec%nv call get_phase_compset(meqrec%iphl(mph),meqrec%icsl(mph),& lokph,lokcs) ceq%phase_varres(lokcs)%amfu=antot*ceq%phase_varres(lokcs)%amfu enddo endif if(ocv() .or. errout.gt.0) & write(*,103)(meqrec%iphl(mjj),meqrec%icsl(mjj),meqrec%aphl(mjj),& mjj=1,meqrec%nv) 103 format('Phases: ',12(i3,i2,F5.2)) goto 200 endif !-------------------- ! no global gridmin or we come here if gridtest finds a new stable phase ! UNFINISHED: A better start guess should be made!!! ! 110 continue ! write(*,*)'starting without gridmin',errout meqrec%nv=0 ! at least one phase must be stable mostcon=0 mostconph=0 mph=0 jph=0 sumnp=zero selph1: do iph=1,noph() selcs1: do ics=1,noofcs(iph) kst=test_phase_status(iph,ics,xxx,ceq) if(gx%bmperr.ne.0) goto 1000 ! new: -4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fix ! skip loop selph1 for phases that are dormant or suspended if(kst.le.PHDORM) then if(ics.lt. noofcs(iph)) then cycle selcs1 else cycle selph1 endif endif call get_phase_compset(iph,ics,lokph,lokcs) if(ceq%phase_varres(lokcs)%amfu.gt.zero) then meqrec%nv=meqrec%nv+1 meqrec%iphl(meqrec%nv)=iph meqrec%icsl(meqrec%nv)=ics meqrec%aphl(meqrec%nv)=ceq%phase_varres(lokcs)%amfu sumnp=sumnp+ceq%phase_varres(lokcs)%amfu endif enddo selcs1 ! select the phases with most constituents call get_phase_variance(iph,nvf) if(mostcon.eq.0) then mostcon=mostcon+1 mostconph(1,1)=nvf mostconph(2,1)=iph else ! very very clumsy do icc=1,mostcon if(nvf.le.mostconph(1,icc)) then if(icc.gt.1) then ! store this phase as a start phase if not in first position ! otherwise ignore it if(mostcon.lt.noel()-meqrec%nfixmu) then mostcon=mostcon+1 do jcc=icc+1,mostcon mostconph(1,jcc)=mostconph(1,jcc-1) mostconph(2,jcc)=mostconph(2,jcc-1) enddo mostconph(1,icc)=nvf mostconph(2,icc)=iph else ! bug reported by valgrid used by UrbanJost icc-1 = 1 but icc>1 here! mostconph(1,icc-1)=nvf mostconph(2,icc-1)=iph endif endif endif enddo endif enddo selph1 if(meqrec%nv.eq.0) then ! no phase with positive amount, set the noel()-meqrec%nfixmu-1 phases stable ! starting with those with highest number of constituents if(mostcon.eq.0) then ! write(*,*)'MM no phase to set stable' gx%bmperr=4200; goto 1000 endif ! write(*,55)'Initial phases set stable: ',mostcon,& ! (mostconph(1,icc),mostconph(2,icc),icc=1,mostcon) !55 format(a,i3,10(2i3,2x)) meqrec%nv=mostcon ! write(*,56)(mostconph(1,icc),icc=1,mostcon) !56 format('Setting start phases: ',20(i3)) do icc=1,mostcon call get_phase_compset(mostconph(2,icc),1,lokph,lokcs) ! ceq%phase_varres(lokcs)%amfu=one/mostcon ceq%phase_varres(lokcs)%amfu=one ceq%phase_varres(lokcs)%phstate=PHENTSTAB meqrec%iphl(icc)=mostconph(2,icc) meqrec%icsl(icc)=1 meqrec%aphl(icc)=one ! this sets a default constitution call set_default_constitution(mostconph(2,icc),1,ceq) enddo else ! hopefully set_constitution has been called ... ! normallize the sum of phase amounts assuming N=1 ... this did not help ... ! if(sumnp.gt.one) then ! sumnp=one/sumnp ! do icc=1,meqrec%nv ! meqrec%aphl(icc)=meqrec%aphl(icc)*sumnp ! enddo ! endif ! write(*,57)(meqrec%iphl(icc),meqrec%icsl(icc),meqrec%aphl(icc),& ! icc=1,meqrec%nv) !57 format('Start phase set: ',10(i3,i2,F6.2)) if(ocv()) write(*,*)'No global minimization, using current phase set',& meqrec%nv endif ! copy ceq%complist%chempot(1) to ceq%cmuval do mjj=1,meqrec%nrel if(abs(ceq%complist(mjj)%chempot(1)).ge.one) then ceq%cmuval(mjj)=ceq%complist(mjj)%chempot(1)/ceq%rtn else ceq%cmuval(mjj)=zero endif enddo if(ocv()) write(*,68)'MM cmuval: ',meqrec%nrel,& (ceq%cmuval(mjj),mjj=1,meqrec%nrel) 68 format(a,i3,6(1pe12.4)) ! ! we must make sure the fix phases are in the initial list of stable phases ! the order does not matter, the phases will be sorted later addfixph: do mjj=1,meqrec%nfixph jph=1 do while (jph.le.meqrec%nv) if(meqrec%iphl(jph).eq.meqrec%fixph(1,mjj) .and. & meqrec%icsl(jph).eq.meqrec%fixph(2,mjj)) then ! found fix phase as already stable, just store the amount meqrec%aphl(jph)=meqrec%fixpham(mjj) cycle addfixph endif jph=jph+1 enddo ! add this phase as stable, check that not too many stable phases ... ! meqrec%nv is the current number of stable phases if(meqrec%nv.eq.meqrec%maxsph) then write(*,69)'MM Too many stable phases',meqrec%nv,meqrec%maxsph 69 format(a,2i5) gx%bmperr=4193; goto 1000 endif ! write(*,*)'Adding fix phase to stable phase set',& ! meqrec%fixph(1,mjj),meqrec%fixph(2,mjj) meqrec%nv=meqrec%nv+1 meqrec%iphl(meqrec%nv)=meqrec%fixph(1,mjj) meqrec%icsl(meqrec%nv)=meqrec%fixph(2,mjj) meqrec%aphl(meqrec%nv)=meqrec%fixpham(mjj) enddo addfixph !------------------------------- special for mapping and STEP mapfixdata: if(allocated(mapfix)) then ! for step only the status word is used to indicate an invarant node ! if(mapfix%nfixph.eq.0) then ! if(btest(mapfix,STEPINVARIANT)) then ! exit mapfixdata ! endif ! endif ! the stable and fix phases copied from mapfix record. do ij=1,meqrec%nv meqrec%iphl(ij)=0 meqrec%icsl(ij)=0 enddo meqrec%nfixph=mapfix%nfixph meqrec%nv=0 do ij=1,meqrec%nfixph meqrec%fixph(1,ij)=mapfix%fixph(ij)%ixphase meqrec%fixph(2,ij)=mapfix%fixph(ij)%compset meqrec%fixpham(ij)=zero if(allocated(mapfix%fixphamap)) then ! attempt 180814 to let fix phases have nonzero amount to improve mapping meqrec%fixpham(ij)=mapfix%fixphamap(ij) write(*,65)'MM fix mapphase: ',mapfix%fixph(ij)%ixphase,& mapfix%fixph(ij)%compset,mapfix%fixphamap(ij) 65 format(a,2i5,1pe12.4) ! else ! write(*,65)'MM mapfix phase: ',mapfix%fixph(ij)%ixphase,& ! mapfix%fixph(ij)%compset endif meqrec%nv=meqrec%nv+1 meqrec%iphl(meqrec%nv)=mapfix%fixph(ij)%ixphase meqrec%icsl(meqrec%nv)=mapfix%fixph(ij)%compset ! 180814 not sufficient to set aphl ! because around line 1010 amfu is set to zero fix mapfix ... removed that!! ! meqrec%aphl(meqrec%nv)=mapfix%fixpham(ij) ! I am not sure what value for mph here ! meqrec%phr(mph)%curd%amfu=zero enddo do ij=1,mapfix%nstabph meqrec%nv=meqrec%nv+1 meqrec%iphl(meqrec%nv)=mapfix%stableph(ij)%ixphase meqrec%icsl(meqrec%nv)=mapfix%stableph(ij)%compset meqrec%aphl(meqrec%nv)=mapfix%stablepham(ij) enddo ! write(*,64)'MM Stable mapphase: ',mapfix%nstabph,& ! mapfix%stableph(1)%ixphase,mapfix%stableph(1)%compset,& ! mapfix%stablepham(1) 64 format(a,i3,2i5,1pe12.4) ! elseif(formap) then ! mapfixrecord not allocated for STEP calculations ! this dis not work for handling invariant nodes for STEP ! write(*,*)'MM calceq7 formap MMSTEPINV:',btest(meqrec%status,MMSTEPINV) ! if(btest(meqrec%status,MMSTEPINV)) then ! The line start at an invariant node for a STEP calculation, ! write(*,*)'MM invariant node with phases: ',meqrec%nstph ! do jj=1,meqrec%nstph ! jq=meqrec%stphl(jj) ! write(*,*)'MM stable: ',jj,jq,meqrec%phr(jq)%curd%amfu ! enddo ! endif endif mapfixdata !------------------------------- ! zero start of link to phases set temporarily dormant .... meqrec%dormlink=0 ! !------------------------------- ! Now we (try to) calculate the equilibrium 200 continue ! allocate phaseremoved to avoid same phase stable again and again ! write(*,*)'MM start interative minimizer',ceq%eqno if(allocated(ceq%phaseremoved)) deallocate(ceq%phaseremoved) ntup=nooftup() allocate(ceq%phaseremoved(2,ntup),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 6: ',errall gx%bmperr=4370; goto 1000 endif ceq%phaseremoved=0 ! ! this routine varies the set of phases and the phase constitutions ! until the stable set is found for the given set of conditions. if(ocv()) write(*,*)'MM calling meq_phaseset' call meq_phaseset(meqrec,formap,mapfix,ceq) if(gx%bmperr.ne.0) goto 1000 ! gridtest=.false. !------------------------------------------------------ ! ! When we come here the equilibrium is calculated or calculation failed ! if failed or called from step/map (formap TRUE) just exit if(gx%bmperr.ne.0 .or. formap) goto 1000 ! write(*,*)'End of calceq7 ',gridtest if(gridtest) then ! gridtest value is set to .TRUE. if no gridmin done initially meqrec%status=ibset(meqrec%status,MMNOSTARTVAL) endif !-------------------------------------------------- 1000 continue ! extract configurational entropy for mqmqa ! write(*,'("MM mqmqa entropy: ",1pe14.4)')sconfmqmqa ! write(*,*)'MM back from meq_phaseset' if(gx%bmperr.ne.0) then ! test if total number of models > 10; that can create converge problems saverr=gx%bmperr; gx%bmperr=0 ! This routine returns total G, S, V, N and B call sumprops(props,ceq) if(gx%bmperr.ne.0) then write(*,*)'Convergence error, check your conditions are reasonable' elseif(props(4).gt.1.0D1 .and. & .not.(saverr.eq.4210 .or. saverr.eq.4364)) then write(*,'(a,a,i5,1pe12.4)')'Convergence error, maybe reduce ',& 'the size of your system!',saverr,props(4) endif gx%bmperr=saverr endif ! This error means T or P is less than 0.1 if(gx%bmperr.eq.4187) write(*,*)'Exit calceq7 with error ',gx%bmperr return end subroutine calceq7 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine meq_phaseset !\begin{verbatim} subroutine meq_phaseset(meqrec,formap,mapfix,ceq) ! this subroutine can change the set of stable phase and their amounts ! and constitutions until equilibrium is found for the current conditions. implicit none TYPE(meq_setup) :: meqrec type(map_fixph), allocatable :: mapfix TYPE(gtp_equilibrium_data), pointer :: ceq logical formap !\end{verbatim} ! should one use meqrec as pointer here??? integer ok,iadd,iph,ics,irem,jj,jph,kk,lastchange,lokph,lokcs,minadd integer kph,mph,nip,zap,toomanystable,jrem,krem,inmap double precision, parameter :: addedphase_amount=1.0D-2 double precision xxx,tpvalsave(2) integer iremsave,zz,tupadd,tuprem,samephase,phloopaddrem1,phloopaddrem2 ! mapx is special for using meq_sameset for mapping integer phloopv,findtupix,saverr,mapx,errall character phnames*50,phname2*24 ! prevent loop that a phase is added/removed more than 10 times integer, allocatable, dimension(:,:) :: addremloop ! replace always FALSE except when we must replace a phase as we have max stable logical replace,force ! number of iterations without adding or removing a phase replace=.FALSE. samephase=0 lastchange=0 ! if(ocv()) write(*,*)'entering meq_phaseset: ' ! write(*,*)'MM entering meq_phaseset: ' meqrec%dormlink=0 ! nphase is set to total number of phases (phase+compset) to be calculated ! >>> parallellization ALERT, nphase may change when composition sets created ! call sumofphcs(meqrec%nphase,ceq) ! meqrec%nphase=totalphcs(ceq) meqrec%nphase=nonsusphcs(ceq) if(gx%bmperr.ne.0) goto 1000 ! Nathalie had an error here "already allocated" if(allocated(meqrec%phr)) deallocate(meqrec%phr) allocate(meqrec%phr(meqrec%nphase),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 7: ',errall gx%bmperr=4370; goto 1000 endif ! order the inital set of stable phases in ascending order ! VERY CLUMSY SORTING 15 continue ok=0 ! write(*,16)meqrec%nv,meqrec%nphase,size(meqrec%iphl) !16 format('sort: ',10i3) do iph=2,meqrec%nv if(meqrec%iphl(iph-1).gt.meqrec%iphl(iph)) then ok=1 kk=meqrec%iphl(iph-1) meqrec%iphl(iph-1)=meqrec%iphl(iph) meqrec%iphl(iph)=kk kk=meqrec%icsl(iph-1) meqrec%icsl(iph-1)=meqrec%icsl(iph) meqrec%icsl(iph)=kk xxx=meqrec%aphl(iph-1) meqrec%aphl(iph-1)=meqrec%aphl(iph) meqrec%aphl(iph)=xxx endif enddo if(ok.ne.0) goto 15 17 continue ok=0 do iph=2,meqrec%nv if(meqrec%iphl(iph-1).eq.meqrec%iphl(iph)) then if(meqrec%icsl(iph-1).gt.meqrec%icsl(iph)) then kk=meqrec%icsl(iph-1) meqrec%icsl(iph-1)=meqrec%icsl(iph) meqrec%icsl(iph)=kk xxx=meqrec%aphl(iph-1) meqrec%aphl(iph-1)=meqrec%aphl(iph) meqrec%aphl(iph)=xxx ok=1 endif endif enddo if(ok.ne.0) goto 17 !----------------------------- mph=0 nip=1 ! krem=0 meqrec%nstph=0 allphases: do iph=1,noph() allcompsets: do ics=1,noofcs(iph) ! ignore hidden and suspended phases (also ignored above in sumofphcs) ! entered, fixed and dormat has values 1, 2 and 3, suspended 4, hidden 5 zap=test_phase_status(iph,ics,xxx,ceq) ! new: -4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fixed phstatus: if(zap.ge.PHDORM) then mph=mph+1 ! this iph is the index in the phlista record meqrec%phr(mph)%iph=iph meqrec%phr(mph)%ics=ics ! compare with these the first time a phase wants to be added or removed ! if zero it means phase can be added/removed at iteration default_minadd/default_minrem meqrec%phr(mph)%itadd=0 meqrec%phr(mph)%itrem=0 ! initiate indicator for phases with fix composition, set to 1 later if so meqrec%phr(mph)%xdone=0 ! save phasestatus, zap>-2 here so set all -1,0,1 set to 0 if(abs(zap).le.1) zap=0 meqrec%phr(mph)%phasestatus=zap ! set link to calculated values of G etc. call get_phase_compset(iph,ics,lokph,lokcs) meqrec%phr(mph)%curd=>ceq%phase_varres(lokcs) ! save phase tuple index findtupix=meqrec%phr(mph)%curd%phtupx meqrec%phr(mph)%phtupix=findtupix ! set %volatile=0 to indicate start of equilibrium calculation ! used for the cvmsro model (maybe not needed) in ges5X.F90 ceq%phase_varres(lokcs)%volatile=0 ! write(*,'(a,4i6,5x,3i6)')'MM save tuple index: ',mph,iph,ics,& ! findtupix,phasetuple(findtupix)%ixphase,& ! phasetuple(findtupix)%compset,phasetuple(findtupix)%lokph ! set number of constituents, DO NOT USE size(...curd%size(yfr)!!! meqrec%phr(mph)%ncc=noconst(iph,ics,ceq) whenmap: if(formap) then ! when mapping fix phases are used to replace axis conditions. The ! fix phases are in the meqrec%fixph array ! They do not return PHFIXED for test_phase_status !!! do zz=1,meqrec%nfixph if(iph.eq.meqrec%fixph(1,zz) .and. & ics.eq.meqrec%fixph(2,zz)) then meqrec%phr(mph)%phasestatus=PHFIXED if(allocated(mapfix)) then if(allocated(mapfix%fixphamap)) then meqrec%phr(mph)%curd%amfu=mapfix%fixphamap(1) write(*,*)'MM set fixamount: ',& mapfix%fixphamap(1) endif endif endif enddo ! inmap=1 turns off converge control of T inmap=1 else ! inmap=0 means not called from step/map routines inmap=0 endif whenmap meqrec%phr(mph)%ionliq=-1 meqrec%phr(mph)%i2sly=0 if(test_phase_status_bit(iph,PHIONLIQ)) meqrec%phr(mph)%ionliq=1 ! already done: set link to calculated values of G etc. ! call get_phase_compset(iph,ics,lokph,lokcs) ! meqrec%phr(mph)%curd=>ceq%phase_varres(lokcs) ! causing trouble at line 3175 ??? compset: if(nip.le.meqrec%nv) then if(iph.eq.meqrec%iphl(nip) .and. ics.eq.meqrec%icsl(nip)) then ! this phase is part of the initial stable set, increment nstph meqrec%nstph=meqrec%nstph+1 meqrec%stphl(meqrec%nstph)=mph meqrec%phr(mph)%stable=1 if(meqrec%phr(mph)%phasestatus.eq.PHFIXED) then ! Rather confused here ... ! fixed phases as conditions have an amount in meqrec%fixpham ! fixed phases during mapping should have zero amount (maybe not ...) ! krem=krem+1 ! write(*,*)'MM aphl for fix phase: ',krem,mph,& ! meqrec%fixpham(krem) if(meqrec%phr(mph)%curd%phstate.ne.PHFIXED) then ! this is a phase set fix by mapping, set amount to zero unless mapfix%fixpham ! but mapfix is not available in this routine .. if(allocated(mapfix%fixphamap)) then ! 180814 tried to remove setting fix phase amount to zero write(*,*)'MM nonzero mapfix amount !' meqrec%phr(mph)%curd%amfu=mapfix%fixphamap(1) else meqrec%phr(mph)%curd%amfu=zero endif endif else ! this is setting non-zero fixed amount of a phase as condition ! Trying to handle this in mapping ... but here it not the fix phase ... if(allocated(mapfix)) then if(allocated(mapfix%fixphamap)) & write(*,*)'MM phase amount: ',& meqrec%phr(mph)%iph,meqrec%aphl(meqrec%nstph) endif meqrec%phr(mph)%curd%amfu=meqrec%aphl(meqrec%nstph) endif ! set "previous values" meqrec%phr(mph)%prevam=meqrec%aphl(meqrec%nstph) meqrec%phr(mph)%prevdg=zero nip=nip+1 else ! unstable phase meqrec%phr(mph)%stable=0 meqrec%phr(mph)%prevam=zero meqrec%phr(mph)%prevdg=-one meqrec%phr(mph)%curd%amfu=zero endif else ! unstable phase ! write(*,312)'MM nip: ',nip,meqrec%nv !312 format(a,5i4) meqrec%phr(mph)%stable=0 meqrec%phr(mph)%prevam=zero meqrec%phr(mph)%prevdg=-one meqrec%phr(mph)%curd%amfu=zero endif compset ! mark that no data arrays allocated for this phase meqrec%phr(mph)%idim=0 ! initiate link to another phase temporarily set dormant zero meqrec%phr(mph)%dormlink=0 else ! we are here for phases that are suspended, test_phase_status return -3 ! make sure stable bit is cleared in phases not included in calculation ! maybe the whole status word should be zeroed? call get_phase_compset(iph,ics,lokph,lokcs) ceq%phase_varres(lokcs)%status2=& ibclr(ceq%phase_varres(lokcs)%status2,CSABLE) ! check if suspended phase bits CSSUS set !z if(btest(ceq%phase_varres(lokcs)%status2,CSSUS)) then ! write(*,*)'MM Suspended bit set',lokph,lokcs ! else ! This should not be necessary but it fixes the problem using c n with ! suspended phases. The CSSUS bit should no longer be used??? ! write(*,*)'MM warning, suspended bit NOT set',lokph,lokcs !z ceq%phase_varres(lokcs)%status2=& !z ibset(ceq%phase_varres(lokcs)%status2,CSSUS) !z endif endif phstatus enddo allcompsets enddo allphases ! problem phases suspended are restored!! ! write(*,*)'MM at start, nonsuspenden phases: ',mph meqrec%noofits=0 toomanystable=0 jrem=0 krem=0 iremsave=0 phloopaddrem1=0 ! code above executed only intially ! write(*,*)'MM allocating addremloop',meqrec%nphase allocate(addremloop(meqrec%nphase,3),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 8: ',errall gx%bmperr=4370; goto 1000 endif addremloop=0 !---------------------------------------------------------------- ! ! meq_sameset calculate the equilibrium for a given set of stable phases ! if the phase set change we return to this routine to take some action and ! then call meq_sameset again ! irem nonzero if phase irem should be removed ! iadd nonzero if phase iadd should be added ! meqrec has the general information needed ! meqrec%phr is the array with phases ! ceq is the connection to the model package data 200 continue ! iadd=-1 ! iadd =-1 turns on verbose in meq_sameset iadd=0 irem=iremsave ! for debuging convergence ! call list_stable_phases('MM call:',meqrec%noofits,iadd,irem,meqrec,ceq) ! write(*,*)'MM calling meq_sameset ',meqrec%noofits ! write(*,*)'MM calling list conditions' ! call list_conditions(kou,ceq) ! meq_sameset varies amounts of stable phases and constitutions of all phases ! If there is a phase change (iadd or irem nonzeri) or error it exits ! mapx is needed when using meq_sameset for mapping, irrelevant here mapx=0 call meq_sameset(irem,iadd,mapx,meqrec,meqrec%phr,inmap,ceq) if(ocv()) write(*,*)'MM back from sameset ',irem,iadd,meqrec%noofits if(gx%bmperr.ne.0) then if(gx%bmperr.eq.4364) then ! write(*,*)'MM Two phases with same stoichiometry stable, to be fixed' endif goto 1000 endif ! force=.false. ! call list_stable_phases('MM back:',meqrec%noofits,iadd,irem,meqrec,ceq) ! write(*,*)'MM line 1114:',irem,iadd if(irem.gt.0 .or. iadd.gt.0) then if(iremsave.gt.0 .and. iadd.eq.iremsave) then ! if iadd=iremsave>0 there was a equil matrix error when removing iremsave irem=0 force=.true. !CCI elseif(meqrec%noofits-lastchange.lt.default_nochange) then !CCI ! write(*,221)' *** Phase set change not allowed: ',& ! meqrec%noofits,lastchange,default_nochange,irem,iadd !221 format(a,10i4) goto 200 endif ! keep record of adding and removing phases if(iadd.gt.0) then addremloop(iadd,1)=meqrec%noofits if(irem.eq.0) then addremloop(iadd,2)=addremloop(iadd,2)+1 ! write(*,'(a,4i5)')'MM adding: ',addremloop(iadd,1),iadd,& ! addremloop(iadd,2),addremloop(iadd,3) endif if(addremloop(iadd,2).gt.5) then if(.not.btest(meqrec%status,MMQUIET)) & write(*,'(a,2i4,"#",i1)')'MM Removing phase: ',iadd,& meqrec%phr(iadd)%iph,meqrec%phr(iadd)%ics meqrec%phr(iadd)%phasestatus=PHDORM meqrec%phr(iadd)%curd%phstate=PHDORM meqrec%phr(iadd)%dormlink=meqrec%dormlink meqrec%dormlink=iadd ! iremsave keeps track of last removed phase, if equal to iadd set it to 0 if(iremsave.eq.iadd) iremsave=0 iadd=0 goto 200 endif else addremloop(irem,3)=addremloop(irem,3)+1 ! write(*,'(a,3i5)')'MM removing: ',addremloop(irem,1),irem,& ! addremloop(iadd,2),addremloop(iadd,3) ! if(addremloop(irem,3).gt.5) then ! write(*,'(a,3i5)')'MM Suspend ',addremloop(irem,1),irem,& ! meqrec%dormlink ! meqrec%phr(irem)%phasestatus=PHDORM ! meqrec%phr(irem)%curd%phstate=PHDORM ! meqrec%phr(irem)%dormlink=meqrec%dormlink ! meqrec%dormlink=irem ! irem=0 ! goto 200 ! endif endif ! What is iadd here? Not phasetuple index!! if(iadd.gt.0) then ! check if phase to be added is already stable as another composition set ! This check should maybe be above as maybe another phase want to be stable?? ! The last argument is not used if(same_composition(iadd,meqrec%phr,meqrec,ceq,zero)) then ! write(*,*)'MM ignoring the same phase twice: ',iadd goto 200 endif ! do not add phases with net charge !CCI if(meqrec%phr(iadd)%curd%netcharge.gt.default_addchargedphase) then !CCI if(iadd.ne.samephase) then ! call get_phasetup_name(iadd,phname2) call get_phasetup_name(meqrec%phr(iadd)%curd%phtupx,phname2) write(*,'(a,a,2i4,a,1pe12.4)')'MM ignoring phase: ',& trim(phname2),iadd,meqrec%phr(iadd)%curd%phtupx,& ' with charge:',meqrec%phr(iadd)%curd%netcharge ! meqrec%phr(iadd)%curd%phtupx,meqrec%phr(iadd)%curd%netcharge 218 format(a,2i5,1pe14.6) ! change 2021.08.19 when a phase with no ions has net charge .... why ! samephase=iadd iadd=0 endif goto 200 elseif(phloopaddrem1.gt.4) then ! reset this phase to a default constitution if(.not.btest(meqrec%status,MMQUIET)) & write(*,*)'MM phloopaddrem: ',phloopaddrem2 iadd=phloopaddrem2 phloopv=phasetuple(iadd)%lokph ! if(ceq%phlista(phloopv)%tnooffr-ceq%phlista(phloopv)%noofsubl & ! .gt. 0) then ! reset troublesome phase constitution if it can vary call set_default_constitution(phasetuple(iadd)%ixphase,& phasetuple(iadd)%compset,ceq) ! else ! set phase dormant ... Hm I do not understand meqrec%phr any longer ... ! phloopv=phasetuple(iadd)%lokvares ! ceq%phase_varres(phloopv)%phstate=PHDORM ! endif iadd=0 phloopaddrem1=0 phloopaddrem2=0 goto 200 ! elseif(meqrec%phr(iadd)%curd%netcharge.gt.1.0D-8) then ! write(*,231)'MM adding phase with net charge: ',iadd,& ! meqrec%phr(iadd)%curd%phtupx,meqrec%phr(iadd)%curd%netcharge !231 format(a,2i5,1pe14.6) endif endif tupadd=0 tuprem=0 xxx=0.0D0 ! if(iadd.gt.0) tupadd=meqrec%phr(iadd)%curd%phtupx ! if(irem.gt.0) tuprem=meqrec%phr(irem)%curd%phtupx if(iadd.gt.0) tupadd=meqrec%phr(iadd)%phtupix if(irem.gt.0) tuprem=meqrec%phr(irem)%phtupix if(.not.btest(meqrec%status,MMQUIET)) then if(iadd.gt.0) then phnames='+' call get_phasetup_name(tupadd,phnames(2:)) if(irem.gt.0) then kk=len_trim(phnames)+3 phnames(kk-1:kk-1)='-' call get_phasetup_name(tuprem,phnames(kk:)) endif else phnames='-' call get_phasetup_name(tuprem,phnames(2:)) endif addph: if(formap) then ! if(btest(meqrec%status,MMSTEPINV)) then ! This did not work to handle invariants during STEP ! we are exiting an invariant node for a STEP calculation, allow phase change ! meq_sameset wants to ADD a phase, instead remove the last stable phase ! write(*,*)'MM meq_phaseset invariant node',meqrec%noofits,iadd ! do jj=1,meqrec%nstph ! irem=meqrec%stphl(jj) ! if(iadd.eq.0 .and. & ! meqrec%phr(irem)%curd%amfu.eq.zero) then ! meqrec%phr(irem)%curd%amfu=1.0D-1 ! endif ! write(*,*)'MM stable: ',jj,irem,meqrec%phr(irem)%curd%amfu ! enddo ! if(iadd.gt.0 .and. meqrec%nstph.gt.1) then ! meqrec%nstph=meqrec%nstph-1 ! meqrec%phr(irem)%curd%amfu=zero ! write(*,*)'MM ignore adding ',iadd,' but remove ',irem ! iadd=0 ! goto 200 ! endif ! exit addph ! endif ! This can be too strong, we can have a tie-line betwen two stoichiometric ! phases, i.e. a new phase appears at first attempt to step in two-phase region. ! UNFINISHED handling of many exceptions during mapping write(*,'(a,a)')'MM Phase change not allowed: ',trim(phnames) gx%bmperr=4210; goto 1000 #ifdef silent #else elseif(ceq%eqno.ne.1) then ! write(*,219)meqrec%noofits,iadd,irem,' at equil: ',ceq%eqno !219 format('Phase change: its/add/remove: ',3i5,a,i5) if(.not.btest(meqrec%status,MMQUIET)) & write(*,219)ceq%eqno,meqrec%noofits,trim(phnames) 219 format('Phase change (equil: ',i3,') iteration: ',i5,', phase: ',a) #endif else if(iadd.gt.0) then phnames='+' call get_phasetup_name(tupadd,phnames(2:)) if(irem.gt.0) then kk=len_trim(phnames)+3 phnames(kk-1:kk-1)='-' call get_phasetup_name(tuprem,phnames(kk:)) endif else phnames='-' call get_phasetup_name(tuprem,phnames(2:)) endif #ifdef silent #else if(.not.btest(meqrec%status,MMQUIET)) & write(*,281)meqrec%noofits,trim(phnames) 281 format('Phase change iteration: ',i5,2x,a) #endif endif addph endif endif 222 continue remove: if(irem.gt.0) then ! remove a phase --------------------------- if(ocv()) write(*,223)'Phase to be removed: ',meqrec%phr(irem)%iph,& meqrec%phr(irem)%ics,meqrec%phr(irem)%curd%amfu,meqrec%noofits if(meqrec%nstph.eq.1) then if(.not.REPLACE) then ! we must be able to REPLACE the only stable phase for a unary system write(*,*)'Attempt to remove the only stable phase!!!' goto 200 endif ! write(*,*)'MM replacing one stable phase with another',irem,iadd else ! make sure replace is false unless explitly set below replace=.FALSE. endif !CCI if(meqrec%noofits-meqrec%phr(irem)%itadd.lt.default_minrem) then !CCI ! if phase was just added do not remove before default_minrem iterations if(ocv()) write(*,*)'Too soon to remove phase',& meqrec%phr(irem)%curd%phtupx,meqrec%noofits,& meqrec%phr(irem)%itadd if(phloopaddrem1.gt.0) then if(phloopaddrem2.eq.meqrec%phr(irem)%curd%phtupx) then phloopaddrem1=phloopaddrem1+1 else phloopaddrem2=0 phloopaddrem1=0 endif else phloopaddrem2=meqrec%phr(irem)%curd%phtupx phloopaddrem1=1 endif goto 200 endif ! shift phases after irem down in meqrec%stphl ! irem is index to meqrec%phr(), meqrec%stphl(jph) is index to meqrec%phr meqrec%nstph=meqrec%nstph-1 do iph=1,meqrec%nstph jj=meqrec%stphl(iph) if(jj.ge.irem) then meqrec%stphl(iph)=meqrec%stphl(iph+1) endif enddo ! we must zero the last phase !! meqrec%stphl(meqrec%nstph+1)=0 ! meqrec%phr(irem)%itrem=meqrec%noofits meqrec%phr(irem)%prevam=zero meqrec%phr(irem)%stable=0 meqrec%phr(irem)%curd%amfu=zero ! save irem as it is used to restore a phase if massbalance problem iremsave=irem irem=0 lastchange=meqrec%noofits ! one can remove and add a phase at the same time !!! if(iadd.eq.0) then toomanystable=0 jrem=0 goto 200 endif endif remove !------------------------------------------- add: if(iadd.gt.0) then ! add a phase. This can be tricky ! NOTE it must be added so meqrec%stphl in ascending order if(ocv()) write(*,223)'Phase to be added: ',meqrec%phr(iadd)%iph,& meqrec%phr(iadd)%ics,meqrec%phr(iadd)%curd%dgm,meqrec%noofits 223 format(a,2x,2i4,1pe15.4,i7) !CCI if(meqrec%noofits-meqrec%phr(iadd)%itrem.lt.default_minadd .and. .not.force) then !CCI ! if phase was just removed, do not add it before default_minadd iterations ! if(.not.btest(meqrec%status,MMQUIET))write(*,224) if(ocv()) write(*,224)meqrec%phr(iadd)%curd%phtupx,& meqrec%noofits,meqrec%phr(iadd)%itrem,phloopaddrem1,& phloopaddrem2,default_minadd 224 format('Too soon to add phase: ',i3,2x,i4,2x,5i5) if(phloopaddrem1.gt.0) then if(phloopaddrem2.eq.meqrec%phr(iadd)%curd%phtupx) then phloopaddrem1=phloopaddrem1+1 else phloopaddrem2=0 phloopaddrem1=0 endif else phloopaddrem2=meqrec%phr(iadd)%curd%phtupx phloopaddrem1=1 endif goto 200 endif ! if(iadd.eq.abs(iremsave)) then ! write(*,*)'Phase just removed, do not add: ',iadd ! iremsave=0 ! goto 200 ! endif ! make sure iremsave is zero iremsave=0 if(meqrec%nstph.eq.meqrec%maxsph) then ! No more phases allowed, we must see if some other phase may be removed if(toomanystable.ge.3) then ! write(*,*)'Attempt to set too many phases stable',meqrec%maxsph ! gx%bmperr=4201; goto 1000 ! During mapping do not replace phases ... if(formap) then gx%bmperr=4201; goto 1000 endif ! UNFINISHED code below if(jrem.eq.0) then ! try to remove a stable phase ... which? Replace the one that does not ! disturb the order of phases in meqrec%stphl by adding iadd do iph=1,meqrec%nstph if(iadd.gt.meqrec%stphl(iph)) cycle jrem=meqrec%stphl(iph); exit enddo ! if jrem zero here replace the last if(jrem.eq.0) jrem=meqrec%stphl(meqrec%nstph) krem=jrem irem=jrem if(.not.btest(meqrec%status,MMQUIET)) & write(*,241)meqrec%noofits,irem,iadd,ceq%tpval(1) 241 format('MM Too many stable phases at iter ',i3,', phase ',i3,& ' replaced by ',i3,', T= ',F8.2) ! write(*,240)meqrec%noofits,irem,iadd,ceq%tpval(1),& ! (meqrec%stphl(iph),iph=1,meqrec%nstph) !240 format('Too many stable phases at iter ',i3,', phase ',i3,& ! ' replaced by ',i3,', T= ',F8.2/3x,15(i3)) replace=.TRUE. goto 222 else write(*,*)'MM setting too many phases stable',meqrec%maxsph gx%bmperr=4201; goto 1000 endif else ! try ignore adding 3 times ! write(*,*)'Ignoring attempt to set too many phases stable',& ! meqrec%maxsph,toomanystable toomanystable=toomanystable+1 goto 200 endif endif ! the phase must be added in sequential order of phase and composition set no findplace: do jph=1,meqrec%nstph jj=meqrec%stphl(jph) if(meqrec%phr(iadd)%iph.gt.meqrec%phr(jj)%iph) then cycle endif if(meqrec%phr(iadd)%iph.lt.meqrec%phr(jj)%iph) then exit endif ! if same phase number compare composition set numbers if(meqrec%phr(iadd)%iph.eq.meqrec%phr(jj)%iph) then if(meqrec%phr(iadd)%ics.gt.meqrec%phr(jj)%ics) then cycle else exit endif endif enddo findplace ! one should come here at exit, iadd should be inserted before ! meqrec%stphl(jph), jph can be nstph+1 if added phase should be the last ! otherwise shift previous phases one step up. do kph=meqrec%nstph,jph,-1 meqrec%stphl(kph+1)=meqrec%stphl(kph) enddo ! write(*,*)'Phase added: ',jph,meqrec%nstph,meqrec%maxsph ! phase added at jph, (note jph may be equal to nstph+1) meqrec%stphl(jph)=iadd meqrec%nstph=meqrec%nstph+1 meqrec%phr(iadd)%itadd=meqrec%noofits meqrec%phr(iadd)%curd%dgm=zero lastchange=meqrec%noofits ! maybe some more variables should be set? meqrec%phr(iadd)%curd%amfu=addedphase_amount meqrec%phr(iadd)%stable=1 iadd=0 toomanystable=0 jrem=0 goto 200 endif add !--------------------------------------------------- ! found stable phase set or error 1000 continue if(gx%bmperr.eq.0) then ! equilibrium calculation converged, one should add check on stability ! ! >> add calculate eigenvalues of phase matrix to check stability, ! >> a negative eigenvalue means inside spinodal ! >> Note charge problems for metastable phases, phase must be neutral ... ! !------------------------------------------------------------ ! clear bits: no equilibrium calculated/ inconsistent conditions and result/ ! equilibrium calculation failed/ only gridcal ceq%status=ibclr(ceq%status,EQNOEQCAL) ceq%status=ibclr(ceq%status,EQINCON) ceq%status=ibclr(ceq%status,EQFAIL) ceq%status=ibclr(ceq%status,EQGRIDCAL) ! set stable bit in stable phases and clear it in all others kk=1 do jj=1,mph if(jj.eq.meqrec%stphl(kk)) then meqrec%phr(jj)%curd%status2=& ibset(meqrec%phr(jj)%curd%status2,CSABLE) ! the stable phase list should be ordered in increasing phase number kk=min(kk+1,meqrec%nstph) ! write(*,*)'mm max kk: ',kk,meqrec%nstph else meqrec%phr(jj)%curd%status2=& ibclr(meqrec%phr(jj)%curd%status2,CSABLE) endif enddo !----------------------- ! loop through all phases and if their status is entered set it as PHENTUNST ! unless stablestable phases and set the PHENTST for phases in stable set ! That is important for extracting values later ... do jph=1,meqrec%nphase if(meqrec%phr(jph)%curd%phstate.ge.PHENTUNST .and. & meqrec%phr(jph)%curd%phstate.le.PHENTSTAB) then meqrec%phr(jph)%curd%phstate=PHENTUNST endif enddo do jph=1,meqrec%nstph jj=meqrec%stphl(jph) if(meqrec%phr(jj)%curd%phstate.lt.PHFIXED) then meqrec%phr(jj)%curd%phstate=PHENTSTAB endif enddo !----------------------------------------- else ! write(*,*)'MM cleaning up due to error' ! set some failure bits ceq%status=ibset(ceq%status,EQINCON) ceq%status=ibset(ceq%status,EQFAIL) ceq%status=ibclr(ceq%status,EQGRIDCAL) ! even when not converged save the current chemical potentials do jj=1,meqrec%nrel ceq%complist(jj)%chempot(1)=ceq%cmuval(jj)*ceq%rtn enddo endif ! restore phases set dormant jph=0 if(gx%bmperr.ne.0) then ! save any error already set and clear error code saverr=gx%bmperr; gx%bmperr=0 else saverr=0 endif jj=meqrec%dormlink 1200 continue if(jj.ne.0) then ! if(.not.btest(meqrec%status,MMQUIET)) & ! write(*,*)'Restore from dormant: ',jj,meqrec%phr(jj)%iph,& ! meqrec%phr(jj)%ics kk=meqrec%phr(jj)%phtupix phnames=' ' call get_phasetup_name(kk,phnames) if(gx%bmperr.ne.0) then write(*,*)'MM cannot find phasetup name: ',jj,kk,gx%bmperr gx%bmperr=0 endif if(.not.btest(meqrec%status,MMQUIET)) then if(meqrec%phr(jj)%curd%dgm.gt.zero) then write(*,1220)jj,kk,trim(phnames),meqrec%phr(jj)%curd%dgm 1220 format('MM Restoring phase: ',2i5,2x,a,5x,1pe12.4) else write(*,1220)jj,kk,trim(phnames) endif endif if(meqrec%phr(jj)%curd%dgm.gt.1.0D-2) jph=jj ! do I have two places for suspendeded ?? YES!! meqrec%phr(jj)%phasestatus=PHENTUNST ! below is in the phase_varres record, previous is temporary equilibrium data meqrec%phr(jj)%curd%phstate=PHENTUNST jj=meqrec%phr(jj)%dormlink goto 1200 endif if(jph.gt.0) then if(.not.btest(meqrec%status,MMQUIET)) & write(*,*)'MM warning, a restored phase wants to be stable:',jph gx%bmperr=4363 endif ! we may already have had an error ... if(saverr.ne.0) gx%bmperr=saverr ! try to find problem with listed chemical potential ! chempot(2) should be value with user defined reference state, if(gx%bmperr.eq.0) then do jj=1,meqrec%nrel xxx=zero lokph=ceq%complist(jj)%phlink if(lokph.gt.0) then ! we must also handle reference state at fix T !! ! lokph is index of phase in phlista, calcg_endmember want index in phases .... ! write(*,*)'Component has defined reference state: ',jj,lokph tpvalsave=ceq%tpval ! modified calcg_endmember to convert negative phase index to phase number ... ! write(*,*)'MM calling calcg_endmember 1: ',-lokph ! MUS same as TC MU call calcg_endmember(-lokph,ceq%complist(jj)%endmember,xxx,ceq) if(gx%bmperr.ne.0) then write(*,68)'MM error calculating reference state',gx%bmperr,& -lokph,jj,xxx,tpvalsave(1),ceq%complist(jj)%endmember 68 format(a,3i5,2(1pe12.4),2x,10i3) ceq%tpval=tpvalsave ! stop goto 998 endif endif ! MU same as TC MUR ceq%complist(jj)%chempot(2)=ceq%complist(jj)%chempot(1)+xxx*ceq%rtn enddo ! else ! write(*,69)'Unable to calculate reference states due to errors' !69 format(a) endif ! write(*,37)'mu1: ',(ceq%complist(jj)%chempot(1),jj=1,meqrec%nrel) ! write(*,37)'mu2: ',(ceq%complist(jj)%chempot(2),jj=1,meqrec%nrel) !37 format(a,6(1pe12.4)) !------------- 998 continue if(.not.formap) then ! if called during mapping keep phr deallocate(meqrec%phr) endif ! >>>> here one can allow new composition set in parallelization return end subroutine meq_phaseset !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine meq_sameset !\begin{verbatim} recursive subroutine meq_sameset(irem,iadd,mapx,meqrec,phr,inmap,ceq) ! iterate until phase set change, converged or error (incl too many its) ! iadd = -1 indicates called from calculating a sequence of equilibria ! mapx is used when calling meq_sameset from step/map implicit none integer irem,iadd,inmap,mapx TYPE(meq_setup) :: meqrec TYPE(meq_phase), dimension(*), target :: phr TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} if(globaldata%mqmqa1.eq.1.0d0) then call meq_sameset_okmap4(irem,iadd,mapx,meqrec,phr,inmap,ceq) else call meq_sameset_okmqmqa(irem,iadd,mapx,meqrec,phr,inmap,ceq) endif return end subroutine meq_sameset !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine meq_sameset_okmap4 !\begin{verbatim} recursive subroutine meq_sameset_okmap4(irem,iadd,mapx,meqrec,phr,inmap,ceq) ! iterate until phase set change, converged or error (incl too many its) ! iadd = -1 indicates called from calculating a sequence of equilibria ! mapx is used when calling meq_sameset from step/map implicit none integer irem,iadd,inmap,mapx TYPE(meq_setup) :: meqrec TYPE(meq_phase), dimension(*), target :: phr TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer increase,ioff,ik,jj,jph,ie,ierr,jmaxy integer kk,kkz,level3,mph,negam,negamph,nj,nk,nl integer nz1,nz2 TYPE(meq_phase), pointer :: pmi ! Using SAVE not possible for parallel calculations here once is just warning logical, save :: once=.true. double precision, dimension(5) :: qq double precision, dimension(maxconst) :: ycormax double precision, dimension(:,:), allocatable :: smat double precision, dimension(:), allocatable :: svar ! these arrays should maybe be allocated .... double precision, dimension(maxconst) :: ycorr,yarr integer converged,jz double precision chargefact,chargerr double precision dgm,summ,dgmmax,gsurf,phf,phs double precision prevmaxycorr,pv,signerr double precision xxx,ycormax2,yprev,ys,ysmm,ysmt,yss,yst double precision yvar1,yvar2 double precision maxphch double precision sum double precision, dimension(:), allocatable :: cit double precision deltat,deltap,deltaam,yfact ! to check if we are calculating a single almost stoichiometric phase ... integer iz,tcol,pcol,nophasechange,notagain double precision maxphasechange,molesofatoms,factconv double precision lastdeltat,deltatycond,phfmin,value integer notf,dncol,iy,jy,iremsave,phasechangeok,nextch,iremax,srem,errall character phnames*50 double precision, dimension(:), allocatable :: lastdeltaam logical vbug,stoikph,badmat !CCI integer cmix(22), cmode double precision cvalue, maxprescribed, sumprescribed, ccf(5) TYPE(gtp_condition), pointer :: conditionScale, lastcondScale !CCI ! NOTE using save cannot be reconciled with parallel calculations save notagain ! ! do not allow return unless meqrec%noofits greater or equal to nextch mapx=0 nextch=meqrec%noofits+4 stoikph=.true. nophasechange=0 maxphasechange=zero ! this is set each time the set of phases changes, controls change in T ! when there is a condition on y !CCI deltaTycond=default_deltaTycond !CCI if(iadd.eq.-1 .or. ocv()) then write(*,*)'Debug output in meq_sameset' vbug=.TRUE.; iadd=0 else vbug=.FALSE. endif ! vbug=.TRUE. if(vbug)write(*,*)'entering meq_sameset',meqrec%nphase,irem ! write(*,*)'MM entering meq_sameset',meqrec%nphase,irem iremsave=irem ! this is max correction of constituent fraction for each phases ycormax=zero ! magic trying to force decreasing step in fractions ! ymagic=one ! nmagic=0 ! this is an attempt to decrease variation in phase amount corrections allocate(lastdeltaam(meqrec%nstph),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 9: ',errall gx%bmperr=4370; goto 1000 endif lastdeltaam=zero ! dimension matrix for conditions, components+stable phases nz1=meqrec%nrel-meqrec%nfixmu+meqrec%nstph-meqrec%nfixph if(meqrec%tpindep(1)) nz1=nz1+1 if(meqrec%tpindep(2)) nz1=nz1+1 if(ocv()) write(*,11)meqrec%nrel,meqrec%nfixmu,meqrec%nstph,& meqrec%nfixph,meqrec%tpindep,nz1,ceq%tpval(1) 11 format('In meq_sameset, sysmat: ',4i7,2l2,i5,1pe12.4) nz2=nz1+1 if(vbug) write(*,*)'Allocating smat: ',nz1 allocate(smat(nz1,nz2),stat=errall) allocate(svar(nz1),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 10: ',errall gx%bmperr=4370; goto 1000 endif ! check if constituent fraction correction in stable phases increases ! for each iteration. Needed for the Re-V case .... prevmaxycorr=zero increase=0 level3=0 ! this is set TRUE after 3 iterations phasechangeok=meqrec%noofits if(phasechangeok.eq.1) then notagain=0 endif ! debugging problem with changing axis in mapping if(ocv() .and. meqrec%tpindep(1)) write(*,*)'variable T: ',ceq%tpval(1) !------------------------------------------------------------- ! return here until converged or phase set change 100 continue meqrec%noofits=meqrec%noofits+1 cerr%flag=0 ! nonzero flag means error output below ! cerr%flag=1 !CCI if(nophasechange.gt.default_nophasechange) then if(maxphasechange.lt.default_maxphaseamountchange) then !CCI ! if we have not changed the set of stable phases for many iterations ! and the changes in phase amounts is small maybe we are calculationg an ! almost stoichiometric phase? Changes in MU can be large! if(stoikph .and. meqrec%nphase.gt.1) then ! write this message if VERBOSE is set if(btest(globaldata%status,GSVERBOSE)) write(*,30)nophasechange,& converged,cerr%nvs,ceq%tpval(1) 30 format('Slow converge at ',3i3,F10.2) if(cerr%flag.ne.0) then write(*,31)(cerr%typ(iz),cerr%val(iz),cerr%dif(iz),& iz=1,cerr%nvs) 31 format('MM 31: ',3(i3,1pe12.4,e10.2)) endif ! write message only (once for each minimization) stoikph=.false. ! if this happends during step/map give error message to force smaller steps if(inmap.eq.1 .and. meqrec%noofits.eq.ceq%maxiter) then gx%bmperr=4359; goto 1000 endif endif !+ converged=0 !+ goto 1000 ! else ! maybe use this to improve concergence?? ! if(.not.allocated(loopfact)) then ! allocate(loopfact(meqrec%nrel)) ! endif endif endif nophasechange=nophasechange+1 cerr%nvs=0 cerr%mconverged=0 ! this is magic .... ! nmagic=nmagic+1 ! if(mod(nmagic,5).eq.0) ymagic=0.5*ymagic ! if(mod(nmagic,25).eq.0) ymagic=one ! end of magic !101 format(a) ! write(*,*)'Iteration: ',meqrec%noofits,' ----------------------------- ' if(ocv()) write(*,199)meqrec%noofits,ceq%tpval(1),meqrec%nstph,& (meqrec%stphl(jz),jz=1,meqrec%nstph) !199 format(/'Equil iter: ',i3,f8.2,', stable phases: ',i3,2x,10i3) 199 format(/'Equil iter: ',i3,f8.2,', stable phases: ',i3,2x,100i3) if(meqrec%noofits.gt.ceq%maxiter) goto 1200 converged=0 if(vbug) write(*,*)'Iteration: ',meqrec%noofits,converged ! loop for all phases and composition sets, loop over phr ! if(meqrec%tpindep(1)) write(*,*)'variable T: ',meqrec%noofits,ceq%tpval(1) ! ! >>>>>>>>>>>> here we can parallelize ! !-$omp parallel do private(pmi) shared(meqrec) ! nullify liquid pointer nullify(meqrec%pmiliq) ! write(*,*)'MM meq_sameset: begin loop for all phases' parallel: do mph=1,meqrec%nphase pmi=>phr(mph) ! this routine calculates G and derivatives, the phase matrix and inverts it. ! it also calculates the amounts of moles of components in the phase !-$ write(*,*)'Phase and tread: ',mph,omp_get_thread_num() ! to set correct pmiliq we must calculate all liquids first!! ! write(*,*)'MM call onephase: ',pmi%iph,pmi%ics call meq_onephase(meqrec,pmi,ceq) ! write(*,*)'MM back from onephase: ',gx%bmperr if(gx%bmperr.ne.0) then ! using LAPCK gives severe problems if we do not stop goto 1000 if(pmi%stable.eq.0) then ! if this happends for an unstable phase just continue but ensure it will ! not be stable (in a very crude way) ! write(*,*)'Matrix inversion error for unstable phase',pmi%iph pmi%curd%gval(1,1)=one gx%bmperr=0 else ! Inversion error for stable phase is fatal, error code already set if(once) then write(*,*)'Warning, matrix inversion problem: ',pmi%iph once=.false. else goto 1000 endif gx%bmperr=0 endif endif !107 format(a,6(1pe12.3)) ! end of pmi% scope enddo parallel ! hejhopp ! write(*,*)'MM meq_sameset: end loop for all phases' !-$omp end parallel do ! !======================================================================= ! step 2: calculation of equil matrix ! Solve for chemical potentials and conditions using all stable phases ! The EQUIL MATRIX (smat) has one row for each stable phase and ! one row for each component representing a condition ! (If a fix phase condition or chem.pot. condition slightly different??) !---------------------------------------- 300 continue ! if(vbug) write(*,301)'MM Calculating general equil matrix',meqrec%nfixmu,& ! write(*,301)'MM Calculating general equil matrix',meqrec%nfixmu,& ! meqrec%nfixph,meqrec%tpindep,meqrec%noofits 301 format(a,2i2,2l2,i5) ! some arguments here are redundant but kept for some call setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,& dncol,converged,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'MM Back from setup_equilmatrix',tcol !===================================================================== ! debug output of equil matrix, last column is right hand side !380 continue ! open(33,file='eqmat.dat ',access='sequential',status='unknown') ! write(33,*)'Equilibrium matrix',nz1 ! do iz=1,nz1 ! write(33,112)iz,(smat(iz,jz),jz=1,nz2) !112 format('>',i4,1x,4(1pe15.6)) ! enddo !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> debug ! debug output to follow the minimization: all mu_i, and ! for all stable phases np^alpha, G^alpha, and x^alpha_i ! call calc_molmass(xdum,wdum,tmdum,wmdum,ceq) ! write(*,116)'MM mu:',meqrec%nstph,(ceq%cmuval(iz),iz=1,meqrec%nrel),& ! (xdum(iz),iz=1,meqrec%nrel) !116 format(a,i3,6(1pe12.4)) ! do iz=1,meqrec%nstph ! jj=meqrec%stphl(iz) ! call calc_phase_molmass(phr(jj)%iph,phr(jj)%ics,& ! xdum,wdum,tmdum,wmdum,dumdum,ceq) ! if(gx%bmperr.ne.0) stop 'debug' ! amount of phase, G of phase, x_i of phase ! write(*,116)'MM ph:',jj,phr(jj)%curd%amfu,smat(iz,nz2),& ! (xdum(ioff),ioff=1,meqrec%nrel) ! enddo ! end debug output !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> if(vbug) then ! when convergence problem list smat here and (and svar below) and study!!! call list_conditions(kou,ceq) do iz=1,nz1 write(*,228)'smat1:',(smat(iz,jz),jz=1,nz2) enddo endif 228 format(a,6(1pe12.4),(8x,6e12.4)) ! This is an emergecy check that the smat matrix does not contain ! values >default_bigvalues. We should test for Infinity and NaN but how?? do iz=1,nz1 do jz=1,nz2 !CCI if(abs(smat(iz,jz)).gt.default_bigvalues) then !CCI write(*,118)iz,jz 118 format('meq_sameset has illegal values in equilibrium matrix',2i4) gx%bmperr=4354; goto 990 endif enddo enddo ! HERE new values of chemical potentials and and amount of phases ! call lingld(nz1,nz2,smat,svar,nz1,ierr) ! goto 119 ! Rearranged the IF statements/BoS ! if(inmap.eq.0 and ceq%splitsolver .eq. 1) then !CCI !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Development based on the work of Joao Pedro Carvalho Teuber 12/2020 ! Jacobi preconditioning if allowed !BS if((inmap.eq.0).and.(ceq%splitsolver.gt.0).and.& !BS (meqrec%nrel.eq.meqrec%nstph)) then !BS call precond(nz1,nz2,smat,badmat) ! added due to problems with parallel1 and parallel2, 20200220/BoS ! PRECOND has found a zero diagonal element but just use lingld and skip split ! if(badmat) then ! write(*,112)nz1,nz2 112 format('MEQ_SAMESET: phase matrix illconditioned',2i3) ! debug output ! do iz=1,nz1 ! write(*,113)iz,(smat(iz,jz),jz=1,nz1) ! enddo 113 format(i3,20(1pe11.3)) ! call lingld(nz1,nz2,smat,svar,nz1,ierr) ! goto 119 ! end if ! endif ! if((inmap.eq.0).and.(ceq%splitsolver.gt.0).and.& ! .not.badmat .and. (meqrec%nrel.eq.meqrec%nstph)) then ! Splitting is possible for given T, P, composition and ! when the number of component is equal to the number of stable phases ! (conditions giving square mass matric) ! ís this OK if BADNAT is TRUE?? !BS if(badmat) write(*,*)'MEQ_SAMESET: matrix has a diagonal element zero' !BS call lingldSplit(nz1,nz2,smat,svar,nz1,ierr,meqrec%nrel,meqrec%nstph) !BS else ! this used when equilibrium is NOT invariant call lingld(nz1,nz2,smat,svar,nz1,ierr) !BS endif !----------------------------------------------------------------------- ! write(*,*)'MM meq_sameset: back from lingld' ! 119 continue if(ierr.ne.0) then if(vbug) write(*,*)'Error solving equil matrix 1',meqrec%noofits,ierr,& iremsave if(iremsave.gt.0) then ! parallel2 goes into a loop here when phase iremsave has been suspended ! after at has been set suspended .... fixed by not returning nonzero irem ! equil matrix wrong at first iteration after removing a phase ! This can be caused by having no phase with solubility of an element ! (happened in Fe-O-U-Zr calculation with just C1_MO2 stable and C1 does not ! dissolve Fe). Try to set back the last phase removed!! if(.not.btest(meqrec%status,MMQUIET)) then kk=meqrec%phr(iremsave)%phtupix phnames=' ' call get_phasetup_name(kk,phnames) write(*,*)'Error, restoring previously removed phase: ',& trim(phnames) endif ! NOTE: it should also be removed from the dormant list!! iadd=iremsave notagain=iremsave goto 1100 endif if(vbug) then do iz=1,nz1 write(*,228)'smat2:',(smat(iz,jz),jz=1,nz2) enddo endif ! debug output ... ! write(*,229)'ce:',meqrec%noofits ! call list_conditions(kou,ceq) ! do iz=1,nz1 ! write(*,228)'smat2:',(smat(iz,jz),jz=1,nz2) ! enddo ! gx%bmperr=4203; goto 1000 endif ! when problems output svar here !! (and smat1: above) ! write(33,*)'Solution' ! write(*,228)'PHMAT: ',(svar(jz),jz=1,nz1) ! close(33) ! write(*,228)'svar1:',(svar(jz),jz=1,nz1) if(vbug) write(*,228)'svar1:',(svar(jz),jz=1,nz1) ! ! if no error at first calculation after phase set change iremsave=0 iremsave=0 if(vbug) write(*,229)'pm: ',meqrec%noofits,(svar(iz),iz=1,nz1) ! write(*,229)'pm: ',meqrec%noofits,(svar(iz),iz=1,nz1) 229 format(a,i3,6(1pe12.4)) !--------- ! copy the chemical potentials, take care of fixed values .... ! new potentials are in svar(1..meqrec%nrel-meqrec%nfixmu) iz=1 notf=1 setmu: do ik=1,meqrec%nrel if(notf.le.meqrec%nfixmu) then if(ik.eq.meqrec%mufixel(notf)) then ! this potential is fixed, no incrementing "iz", ceq%cmuval(ik) is a condition ceq%complist(ik)%chempot(1)=meqrec%mufixval(1)*ceq%rtn notf=notf+1 cycle setmu endif endif ! if(abs(svar(iz)-ceq%cmuval(ik)).gt.ceq%xconv) then ! attempt to handle problem with MQMQA phase convergence ! if(abs(svar(iz)-ceq%cmuval(ik)).gt.abs(ceq%xconv*ceq%cmuval(ik))) then if(abs(svar(iz)-ceq%cmuval(ik)).gt.& abs(globaldata%mqmqa1*ceq%xconv*ceq%cmuval(ik))) then ! when MQMQA phase is involved globaldata%mqmqa1 is 1.0D4, otherwise 1.0D0 ! write(*,*)'MM mqmqa1:',globaldata%mqmqa1 ! ! if(vbug) write(*,387)'Unconverged pot: ',iz,ik,& if(nophasechange.gt.100) then ! Attempt to improve convergence for a 15 component system ... failed ! xxx=0.25D0*(3.0D0*svar(iz)+1.0D0*ceq%cmuval(ik)) ! write(*,387)'Uncnv pot: ',iz,ik,& ! svar(iz),ceq%cmuval(ik),xxx,abs(svar(iz)-ceq%cmuval(ik)),& ! abs(ceq%xconv*ceq%cmuval(ik)) !387 format(a,2i3,3(1pe14.5),2(1pe10.2)) ! take mean value ... DO NOT TRY THIS IF IT IS NOT ALMOST CONVERGED!!! ! svar(iz)=xxx endif converged=7 cerr%mconverged=converged endif ceq%cmuval(ik)=svar(iz) ! svar(iz) is mu/RT, chemput is mu ceq%complist(ik)%chempot(1)=svar(iz)*ceq%rtn iz=iz+1 enddo setmu ioff=meqrec%nrel-meqrec%nfixmu+1 !------------ ! update T and P if variable if(meqrec%tpindep(1)) then xxx=ceq%tpval(1) ! check convergence ! write(*,*)'Delta T: ',svar(ioff),1.0D2*ceq%xconv ! if(abs(svar(ioff)).gt.1.0D2*ceq%xconv) then ! this convergece criteria needed for the CHO-gas calculation!!! ! but causes problem calculating phase diagrams ... inmap=1 for step/map ! OBS svar(ioff) is Delta T, not absolute value !CCI if(inmap.eq.0 .and. abs(svar(ioff)).gt.default_deltaT*ceq%xconv) then !CCI converged=8 cerr%mconverged=converged endif !CCI ! limit changes in T to +/- 20% of current value (see default_limitchangesT) if(abs(svar(ioff)/ceq%tpval(1)).gt.default_limitchangesT) then svar(ioff)=sign(default_limitchangesT*ceq%tpval(1),svar(ioff)) endif !CCI ! limit change in T when there is condition on y if(ycondTlimit) then deltat=svar(ioff) ! Suck it happend that svar(ioff) changed sign each iteration .... if(lastdeltat*deltat.lt.zero) then deltatycond=max(deltatycond-one,one) ! never increase during one minimization ... ! else ! deltatycond=2.5D1 endif if(abs(svar(ioff)).gt.deltatycond) then if(svar(ioff).gt.zero) then svar(ioff)=deltatycond else svar(ioff)=-deltatycond endif write(*,*)'MM ycondTlimit: ',deltat,svar(ioff) lastdeltat=svar(ioff) endif endif deltat=svar(ioff) ! limit maximum change in deltat if(abs(deltat).gt.meqrec%tpmaxdelta(1)) then deltat=sign(meqrec%tpmaxdelta(1),deltat) if(ocv()) write(*,386)'limit the change in T: ',& ceq%tpval(1),deltat,svar(ioff) 386 format(a,3(1pe12.4)) endif ceq%tpval(1)=ceq%tpval(1)+deltat ! problems here when -finit-local-zero is removed if(vbug) write(*,*)'T and deltaT:',ceq%tpval(1),deltat !CCI if(ceq%tpval(1).le.default_minimalchangesT) then write(*,*)'Attempt to set a temperature less than ',default_minimalchangesT,' K !!!' !CCI gx%bmperr=4187; goto 1000 endif ioff=ioff+1 endif if(meqrec%tpindep(2)) then ! if pressure variable xxx=ceq%tpval(2) ! check convergence ! ??? svar(ioff) much too small!! why? add a factor ... ! svar(ioff)=1.0D2*svar(ioff) !CCI if(abs(svar(ioff)).gt.default_deltaP*ceq%xconv) then !CCI converged=8 cerr%mconverged=converged endif ! write(*,389)'HMS pv: ',ioff,converged,svar(ioff),ceq%tpval(2) !389 format(a,2i3,4(1pe12.4)) !CCI if(abs(svar(ioff)/ceq%tpval(2)).gt.default_limitchangesP) then svar(ioff)=sign(default_limitchangesP*ceq%tpval(2),svar(ioff)) endif !CCI deltap=svar(ioff) ! limit the changes in P if(abs(deltap).gt.meqrec%tpmaxdelta(2)) then deltap=sign(meqrec%tpmaxdelta(2),deltap) if(ocv()) write(*,386)'limit the change in P: ',& ceq%tpval(2),deltap,svar(ioff) endif ceq%tpval(2)=ceq%tpval(2)+svar(ioff) !CCI if(ceq%tpval(2).le.default_minimalchangesP) then !CCI write(*,*)'Attempt to set pressure lower than ',default_minimalchangesP,' Pa!!!' gx%bmperr=4187; goto 1000 endif ioff=ioff+1 endif !------------ ! update phase amounts, take care of fixed phases .... ! the change in amounts are in svar(ioff+...) negamph=0 negam=0 irem=0 iremax=0 phfmin=zero ! dncol+1 should be the first Delta_phase-amount ioff=dncol+1 ! scale all changes in phase amount with total number of atoms. At present ! assume this is unity. Without scaling phase changes can be +/-1E+11 or more ! which creates instabilities maxphch=zero ! normphchange: do jph=1,meqrec%nstph normphchange: do jph=1,meqrec%nstph-meqrec%nfixph if(abs(svar(ioff+jph-1)).gt.maxphch) maxphch=abs(svar(ioff+jph-1)) enddo normphchange !CCI ! By default, ceq%scale_change_phase_amount equals to one. ! Such a value is changed by the user in !------------------------------------------------------- !------------------------------------------------------- if(meqrec%noofits.eq.1) then if(ceq%type_change_phase_amount.gt.0) then ! whenever prescribed values are too big or differ greatly in order of magnitude ! Only cmix(1)=5 is interesting here. potentials already cared for ! loop if not the last condition ! This is the condition, cvalue is the prescibed value ! cmode and cmix contain information how to calculate its current value lastcondScale=>ceq%lastcondition conditionScale=>lastcondScale conditionScale=>conditionScale%next !--- ! loop over all conditions and stops when the pointer condition is empty ! (use of apply_condition_value subroutine in gtp3D.F90) !--- cmode=-1 cmix=0 maxprescribed = one sumprescribed = zero do while(.not.associated(conditionScale,lastcondScale)) call apply_condition_value(conditionScale,cmode,cvalue,cmix,ccf,ceq) if (cmix(1).eq.5) then cvalue = conditionScale%prescribed if (cvalue.gt. maxprescribed ) then maxprescribed = cvalue endif sumprescribed = sumprescribed + cvalue endif conditionScale=>conditionScale%next enddo sumprescribed = sumprescribed - one sumprescribed = abs(sumprescribed) if(sumprescribed.lt.one) then sumprescribed = sumprescribed + one endif if(ceq%type_change_phase_amount.eq.1) ceq%scale_change_phase_amount=sumprescribed if(ceq%type_change_phase_amount.eq.2) ceq%scale_change_phase_amount=maxprescribed else ceq%scale_change_phase_amount=default_scalechangephaseamount endif endif !------------------------------------------------------- !------------------------------------------------------- if(maxphch.gt.ceq%scale_change_phase_amount) then ioff=dncol+1 do jph=1,meqrec%nstph-meqrec%nfixph svar(ioff+jph-1)=svar(ioff+jph-1)*ceq%scale_change_phase_amount/maxphch enddo endif !CCI ! ioff=dncol+1 ! do not change phase amounts the first iteration ! write(*,554)svar !554 format('MM svar: ',6(1pe12.4)) ! if(meqrec%noofits.eq.1) then ! goto 555 ! endif phamount2: do jph=1,meqrec%nstph ! loop for all stable phases jj=meqrec%stphl(jph) ! phr(jj)%curd%damount=zero ! kkz=test_phase_status(phr(jj)%iph,phr(jj)%ics,xxx,ceq) kkz=phr(jj)%phasestatus ! new -4=hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fixed if(kkz.ge.PHENTUNST .and. kkz.le.PHENTSTAB) then ! phase is entered so its amount can change, -svar(ioff) is the change phs=phr(jj)%curd%amfu if(ioff.gt.size(svar)) then ! error here calculating Fe-Si-C with 2 phases set fix zero ! setting w(si)=w(c)=none and fix T; should have w(si) fix and T=none write(*,42)'MM Too many phases with variable amount',ioff,& size(svar),meqrec%nstph,phr(jj)%iph 42 format(a,10i4) gx%bmperr=4193; goto 1000 endif deltaam=svar(ioff) ! Sigli convergence problem, bad guess of start amount of phases?? ! NOTE sign! -deltaam is the change in amount of phase, ! write(*,43)'Deltaam: ',meqrec%noofits,jj,deltaam,lastdeltaam(jph),& ! phr(jj)%curd%amfu,phr(jj)%curd%amfu-deltaam !43 format(a,2i3,6(1pe12.4)) ! tried to avoid too large changes in phase amount, just made things worse ! if(meqrec%noofits.lt.3 .and. & ! abs(deltaam).gt.0.5D0*phr(jj)%curd%amfu) then ! deltaam=sign(0.1D0*phr(jj)%curd%amfu,deltaam) ! write(*,43)'Modified: ',meqrec%noofits,jj,deltaam ! endif ! limit change in amount of phase if(abs(deltaam).gt.ceq%xconv) then ! For the equil O-U with conditions on N(O) and N(U) there is no problem ! with the amount of C1 but with N= and x(O)= the phase amount change varies ! with sign and converges very slowly. Probably an interference with the ! charge balance criteria. if(lastdeltaam(jph)*deltaam.lt.zero) then ! wow, this seems to work ... other attmepts interfere directly with the ! charge balance so one should carefully check how they are connected... ! deltaam=5.0D-1*deltaam ! The half worked to C1+tetragonal, it did not work for ionic liquid misc. gap ! and in that case there is no charge balance criteria ... suck ! deltaam=5.0D-1*deltaam ! Dubbelt wow ... 0.2 works for both cases ... why?? More iterations though .. deltaam=2.0D-1*deltaam if(ocv()) write(*,3)'Phase amount sign change: ',& meqrec%noofits,jph,jj,phs,lastdeltaam(jph),deltaam ! write(*,3)'Phase amount sign change: ',& ! meqrec%noofits,jph,jj,phs,lastdeltaam(jph),deltaam 3 format(a,3i3,6(1pe12.4)) endif if(converged.lt.6) then converged=6 cerr%mconverged=converged endif if(vbug) write(*,381)'Phase amount change: ',meqrec%noofits,jj,& phs,deltaam 381 format(a,2i3,4(1pe12.4)) endif lastdeltaam(jph)=deltaam if(phr(jj)%curd%amfu-deltaam.le.zero) then if(meqrec%nstph.eq.1) then ! this is the only stable phase! cannot have negative or zero amount! deltaam=phr(jj)%curd%amfu-1.0D-2 endif endif ! if(-deltaam.gt.one) then !CCI Useless if type_change_phase_amount>0 (0 also??) ! if(abs(deltaam).gt.one) then if(abs(deltaam).gt.one .and. ceq%type_change_phase_amount.eq.0) then !CCI Useless if type_change_phase_amount>0 (0 also??) ) then ! try to prevent too large increase/decrease in phase amounts. ! Should be related to total amount of components. if(.not.btest(meqrec%status,MMQUIET)) & write(*,*)'Large change in phase amount: ',deltaam ! deltaam=-one deltaam=sign(0.5D0,deltaam) endif !CCI if(abs(deltaam).gt.maxphasechange) then ! to allow checks when phase set does not change and amount changes are small ! like when calculating an almost stoichiometric composition like UO2 with ! n(o)=2 and n(u)=1 at low T maxphasechange=abs(deltaam) endif ! special test for Al-Ni fcc/fcc#2 two-phase ! Calculations with Al-Ni T=1000, x(al)=.2 gives just a single FCC phase ! possible problems that we change the amounts of the wrong composition set? ! HOWEVER, I found the error is the second derivatives are wrong!! ! if(meqrec%noofits.lt.10) deltaam=0.1*deltaam ! write(*,383)'MM phase change: ',meqrec%noofits,jj,& ! phr(jj)%iph,phr(jj)%ics,phr(jj)%curd%amfu,deltaam,svar(ioff) !383 format(a,2i3,2x,2i3,3(1pe12.4)) phf=phr(jj)%curd%amfu-deltaam if(phs.gt.0.2D0 .and. phf.le.zero) then ! violent change of phase fractions in Siglis case, liquid change from 1 to 0 ! Prevent changes larger than 0.1 if value larger than 0.5 ! old value of amfu in phs phf=0.1D0 endif ! write(*,363)' >>>> Stable phase: ',jj,phr(jj)%iph,& ! phr(jj)%ics,phf,phs,deltaam,sum 363 format(a,3i3,6(1pe12.4)) ! phr(jj)%curd%damount=deltaam ioff=ioff+1 elseif(kkz.eq.PHFIXED) then ! phase is fix, there is no change in its amounts phf=phr(jj)%curd%amfu ! write(*,*)'Fixed phase: ',jj,phf else ! phase is dormant or suspended, must not be stable!!!! call get_phase_name(phr(jj)%iph,phr(jj)%ics,phnames) if(gx%bmperr.ne.0) goto 1000 ! write(*,373)phr(jj)%iph,phr(jj)%ics,kkz ! write(*,373)trim(phnames),kkz 373 format('MM The phase ',a,' cannot vary its amount:',3i7) gx%bmperr=4194; goto 1000 endif ! problem with Fe-O-U-Zr convergence, all phases disappear ?? ! write(*,364)'Stable phase: ',meqrec%noofits,jj,phr(jj)%iph,& ! phr(jj)%ics,phf,phs,phr(jj)%prevam !364 format(a,4i3,6(1pe12.4)) ! make sure the driving force of stable phases to zero phr(jj)%curd%dgm=zero if(phf.lt.zero) then ! phase has negative amount, NOT ALLOWED if it is the only stable phase if(meqrec%nstph-meqrec%nfixph.eq.1) then ! write(*,367)'Trying to remove the only stable phase ',jj,& ! phr(jj)%curd%amfu 367 format(a,i3,1pe14.6) phf=0.5D0*phr(jj)%curd%amfu gx%bmperr=4195; goto 1000 else ! select phase with most negative amount if(phf.lt.phfmin) then phfmin=phf iremax=jj endif ! trying to improve convergence by allowing phases to be removed quicker ! write(*,363)'Phase with negative amount: ',jj,meqrec%noofits,0,& ! phf,phs,phr(jj)%prevam ! if(phf.lt.-1.0D-2) phf=zero if(jj.ne.notagain .and. phr(jj)%prevam.lt.zero) then ! remove this phase if negative amount previous iteration also irem=jj ! write(*,376)'meq_sameset remove: ',meqrec%noofits,nextch,& ! jj,notagain 376 format(a,4i4) ! jumping to 1000 here means constitutions not changed in this iteration goto 1000 else ! mark this phase had negative amount this iteration ! PROBLEM removing one of two composition sets of the same phase, ! (miscibility gap), they may change which have negative amount each iteration phr(jj)%prevam=-one phf=zero endif endif else ! phase has positive amount, mark in prevam phr(jj)%prevam=one endif ! store the new phase fraction (moles formula units) phr(jj)%curd%amfu=phf enddo phamount2 ! end of loop for jph=1,meqrec%nstph !555 continue ! ! if(iremax.gt.0) then ! write(*,*)'meq_sameset remove?',meqrec%noofits,iremax,phfmin ! endif if(vbug) write(*,*)'finished updating phase amounts: ',& meqrec%noofits,phasechangeok,irem ! if(meqrec%nfixmu.gt.0) then ! write(*,33)'mu1: ',(ceq%cmuval(nj),nj=1,meqrec%nrel) ! write(*,33)'mu2: ',(ceq%complist(nj)%chempot(1),nj=1,meqrec%nrel) ! write(*,33)'mu3: ',(ceq%complist(nj)%chempot(2),nj=1,meqrec%nrel) ! write(*,33)'mu4: ',(svar(nj),nj=1,meqrec%nrel) !33 format(a,6(1pe12.4)) ! endif !------------------------------------------------------- ! After solving the equil matrix and updating the chemical potentials, ! the phase amounts and possibly T and P we correct constitions of all phases ! - Now calculate correction of constituent fractions for all phases ! See BoJ thesis eq. 30 (also in metastable phases) (paper I) ! At the same time calculate the driving force for metastable phases ycorr=zero ycormax2=zero ! to handle charge balance correction of constituent fractions chargerr=zero ! chargerr fitted to fastest convergence using the ou test case ! chargefact=1.0D-1 requires more than 100 iterations ! chargefact=one requires more than 100 iterations ! this value requires about 40 iteration !CCI chargefact=0.5*default_chargefact !CCI ! chargefact=1.0D-1 ! kk is used to check if a charged phase is stable, ! it is incremented for each stable phase kk=1 ! iadd is set to the unstable phase with largest positive driving force ! dgmmax is the largest psoitive driving force iadd=0 dgmmax=zero ysmm=zero !----------------------------------------------------- !CCI ! Update the constitutions. If irem>0 remove this phase unless ! we have made at least 'default_noremove' (see ocparam.F90) iterations with the current phase set if(irem.gt.0 .and. meqrec%noofits-phasechangeok.gt.default_noremove) goto 1000 !CCI !-------------------------- ! These are needed to avoid several phases have exactly the same fracions ! if the start guess is very bad and limitations are used yvar1=default_yvar1 yvar2=default_yvar2 !----------------------------------------- lap: do jj=1,meqrec%nphase ! The current chemical potentials are in ceq%cmuval(i) ! if(vbug) write(*,*)'Phase: ',phr(jj)%iph,phr(jj)%ics,& ! phr(jj)%curd%amfu if(jj.eq.meqrec%stphl(kk)) then ! jj is stable, increment kk but do not make it larger than meqrec%nstph ! save index in meqrec%stphl in jph !!!!!!!!!!! kk never used !!!!!!!!! jph=kk kk=min(kk+1,meqrec%nstph) ! if(meqrec%noofits.le.2) write(*,83)'dy1: ',jj,jph,kk !83 format(a,3i3,6(1pe12.4)) else ! phase is not stable ! calculate driving force for unstable phases. First calculate the sum ! of the current phase composition and the calculated chemical potentials jph=0 gsurf=zero; summ=zero do ie=1,meqrec%nrel ! fatal parallel execution error once here ! index '1' of dimension 1 of array 'phr' above upper bound of 0 gsurf=gsurf+phr(jj)%xmol(ie)*ceq%cmuval(ie) summ=summ+phr(jj)%xmol(ie) enddo gsurf=gsurf/summ ! calculate G_m plus any deltat and deltap terms dgm=phr(jj)%curd%gval(1,1) if(meqrec%tpindep(1)) then dgm=dgm+phr(jj)%curd%gval(2,1)*deltat endif if(meqrec%tpindep(2)) then dgm=dgm+phr(jj)%curd%gval(3,1)*deltap endif ! scale dgm per mole atoms molesofatoms=phr(jj)%curd%abnorm(1) if(molesofatoms.lt.0.3D0) then ! problem when a phase is stable with just vacancies !!!!!!!!!!!! if(phr(jj)%phasestatus.gt.0) then write(*,'(a,i3,a,F8.4)')'MM Phase: ',jj,& ' moles of atoms: ',molesofatoms endif endif ! dgm=gsurf-dgm/phr(jj)%curd%abnorm(1) dgm=gsurf-dgm/molesofatoms if(phr(jj)%phasestatus.gt.0) then ! we should be here only for UNSTABLE phases, phr(jj)%phasestatus<=0 ! For some reason a phase has entered/fixed status (>0) THAT IS AN ERROR ! It happened in SMP2A when mapping Al-Ni and correcting too long step in T write(*,'(a,i4,i3)')'MM phase status reset:',jj,phr(jj)%phasestatus phr(jj)%phasestatus=0 endif if(dgm.gt.dgmmax) then if(phr(jj)%phasestatus.ge.PHENTUNST .and. & phr(jj)%phasestatus.le.PHENTERED) then ! phase is entered, can have status changed ! if this is another constitution set of an already stable phase then check ! below if the constitution of this phase is very similar to the stable one iadd=jj dgmmax=dgm ! write(*,379)'meq_sameset add: ',meqrec%noofits,nextch,& ! iadd,dgmmax 379 format(a,3i4,4(1pe12.4)) endif endif ! The difference between previous and current DGM is used to check for ! convergence below. Very important to check if continue iterating!! phr(jj)%prevdg=phr(jj)%curd%dgm phr(jj)%curd%dgm=dgm endif ! Update constituent fractions for ALL phases, stable or not ! if phr(jj)%xdone=1 then phase has no composition variation if(phr(jj)%xdone.eq.1) cycle !---------------------------------------------------- allocate(cit(phr(jj)%idim),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 11: ',errall gx%bmperr=4370; goto 1000 endif cit=zero if(meqrec%tpindep(1)) then ! variable T, code copied from calc_dgdyterms, cit(nj) used below ! write(*,44)'index 1: ',jj,phr(jj)%ncc,phr(jj)%idim,& ! size(phr(jj)%invmat) do jy=1,phr(jj)%ncc sum=zero do iy=1,phr(jj)%ncc sum=sum+phr(jj)%invmat(iy,jy)*& phr(jj)%curd%dgval(2,iy,1) enddo cit(iy)=sum*deltat ! write(*,44)'index 2: ',jj,jy,iy,0,sum !44 format(a,4i3,6(1pe12.4)) enddo !! end copy ! write(*,*)'Adding contribution from variable T to delta-y',& ! phr(jj)%ncc ! missing code for correction due to variable P????? endif ! These are used to introduce some variation in fractions when the values ! exceed limits. Otherwise one can as Sigli found have two stable phases ! with exactly the same fractions and have a crash ! moody: do nj=1,phr(jj)%ncc ys=zero do nk=1,phr(jj)%ncc pv=zero do nl=1,meqrec%nrel ! ceq%cmuval(nl) is the chemical potential of element nl (divided by RT) ! phr(jj)%dxmol(nl,nk) is the derivative of component nl ! wrt constituent nk ! write(*,*)'ycorr: ',nl,ceq%complist(nl)%chempot(1)/ceq%rtn ! write(*,612)'MM y1: ',nk,nl,& ! ceq%complist(nl)%chempot(1)/ceq%rtn,ceq%cmuval(nl) !612 format(a,2i4,6(1pe12.4)) pv=pv+ceq%complist(nl)%chempot(1)/ceq%rtn*phr(jj)%dxmol(nl,nk) ! write(*,111)'pvx: ',nj,pv,ceq%complist(nl)%chempot(1),& ! ceq%rtn,phr(jj)%dxmol(nl,nk) ! pv=pv+ceq%cmuval(nl)*phr(jj)%dxmol(nl,nk) ! pv=pv+svar(nl)*phr(jj)%dxmol(nl,nk) enddo pv=pv-phr(jj)%curd%dgval(1,nk,1) ys=ys+phr(jj)%invmat(nj,nk)*pv ! write(*,111)'pvx: ',nj,ys,pv,phr(1)%curd%dgval(1,nk,1),& ! phr(1)%invmat(nj,nk) !111 format(a,i2,6(1pe12.4)) enddo if(phr(jj)%chargebal.eq.1) then ! For charged phases add a term ! phr(jj)%invmat(phr(jj)%idim,phr(jj)%idim)*Q ys=ys-chargefact*phr(jj)%invmat(nj,phr(jj)%idim)*& phr(jj)%curd%netcharge ! ys=ys-chargefact*phr(jj)%invmat(nj,phr(jj)%idim)*& ! phr(jj)%charge ! jph is nonzero only for stable phases if(jph.gt.0 .and. & ! if(jj.eq.meqrec%stphl(kk) .and. & ! Hm, is this check correct? kk is updated above to be the next stable phase.. ! abs(phr(jj)%charge).gt.chargerr) then ! chargerr=abs(phr(jj)%charge) ! signerr=phr(jj)%charge abs(phr(jj)%curd%netcharge).gt.chargerr) then chargerr=abs(phr(jj)%curd%netcharge) signerr=phr(jj)%curd%netcharge endif ! write(*,*)'Charge: ',jj,phr(jj)%netcharge else ! enshure charge is zero!! if(phr(jj)%curd%netcharge.ne.zero) & write(*,*)'MM neutral phase with charge: ',& phr(jj)%curd%phlink,phr(jj)%curd%netcharge phr(jj)%curd%netcharge=zero endif ! when T is variable ycorr(nj)=ys+cit(nj) if(abs(ycorr(nj)).gt.ycormax2) then ycormax2=ycorr(nj) endif ! Sigli converge problem, fixed by changing stable phases in different order ! write(*,111)converged,jj,nj,ys !111 format('Y corr: cc/ph/cons/y: ',i2,2i4,1pe12.4) ! should possibly be ycorr(nj) instead of ys (ycorrmax) if(abs(ys).gt.ceq%xconv) then ! if the change in any constituent fraction larger than xconv continue iterate ! write(*,*)'Convergence criteria, phase/const: ',jj,nk if(phr(jj)%stable.eq.0) then ! Phase is not stable ! Handle convergence criteria different if inmap=1 or not mapping7: if(inmap.eq.0) then ! we are NOT in STEP/MAP, increase convergence criteria to handle ! the Mo-Ni-Re 3 phase equilibria !CCI if(abs(ys).gt.default_correctionfactorYS*phr(jj)%curd%yfr(nj)) then !CCI ! for unstable phases the corrections must be smaller than ...???? if(converged.lt.3) then converged=3 cerr%mconverged=converged yss=ys yst=phr(jj)%curd%yfr(nj) endif !CCI elseif(abs(ys).gt.default_correctionfactorXCONV*ceq%xconv) then !CCI !212 format(a,3i3,i4,4(1pe12.4)) if(converged.lt.4) then !CCI factconv=default_correctionfactorDGM if(phr(jj)%ncc.gt.10) then ! Calculation with the COST507 database and 20 elements too many iterations ! ... allow larger gdconv(1) factconv=10.0*factconv endif !CCI if(phr(jj)%curd%dgm-phr(jj)%prevdg.gt.& factconv*ceq%gdconv(1)) then ! Must be less than this if(phr(jj)%curd%dgm-phr(jj)%prevdg.gt.5.0E-3) then converged=4 cerr%mconverged=converged yss=ys yst=phr(jj)%curd%yfr(nj) endif endif else if(converged.eq.0) then converged=1 cerr%mconverged=converged yss=ys yst=phr(jj)%curd%yfr(nj) endif endif else ! we are doing step/map NO CHANGE, use old convergence criteria ! otherwise step1 and mmap4 are uncomplete with those above ... !CCI if(abs(ys).gt.default_correctionfactorYS*phr(jj)%curd%yfr(nj)) then ! for unstable phases the corrections must be smaller than ...???? if(converged.lt.3) then converged=3 cerr%mconverged=converged yss=ys yst=phr(jj)%curd%yfr(nj) endif elseif(abs(ys).gt.default_correctionfactorXCONV*ceq%xconv) then !CCI ! maybe accept 100 times larger correction than for stable phases ! write(*,107)'metast ph ycorr: ',ys,& ! phr(jj)%curd%yfr(nj) if(converged.lt.2) then converged=2 cerr%mconverged=converged yss=ys yst=phr(jj)%curd%yfr(nj) endif else if(converged.eq.0) then converged=1 cerr%mconverged=converged yss=ys yst=phr(jj)%curd%yfr(nj) endif endif endif mapping7 elseif(converged.lt.4) then ! large correction in fraction of constituent fraction of stable phase ! Problem here with CVMSRO model, ys=0.00272 when x(b)=.5 ! write(*,*)'MM converged 4A: ',jj,nj,ys converged=4 cerr%mconverged=converged yss=ys yst=phr(jj)%curd%yfr(nj) endif elseif(phr(jj)%stable.eq.1) then ! check to find good convergence criteria in Re-V test case if(abs(ycorr(nj)).gt.ysmm) then jmaxy=jj ysmm=abs(ycorr(nj)) ysmt=phr(jj)%curd%yfr(nj) endif ! check if the change in any fraction is larger than the fraction ... if(ycorr(nj).gt.phr(jj)%curd%yfr(nj)) then ! write(*,612)'MM y2: ',jj,nj,ycorr(nj),phr(jj)%curd%yfr(nj) if(converged.lt.4) then converged=4 cerr%mconverged=converged endif endif endif enddo moody ! end of correction of y fractions !--------------------------------- ! Limit change in fractions .... all ycorr(nj) multiplied with same factor ! keeping the sum of corrections in all sublattices as zero ! if(converged.ge.4) then ! Added to underetand convergence problem with CVMSRO ! write(*,*)'MM CVMSRO convergence: ',meqrec%noofits,jj,converged ! converged=1 or 2 means constituent fraction in metastable phase not converged ! converged 3 means large change constituent fraction of unstable phase ! converged 4 means a constituent fraction of a stable phase change a lot ! converged=5 means a condition not fullfilled ! converged=6 means charge balance not converged or large phase fraction change ! converged=7 means large change in chemical potentials ! converged=8 means large change T or P ! endif if(vbug) write(*,74)'maximum corr: ',& meqrec%noofits,jj,ycormax2,ycormax(jj) 74 format(a,2i3,2(1pe12.4)) if(ycormax(jj)*ycormax2.le.zero) then ! the condition is zero at first step, limit that yfact=one/(2.0D0+abs(ycormax2)) ycormax2=yfact*ycormax2 !CCI elseif(phr(jj)%ionliq.gt.0 .and. ycormax2.lt.default_upperycormax2) then !CCI ! step seems to be very small ... try to decrease number of iteration yfact=2.0d0 else yfact=one endif moody2: do nj=1,phr(jj)%ncc ! all corrections of constituent fractions in ycorr(1..phr(jj)%ncc) ! ymagic is halfed every 5th iteration when same phase set, after 5 times reset yprev=phr(jj)%curd%yfr(nj) ! yarr(nj)=yprev+ycorr(nj) if(phr(jj)%ionliq.gt.0) then ! For ionic liquids, an even smaller step is allowed ... ! The O-Pu-U test case converged up to 2800 without any particular factor ! with a factor 0.4 it converged up to 3000K (~150 its), yfact does not ! has any significant influence. ! yarr(nj)=yprev+4.0D-1*ycorr(nj)*yfact ! tafidbug, 0.2 created problems ! yarr(nj)=yprev+2.0D-1*ycorr(nj)*yfact ! yarr(nj)=yprev+3.0D-1*ycorr(nj)*yfact !CCI yarr(nj)=yprev+default_ionliqyfact*ycorr(nj)*yfact !CCI ! yarr(nj)=yprev+ycorr(nj)*yfact ! write(*,281)'ycorr: ',nj,yfact,yprev,yarr(nj) !281 format(a,i3,6(1pe12.4)) else yarr(nj)=yprev+ycorr(nj)*yfact endif ! if(vbug) then ! output to check reasons for bad convergence ! write(*,57)'MM y&dy ',phr(jj)%iph,phr(jj)%ics,& ! phr(jj)%stable,nj,& ! ys,cit(nj),phr(jj)%curd%yfr(nj),yarr(nj),ycorr(nj) !57 format(a,3i2,i3,5(1pe12.4)) ! endif !CCI if(yarr(nj).lt.default_ymin) then !CCI ! this added to avoid too drastic jumps in small fractions ! The test case ccrfe1.OCM needs this !CCI if(yprev.gt.default_ylow) then !CCI ! write(*,*)'Applying fraction change limitation 4 ',jj !CCI yarr(nj)=0.9*default_ylow !CCI elseif(test_phase_status_bit(phr(jj)%iph,PHGAS)) then ! for gas phase one must allow smaller constituent fractions !CCI if(yarr(nj).lt.default_ymingas) then yarr(nj)=default_ymingas endif !CCI else ! write(*,*)'Applying fraction change limitation 5 ',jj !CCI yarr(nj)=default_ymin+yvar2 !CCI yvar2=2.0D0*yvar2 if(yvar2.gt.default_upperyvar2) yvar2=default_yvar2 !CCI endif endif if(yarr(nj).gt.one) then ! write(*,*)'Applying fraction change limitation 6 ',jj yarr(nj)=one-yvar1 yvar1=2.0D0*yvar1 !CCI if(yvar1.gt.default_upperyvar1) yvar1=default_yvar1 !CCI endif enddo moody2 ! end loop for all constituents nj in phase jj ! ycormax(jj)=ycormax2 ! >>>>>>>>>>>>>>>>>> HERE the new constitution is set <<<<<<<<<<<<<<<<<<<<< ! if(meqrec%noofits.le.2) write(*,83)'dy2: ',jj,phr(jj)%iph,kk,& ! (yarr(nj),nj=1,phr(jj)%ncc) ! write(*,114)'YARR: ',jj,phr(jj)%ics,(yarr(nj),nj=1,phr(jj)%ncc) !114 format(a,2i3,8(F7.4)) ! write(*,*)'MM calling set_constitution 1:',phr(jj)%iph,phr(jj)%ics call set_constitution(phr(jj)%iph,phr(jj)%ics,yarr,qq,ceq) if(gx%bmperr.ne.0) goto 1000 ! >>>>>>>>>>>>>>>>>> for all phases <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< deallocate(cit) enddo lap ! finished correction of all constituent fractions in all phases !------------------------------------------------------- ! do jph=1,meqrec%nstph ! jj=meqrec%stphl(jph) ! write(*,393)'Stable phase: ',phr(jj)%iph,phr(jj)%ics,& ! phr(jj)%curd%amfu ! enddo !393 format(a,2i4,6(1pe12.4)) ! check if fraction corrections in stable phases increases ! it solved a problem in ReV when fractions initially changed very little ! but the change increased each iteration if(meqrec%noofits.gt.8) then ! this means minimum 8 iterations!! increase=0 elseif(abs(ysmm).gt.prevmaxycorr) then ! do this check only for the first 8 iterations increase=1 ! write(*,265)increase,ysmm,prevmaxycorr !265 format('*** max stable phase ycorr: ',i3,2(1pe12.4)) endif prevmaxycorr=abs(ysmm) !------------------------------------------------------- ! check charge balance, must be 100 times better than fractions ! otherwise strange chemical potentials, why?? ! The request for 100 times better than ceq%xconv is OK with conditions ! N(U)= N(O)= but not with N= x(O)= ! if(chargerr.gt.1.0D-2*ceq%xconv) then ! strengthen charge balance convergence criteria if(chargerr.gt.ceq%xconv) then if(ocv()) write(*,654)'Charge error: ',signerr,chargerr,ceq%xconv 654 format(a,6(1pe12.4)) if(converged.lt.6) then converged=6 cerr%mconverged=converged endif endif !------------------------------------------------------- if(converged.eq.3) then ! force one extra iterations with large fraction variations in unstable phases ! write(*,267)'End of iteration: ',meqrec%noofits,converged,& ! increase,yss,yst level3=level3+1 elseif(converged.eq.4) then ! this means large fraction variations in stable phases ! write(*,267)'End of iteration: ',meqrec%noofits,converged,& ! increase,yss,yst !267 format(a,3i4,2(1pe12.4)) level3=0 else ! write(*,267)'End of iteration: ',meqrec%noofits,converged,increase level3=0 endif !---------------------------------------------- ! continue iterate if phase change or not converged ! call get_state_var_value('X(O) ',value,phnames,ceq) ! trying to understand how STEP/MAP sets fix phases .... ! write(*,*)'MM Fraction of O: ',value if(iadd.gt.0) then ! check if phase to be added is already stable as another composition set ! This check should maybe be above as maybe another phase want to be stable?? if(same_composition(iadd,phr,meqrec,ceq,dgm)) iadd=0 endif ! check if phase iadd is stoichiometric and if so check of any stable phase ! phase that is stoichiometric has the same composition!! IF SO ! remove that phase at the same time ... srem=0 if(meqrec%nrel.gt.1 .and. iadd.gt.0) then ! skip this for unary system!!! jy=meqrec%phr(iadd)%phtupix samestoi: do nj=1,meqrec%nstph ! loop through all stable phases for other phase with same stoichiometry jj=meqrec%stphl(nj) if(jj.ne.iadd) then iy=meqrec%phr(jj)%phtupix ! check if same composition ... how? same_stoik in gtp3Y.F90 if(same_stoik(jy,iy)) then srem=jj exit samestoi endif endif enddo samestoi endif if(srem.gt.0) then jy=meqrec%phr(iadd)%phtupix call get_phasetup_name(jy,phnames) iz=len_trim(phnames)+2 call get_phasetup_name(iy,phnames(iz:)) ! write(*,*)'MM Same stoichiometry: ',trim(phnames),inmap,value ! try to handle this by calculating the T when the two stochiometric phases ! has the same Gibbs energy. Use this only if maping and T is not a condition if(inmap.ne.0) then ! inmap=0 if we are not in a step/map calculation ! I do not understand why iy and jy here ?? I think iadd and srem ... call two_stoich_same_comp(iy,jy,mapx,meqrec,inmap,ceq) endif iadd=iy; irem=jy ! write(*,*)'Phases: ',iadd,irem ! after this routine set the error code to return to mapping ! stop 'same stoichimetries' ! to be handelled either by map/step routines or meq_phaseset gx%bmperr=4364; goto 1000 endif ! if(meqrec%noofits.gt.2 .and. (irem.gt.0 .or. iadd.gt.0)) then if(irem.ne.0 .or. iadd.ne.0) then goto 1100 endif !-------------------------------------------------------------------- ! write(*,*)'Iterations and convergence: ',meqrec%noofits,converged !-------------------------------------------------------------------- ! check convergence ! if(meqrec%noofits.gt.400) then ! write(*,778)'Test converged: ',meqrec%noofits,converged !778 format(a,2i4) ! endif !------------------------------------------------------------ ! This output gives a good indication for convergence problem if(vbug) write(*,*)'Convergence criteria: ',converged,level3 ! converged=1 or 2 means constituent fraction in metastable phase not converged if(converged.gt.3) goto 100 ! converged 3 means large change conts. fraction of unstable phase change a lot ! level3 is nuber of previous iteration with converged=3 ! with allcost I had the correct equilibrium but occational converged=4 ! probably because a metastable liquid with almost identical composition ! as the stable interfeared. Accept converged=3 twice in a row as correct!! ! if(converged.eq.3 .and. level3.lt.4) goto 100 if(converged.eq.3 .and. level3.lt.2) goto 100 ! converged 4 means a constituent fraction of a stable phase change a lot ! converged=5 means a condition not fullfilled ! converged=6 means charge balance not converged or large phase fraction change ! converged=7 means large change in chemical potentials ! converged=8 means large change T or P ! always force 4 iterations, there is a minimum above forcing 9 iterations. !CCI if(meqrec%noofits.lt.default_minimaliterations) goto 100 !CCI if(increase.ne.0) then ! continue if corrections in constituent fractions in stable phases increases ! This is needed to change fractions in a gas from 1E-20 to some significant ! value goto 100 endif !------------------------ ! equilibrium calculation converged, do some common thing ! write(*,*)'Converged: ',converged goto 800 ! !============================================================== ! equilibrium calculation converged, save chemical potentials (svar*RT) 800 continue !------------------------------------------------------ ! do not save system matrix but save -dimension for use with derivatives ceq%sysmatdim=-nz1 ! but save components with fix mu and fix phases ceq%nfixmu=meqrec%nfixmu if(allocated(ceq%fixmu)) deallocate(ceq%fixmu) if(ceq%nfixmu.gt.0) then allocate(ceq%fixmu(ceq%nfixmu),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 12: ',errall gx%bmperr=4370; goto 1000 endif do ie=1,ceq%nfixmu ceq%fixmu(ie)=meqrec%mufixel(ie) enddo endif ceq%nfixph=meqrec%nfixph if(allocated(ceq%fixph)) deallocate(ceq%fixph) if(ceq%nfixph.gt.0) then allocate(ceq%fixph(2,ceq%nfixph),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 13: ',errall gx%bmperr=4370; goto 1000 endif do ie=1,ceq%nfixph ! phase and composition set numbers ceq%fixph(1,ie)=meqrec%fixph(1,ie) ceq%fixph(2,ie)=meqrec%fixph(2,ie) enddo endif !------------------------------------- if(vbug) write(*,*)'At 800 in meq_sameset: ',meqrec%nrel ceq%rtn=globaldata%rgas*ceq%tpval(1) do ie=1,meqrec%nrel ceq%complist(ie)%chempot(1)=ceq%cmuval(ie)*ceq%rtn ! write(*,*)'Chempot/RT: ',cea%cmuval(ie),svar(ie) enddo ! list stable phases on exit ! do jph=1,meqrec%nstph ! jj=meqrec%stphl(jph) ! write(*,393)'Stable phase Z: ',phr(jj)%iph,phr(jj)%ics,& ! phr(jj)%curd%amfu ! enddo ! set status of the stable phases on exit do jph=1,meqrec%nstph jj=meqrec%stphl(jph) call mark_stable_phase(phr(jj)%iph,phr(jj)%ics,ceq) ! write(*,393)'Stable phase Z: ',phr(jj)%iph,phr(jj)%ics,& ! phr(jj)%curd%amfu enddo !---------------------- ! save inverted phase matrix and more for future use when calculating H.T etc ! If already allocated then dealloc/alloc as number of constituents can change ! if(vbug) write(*,*)'allocate/deallocate in meq_sameset: ',meqrec%nphase do jj=1,meqrec%nphase if(allocated(phr(jj)%curd%cinvy)) then deallocate(phr(jj)%curd%cinvy) deallocate(phr(jj)%curd%cxmol) deallocate(phr(jj)%curd%cdxmol) endif ! why is the dimension if invmat so different??? ie=phr(jj)%idim if(vbug) write(*,*)'Save inverted phase matrix in meq_sameset: ',jj,ie ! ie=int(sqrt(real(size(phr(jj)%invmat)))+0.1) ! write(*,*)'Size: ',ie,phr(jj)%ncc allocate(phr(jj)%curd%cinvy(ie,ie),stat=errall) allocate(phr(jj)%curd%cxmol(meqrec%nrel),stat=errall) allocate(phr(jj)%curd%cdxmol(meqrec%nrel,phr(jj)%ncc),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 14: ',errall gx%bmperr=4370; goto 1000 endif phr(jj)%curd%cinvy=phr(jj)%invmat phr(jj)%curd%cxmol=phr(jj)%xmol phr(jj)%curd%cdxmol=phr(jj)%dxmol !---------------------- enddo goto 1000 ! output of equilibrium matrix when error return 990 continue do iz=1,nz1 write(*,228)'smat1:',(smat(iz,jz),jz=1,nz2) enddo ! 1000 continue if(gx%bmperr.ne.0) then ceq%status=ibset(ceq%status,EQFAIL) ! write(*,*)'minimization error: ',gx%bmperr ! elseif(irem.eq.0 .and. iadd.eq.0) then endif ! jump here if phase change 1100 continue ! trying to extract the configuratinal entropy of MQMQA ! write(*,'("MM leaving meq_sameset",1pe14.4)')sconfmqmqa ! DEBUG output for testing when phase change, Christines probkem ! write(*,*)'MM iadd and irem: ',iadd,irem ! if(iadd.gt.0) then ! jy=meqrec%phr(iadd)%phtupix ! call get_phasetup_name(jy,phnames) ! write(*,'(a,i4,2x,a,1pe12.4)')'MM found new stable phase: ',jy,& ! trim(phnames),ceq%phase_varres(phasetuple(jy)%lokvares)%dgm ! call list_conditions(kou,ceq) ! elseif(irem.ne.0) then ! jy=meqrec%phr(abs(irem))%phtupix ! call get_phasetup_name(jy,phnames) ! write(*,*)'MM found unstable phase: ',trim(phnames),jy,& ! trim(phnames),ceq%phase_varres(phasetuple(jy)%lokvares)%dgm ! call list_conditions(kou,ceq) ! endif if(vbug) write(*,*)'Deallocating smat and svar' deallocate(smat) deallocate(svar) if(vbug) write(*,*)'Final return from meq_sameset' ! if(gx%bmperr.ne.0) write(*,*)'Error return from meq_sameset',gx%bmperr ! if(irem*iadd.gt.0) write(*,*)'Leaving meq_sameset: ',irem,iadd ! write(*,*)'Exit meq_sameset' return ! too many iterations 1200 continue ! write(*,*)'Too many iterations: ',meqrec%noofits,ceq%maxiter gx%bmperr=4204 goto 1000 end subroutine meq_sameset_okmap4 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine meq_sameset_okmqmqa !\begin{verbatim} recursive subroutine meq_sameset_okmqmqa(irem,iadd,mapx,meqrec,phr,inmap,ceq) ! iterate until phase set change, converged or error (incl too many its) ! iadd = -1 indicates called from calculating a sequence of equilibria ! mapx is used when calling meq_sameset from step/map ! ! used for mqmqa ! implicit none integer irem,iadd,inmap,mapx TYPE(meq_setup) :: meqrec TYPE(meq_phase), dimension(*), target :: phr TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer increase,ioff,ik,jj,jph,ie,ierr,jmaxy integer kk,kkz,level3,mph,negam,negamph,nj,nk,nl integer nz1,nz2 TYPE(meq_phase), pointer :: pmi ! Using SAVE not possible for parallel calculations here once is just warning logical, save :: once=.true. double precision, dimension(5) :: qq double precision, dimension(maxconst) :: ycormax double precision, dimension(:,:), allocatable :: smat double precision, dimension(:), allocatable :: svar ! these arrays should maybe be allocated .... double precision, dimension(maxconst) :: ycorr,yarr integer converged,jz double precision chargefact,chargerr double precision dgm,summ,dgmmax,gsurf,phf,phs double precision prevmaxycorr,pv,signerr double precision xxx,ycormax2,yprev,ys,ysmm,ysmt,yss,yst double precision yvar1,yvar2 double precision maxphch double precision sum double precision, dimension(:), allocatable :: cit double precision deltat,deltap,deltaam,yfact ! to check if we are calculating a single almost stoichiometric phase ... integer iz,tcol,pcol,nophasechange,notagain double precision maxphasechange,molesofatoms,factconv double precision lastdeltat,deltatycond,phfmin,value integer notf,dncol,iy,jy,iremsave,phasechangeok,nextch,iremax,srem,errall character phnames*50 double precision, dimension(:), allocatable :: lastdeltaam logical vbug,stoikph,badmat !CCI integer cmix(22), cmode double precision cvalue, maxprescribed, sumprescribed, ccf(5) TYPE(gtp_condition), pointer :: conditionScale, lastcondScale !CCI ! NOTE using save cannot be reconciled with parallel calculations save notagain ! ! do not allow return unless meqrec%noofits greater or equal to nextch mapx=0 nextch=meqrec%noofits+4 stoikph=.true. nophasechange=0 maxphasechange=zero ! this is set each time the set of phases changes, controls change in T ! when there is a condition on y !CCI deltaTycond=default_deltaTycond !CCI if(iadd.eq.-1 .or. ocv()) then write(*,*)'Debug output in meq_sameset' vbug=.TRUE.; iadd=0 else vbug=.FALSE. endif ! vbug=.TRUE. if(vbug)write(*,*)'entering meq_sameset',meqrec%nphase,irem ! write(*,*)'MM entering meq_sameset',meqrec%nphase,irem iremsave=irem ! this is max correction of constituent fraction for each phases ycormax=zero ! magic trying to force decreasing step in fractions ! ymagic=one ! nmagic=0 ! this is an attempt to decrease variation in phase amount corrections allocate(lastdeltaam(meqrec%nstph),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 9: ',errall gx%bmperr=4370; goto 1000 endif lastdeltaam=zero ! dimension matrix for conditions, components+stable phases nz1=meqrec%nrel-meqrec%nfixmu+meqrec%nstph-meqrec%nfixph if(meqrec%tpindep(1)) nz1=nz1+1 if(meqrec%tpindep(2)) nz1=nz1+1 if(ocv()) write(*,11)meqrec%nrel,meqrec%nfixmu,meqrec%nstph,& meqrec%nfixph,meqrec%tpindep,nz1,ceq%tpval(1) 11 format('In meq_sameset, sysmat: ',4i7,2l2,i5,1pe12.4) nz2=nz1+1 if(vbug) write(*,*)'Allocating smat: ',nz1 allocate(smat(nz1,nz2),stat=errall) allocate(svar(nz1),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 10: ',errall gx%bmperr=4370; goto 1000 endif ! check if constituent fraction correction in stable phases increases ! for each iteration. Needed for the Re-V case .... prevmaxycorr=zero increase=0 level3=0 ! this is set TRUE after 3 iterations phasechangeok=meqrec%noofits if(phasechangeok.eq.1) then notagain=0 endif ! debugging problem with changing axis in mapping if(ocv() .and. meqrec%tpindep(1)) write(*,*)'variable T: ',ceq%tpval(1) !------------------------------------------------------------- ! return here until converged or phase set change 100 continue meqrec%noofits=meqrec%noofits+1 cerr%flag=0 ! nonzero flag means error output below ! cerr%flag=1 !CCI if(nophasechange.gt.default_nophasechange) then if(maxphasechange.lt.default_maxphaseamountchange) then !CCI ! if we have not changed the set of stable phases for many iterations ! and the changes in phase amounts is small maybe we are calculationg an ! almost stoichiometric phase? Changes in MU can be large! if(stoikph .and. meqrec%nphase.gt.1) then ! write this message if VERBOSE is set if(btest(globaldata%status,GSVERBOSE)) write(*,30)nophasechange,& converged,cerr%nvs,ceq%tpval(1) 30 format('Slow converge at ',3i3,F10.2) if(cerr%flag.ne.0) then write(*,31)(cerr%typ(iz),cerr%val(iz),cerr%dif(iz),& iz=1,cerr%nvs) 31 format('MM 31: ',3(i3,1pe12.4,e10.2)) endif ! write message only (once for each minimization) stoikph=.false. ! if this happends during step/map give error message to force smaller steps if(inmap.eq.1 .and. meqrec%noofits.eq.ceq%maxiter) then gx%bmperr=4359; goto 1000 endif endif !+ converged=0 !+ goto 1000 ! else ! maybe use this to improve concergence?? ! if(.not.allocated(loopfact)) then ! allocate(loopfact(meqrec%nrel)) ! endif endif endif nophasechange=nophasechange+1 cerr%nvs=0 cerr%mconverged=0 ! this is magic .... ! nmagic=nmagic+1 ! if(mod(nmagic,5).eq.0) ymagic=0.5*ymagic ! if(mod(nmagic,25).eq.0) ymagic=one ! end of magic !101 format(a) ! write(*,*)'Iteration: ',meqrec%noofits,' ----------------------------- ' if(ocv()) write(*,199)meqrec%noofits,ceq%tpval(1),meqrec%nstph,& (meqrec%stphl(jz),jz=1,meqrec%nstph) !199 format(/'Equil iter: ',i3,f8.2,', stable phases: ',i3,2x,10i3) 199 format(/'Equil iter: ',i3,f8.2,', stable phases: ',i3,2x,100i3) if(meqrec%noofits.gt.ceq%maxiter) then ! try to extract some more information when too many iterations write(*,1190)meqrec%noofits,ceq%maxiter,converged ! btest(globaldata%status,GSSILENT),& ! btest(globaldata%status,GSVERBOSE) 1190 format('MM Iteration: ',3i5) ! converged means ! converged=1 or 2 means constituent fraction in metastable phase not converged ! converged 3 means large change constituent fraction of unstable phase ! converged 4 means a constituent fraction of a stable phase change a lot ! converged=5 means a condition not fullfilled ! converged=6 means charge balance not converged or large phase fraction change ! converged=7 means large change in chemical potentials ! converged=8 means large change T or P ! if(btest(globaldata%status,GSSILENT)) then ! endif goto 1200 endif converged=0 if(vbug) write(*,*)'Iteration: ',meqrec%noofits,converged ! loop for all phases and composition sets, loop over phr ! if(meqrec%tpindep(1)) write(*,*)'variable T: ',meqrec%noofits,ceq%tpval(1) ! ! >>>>>>>>>>>> here we can parallelize ! !-$omp parallel do private(pmi) shared(meqrec) ! nullify liquid pointer nullify(meqrec%pmiliq) ! write(*,*)'MM meq_sameset: begin loop for all phases' parallel: do mph=1,meqrec%nphase pmi=>phr(mph) ! this routine calculates G and derivatives, the phase matrix and inverts it. ! it also calculates the amounts of moles of components in the phase !-$ write(*,*)'Phase and tread: ',mph,omp_get_thread_num() ! to set correct pmiliq we must calculate all liquids first!! ! write(*,*)'MM call onephase: ',pmi%iph,pmi%ics call meq_onephase(meqrec,pmi,ceq) ! write(*,*)'MM back from onephase: ',gx%bmperr if(gx%bmperr.ne.0) then ! using LAPCK gives severe problems if we do not stop goto 1000 if(pmi%stable.eq.0) then ! if this happends for an unstable phase just continue but ensure it will ! not be stable (in a very crude way) ! write(*,*)'Matrix inversion error for unstable phase',pmi%iph pmi%curd%gval(1,1)=one gx%bmperr=0 else ! Inversion error for stable phase is fatal, error code already set if(once) then write(*,*)'Warning, matrix inversion problem: ',pmi%iph once=.false. else goto 1000 endif gx%bmperr=0 endif endif !107 format(a,6(1pe12.3)) ! end of pmi% scope enddo parallel ! hejhopp ! write(*,*)'MM meq_sameset: end loop for all phases' !-$omp end parallel do ! !======================================================================= ! step 2: calculation of equil matrix ! Solve for chemical potentials and conditions using all stable phases ! The EQUIL MATRIX (smat) has one row for each stable phase and ! one row for each component representing a condition ! (If a fix phase condition or chem.pot. condition slightly different??) !---------------------------------------- 300 continue ! if(vbug) write(*,301)'MM Calculating general equil matrix',meqrec%nfixmu,& ! write(*,301)'MM Calculating general equil matrix',meqrec%nfixmu,& ! meqrec%nfixph,meqrec%tpindep,meqrec%noofits 301 format(a,2i2,2l2,i5) ! some arguments here are redundant but kept for some call setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,& dncol,converged,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'MM Back from setup_equilmatrix',tcol !===================================================================== ! debug output of equil matrix, last column is right hand side !380 continue ! open(33,file='eqmat.dat ',access='sequential',status='unknown') ! write(33,*)'Equilibrium matrix',nz1 ! do iz=1,nz1 ! write(33,112)iz,(smat(iz,jz),jz=1,nz2) !112 format('>',i4,1x,4(1pe15.6)) ! enddo !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> debug ! debug output to follow the minimization: all mu_i, and ! for all stable phases np^alpha, G^alpha, and x^alpha_i ! call calc_molmass(xdum,wdum,tmdum,wmdum,ceq) ! write(*,116)'MM mu:',meqrec%nstph,(ceq%cmuval(iz),iz=1,meqrec%nrel),& ! (xdum(iz),iz=1,meqrec%nrel) !116 format(a,i3,6(1pe12.4)) ! do iz=1,meqrec%nstph ! jj=meqrec%stphl(iz) ! call calc_phase_molmass(phr(jj)%iph,phr(jj)%ics,& ! xdum,wdum,tmdum,wmdum,dumdum,ceq) ! if(gx%bmperr.ne.0) stop 'debug' ! amount of phase, G of phase, x_i of phase ! write(*,116)'MM ph:',jj,phr(jj)%curd%amfu,smat(iz,nz2),& ! (xdum(ioff),ioff=1,meqrec%nrel) ! enddo ! end debug output !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> if(vbug) then ! when convergence problem list smat here and (and svar below) and study!!! call list_conditions(kou,ceq) do iz=1,nz1 write(*,228)'smat1:',(smat(iz,jz),jz=1,nz2) enddo endif 228 format(a,6(1pe12.4),(8x,6e12.4)) ! This is an emergecy check that the smat matrix does not contain ! values >default_bigvalues. We should test for Infinity and NaN but how?? do iz=1,nz1 do jz=1,nz2 !CCI if(abs(smat(iz,jz)).gt.default_bigvalues) then !CCI write(*,118)iz,jz 118 format('meq_sameset has illegal values in equilibrium matrix',2i4) gx%bmperr=4354; goto 990 endif enddo enddo ! HERE new values of chemical potentials and and amount of phases ! call lingld(nz1,nz2,smat,svar,nz1,ierr) ! goto 119 ! Rearranged the IF statements/BoS ! if(inmap.eq.0 and ceq%splitsolver .eq. 1) then !CCI !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Development based on the work of Joao Pedro Carvalho Teuber 12/2020 ! Jacobi preconditioning if allowed !BS if((inmap.eq.0).and.(ceq%splitsolver.gt.0).and.& !BS (meqrec%nrel.eq.meqrec%nstph)) then !BS call precond(nz1,nz2,smat,badmat) ! added due to problems with parallel1 and parallel2, 20200220/BoS ! PRECOND has found a zero diagonal element but just use lingld and skip split ! if(badmat) then ! write(*,112)nz1,nz2 112 format('MEQ_SAMESET: phase matrix illconditioned',2i3) ! debug output ! do iz=1,nz1 ! write(*,113)iz,(smat(iz,jz),jz=1,nz1) ! enddo 113 format(i3,20(1pe11.3)) ! call lingld(nz1,nz2,smat,svar,nz1,ierr) ! goto 119 ! end if ! endif ! if((inmap.eq.0).and.(ceq%splitsolver.gt.0).and.& ! .not.badmat .and. (meqrec%nrel.eq.meqrec%nstph)) then ! Splitting is possible for given T, P, composition and ! when the number of component is equal to the number of stable phases ! (conditions giving square mass matric) ! ís this OK if BADNAT is TRUE?? !BS if(badmat) write(*,*)'MEQ_SAMESET: matrix has a diagonal element zero' !BS call lingldSplit(nz1,nz2,smat,svar,nz1,ierr,meqrec%nrel,meqrec%nstph) !BS else ! this used when equilibrium is NOT invariant call lingld(nz1,nz2,smat,svar,nz1,ierr) !BS endif !----------------------------------------------------------------------- ! write(*,*)'MM meq_sameset: back from lingld' ! 119 continue if(ierr.ne.0) then if(vbug) write(*,*)'Error solving equil matrix 1',meqrec%noofits,ierr,& iremsave if(iremsave.gt.0) then ! parallel2 goes into a loop here when phase iremsave has been suspended ! after at has been set suspended .... fixed by not returning nonzero irem ! equil matrix wrong at first iteration after removing a phase ! This can be caused by having no phase with solubility of an element ! (happened in Fe-O-U-Zr calculation with just C1_MO2 stable and C1 does not ! dissolve Fe). Try to set back the last phase removed!! if(.not.btest(meqrec%status,MMQUIET)) then kk=meqrec%phr(iremsave)%phtupix phnames=' ' call get_phasetup_name(kk,phnames) write(*,*)'Error, restoring previously removed phase: ',& trim(phnames) endif ! NOTE: it should also be removed from the dormant list!! iadd=iremsave notagain=iremsave goto 1100 endif if(vbug) then do iz=1,nz1 write(*,228)'smat2:',(smat(iz,jz),jz=1,nz2) enddo endif ! debug output ... ! write(*,229)'ce:',meqrec%noofits ! call list_conditions(kou,ceq) ! do iz=1,nz1 ! write(*,228)'smat2:',(smat(iz,jz),jz=1,nz2) ! enddo ! gx%bmperr=4203; goto 1000 endif ! when problems output svar here !! (and smat1: above) ! write(33,*)'Solution' ! write(*,228)'PHMAT: ',(svar(jz),jz=1,nz1) ! close(33) ! write(*,228)'svar1:',(svar(jz),jz=1,nz1) if(vbug) write(*,228)'svar1:',(svar(jz),jz=1,nz1) ! ! if no error at first calculation after phase set change iremsave=0 iremsave=0 if(vbug) write(*,229)'pm: ',meqrec%noofits,(svar(iz),iz=1,nz1) ! write(*,229)'pm: ',meqrec%noofits,(svar(iz),iz=1,nz1) 229 format(a,i3,6(1pe12.4)) !--------- ! copy the chemical potentials, take care of fixed values .... ! new potentials are in svar(1..meqrec%nrel-meqrec%nfixmu) iz=1 notf=1 setmu: do ik=1,meqrec%nrel if(notf.le.meqrec%nfixmu) then if(ik.eq.meqrec%mufixel(notf)) then ! this potential is fixed, no incrementing "iz", ceq%cmuval(ik) is a condition ceq%complist(ik)%chempot(1)=meqrec%mufixval(1)*ceq%rtn notf=notf+1 cycle setmu endif endif !-------------------------------------------------------------------------- ! if(abs(svar(iz)-ceq%cmuval(ik)).gt.ceq%xconv) then ! MQMQA convergence problem fix ? ! Here ceq%xconv normally is 1.0D-6 if(abs(svar(iz)-ceq%cmuval(ik)).gt.& ! abs(1.0D4*ceq%xconv*ceq%cmuval(ik))) then abs(globaldata%mqmqa1*ceq%xconv*ceq%cmuval(ik))) then ! convergence problems with MQMQA better with a factor 1.0D4 ! By default mqmqa1 is 1.0D0, when MQMQX phase involved set to 1.0D4 ! ! MQMQA problem here with K-Li-Na/Cl with KLIN100=-25000 and N(NA)>0.6 ! changing ceq%xconv from 1.0e-6 to 0.01 fixes this problem and seems OK ! for the MQMQA case it OK over the whole composition range ! Does it work in general? Defaly ceq$xconv=1.0D-6, try 1.0D4 larger ... ! ! Tested all examples/macros/ and they worked except map11 for Cr-Fe ! modified the start equilibria and then it worked ! So I will keep this reduced convergence criteria, there are more ! important below. ! !-------------------------------------------------------------------------- ! if(vbug) write(*,387)'Unconverged pot: ',iz,ik,& ! if(nophasechange.gt.100) then ! Attempt to improve convergence for a 15 component system ... failed ! xxx=0.25D0*(3.0D0*svar(iz)+1.0D0*ceq%cmuval(ik)) xxx=globaldata%mqmqa1 ! write(*,387)'Uncnv pot: ',iz,ik,& ! svar(iz),ceq%cmuval(ik),xxx,abs(svar(iz)-ceq%cmuval(ik)),& ! abs(ceq%xconv*ceq%cmuval(ik)) 387 format(a,2i3,3(1pe14.5),2(1pe10.2)) ! take mean value ... DO NOT TRY THIS IF IT IS NOT ALMOST CONVERGED!!! ! svar(iz)=xxx ! endif converged=7 cerr%mconverged=converged !----------------------------------------- debug output start ! write(*,388)iz,ik,svar(iz),1.0D4*ceq%xconv,ceq%cmuval(ik),& ! abs(svar(iz)-ceq%cmuval(ik)),abs(1.0D4*ceq%xconv*ceq%cmuval(ik)) 388 format('MM conv=7:',2i3,5(1pe11.3)) !----------------------------------------- debug output end elseif(mqmqder) then ! Setting the mqmqa derivative bug gives this output ! debug test to discover the ratios, these do not indicate any problem write(*,389)meqrec%noofits,svar(iz),ceq%cmuval(ik),ceq%xconv,& abs(svar(iz)-ceq%cmuval(ik))/ceq%cmuval(ik) 389 format('MM convergenge 7 accuracy: ',i3,4(1pe12.4)) endif ceq%cmuval(ik)=svar(iz) ! svar(iz) is mu/RT, chemput is mu ceq%complist(ik)%chempot(1)=svar(iz)*ceq%rtn iz=iz+1 enddo setmu ioff=meqrec%nrel-meqrec%nfixmu+1 !------------ ! update T and P if variable if(meqrec%tpindep(1)) then xxx=ceq%tpval(1) ! check convergence ! write(*,*)'Delta T: ',svar(ioff),1.0D2*ceq%xconv ! if(abs(svar(ioff)).gt.1.0D2*ceq%xconv) then ! this convergece criteria needed for the CHO-gas calculation!!! ! but causes problem calculating phase diagrams ... inmap=1 for step/map ! OBS svar(ioff) is Delta T, not absolute value !CCI if(inmap.eq.0 .and. abs(svar(ioff)).gt.default_deltaT*ceq%xconv) then !CCI converged=8 cerr%mconverged=converged endif !CCI ! limit changes in T to +/- 20% of current value (see default_limitchangesT) if(abs(svar(ioff)/ceq%tpval(1)).gt.default_limitchangesT) then svar(ioff)=sign(default_limitchangesT*ceq%tpval(1),svar(ioff)) endif !CCI ! limit change in T when there is condition on y if(ycondTlimit) then deltat=svar(ioff) ! Suck it happend that svar(ioff) changed sign each iteration .... if(lastdeltat*deltat.lt.zero) then deltatycond=max(deltatycond-one,one) ! never increase during one minimization ... ! else ! deltatycond=2.5D1 endif if(abs(svar(ioff)).gt.deltatycond) then if(svar(ioff).gt.zero) then svar(ioff)=deltatycond else svar(ioff)=-deltatycond endif write(*,*)'MM ycondTlimit: ',deltat,svar(ioff) lastdeltat=svar(ioff) endif endif deltat=svar(ioff) ! limit maximum change in deltat if(abs(deltat).gt.meqrec%tpmaxdelta(1)) then deltat=sign(meqrec%tpmaxdelta(1),deltat) if(ocv()) write(*,386)'limit the change in T: ',& ceq%tpval(1),deltat,svar(ioff) 386 format(a,3(1pe12.4)) endif ceq%tpval(1)=ceq%tpval(1)+deltat ! problems here when -finit-local-zero is removed if(vbug) write(*,*)'T and deltaT:',ceq%tpval(1),deltat !CCI if(ceq%tpval(1).le.default_minimalchangesT) then write(*,*)'Attempt to set a temperature less than ',& default_minimalchangesT,' K !!!' !CCI gx%bmperr=4187; goto 1000 endif ioff=ioff+1 endif if(meqrec%tpindep(2)) then ! if pressure variable xxx=ceq%tpval(2) ! check convergence ! ??? svar(ioff) much too small!! why? add a factor ... ! svar(ioff)=1.0D2*svar(ioff) !CCI if(abs(svar(ioff)).gt.default_deltaP*ceq%xconv) then !CCI converged=8 cerr%mconverged=converged endif ! write(*,389)'HMS pv: ',ioff,converged,svar(ioff),ceq%tpval(2) !389 format(a,2i3,4(1pe12.4)) !CCI if(abs(svar(ioff)/ceq%tpval(2)).gt.default_limitchangesP) then svar(ioff)=sign(default_limitchangesP*ceq%tpval(2),svar(ioff)) endif !CCI deltap=svar(ioff) ! limit the changes in P if(abs(deltap).gt.meqrec%tpmaxdelta(2)) then deltap=sign(meqrec%tpmaxdelta(2),deltap) if(ocv()) write(*,386)'limit the change in P: ',& ceq%tpval(2),deltap,svar(ioff) endif ceq%tpval(2)=ceq%tpval(2)+svar(ioff) !CCI if(ceq%tpval(2).le.default_minimalchangesP) then !CCI write(*,*)'Attempt to set pressure lower than ',default_minimalchangesP,' Pa!!!' gx%bmperr=4187; goto 1000 endif ioff=ioff+1 endif !------------ ! update phase amounts, take care of fixed phases .... ! the change in amounts are in svar(ioff+...) negamph=0 negam=0 irem=0 iremax=0 phfmin=zero ! dncol+1 should be the first Delta_phase-amount ioff=dncol+1 ! scale all changes in phase amount with total number of atoms. At present ! assume this is unity. Without scaling phase changes can be +/-1E+11 or more ! which creates instabilities maxphch=zero ! normphchange: do jph=1,meqrec%nstph normphchange: do jph=1,meqrec%nstph-meqrec%nfixph if(abs(svar(ioff+jph-1)).gt.maxphch) maxphch=abs(svar(ioff+jph-1)) enddo normphchange !CCI ! By default, ceq%scale_change_phase_amount equals to one. ! Such a value is changed by the user in !------------------------------------------------------- !------------------------------------------------------- if(meqrec%noofits.eq.1) then if(ceq%type_change_phase_amount.gt.0) then ! whenever prescribed values are too big or differ greatly in order of magnitude ! Only cmix(1)=5 is interesting here. potentials already cared for ! loop if not the last condition ! This is the condition, cvalue is the prescibed value ! cmode and cmix contain information how to calculate its current value lastcondScale=>ceq%lastcondition conditionScale=>lastcondScale conditionScale=>conditionScale%next !--- ! loop over all conditions and stops when the pointer condition is empty ! (use of apply_condition_value subroutine in gtp3D.F90) !--- cmode=-1 cmix=0 maxprescribed = one sumprescribed = zero do while(.not.associated(conditionScale,lastcondScale)) call apply_condition_value(conditionScale,cmode,cvalue,cmix,ccf,ceq) if (cmix(1).eq.5) then cvalue = conditionScale%prescribed if (cvalue.gt. maxprescribed ) then maxprescribed = cvalue endif sumprescribed = sumprescribed + cvalue endif conditionScale=>conditionScale%next enddo sumprescribed = sumprescribed - one sumprescribed = abs(sumprescribed) if(sumprescribed.lt.one) then sumprescribed = sumprescribed + one endif if(ceq%type_change_phase_amount.eq.1) ceq%scale_change_phase_amount=sumprescribed if(ceq%type_change_phase_amount.eq.2) ceq%scale_change_phase_amount=maxprescribed else ceq%scale_change_phase_amount=default_scalechangephaseamount endif endif !------------------------------------------------------- !------------------------------------------------------- if(maxphch.gt.ceq%scale_change_phase_amount) then ioff=dncol+1 do jph=1,meqrec%nstph-meqrec%nfixph svar(ioff+jph-1)=svar(ioff+jph-1)*ceq%scale_change_phase_amount/maxphch enddo endif !CCI ! ioff=dncol+1 ! do not change phase amounts the first iteration ! write(*,554)svar !554 format('MM svar: ',6(1pe12.4)) ! if(meqrec%noofits.eq.1) then ! goto 555 ! endif phamount2: do jph=1,meqrec%nstph ! loop for all stable phases jj=meqrec%stphl(jph) ! phr(jj)%curd%damount=zero ! kkz=test_phase_status(phr(jj)%iph,phr(jj)%ics,xxx,ceq) kkz=phr(jj)%phasestatus ! new -4=hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fixed if(kkz.ge.PHENTUNST .and. kkz.le.PHENTSTAB) then ! phase is entered so its amount can change, -svar(ioff) is the change phs=phr(jj)%curd%amfu if(ioff.gt.size(svar)) then ! error here calculating Fe-Si-C with 2 phases set fix zero ! setting w(si)=w(c)=none and fix T; should have w(si) fix and T=none write(*,42)'MM Too many phases with variable amount',ioff,& size(svar),meqrec%nstph,phr(jj)%iph 42 format(a,10i4) gx%bmperr=4193; goto 1000 endif deltaam=svar(ioff) ! Sigli convergence problem, bad guess of start amount of phases?? ! NOTE sign! -deltaam is the change in amount of phase, ! write(*,43)'Deltaam: ',meqrec%noofits,jj,deltaam,lastdeltaam(jph),& ! phr(jj)%curd%amfu,phr(jj)%curd%amfu-deltaam !43 format(a,2i3,6(1pe12.4)) ! tried to avoid too large changes in phase amount, just made things worse ! if(meqrec%noofits.lt.3 .and. & ! abs(deltaam).gt.0.5D0*phr(jj)%curd%amfu) then ! deltaam=sign(0.1D0*phr(jj)%curd%amfu,deltaam) ! write(*,43)'Modified: ',meqrec%noofits,jj,deltaam ! endif ! limit change in amount of phase if(abs(deltaam).gt.ceq%xconv) then ! For the equil O-U with conditions on N(O) and N(U) there is no problem ! with the amount of C1 but with N= and x(O)= the phase amount change varies ! with sign and converges very slowly. Probably an interference with the ! charge balance criteria. if(lastdeltaam(jph)*deltaam.lt.zero) then ! wow, this seems to work ... other attmepts interfere directly with the ! charge balance so one should carefully check how they are connected... ! deltaam=5.0D-1*deltaam ! The half worked to C1+tetragonal, it did not work for ionic liquid misc. gap ! and in that case there is no charge balance criteria ... suck ! deltaam=5.0D-1*deltaam ! Dubbelt wow ... 0.2 works for both cases ... why?? More iterations though .. deltaam=2.0D-1*deltaam if(ocv()) write(*,3)'Phase amount sign change: ',& meqrec%noofits,jph,jj,phs,lastdeltaam(jph),deltaam ! write(*,3)'Phase amount sign change: ',& ! meqrec%noofits,jph,jj,phs,lastdeltaam(jph),deltaam 3 format(a,3i3,6(1pe12.4)) endif if(converged.lt.6) then converged=6 cerr%mconverged=converged endif if(vbug) write(*,381)'Phase amount change: ',meqrec%noofits,jj,& ! write(*,381)'MM Phase amount change: ',meqrec%noofits,jj,& phs,deltaam 381 format(a,2i3,4(1pe12.4)) endif lastdeltaam(jph)=deltaam if(phr(jj)%curd%amfu-deltaam.le.zero) then if(meqrec%nstph.eq.1) then ! this is the only stable phase! cannot have negative or zero amount! deltaam=phr(jj)%curd%amfu-1.0D-2 endif endif ! if(-deltaam.gt.one) then !CCI Useless if type_change_phase_amount>0 (0 also??) ! if(abs(deltaam).gt.one) then if(abs(deltaam).gt.one .and. ceq%type_change_phase_amount.eq.0) then !CCI Useless if type_change_phase_amount>0 (0 also??) ) then ! try to prevent too large increase/decrease in phase amounts. ! Should be related to total amount of components. if(.not.btest(meqrec%status,MMQUIET)) & write(*,*)'Large change in phase amount: ',deltaam ! deltaam=-one deltaam=sign(0.5D0,deltaam) endif !CCI if(abs(deltaam).gt.maxphasechange) then ! to allow checks when phase set does not change and amount changes are small ! like when calculating an almost stoichiometric composition like UO2 with ! n(o)=2 and n(u)=1 at low T maxphasechange=abs(deltaam) endif ! special test for Al-Ni fcc/fcc#2 two-phase ! Calculations with Al-Ni T=1000, x(al)=.2 gives just a single FCC phase ! possible problems that we change the amounts of the wrong composition set? ! HOWEVER, I found the error is the second derivatives are wrong!! ! if(meqrec%noofits.lt.10) deltaam=0.1*deltaam ! write(*,383)'MM phase change: ',meqrec%noofits,jj,& ! phr(jj)%iph,phr(jj)%ics,phr(jj)%curd%amfu,deltaam,svar(ioff) !383 format(a,2i3,2x,2i3,3(1pe12.4)) phf=phr(jj)%curd%amfu-deltaam if(phs.gt.0.2D0 .and. phf.le.zero) then ! violent change of phase fractions in Siglis case, liquid change from 1 to 0 ! Prevent changes larger than 0.1 if value larger than 0.5 ! old value of amfu in phs phf=0.1D0 endif ! write(*,363)' >>>> Stable phase: ',jj,phr(jj)%iph,& ! phr(jj)%ics,phf,phs,deltaam,sum 363 format(a,3i3,6(1pe12.4)) ! phr(jj)%curd%damount=deltaam ioff=ioff+1 elseif(kkz.eq.PHFIXED) then ! phase is fix, there is no change in its amounts phf=phr(jj)%curd%amfu ! write(*,*)'Fixed phase: ',jj,phf else ! phase is dormant or suspended, must not be stable!!!! call get_phase_name(phr(jj)%iph,phr(jj)%ics,phnames) if(gx%bmperr.ne.0) goto 1000 ! write(*,373)phr(jj)%iph,phr(jj)%ics,kkz ! write(*,373)trim(phnames),kkz 373 format('MM The phase ',a,' cannot vary its amount:',3i7) gx%bmperr=4194; goto 1000 endif ! problem with Fe-O-U-Zr convergence, all phases disappear ?? ! write(*,364)'Stable phase: ',meqrec%noofits,jj,phr(jj)%iph,& ! phr(jj)%ics,phf,phs,phr(jj)%prevam !364 format(a,4i3,6(1pe12.4)) ! make sure the driving force of stable phases to zero phr(jj)%curd%dgm=zero if(phf.lt.zero) then ! phase has negative amount, NOT ALLOWED if it is the only stable phase if(meqrec%nstph-meqrec%nfixph.eq.1) then ! write(*,367)'Trying to remove the only stable phase ',jj,& ! phr(jj)%curd%amfu 367 format(a,i3,1pe14.6) phf=0.5D0*phr(jj)%curd%amfu gx%bmperr=4195; goto 1000 else ! select phase with most negative amount if(phf.lt.phfmin) then phfmin=phf iremax=jj endif ! trying to improve convergence by allowing phases to be removed quicker ! write(*,363)'Phase with negative amount: ',jj,meqrec%noofits,0,& ! phf,phs,phr(jj)%prevam ! if(phf.lt.-1.0D-2) phf=zero if(jj.ne.notagain .and. phr(jj)%prevam.lt.zero) then ! remove this phase if negative amount previous iteration also irem=jj ! write(*,376)'meq_sameset remove: ',meqrec%noofits,nextch,& ! jj,notagain 376 format(a,4i4) ! jumping to 1000 here means constitutions not changed in this iteration goto 1000 else ! mark this phase had negative amount this iteration ! PROBLEM removing one of two composition sets of the same phase, ! (miscibility gap), they may change which have negative amount each iteration phr(jj)%prevam=-one phf=zero endif endif else ! phase has positive amount, mark in prevam phr(jj)%prevam=one endif ! store the new phase fraction (moles formula units) phr(jj)%curd%amfu=phf enddo phamount2 ! end of loop for jph=1,meqrec%nstph !555 continue ! ! if(iremax.gt.0) then ! write(*,*)'meq_sameset remove?',meqrec%noofits,iremax,phfmin ! endif if(vbug) write(*,*)'finished updating phase amounts: ',& meqrec%noofits,phasechangeok,irem ! if(meqrec%nfixmu.gt.0) then ! write(*,33)'mu1: ',(ceq%cmuval(nj),nj=1,meqrec%nrel) ! write(*,33)'mu2: ',(ceq%complist(nj)%chempot(1),nj=1,meqrec%nrel) ! write(*,33)'mu3: ',(ceq%complist(nj)%chempot(2),nj=1,meqrec%nrel) ! write(*,33)'mu4: ',(svar(nj),nj=1,meqrec%nrel) !33 format(a,6(1pe12.4)) ! endif !------------------------------------------------------- ! After solving the equil matrix and updating the chemical potentials, ! the phase amounts and possibly T and P we correct constitions of all phases ! - Now calculate correction of constituent fractions for all phases ! See BoJ thesis eq. 30 (also in metastable phases) (paper I) ! At the same time calculate the driving force for metastable phases ycorr=zero ycormax2=zero ! to handle charge balance correction of constituent fractions chargerr=zero ! chargerr fitted to fastest convergence using the ou test case ! chargefact=1.0D-1 requires more than 100 iterations ! chargefact=one requires more than 100 iterations ! this value requires about 40 iteration !CCI chargefact=0.5*default_chargefact !CCI ! chargefact=1.0D-1 ! kk is used to check if a charged phase is stable, ! it is incremented for each stable phase kk=1 ! iadd is set to the unstable phase with largest positive driving force ! dgmmax is the largest psoitive driving force iadd=0 dgmmax=zero ysmm=zero !----------------------------------------------------- !CCI ! Update the constitutions. If irem>0 remove this phase unless ! we have made at least 'default_noremove' (see ocparam.F90) iterations ! with the current phase set if(irem.gt.0 .and. meqrec%noofits-phasechangeok.gt.default_noremove) & goto 1000 !CCI !-------------------------- ! These are needed to avoid several phases have exactly the same fracions ! if the start guess is very bad and limitations are used yvar1=default_yvar1 yvar2=default_yvar2 !----------------------------------------- lap: do jj=1,meqrec%nphase ! The current chemical potentials are in ceq%cmuval(i) ! if(vbug) write(*,*)'Phase: ',phr(jj)%iph,phr(jj)%ics,& ! phr(jj)%curd%amfu if(jj.eq.meqrec%stphl(kk)) then ! jj is stable, increment kk but do not make it larger than meqrec%nstph ! save index in meqrec%stphl in jph !!!!!!!!!!! kk never used !!!!!!!!! jph=kk kk=min(kk+1,meqrec%nstph) ! if(meqrec%noofits.le.2) write(*,83)'dy1: ',jj,jph,kk !83 format(a,3i3,6(1pe12.4)) else ! phase is not stable ! calculate driving force for unstable phases. First calculate the sum ! of the current phase composition and the calculated chemical potentials jph=0 gsurf=zero; summ=zero do ie=1,meqrec%nrel ! fatal parallel execution error once here ! index '1' of dimension 1 of array 'phr' above upper bound of 0 gsurf=gsurf+phr(jj)%xmol(ie)*ceq%cmuval(ie) summ=summ+phr(jj)%xmol(ie) enddo gsurf=gsurf/summ ! calculate G_m plus any deltat and deltap terms dgm=phr(jj)%curd%gval(1,1) if(meqrec%tpindep(1)) then dgm=dgm+phr(jj)%curd%gval(2,1)*deltat endif if(meqrec%tpindep(2)) then dgm=dgm+phr(jj)%curd%gval(3,1)*deltap endif ! scale dgm per mole atoms molesofatoms=phr(jj)%curd%abnorm(1) if(molesofatoms.lt.0.3D0) then ! problem when a phase is stable with just vacancies !!!!!!!!!!!! if(phr(jj)%phasestatus.gt.0) then write(*,'(a,i3,a,F8.4)')'MM Phase: ',jj,& ' moles of atoms: ',molesofatoms endif endif ! dgm=gsurf-dgm/phr(jj)%curd%abnorm(1) dgm=gsurf-dgm/molesofatoms if(phr(jj)%phasestatus.gt.0) then ! we should be here only for UNSTABLE phases, phr(jj)%phasestatus<=0 ! For some reason a phase has entered/fixed status (>0) THAT IS AN ERROR ! It happened in SMP2A when mapping Al-Ni and correcting too long step in T write(*,'(a,i4,i3)')'MM phase status reset:',jj,phr(jj)%phasestatus phr(jj)%phasestatus=0 endif if(dgm.gt.dgmmax) then if(phr(jj)%phasestatus.ge.PHENTUNST .and. & phr(jj)%phasestatus.le.PHENTERED) then ! phase is entered, can have status changed ! if this is another constitution set of an already stable phase then check ! below if the constitution of this phase is very similar to the stable one iadd=jj dgmmax=dgm ! write(*,379)'meq_sameset add: ',meqrec%noofits,nextch,& ! iadd,dgmmax 379 format(a,3i4,4(1pe12.4)) endif endif ! The difference between previous and current DGM is used to check for ! convergence below. Very important to check if continue iterating!! phr(jj)%prevdg=phr(jj)%curd%dgm phr(jj)%curd%dgm=dgm endif ! Update constituent fractions for ALL phases, stable or not ! if phr(jj)%xdone=1 then phase has no composition variation if(phr(jj)%xdone.eq.1) cycle !---------------------------------------------------- allocate(cit(phr(jj)%idim),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 11: ',errall gx%bmperr=4370; goto 1000 endif cit=zero if(meqrec%tpindep(1)) then ! variable T, code copied from calc_dgdyterms, cit(nj) used below ! write(*,44)'index 1: ',jj,phr(jj)%ncc,phr(jj)%idim,& ! size(phr(jj)%invmat) do jy=1,phr(jj)%ncc sum=zero do iy=1,phr(jj)%ncc sum=sum+phr(jj)%invmat(iy,jy)*& phr(jj)%curd%dgval(2,iy,1) enddo cit(iy)=sum*deltat ! write(*,44)'index 2: ',jj,jy,iy,0,sum !44 format(a,4i3,6(1pe12.4)) enddo !! end copy ! write(*,*)'Adding contribution from variable T to delta-y',& ! phr(jj)%ncc ! missing code for correction due to variable P????? endif ! These are used to introduce some variation in fractions when the values ! exceed limits. Otherwise one can as Sigli found have two stable phases ! with exactly the same fractions and have a crash ! moody: do nj=1,phr(jj)%ncc ys=zero do nk=1,phr(jj)%ncc pv=zero do nl=1,meqrec%nrel ! ceq%cmuval(nl) is the chemical potential of element nl (divided by RT) ! phr(jj)%dxmol(nl,nk) is the derivative of component nl ! wrt constituent nk ! write(*,*)'ycorr: ',nl,ceq%complist(nl)%chempot(1)/ceq%rtn ! write(*,612)'MM y1: ',nk,nl,& ! ceq%complist(nl)%chempot(1)/ceq%rtn,ceq%cmuval(nl) !612 format(a,2i4,6(1pe12.4)) pv=pv+ceq%complist(nl)%chempot(1)/ceq%rtn*phr(jj)%dxmol(nl,nk) ! write(*,111)'pvx: ',nj,pv,ceq%complist(nl)%chempot(1),& ! ceq%rtn,phr(jj)%dxmol(nl,nk) ! pv=pv+ceq%cmuval(nl)*phr(jj)%dxmol(nl,nk) ! pv=pv+svar(nl)*phr(jj)%dxmol(nl,nk) enddo pv=pv-phr(jj)%curd%dgval(1,nk,1) ys=ys+phr(jj)%invmat(nj,nk)*pv ! write(*,111)'pvx: ',nj,ys,pv,phr(1)%curd%dgval(1,nk,1),& ! phr(1)%invmat(nj,nk) !111 format(a,i2,6(1pe12.4)) enddo if(phr(jj)%chargebal.eq.1) then ! For charged phases add a term ! phr(jj)%invmat(phr(jj)%idim,phr(jj)%idim)*Q ys=ys-chargefact*phr(jj)%invmat(nj,phr(jj)%idim)*& phr(jj)%curd%netcharge ! ys=ys-chargefact*phr(jj)%invmat(nj,phr(jj)%idim)*& ! phr(jj)%charge ! jph is nonzero only for stable phases if(jph.gt.0 .and. & ! if(jj.eq.meqrec%stphl(kk) .and. & ! Hm, is this check correct? kk is updated above to be the next stable phase.. ! abs(phr(jj)%charge).gt.chargerr) then ! chargerr=abs(phr(jj)%charge) ! signerr=phr(jj)%charge abs(phr(jj)%curd%netcharge).gt.chargerr) then chargerr=abs(phr(jj)%curd%netcharge) signerr=phr(jj)%curd%netcharge endif ! write(*,*)'Charge: ',jj,phr(jj)%netcharge else ! enshure charge is zero!! if(phr(jj)%curd%netcharge.ne.zero) & write(*,*)'MM neutral phase with charge: ',& phr(jj)%curd%phlink,phr(jj)%curd%netcharge phr(jj)%curd%netcharge=zero endif ! when T is variable ycorr(nj)=ys+cit(nj) if(abs(ycorr(nj)).gt.ycormax2) then ycormax2=ycorr(nj) endif ! Sigli converge problem, fixed by changing stable phases in different order ! write(*,111)converged,jj,nj,ys !111 format('Y corr: cc/ph/cons/y: ',i2,2i4,1pe12.4) ! should possibly be ycorr(nj) instead of ys (ycorrmax) abssys: if(abs(ys).gt.ceq%xconv) then ! if the change in any constituent fraction larger than xconv continue iterate ! write(*,*)'Convergence criteria, phase/const: ',jj,nk if(phr(jj)%stable.eq.0) then ! Phase is not stable ! Handle convergence criteria different if inmap=1 or not mapping7: if(inmap.eq.0) then !----------------------------------------- reduce indentation ! we are NOT in STEP/MAP, increase convergence criteria to handle ! the Mo-Ni-Re 3 phase equilibria !CCI if(abs(ys).gt.default_correctionfactorYS*phr(jj)%curd%yfr(nj)) then !CCI ! for unstable phases the corrections must be smaller than ...???? if(converged.lt.3) then converged=3 cerr%mconverged=converged yss=ys yst=phr(jj)%curd%yfr(nj) endif !CCI elseif(abs(ys).gt.default_correctionfactorXCONV*ceq%xconv) then !CCI !212 format(a,3i3,i4,4(1pe12.4)) if(converged.lt.4) then !CCI factconv=default_correctionfactorDGM if(phr(jj)%ncc.gt.10) then ! Calculation with the COST507 database and 20 elements too many iterations ! ... allow larger gdconv(1) factconv=10.0*factconv endif !CCI if(phr(jj)%curd%dgm-phr(jj)%prevdg.gt.& factconv*ceq%gdconv(1)) then ! Must be less than this if(phr(jj)%curd%dgm-phr(jj)%prevdg.gt.5.0E-3) then converged=4 cerr%mconverged=converged yss=ys yst=phr(jj)%curd%yfr(nj) endif endif else if(converged.eq.0) then converged=1 cerr%mconverged=converged yss=ys yst=phr(jj)%curd%yfr(nj) endif endif !----------------------- else of mapping7 else ! we are doing step/map NO CHANGE, use old convergence criteria ! otherwise step1 and mmap4 are incompatible with those above ... !CCI if(abs(ys).gt.default_correctionfactorYS*phr(jj)%curd%yfr(nj)) then ! for unstable phases the corrections must be smaller than ...???? if(converged.lt.3) then converged=3 cerr%mconverged=converged yss=ys yst=phr(jj)%curd%yfr(nj) endif elseif(abs(ys).gt.default_correctionfactorXCONV*ceq%xconv) then !CCI ! maybe accept 100 times larger correction than for stable phases ! write(*,107)'metast ph ycorr: ',ys,& ! phr(jj)%curd%yfr(nj) if(converged.lt.2) then converged=2 cerr%mconverged=converged yss=ys yst=phr(jj)%curd%yfr(nj) endif else if(converged.eq.0) then converged=1 cerr%mconverged=converged yss=ys yst=phr(jj)%curd%yfr(nj) endif endif endif mapping7 !----------------------------------- return to original indentation ! elseif of abssy elseif(converged.lt.4) then ! large correction in fraction of constituent fraction of stable phase ! Problem here with CVMSRO model, ys=0.00272 when x(b)=.5 ! write(*,*)'MM converged 4A: ',jj,nj,ys ! Problem here also with MQMQA, the KLiNa step calculation with N(Na)>.6 ! write(*,*)'MM problem 1 with MQMQA? line 2904 ignored' ! just ignoring it works OK ! converged=4 ! cerr%mconverged=converged ! yss=ys ! yst=phr(jj)%curd%yfr(nj) endif elseif(phr(jj)%stable.eq.1) then ! check to find good convergence criteria in Re-V test case if(abs(ycorr(nj)).gt.ysmm) then jmaxy=jj ysmm=abs(ycorr(nj)) ysmt=phr(jj)%curd%yfr(nj) endif ! check if the change in any fraction is larger than the fraction ... if(ycorr(nj).gt.phr(jj)%curd%yfr(nj)) then ! write(*,612)'MM y2: ',jj,nj,ycorr(nj),phr(jj)%curd%yfr(nj) if(converged.lt.4) then ! write(*,*)'MM problem 2 with MQMQA? line 2921' converged=4 cerr%mconverged=converged endif endif endif abssys enddo moody ! end of correction of y fractions !--------------------------------- ! Limit change in fractions .... all ycorr(nj) multiplied with same factor ! keeping the sum of corrections in all sublattices as zero ! if(converged.ge.4) then ! Added to underetand convergence problem with CVMSRO ! write(*,*)'MM CVMSRO convergence: ',meqrec%noofits,jj,converged ! converged=1 or 2 means constituent fraction in metastable phase not converged ! converged 3 means large change constituent fraction of unstable phase ! converged 4 means a constituent fraction of a stable phase change a lot ! converged=5 means a condition not fullfilled ! converged=6 means charge balance not converged or large phase fraction change ! converged=7 means large change in chemical potentials ! converged=8 means large change T or P ! endif if(vbug) write(*,74)'maximum corr: ',& meqrec%noofits,jj,ycormax2,ycormax(jj) 74 format(a,2i3,2(1pe12.4)) if(ycormax(jj)*ycormax2.le.zero) then ! the condition is zero at first step, limit that yfact=one/(2.0D0+abs(ycormax2)) ycormax2=yfact*ycormax2 !CCI elseif(phr(jj)%ionliq.gt.0 .and. ycormax2.lt.default_upperycormax2) then !CCI ! step seems to be very small ... try to decrease number of iteration yfact=2.0d0 else yfact=one endif moody2: do nj=1,phr(jj)%ncc ! all corrections of constituent fractions in ycorr(1..phr(jj)%ncc) ! ymagic is halfed every 5th iteration when same phase set, after 5 times reset yprev=phr(jj)%curd%yfr(nj) ! yarr(nj)=yprev+ycorr(nj) if(phr(jj)%ionliq.gt.0) then ! For ionic liquids, an even smaller step is allowed ... ! The O-Pu-U test case converged up to 2800 without any particular factor ! with a factor 0.4 it converged up to 3000K (~150 its), yfact does not ! has any significant influence. ! yarr(nj)=yprev+4.0D-1*ycorr(nj)*yfact ! tafidbug, 0.2 created problems ! yarr(nj)=yprev+2.0D-1*ycorr(nj)*yfact ! yarr(nj)=yprev+3.0D-1*ycorr(nj)*yfact !CCI yarr(nj)=yprev+default_ionliqyfact*ycorr(nj)*yfact !CCI ! yarr(nj)=yprev+ycorr(nj)*yfact ! write(*,281)'ycorr: ',nj,yfact,yprev,yarr(nj) !281 format(a,i3,6(1pe12.4)) else yarr(nj)=yprev+ycorr(nj)*yfact endif ! if(vbug) then ! output to check reasons for bad convergence ! write(*,57)'MM y&dy ',phr(jj)%iph,phr(jj)%ics,& ! phr(jj)%stable,nj,& ! ys,cit(nj),phr(jj)%curd%yfr(nj),yarr(nj),ycorr(nj) !57 format(a,3i2,i3,5(1pe12.4)) ! endif !CCI if(yarr(nj).lt.default_ymin) then !CCI ! this added to avoid too drastic jumps in small fractions ! The test case ccrfe1.OCM needs this !CCI if(yprev.gt.default_ylow) then !CCI ! write(*,*)'Applying fraction change limitation 4 ',jj !CCI yarr(nj)=0.9*default_ylow !CCI elseif(test_phase_status_bit(phr(jj)%iph,PHGAS)) then ! for gas phase one must allow smaller constituent fractions !CCI if(yarr(nj).lt.default_ymingas) then yarr(nj)=default_ymingas endif !CCI else ! write(*,*)'Applying fraction change limitation 5 ',jj !CCI yarr(nj)=default_ymin+yvar2 !CCI yvar2=2.0D0*yvar2 if(yvar2.gt.default_upperyvar2) yvar2=default_yvar2 !CCI endif endif if(yarr(nj).gt.one) then ! write(*,*)'Applying fraction change limitation 6 ',jj yarr(nj)=one-yvar1 yvar1=2.0D0*yvar1 !CCI if(yvar1.gt.default_upperyvar1) yvar1=default_yvar1 !CCI endif enddo moody2 ! end loop for all constituents nj in phase jj ! ycormax(jj)=ycormax2 ! >>>>>>>>>>>>>>>>>> HERE the new constitution is set <<<<<<<<<<<<<<<<<<<<< ! if(meqrec%noofits.le.2) write(*,83)'dy2: ',jj,phr(jj)%iph,kk,& ! (yarr(nj),nj=1,phr(jj)%ncc) ! write(*,114)'YARR: ',jj,phr(jj)%ics,(yarr(nj),nj=1,phr(jj)%ncc) !114 format(a,2i3,8(F7.4)) ! write(*,*)'MM calling set_constitution 1:',phr(jj)%iph,phr(jj)%ics call set_constitution(phr(jj)%iph,phr(jj)%ics,yarr,qq,ceq) if(gx%bmperr.ne.0) goto 1000 ! >>>>>>>>>>>>>>>>>> for all phases <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< deallocate(cit) enddo lap ! finished correction of all constituent fractions in all phases !------------------------------------------------------- ! do jph=1,meqrec%nstph ! jj=meqrec%stphl(jph) ! write(*,393)'Stable phase: ',phr(jj)%iph,phr(jj)%ics,& ! phr(jj)%curd%amfu ! enddo !393 format(a,2i4,6(1pe12.4)) ! check if fraction corrections in stable phases increases ! it solved a problem in ReV when fractions initially changed very little ! but the change increased each iteration if(meqrec%noofits.gt.8) then ! this means minimum 8 iterations!! increase=0 elseif(abs(ysmm).gt.prevmaxycorr) then ! do this check only for the first 8 iterations increase=1 ! write(*,265)increase,ysmm,prevmaxycorr !265 format('*** max stable phase ycorr: ',i3,2(1pe12.4)) endif prevmaxycorr=abs(ysmm) !------------------------------------------------------- ! check charge balance, must be 100 times better than fractions ! otherwise strange chemical potentials, why?? ! The request for 100 times better than ceq%xconv is OK with conditions ! N(U)= N(O)= but not with N= x(O)= ! if(chargerr.gt.1.0D-2*ceq%xconv) then ! strengthen charge balance convergence criteria if(chargerr.gt.ceq%xconv) then ! if(ocv()) write(*,654)'Charge error: ',signerr,chargerr,ceq%xconv write(*,654)'MM charge error: ',signerr,chargerr,ceq%xconv 654 format(a,6(1pe12.4)) if(converged.lt.6) then converged=6 cerr%mconverged=converged endif endif !------------------------------------------------------- if(converged.eq.3) then ! force one extra iterations with large fraction variations in unstable phases ! write(*,267)'End of iteration: ',meqrec%noofits,converged,& ! increase,yss,yst level3=level3+1 elseif(converged.eq.4) then ! this means large fraction variations in stable phases ! write(*,267)'End of iteration: ',meqrec%noofits,converged,& ! increase,yss,yst !267 format(a,3i4,2(1pe12.4)) level3=0 else ! write(*,267)'End of iteration: ',meqrec%noofits,converged,increase level3=0 endif !---------------------------------------------- ! continue iterate if phase change or not converged ! call get_state_var_value('X(O) ',value,phnames,ceq) ! trying to understand how STEP/MAP sets fix phases .... ! write(*,*)'MM Fraction of O: ',value if(iadd.gt.0) then ! check if phase to be added is already stable as another composition set ! This check should maybe be above as maybe another phase want to be stable?? if(same_composition(iadd,phr,meqrec,ceq,dgm)) iadd=0 endif ! check if phase iadd is stoichiometric and if so check of any stable phase ! phase that is stoichiometric has the same composition!! IF SO ! remove that phase at the same time ... srem=0 if(meqrec%nrel.gt.1 .and. iadd.gt.0) then ! skip this for unary system!!! jy=meqrec%phr(iadd)%phtupix samestoi: do nj=1,meqrec%nstph ! loop through all stable phases for other phase with same stoichiometry jj=meqrec%stphl(nj) if(jj.ne.iadd) then iy=meqrec%phr(jj)%phtupix ! check if same composition ... how? same_stoik in gtp3Y.F90 if(same_stoik(jy,iy)) then srem=jj exit samestoi endif endif enddo samestoi endif if(srem.gt.0) then jy=meqrec%phr(iadd)%phtupix call get_phasetup_name(jy,phnames) iz=len_trim(phnames)+2 call get_phasetup_name(iy,phnames(iz:)) ! write(*,*)'MM Same stoichiometry: ',trim(phnames),inmap,value ! try to handle this by calculating the T when the two stochiometric phases ! has the same Gibbs energy. Use this only if maping and T is not a condition if(inmap.ne.0) then ! inmap=0 if we are not in a step/map calculation ! I do not understand why iy and jy here ?? I think iadd and srem ... call two_stoich_same_comp(iy,jy,mapx,meqrec,inmap,ceq) endif iadd=iy; irem=jy ! write(*,*)'Phases: ',iadd,irem ! after this routine set the error code to return to mapping ! stop 'same stoichimetries' ! to be handelled either by map/step routines or meq_phaseset gx%bmperr=4364; goto 1000 endif ! if(meqrec%noofits.gt.2 .and. (irem.gt.0 .or. iadd.gt.0)) then if(irem.ne.0 .or. iadd.ne.0) then goto 1100 endif !-------------------------------------------------------------------- ! write(*,*)'Iterations and convergence: ',meqrec%noofits,converged !-------------------------------------------------------------------- ! check convergence ! if(meqrec%noofits.gt.400) then ! write(*,778)'Test converged: ',meqrec%noofits,converged !778 format(a,2i4) ! endif !------------------------------------------------------------ ! This output gives a good indication for convergence problem if(vbug) write(*,*)'Convergence criteria: ',converged,level3 ! converged=1 or 2 means constituent fraction in metastable phase not converged if(converged.gt.3) goto 100 ! converged 3 means large change conts. fraction of unstable phase change a lot ! level3 is nuber of previous iteration with converged=3 ! with allcost I had the correct equilibrium but occational converged=4 ! probably because a metastable liquid with almost identical composition ! as the stable interfeared. Accept converged=3 twice in a row as correct!! ! if(converged.eq.3 .and. level3.lt.4) goto 100 if(converged.eq.3 .and. level3.lt.2) goto 100 ! converged 4 means a constituent fraction of a stable phase change a lot ! converged=5 means a condition not fullfilled ! converged=6 means charge balance not converged or large phase fraction change ! converged=7 means large change in chemical potentials ! converged=8 means large change T or P ! always force 4 iterations, there is a minimum above forcing 9 iterations. !CCI if(meqrec%noofits.lt.default_minimaliterations) goto 100 !CCI if(increase.ne.0) then ! continue if corrections in constituent fractions in stable phases increases ! This is needed to change fractions in a gas from 1E-20 to some significant ! value goto 100 endif !------------------------ ! equilibrium calculation converged, do some common thing ! write(*,*)'Converged: ',converged goto 800 ! !============================================================== ! equilibrium calculation converged, save chemical potentials (svar*RT) 800 continue !------------------------------------------------------ ! do not save system matrix but save -dimension for use with derivatives ceq%sysmatdim=-nz1 ! but save components with fix mu and fix phases ceq%nfixmu=meqrec%nfixmu if(allocated(ceq%fixmu)) deallocate(ceq%fixmu) if(ceq%nfixmu.gt.0) then allocate(ceq%fixmu(ceq%nfixmu),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 12: ',errall gx%bmperr=4370; goto 1000 endif do ie=1,ceq%nfixmu ceq%fixmu(ie)=meqrec%mufixel(ie) enddo endif ceq%nfixph=meqrec%nfixph if(allocated(ceq%fixph)) deallocate(ceq%fixph) if(ceq%nfixph.gt.0) then allocate(ceq%fixph(2,ceq%nfixph),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 13: ',errall gx%bmperr=4370; goto 1000 endif do ie=1,ceq%nfixph ! phase and composition set numbers ceq%fixph(1,ie)=meqrec%fixph(1,ie) ceq%fixph(2,ie)=meqrec%fixph(2,ie) enddo endif !------------------------------------- if(vbug) write(*,*)'At 800 in meq_sameset: ',meqrec%nrel ceq%rtn=globaldata%rgas*ceq%tpval(1) do ie=1,meqrec%nrel ceq%complist(ie)%chempot(1)=ceq%cmuval(ie)*ceq%rtn ! write(*,*)'Chempot/RT: ',cea%cmuval(ie),svar(ie) enddo ! list stable phases on exit ! do jph=1,meqrec%nstph ! jj=meqrec%stphl(jph) ! write(*,393)'Stable phase Z: ',phr(jj)%iph,phr(jj)%ics,& ! phr(jj)%curd%amfu ! enddo ! set status of the stable phases on exit do jph=1,meqrec%nstph jj=meqrec%stphl(jph) call mark_stable_phase(phr(jj)%iph,phr(jj)%ics,ceq) ! write(*,393)'Stable phase Z: ',phr(jj)%iph,phr(jj)%ics,& ! phr(jj)%curd%amfu enddo !---------------------- ! save inverted phase matrix and more for future use when calculating H.T etc ! If already allocated then dealloc/alloc as number of constituents can change ! if(vbug) write(*,*)'allocate/deallocate in meq_sameset: ',meqrec%nphase do jj=1,meqrec%nphase if(allocated(phr(jj)%curd%cinvy)) then deallocate(phr(jj)%curd%cinvy) deallocate(phr(jj)%curd%cxmol) deallocate(phr(jj)%curd%cdxmol) endif ! why is the dimension if invmat so different??? ie=phr(jj)%idim if(vbug) write(*,*)'Save inverted phase matrix in meq_sameset: ',jj,ie ! ie=int(sqrt(real(size(phr(jj)%invmat)))+0.1) ! write(*,*)'Size: ',ie,phr(jj)%ncc allocate(phr(jj)%curd%cinvy(ie,ie),stat=errall) allocate(phr(jj)%curd%cxmol(meqrec%nrel),stat=errall) allocate(phr(jj)%curd%cdxmol(meqrec%nrel,phr(jj)%ncc),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 14: ',errall gx%bmperr=4370; goto 1000 endif phr(jj)%curd%cinvy=phr(jj)%invmat phr(jj)%curd%cxmol=phr(jj)%xmol phr(jj)%curd%cdxmol=phr(jj)%dxmol !---------------------- enddo goto 1000 ! output of equilibrium matrix when error return 990 continue do iz=1,nz1 write(*,228)'smat1:',(smat(iz,jz),jz=1,nz2) enddo ! 1000 continue if(gx%bmperr.ne.0) then ceq%status=ibset(ceq%status,EQFAIL) ! write(*,*)'minimization error: ',gx%bmperr ! elseif(irem.eq.0 .and. iadd.eq.0) then endif ! jump here if phase change 1100 continue ! trying to extract the configuratinal entropy of MQMQA ! write(*,'("MM leaving meq_sameset",1pe14.4)')sconfmqmqa ! DEBUG output for testing when phase change, Christines probkem ! write(*,*)'MM iadd and irem: ',iadd,irem ! if(iadd.gt.0) then ! jy=meqrec%phr(iadd)%phtupix ! call get_phasetup_name(jy,phnames) ! write(*,'(a,i4,2x,a,1pe12.4)')'MM found new stable phase: ',jy,& ! trim(phnames),ceq%phase_varres(phasetuple(jy)%lokvares)%dgm ! call list_conditions(kou,ceq) ! elseif(irem.ne.0) then ! jy=meqrec%phr(abs(irem))%phtupix ! call get_phasetup_name(jy,phnames) ! write(*,*)'MM found unstable phase: ',trim(phnames),jy,& ! trim(phnames),ceq%phase_varres(phasetuple(jy)%lokvares)%dgm ! call list_conditions(kou,ceq) ! endif if(vbug) write(*,*)'Deallocating smat and svar' deallocate(smat) deallocate(svar) if(vbug) write(*,*)'Final return from meq_sameset' ! if(gx%bmperr.ne.0) write(*,*)'Error return from meq_sameset',gx%bmperr ! if(irem*iadd.gt.0) write(*,*)'Leaving meq_sameset: ',irem,iadd ! write(*,*)'Exit meq_sameset' return ! too many iterations 1200 continue ! write(*,*)'Too many iterations: ',meqrec%noofits,ceq%maxiter ! if(btest(globaldata%status,GSVERBOSE)) then ! some extra indication of problem ! write(*,1210)converged 1210 format('MM why: ',i5) ! endif gx%bmperr=4204 goto 1000 end subroutine meq_sameset_okmqmqa !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine setup_comp2cons !\begin{verbatim} subroutine setup_comp2cons(meqrec,phr,nz1,smat,tval,xknown,converged,ceq) ! calculate internal equilibrium in a phase for given overall composition ! meqrec and phr contains data for phases, nz1 is dimension of equlibrium ! matrix, smat is the equilibrium matrix, tval is fixed T and P ! xknown is the overall composition TYPE(meq_setup) :: meqrec TYPE(meq_phase), dimension(*), target :: phr double precision smat(nz1,*),tval(*),xknown(*) integer nz1,converged TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} ! TYPE(gtp_condition), pointer :: condition,lastcond TYPE(meq_phase), pointer :: pmi ! cmix dimensioned for 2 terms ... integer tcol,pcol,dncol integer sel,jph,jj,ie,je,ncol integer nz2,nrow,errall double precision cvalue,totam,pham,mag,mat,map,xxx ! the next line of values are a desperate search for a solution ! double precision amount ! double precision hmval double precision, dimension(:), allocatable :: xcol,mamu ! double precision, allocatable :: xxmm(:),wwnn(:),hval(:) ! logical :: calcmolmass ! character encoded*32 !------------------------------------------------------------------- ! Formulating the equil equation in general: ! Variables (one column per variable): ! - The chemical potentials of the components: MEQREC%NREL ! minus the number of fixed chemical potentials: -MEQREC%NFIXMU ! - The variation in T if not fixed +1 ! - The variation in P if not fixed +1 ! - The variation of the amounts of stable phases: MEQREC%NSTPH ! minus those that have fixed amount: -MEQREC%NFIXPH ! ! The variables will be ordered: MU, DeltaT, DeltaP, Delta Phase amounts ! this is important for the order of columns in the equil matrix ! ! Equations (one row per equation): ! If T or P are variable extra columns and terms are needed ! - The expression for the Gibbs energy for each stable phase, M_A mu_A = G ! if a fixed chemical potentials incorporated that incorporated ! if T or P variable an extra term for these ! - The user defined conditions like: ! - Amount of components, N(A)= or B(A)= ! - The total amount of moles, N=, or mass, B= ! - Overall mole fractions, x(A)=, or mass fractions, w(A)= ! - Phase specific mole or mass fractions, x(FCC,C)= or w(LIQUID,B)= ! - The volume V=; enthalpy H= etc., with phase spec and normallizing ! - relations between state variables x(C14,Fe)-x(liq,Fe)= 0 etc. ! ! The equations will always have the G expressions first. The other will ! be random (or in order of the user entered them) ! ! There must be as many equations as there are variables and the construction ! of the equations can be rather complex. ! At present only a limited set has been implemented. ! !------------------------------------------------------------------- ! write(*,*)'MM: in comp2cons' allocate(mamu(meqrec%nrel),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 15: ',errall gx%bmperr=4370; goto 1000 endif ! goto 1000 ! zero all values in equil matrix, dimension (nz1)x(nz1) nz2=nz1+1 tcol=0 pcol=0 dncol=0 !----------------------------------------------------------- ! step 2.1 the Gibbs energies for the phases, we have just one !! ! allstableph: do jph=1,meqrec%nstph jph=1 jj=meqrec%stphl(jph) ! one column with amount of each component to be multiplied with the ! chemical potential ncol=1 xxx=zero gloop: do je=1,meqrec%nrel ! I cannot understand how smat changes columns and rows !!!! smat(1,ncol)=phr(jj)%xmol(je) ! smat(ncol,1)=phr(jj)%xmol(je) ncol=ncol+1 enddo gloop ! column nz2 is the right hand side of the equation, the molar G !? smat(jph,nz2)=phr(jj)%curd%gval(1,1) smat(1,nz2)=phr(jj)%curd%gval(1,1) !? write(*,11)'MM smat1: ',1,(smat(1,ncol),ncol=1,nz2) ! do nrow=1,nz1 ! write(*,11)'MM smat1: ',nrow,(smat(nrow,ncol),ncol=1,nz2) ! enddo !11 format(a,i2,6(1pe12.4)) !------------------------------------------------------------ ! insert code to calculate N(A)=fix for all elements in this phase ! ! case(11) ! N or X with or without indices and normalization !1100 continue nrow=1 ! conditions are N(A)=fix for all elements elloop1: do sel=1,meqrec%nrel ! Formulate equation for total amount N: ! rhs: N-N+\sum_alpha N^a + \sum_i \sum_j dM^a_A/dy_i z^a_ij dG/dy_j ! \sum_B \sum_alpha N^a \sum_i \sum_j dM^_A/dy_i dM^a_B/dy_j*z^a_ij *mu(B) ! \sum_alpha N^a \sum_i d2M^a_A/dTdy_i z^a_ij d2G/dTdy_j *deltaT ! \sum_alpha N^a \sum_i d2M^a_A/dPdy_i z^a_ij d2G/dPdy_j *deltaP ! \sum_A M^a_A *deltaN^a allocate(xcol(nz2),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 16: ',errall gx%bmperr=4370; goto 1000 endif xcol=zero ! totam=zero ! nallph: do jj=1,meqrec%nphase ! we have just one phase jj=1 pmi=>phr(jj) ! moles formula units of phase ?? pham=one ! multiply terms with the inverse phase matrix ie=sel ! MAYBE use calc_dgdyterms1X ?? call calc_dgdyterms1(meqrec%nrel,ie,meqrec%tpindep,& mamu,mag,mat,map,pmi,ceq%cmuval,meqrec%noofits) if(gx%bmperr.ne.0) goto 1000 ! the call above calculates (A is "ie", z_ij is the inverted phase matrix): ! mamu_A(B=1..nrel) = \sum_i \sum_j dM^a_A/dy_i dM^a_B/dy_j z^a_ij ! mag_A = \sum_i \sum_j dM^a_A/dy_i z^a_ij dG/dy_j ! mat_A = \sum_i \sum_j d2M^a_A/dTdy_i z^a_ij d2G/dTdy_j ! map_A = \sum_i \sum_j d2M^a_A/dPdy_i z^a_ij d2G/dPdy_j ! calculate a term for each column to be multiplied with chemical potential ! if the potential is fixed add the term to the rhs ncol=1 elloop2: do je=1,meqrec%nrel ! mamu(B) = \sum_i \sum_j \sum_A dM^a_B/dy_i dM^a_A z^a_ij xcol(ncol)=xcol(ncol)-pham*mamu(je) ncol=ncol+1 enddo elloop2 ! last columns on lhs are amounts of element ie for all stable non-fix phases ! dncol should indicate last column with potential, can be different for ! derivative, notf is set above ! Amount of component in phase ! totam=totam+pham*pmi%xmol(sel) ! pmi%xmol(sel) is the M per formula unit, not mole fraction !!!! jj=size(pmi%xmol) ! write(*,411)'xmol: ',jj,pmi%sumxmol,(pmi%xmol(ncol2),ncol2=1,jj) !411 format(a,i2,6(1pe12.4)) totam=pham*pmi%xmol(sel)/pmi%sumxmol xcol(ncol)=pham*pmi%xmol(sel) ! right hand side (rhs) contribution is ! - NP(phase)*\sum_i \sum_j dM(ie)/dy_i * dG/dy_j * z_ij xxx=xcol(nz2) ! write(*,11)'MM xxx: ',nrow+1,(xcol(je),je=1,nz2) xcol(nz2)=xcol(nz2)-pham*mag ! ! in xcol are values summed over all phases and components ! then copy summed columns to row nrow in matrix smat nrow=nrow+1 if(nrow.gt.nz1) then write(*,*)'MM too many equations 11A',nrow gx%bmperr=4212; goto 1000 endif do ncol=1,nz2 smat(nrow,ncol)=xcol(ncol) enddo deallocate(xcol) ! add N^prescribed - N^current to rhs (right hand side) ! cvalue is the prescibed composition assuming one F.U. of phase ...?? cvalue=xknown(sel) smat(nrow,nz2)=smat(nrow,nz2)-cvalue+totam ! write(*,11)'MM row: ',nrow,cvalue,totam,(smat(nrow,ncol),ncol=1,nz2) ! relative check for convergence if cvalue>1.0 conv: if(abs(totam-cvalue).gt.ceq%xconv*max(1.0d0,abs(cvalue)))then if(converged.lt.5) then converged=5 ! write(*,*)'1: converged=5',cerr%nvs cerr%mconverged=converged if(cerr%nvs.lt.10) then cerr%nvs=cerr%nvs+1 cerr%typ(cerr%nvs)=5 cerr%val(cerr%nvs)=cvalue cerr%dif(cerr%nvs)=totam-cvalue ! write(*,266)'Unconverged condition N or N(A): ',sel,cvalue,totam !266 format(a,i3,4(1pe12.4)) endif endif endif conv enddo elloop1 !---------------------------------------------------------- ! all conditions set !380 continue ! there was a strange error that the matrix had been changed on return ... ! do nrow=1,nz1 ! write(*,11)'MM smat2: ',nrow,(smat(nrow,ncol),ncol=1,nz2) ! enddo goto 1000 1000 continue return end subroutine setup_comp2cons !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine setup_equilmatrix !\begin{verbatim} subroutine setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,& dncol,converged,ceq) ! handels external conditions on extensive variables in the equil matrix ! meqrec and phr contains data for phases, nz1 is dimension of equlibrium ! matrix, smat is the equilibrium matrix, tcol and pcol are columns for ! variable T or P, dncol is the column with phase amount variables. ! converged is used to indicate calling routine and set if not converged ! external variable. TYPE(meq_setup) :: meqrec TYPE(meq_phase), dimension(*), target :: phr double precision smat(nz1,nz1+1) integer nz1,tcol,pcol,converged,dncol TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} TYPE(gtp_condition), pointer :: condition,lastcond TYPE(meq_phase), pointer :: pmi ! cmix dimensioned for 2 terms ... integer cmix(22),cmode,stvix,stvnorm,sel,sph,scs,jph,jj,ie,je,ke,ncol integer notf,nz2,nrow,nterms,mterms,moffs,ncol2,iph integer xterm,yindex,jy,errall double precision cvalue,totam,pham,mag,mat,map,xxx,zval,xval,ccf(5),evalue ! the next line of values are a desperate search for a solution double precision totalmol,totalmass,check1,check2,amount,mag1,mat1,map1 double precision hmval,gref,tpvalsave(2),cib double precision, dimension(:), allocatable :: xcol,mamu,mamu1,zcol,qmat double precision, allocatable :: xxmm(:),wwnn(:),hval(:) logical :: vbug=.FALSE.,calcmolmass,notdone,nosave double precision bbug,dvalue character encoded*32,name*32 ! For saving calculated terms in calc_dgdyterms ! type(saveddgdy), target :: savedrec ! type(saveddgdy), pointer :: saved !------------------------------------------------------------------- ! Formulating the equil equation in general: ! Variables (one column per variable): ! - The chemical potentials of the components: MEQREC%NREL ! minus the number of fixed chemical potentials: -MEQREC%NFIXMU ! - The variation in T if not fixed +1 ! - The variation in P if not fixed +1 ! - The variation of the amounts of stable phases: MEQREC%NSTPH ! minus those that have fixed amount: -MEQREC%NFIXPH ! ! The variables will be ordered: MU, DeltaT, DeltaP, Delta Phase amounts ! this is important for the order of columns in the equil matrix ! ! Equations (one row per equation): ! If T or P are variable extra columns and terms are needed ! - The expression for the Gibbs energy for each stable phase, M_A mu_A = G ! if a fixed chemical potentials incorporated that incorporated ! if T or P variable an extra term for these ! - The user defined conditions like: ! - Amount of components, N(A)= or B(A)= ! - The total amount of moles, N=, or mass, B= ! - Overall mole fractions, x(A)=, or mass fractions, w(A)= ! - Phase specific mole or mass fractions, x(FCC,C)= or w(LIQUID,B)= ! - The volume V=; enthalpy H= etc., with phase spec and normallizing ! - relations between state variables x(C14,Fe)-x(liq,Fe)= 0 etc. ! ! The equations will always have the G expressions first. The other will ! be random (or in order of the user entered them) ! ! There must be as many equations as there are variables and the construction ! of the equations can be rather complex. ! At present only a limited set has been implemented. ! ! A serious bug concerning mole fraction condition was fixed 2014.09.30 ! !------------------------------------------------------------------- ! zero all values in equil matrix, dimension (nz1)x(nz1) nz2=nz1+1 smat=zero ycondTlimit=.false. ! CCI Bugfixes by Clement Introini indicated by CCI 2018.02.20 evalue=zero ! dncol=0 ! write(*,*)'in setup_equil: ',converged,nz1,meqrec%tpindep if(converged.ge.0) then ! converged < 0 means called from dot derivative, then tcol or pcol set ! otherwise set them to zero tcol=0 pcol=0 dncol=0 ! else ! write(*,11)meqrec%nstph,dncol !11 format('setup: ',10i5) endif !----------------------------------------------------------- ! step 2.1 the Gibbs energies for the stable phases (incl fixed) allstableph: do jph=1,meqrec%nstph jj=meqrec%stphl(jph) ! if(meqrec%noofits.le.2) & ! write(*,12)'pha: ',jph,meqrec%nstph,jj,& ! phr(jj)%iph,phr(jj)%ics,& ! phr(jj)%curd%amfu,phr(jj)%curd%gval(1,1) !12 format(a,5i3,6(1pe12.4)) ! column nz2 is the right hand side of the equation, to molar G smat(jph,nz2)=phr(jj)%curd%gval(1,1) ! write(*,313)'Gm: ',0,0,jph,nz2,smat(jph,nz2),ceq%tpval(1) ! one column with amount of component A for each variable chemical potential ! components with fixed chemical potential are automatically skipped ncol=1 xxx=zero gloop: do je=1,meqrec%nrel do ke=1,meqrec%nfixmu if(meqrec%mufixel(ke).eq.je) then ! meqrec%mufixel(ke) is the component number with fix chemical potential ! DONE: reference state must be handelled (may depend on T) ?? ! !--------------------------------------------------------- ! handling of user defined reference states for components iph=ceq%complist(je)%phlink if(iph.gt.0) then ! lokph is index of phase record, to get phase index use phlink .... ! iph=ceq%phase_varres(lokph)%phlink ! write(*,34)'MM refst: ',je,ke,iph,ceq%complist(je)%endmember 34 format(a,3i4,4x,10i3) ! we must also handle reference state at fix T !! tpvalsave=ceq%tpval ! write(*,*)'MM calling calcg_endmember 2: ',-iph call calcg_endmember(-iph,ceq%complist(je)%endmember,& gref,ceq) if(gx%bmperr.ne.0) then write(*,*)'MM error calculating reference state' ceq%tpval=tpvalsave goto 1000 endif ! this is only place where we need to use %mufixvalref ! mufixval should be referred to SER, mufixvalref prescribed value for user ref meqrec%mufixval(ke)=meqrec%mufixvalref(ke)+gref ! write(*,35)'MM gref: ',ke,meqrec%mufixvalref(ke),gref,& ! meqrec%mufixval(ke) 35 format(a,i3,6(1pe12.4)) ! also copy to cmuval !!?? YES !!! ceq%cmuval(je)=meqrec%mufixval(ke) ! else ! write(*,*)'No userdefined reference state' endif !--------------------------------------------------------- ! xxx=smat(jph,nz2) smat(jph,nz2)=smat(jph,nz2)-& phr(jj)%xmol(je)*meqrec%mufixval(ke) ! write(*,312)'fix mu G: ',jj,je,ke,xxx,smat(jph,nz2),& ! phr(jj)%xmol(je),meqrec%mufixval(ke) 312 format(a,3i3,6(1pe12.4)) cycle gloop endif enddo smat(jph,ncol)=phr(jj)%xmol(je) ncol=ncol+1 enddo gloop ! write(*,*)'MM dncol: ',ncol,dncol,meqrec%tpindep ! variable T and P? if(meqrec%tpindep(1)) then ! column for variable T, value is -dG/dT ?? if(tcol.eq.0) then tcol=ncol dncol=ncol ncol=ncol+1 endif smat(jph,tcol)=-phr(jj)%curd%gval(2,1) endif if(meqrec%tpindep(2)) then ! column for variable P, value is +dG/dP ?? if(pcol.eq.0) then pcol=ncol dncol=ncol ncol=ncol+1 endif ! PVARIABLE in G smat(jph,pcol)=-phr(jj)%curd%gval(3,1) endif ! if(meqrec%noofits.le.2) & ! write(*,13)'Row: ',jph,jj,(smat(jph,je),je=1,nz2) !13 format(a,2i2,7(1pe10.2)) enddo allstableph ! we have generated meqrec%nstph rows with ncol columns and rhs in column nz2 ! The columns for delta_phase-amounts should be zero ! dncol is number of variable potentials (including T or P if variable) if(dncol.eq.0) dncol=ncol-1 ! do iz=1,dncol ! write(*,228)'smat 1: ',(smat(iz,jz),jz=1,nz2) ! enddo !228 format(a,6(1pe12.4)) ! nrow=meqrec%nstph !------------------------------------------------------------------- ! step 2.2 equations due to user conditions on extensive/normalizzed properties ! nz2 is number of columns, last column is right hand side (rhs) ! nrow is number of nows already filled (G for stable ph) ! nz2=nz1+1 ! ! >>>>>>>>>>> THIS IS UNFINISHED, ONLY A FEW STATE VARIABLES ALLOWED ! expressions only for N and x and H ... added V mm ... y 190720 ! nrow=meqrec%nstph lastcond=>ceq%lastcondition condition=>lastcond allocate(mamu(meqrec%nrel),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 17: ',errall gx%bmperr=4370; goto 1000 endif ! for saving partial dgdyterms, set nosave=.TRUE. to use old calc_dgdyterms1 ! nosave=.TRUE. ! nosave always FALSE as there are places to save results in phase_varres nosave=.FALSE. ! savedrec%sameit=0 ! saved=>savedrec 350 continue ! cmode=0 means calculate and return current value cmode=0 cmix=0 condition=>condition%next ! This is the condition, cvalue is the prescibed value ! cmode and cmix contain information how to calculate its current value ! write(*,*)'MM calling apply',condition%noofterms ! apply_condition in gtp3X.F90 ?? call apply_condition_value(condition,cmode,cvalue,cmix,ccf,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,71)'MM apply 2: ',cmode,cvalue,cmix,ccf(1) 71 format(a,i3,1pe12.4,22i4,1pe12.4) ! if(condition%noofterms.gt.1) write(*,351)nrow,cmode,cmix,nterms,cvalue,& ! (ccf(jj),jj=1,condition%noofterms) ! Only cmix(1)=5 is interesting here. potentials already cared for if(cmix(1).ne.5) then ! loop if not the last condition ! write(*,*)'Taking next condition: ',cmix(1) if(.not.associated(condition,lastcond)) goto 350 goto 380 endif ! check if several terms mterms=1 nterms=condition%noofterms ! do something with the condition ... it can be N=1, x(A)=.1, VM(GAS)=1e-6 etc. ! THE MASTER VERSION OF THIS TABLE in PMOD25C.F90 ! symb cmix(2) indices irrelevant Property ! U 10 (phase#set) 6 Internal energy (J) ! UM 11 " 6 per mole components ! UW 12 " 6 per kg ! UV 13 " 6 per m3 ! UF 14 " 6 per formula unit ! S 2x " 7 entropy ! V 3x " 8 volume ! H 4x " 9 enthalpy ! A 5x " 10 Helmholtz energy ! G 6x " 11 Gibbs energy ! NP 7x " 12 moles of phase ! BP 8x " 13 mass of moles ! DG 9x " 15 Driving force ! Q 10x " 14 Internal stability ! N 11x (component/phase#set,component) 16 moles of components ! X 111 " 17 mole fraction of components ! B 12x " 18 mass of components ! W 122 " 19 mass fraction of components ! Y 13 phase#set,constituent#subl 20 constituent fraction !----- model variables <<<< these now treated differently stvix=cmix(2)/10 ! stvnorm is normalization, 0, 1, 2, 3 or 4 ! 0=none; 1=per mole; 2=per mass; 3=per volume; 4=per formula unit stvnorm=mod(cmix(2),10) select case(stvix) case default write(*,*)'not a condition:',stvix,stvnorm,cmix(1),cmix(2),cmix(3) gx%bmperr=4208; goto 1000 case(1,5) ! stvix=1..6: U, S, V, H, A, G, some conditions not implemented ! 1 2 3 4 5 6 write(*,*)'Not implemented yet: ',stvix,stvnorm gx%bmperr=4207; goto 1000 !------------------------------------------------------------------ ! Entropy for system or phase(s) case(2) ! S entropy condition write(*,*)'MM entropy condition testing: ',nterms,nrow,nz1 if(stvnorm.eq.0) then ! not normallized if(cmix(3).eq.0) then ! condition is S=value sph=0 else ! condition is S(phase#set)=value sph=cmix(3); scs=cmix(4) endif write(*,*)'MM not normallized entropy conditions not implemented' gx%bmperr=4207; goto 1000 else ! entropy difference: to use the condition SM(solid)-SM(liquid)=0 ! for equientropy lines ... ! s1-s2=0: delta-s = ds/dT dT + ds/dy dy + ... = 0 xterm=3 xxx=zero ! calculate and store the drivatives in xcol ! How to know wich is the independent for each index? ! SEE HOW A V condition is calculated below!! allocate(xcol(nz2),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 18: ',errall gx%bmperr=4370; goto 1000 endif 220 continue if(mterms.le.nterms) then ! loop over ALL phases sph=cmix(xterm); scs=cmix(xterm+1) do jph=1,meqrec%nphase if(phr(jph)%iph.eq.sph .and. phr(jph)%ics.eq.scs) then ! extract the value of SM for phase in mterms ! write(*,*)'MM: sph,scs: ',mterms,xterm,sph,scs xxx=xxx+ccf(mterms)*phr(sph)%curd%gval(2,1)/& phr(sph)%curd%abnorm(1) write(*,230)'MM S: ',ccf(mterms),phr(sph)%curd%gval(2,1),& phr(sph)%curd%abnorm(1),phr(sph)%curd%amfu,xxx 230 format(a,6(1pe12.4)) xterm=xterm+4 mterms=mterms+1 goto 220 endif enddo write(*,*)'MM cannot find phase for EEC',mterms gx%bmperr=4399; goto 1000 endif endif nrow=nrow+1 write(*,230)'MM equientropy: ',ceq%tpval(1),cvalue,xxx smat(nrow,1)=xxx ! gx%bmperr=4207; goto 1000 !------------------------------------------------------------------ case(3) ! V volume condition, almost the same a H condition ! Volume for system or phase, NOT normallized if(stvnorm.eq.0) then ! not normallized if(cmix(3).eq.0) then ! condition is V=value sph=0 else ! condition is V(phase#set)=value sph=cmix(3); scs=cmix(4) endif ! FU(alpha) is formula units of alpha phase, V=\sum_alpha VM(alpha) VM(alpha) ! dVM(alpha) = d2GM/dPdy_i*c_iA*\mu_A+ ! \sum_i dGM/dP*dP + ?? ! \sum_alpha ??? ! UNFINISHED ?? allocate(xcol(nz2),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 19: ',errall gx%bmperr=4370; goto 1000 endif xcol=zero totam=zero notf=0 check1=zero check2=zero notdone=.TRUE. vallph: do jph=1,meqrec%nstph ! sum over all stable phases jj=meqrec%stphl(jph) pmi=>phr(jj) ! if phase is not fixed there is a column in xcol for variable amount ! This has to be done before loop of elements if(pmi%phasestatus.ne.PHFIXED) notf=notf+1 if(sph.gt.0) then ! if a phase is specified, skip all other phases if(.not.(sph.eq.phr(jj)%iph .and. scs.eq.phr(jj)%ics)) & cycle vallph endif ! moles formula unit of phase pham=pmi%curd%amfu allocate(hval(pmi%ncc),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 20: ',errall gx%bmperr=4370; goto 1000 endif notdone=.FALSE. if(.not.allocated(mamu1)) then ! it will be deallocated when leaving this subroutine ?? allocate(mamu1((meqrec%nrel)),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 21: ',errall gx%bmperr=4370; goto 1000 endif endif ncol=1 if(stvix.eq.3) then ! V condition, calculate the terms d2G/dPdy_i for all constituents do ie=1,pmi%ncc hval(ie)=pmi%curd%dgval(3,ie,1) enddo ! write(*,*)'Volume condition: ',pcol,pmi%ncc,hval(1) endif ! write(*,75)'hval: ',hval ! write(*,75)'cmuvamanyl: ',(ceq%cmuval(ie),ie=1,meqrec%nrel) ! calculate the terms to be multiplied with the unknown mu(ie) vallel: do ie=1,meqrec%nrel ! multiply terms with the inverse phase matrix and hval() ! but also return values without this in mamu1,mag1,mat1 and map1 needed ! for normalization and if there is a condition on chemical potentials call calc_dgdytermshm(meqrec%nrel,ie,meqrec%tpindep,hval,& mamu,mag,mat,map,mamu1,mag1,mat1,map1,& pmi,ceq%cmuval,meqrec%noofits) if(gx%bmperr.ne.0) goto 1000 ! calculate a term for each column to be multiplied with chemical potential ! if the potential is fixed add the term to the rhs do ke=1,meqrec%nfixmu if(meqrec%mufixel(ke).eq.ie) then ! components with fix chemical potential added to rhs, do not increment ncol!!! xcol(nz2)=xcol(nz2) + pham*meqrec%mufixval(ke)*mamu(ie) ! write(*,102)'fix mu V:',nz2,ie,pham,& ! meqrec%mufixval(ke),mamu1(ie),& ! pham*meqrec%mufixval(ke)*mamu1(ie),xcol(nz2) cycle vallel endif enddo xcol(ncol)=xcol(ncol) - pham*mamu(ie) ncol=ncol+1 enddo vallel ! vallel loop should end here as mat and map are element independent ! If T or P are variable, mat and map include \sum_j hval(j) if(tcol.gt.0) then xxx=xcol(tcol) ! gval(2,1) is dG/dT, gval(4,1) is d2G/dT2, gval(5,1) is d2G/dTdP=dV/dT xcol(tcol)=xcol(tcol)+& 2.0D-3*pham*(ceq%tpval(1)*pmi%curd%gval(5,1)-mat) ! Why is d2G/dTdP multiplied by T?? ! >500 its 1.0D-3*pham*(ceq%tpval(1)*pmi%curd%gval(5,1)-mat) ! 27 its 2.0D-3*pham*(ceq%tpval(1)*pmi%curd%gval(5,1)-mat) ! 80 its 5.0D-3*pham*(ceq%tpval(1)*pmi%curd%gval(5,1)-mat) ! 158 its 1.0D-2*pham*(ceq%tpval(1)*pmi%curd%gval(5,1)-mat) ! slow pham*(ceq%tpval(1)*pmi%curd%gval(5,1)-mat) ! bad pham*ceq%tpval(1)*(ceq%tpval(1)*pmi%curd%gval(5,1)-mat) ! slow pham*(ceq%tpval(1)*pmi%curd%gval(5,1)-mat) ! wrong pham*(mat-ceq%tpval(1)*pmi%curd%gval(5,1)) ! write(*,*)'VCONDT: ',tcol,xcol(tcol) endif ! PVARIABLE for condition on V if(pcol.gt.0) then xxx=xcol(pcol) ! gval(3,1) is dG/dP, gval(6,1) is d2G/dP2, sign??? xcol(pcol)=xcol(pcol)+pham*(pmi%curd%gval(6,1)-map) ! xcol(pcol)=xcol(pcol)+pham*(map-pmi%curd%gval(6,1)) ! pmi%curd%gval(3,1)-ceq%tpval(1)*pmi%curd%gval(5,1)) ! write(*,*)'VCONDP: ',pcol,xcol(pcol) endif ! uncertain if enddo hallel here or after label 7000 above ... deallocate(hval) if(stvix.eq.3) then ! sum the total volume (or for a single phase its volume) ! slow totam=totam+pham*pmi%curd%gval(3,1) ! totam=totam+pham*pmi%curd%gval(3,1) totam=totam+pham*pmi%curd%gval(3,1) ! wrong totam=totam+pham*pmi%curd%gval(3,1)*ceq%rtn endif ! Now the term multipled with change of the amount of the phase if(pmi%phasestatus.ne.PHFIXED) then xcol(dncol+notf)=pmi%curd%gval(3,1) endif ! term to the RHS, sign??? xcol(nz2)=xcol(nz2)+pham*mag ! slow xcol(nz2)=xcol(nz2)+pham*mag ! as slow xcol(nz2)=xcol(nz2)-pham*mag enddo vallph if(sph.gt.0 .and. notdone) then ! if sph.ne.0 it is possible that the specified phase is not stable, check that ! the vallph loop has beed done at least once write(*,*)'Unnormalized volume condition of unstable phase' ! These values are most probably all zero making system matrix singular write(*,177)'xcol: ',nz2,(xcol(jj),jj=1,nz2) gx%bmperr=4196; goto 1000 endif ! Add difference to the RHS. Totam is summed above, cvalue is prescribed value ! write(*,74)'Volume: ',nrow+1,ceq%tpval(1),ceq%rtn,& ! xcol(nz2),totam,cvalue/ceq%rtn ! sign? xcol(nz2)=xcol(nz2)+totam-cvalue/ceq%rtn xcol(nz2)=xcol(nz2)-totam+cvalue/ceq%rtn ! xcol(nz2)=xcol(nz2)-totam+cvalue ! write(*,75)'RHS: ',xcol(nz2),totam,cvalue/ceq%rtn,ceq%rtn,& ! totam*ceq%rtn,ceq%tpval(1) ! test if condition converged, use relative error ! slow if(abs(totam-cvalue/ceq%rtn).gt.ceq%xconv*abs(cvalue)) then if(abs(totam-cvalue/ceq%rtn).gt.ceq%xconv*abs(cvalue)) then ! if(abs(totam-cvalue).gt.ceq%xconv*abs(cvalue)) then ! write(*,75)'Unconverged volume: ',ceq%tpval(1),& ! if(vbug) write(*,75)'Unconverged volume: ',ceq%tpval(1),& ! write(*,75)'Unconverged volume: ',ceq%tpval(1),& ! totam,cvalue,totam-cvalue,ceq%xconv*abs(cvalue) ! totam,cvalue/ceq%rtn,totam-cvalue/ceq%rtn if(converged.lt.5) then converged=5 ! write(*,*)'2: converged=5',cerr%nvs cerr%mconverged=converged if(cerr%nvs.lt.10) then cerr%nvs=cerr%nvs+1 cerr%typ(cerr%nvs)=5 cerr%val(cerr%nvs)=cvalue cerr%dif(cerr%nvs)=totam-cvalue endif endif endif ! we have one more equation to add to the equilibrium matrix nrow=nrow+1 if(nrow.gt.nz1) stop 'MM too many equations 5A' do ncol=1,nz2 smat(nrow,ncol)=xcol(ncol) enddo deallocate(xcol) else ! volume is normalized write(*,*)'Normalized volume condition not implemented yet' gx%bmperr=4207; goto 1000 endif !------------------------------------------------------------------ case(4) ! Enthaly condition (Heat balance). ! Enthalpy for system or phase, normallized or not ! gx%bmperr=4207; goto 1000 if(stvnorm.eq.0) then ! not normallized if(cmix(3).eq.0) then ! condition is H=value or V=value sph=0 else ! condition is H(phase#set)=value or V(phase#set)=value sph=cmix(3); scs=cmix(4) endif ! FU(alpha) is formula units of alpha phase ! dH=\sum_alpha FU(alpha)(dG/y_i-Td2G/dTdy_i)*c_iA*\mu_A + ! (-Td2G/dT2 + \sum_i (dG/dy_i - Td2G/dTdY_i)*c_iT)*dT + ... ! +\sum_alpha (G-TdG/dT)*\delta FU(alpha) = ! \sum_alpha FU(alpha)\sum_i(dG/dy_i-Td2G/dTdy_i)*c_iG + H\tilde - H ! write(*,*)'Condition on H: ',pmi%ncc,dncol ! dV = \sum_alpha FU(alpha)(d2G/dPdy_i)*c_iA*\mu_A+ ! \sum_i dG/dP*dP + ?? ! \sum_alpha ??? ! Condition H=value and H(phase)=value are OK, HM=value is NOT OK Why?? !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ allocate(xcol(nz2),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 22: ',errall gx%bmperr=4370; goto 1000 endif xcol=zero totam=zero notf=0 check1=zero check2=zero notdone=.TRUE. hallph: do jph=1,meqrec%nstph ! sum over all stable phases jj=meqrec%stphl(jph) pmi=>phr(jj) ! if phase is not fixed there is a column in xcol for variable amount ! This has to be done before loop of elements if(pmi%phasestatus.ne.PHFIXED) notf=notf+1 if(sph.gt.0) then ! if a phase is specified, skip all other phases if(.not.(sph.eq.phr(jj)%iph .and. scs.eq.phr(jj)%ics)) & cycle hallph endif ! moles formula unit of phase pham=pmi%curd%amfu allocate(hval(pmi%ncc),stat=errall) notdone=.FALSE. if(.not.allocated(mamu1)) then ! it will be deallocated when leaving this subroutine ?? allocate(mamu1((meqrec%nrel)),stat=errall) endif if(errall.ne.0) then write(*,*)'MM Allocation error 23: ',errall gx%bmperr=4370; goto 1000 endif ncol=1 if(stvix.eq.3) then ! V condition, calculate the terms d2G/dPdy_i for all constituents ! THIS IS REDUNDANT, V HAS ITIS OWN CASE NOW do ie=1,pmi%ncc hval(ie)=pmi%curd%dgval(3,ie,1) enddo ! write(*,*)'Volume condition: ',pcol,pmi%ncc,hval(1) else ! H condition, calculate the terms dG/dy_i - T*d2G/dTdy_i for all constituents do ie=1,pmi%ncc hval(ie)=pmi%curd%dgval(1,ie,1)-& ceq%tpval(1)*pmi%curd%dgval(2,ie,1) enddo ! write(*,*)'Enthalpy condition: ',tcol,hval(1) endif ! write(*,75)'hval: ',hval ! write(*,75)'cmuvamanyl: ',(ceq%cmuval(ie),ie=1,meqrec%nrel) ! calculate the terms to be multiplied with the unknown mu(ie) hallel: do ie=1,meqrec%nrel ! multiply terms with the inverse phase matrix and hval() ! but also return values without this in mamu1,mag1,mat1 and map1 needed ! for normalization and if there is a condition on chemical potentials call calc_dgdytermshm(meqrec%nrel,ie,meqrec%tpindep,hval,& mamu,mag,mat,map,mamu1,mag1,mat1,map1,& pmi,ceq%cmuval,meqrec%noofits) if(gx%bmperr.ne.0) goto 1000 ! write(*,99)'hfix 1: ',ceq%tpval(1),mag,mat,map,mamu 99 format(a,6(1pe12.4)) ! calculate a term for each column to be multiplied with chemical potential ! if the potential is fixed add the term to the rhs do ke=1,meqrec%nfixmu if(meqrec%mufixel(ke).eq.ie) then ! components with fix chemical potential added to rhs, do not increment ncol!!! xcol(nz2)=xcol(nz2) + pham*meqrec%mufixval(ke)*mamu(ie) ! write(*,102)'fix mu H6:',nz2,ie,pham,& ! meqrec%mufixval(ke),mamu1(ie),& ! pham*meqrec%mufixval(ke)*mamu1(ie),xcol(nz2) 102 format(a,2i3,6(1pe12.4)) cycle hallel endif enddo xcol(ncol)=xcol(ncol) - pham*mamu(ie) ncol=ncol+1 enddo hallel ! I think hallel loop should end here as mat and map are element independent ! If T or P are variable, mat and map include \sum_j hval(j) if(tcol.gt.0) then xxx=xcol(tcol) ! gval(2,1) is dG/dT, gval(4,1) is d2G/dT2, sign???? xcol(tcol)=xcol(tcol)+& pham*(ceq%tpval(1)*pmi%curd%gval(4,1)-mat) endif ! PVARIABLE condition on H if(pcol.gt.0) then xxx=xcol(pcol) ! gval(3,1) is dG/dP, gval(5,1) is d2G/dTdP, sign??? xcol(pcol)=xcol(pcol)+pham*(pmi%curd%gval(3,1)-map) ! xcol(pcol)=xcol(pcol)+pham*(map-& ! pmi%curd%gval(3,1)-ceq%tpval(1)*pmi%curd%gval(5,1)) !>> xcol(pcol)=xcol(pcol)-pham*(map-& ! pmi%curd%gval(3,1)+ceq%tpval(1)*pmi%curd%gval(5,1)) ! write(*,363)'d2G/dPdy: H',nrow+1,ie,pcol,& ! xxx,xcol(pcol),pham,mat endif ! uncertain if enddo hallel here or after label 7000 above ... ! enddo hallel ! hval no longer needed deallocate(hval) if(stvix.eq.3) then ! sum the total volune (or for a single phase its volume) totam=totam+pham*pmi%curd%gval(3,1) ! write(*,211)'HMS total volume:',totam,ceq%rtn*totam,cvalue 211 format(a,5(1pe12.4)) else ! Sum the total enthalpy (for a single phase just one value) totam=totam+pham*(pmi%curd%gval(1,1)-& ceq%tpval(1)*pmi%curd%gval(2,1)) ! write(*,73)'pham: ',sph,jj,pham,totam,ceq%cmuval(1),ceq%cmuval(2) endif ! Now the term multipled with change of the amount of the phase if(pmi%phasestatus.ne.PHFIXED) then xcol(dncol+notf)=pmi%curd%gval(1,1)-& ceq%tpval(1)*pmi%curd%gval(2,1) endif ! term to the RHS, sign??? ! xcol(nz2)=xcol(nz2)-pham*mag xcol(nz2)=xcol(nz2)+pham*mag ! write(*,76)'Check2: ',jj,pham,mag,pham*mag enddo hallph if(sph.gt.0 .and. notdone) then ! if sph.ne.0 it is possible that the specified phase is not stable, check that ! the hallph loop has beed done at least once write(*,*)'Unnormalized enthalpy condition of unstable phase' ! These values are most probably all zero making system matrix singular write(*,177)'xcol: ',nz2,(xcol(jj),jj=1,nz2) 177 format(a,i2,6(1pe10.2)) gx%bmperr=4196; goto 1000 endif ! write(*,177)'xcol: ',nz2,(xcol(jj),jj=1,nz2) ! Add difference to the RHS. Totam is summed above, cvalue is prescribed value ! write(*,74)'Enthalpy: ',nrow+1,ceq%tpval(1),ceq%rtn,& ! xcol(nz2),totam,cvalue/ceq%rtn xcol(nz2)=xcol(nz2)+totam-cvalue/ceq%rtn ! write(*,75)'RHS: ',xcol(nz2),totam,cvalue,ceq%rtn,cvalue/ceq%rtn ! test if condition converged, use relative error if(abs(totam-cvalue/ceq%rtn).gt.ceq%xconv*abs(cvalue)) then ! write(*,75)'Unconverged enthalpy: ',ceq%tpval(1),& ! totam,cvalue/ceq%rtn,totam-cvalue/ceq%rtn if(converged.lt.5) then converged=5 ! write(*,*)'3: converged=5',cerr%nvs cerr%mconverged=converged if(cerr%nvs.lt.10) then cerr%nvs=cerr%nvs+1 cerr%typ(cerr%nvs)=5 cerr%val(cerr%nvs)=cvalue/ceq%rtn cerr%dif(cerr%nvs)=totam-cvalue/ceq%rtn endif endif endif ! we have one more equation to add to the equilibrium matrix nrow=nrow+1 if(nrow.gt.nz1) stop 'MM too many equations 5A' do ncol=1,nz2 smat(nrow,ncol)=xcol(ncol) enddo ! write(*,*)'H conv: ',ceq%tpval(1) ! write(*,74)'hline: ',nrow,xcol 75 format(a,6(1pe12.4)) 74 format(a,i2,6(1pe11.3)) 73 format(a,2i3,6(1pe11.3)) ! check1 and check2 should be equal if we set H as current value and release T ! write(*,75)'Check: ',check1,check2 deallocate(xcol) ! .......................................................... else ! normallized HM (per mole, 1), HW (per mass, 2) or HV (per volume, 3) ! write(*,*)'*** Normallized enthalpy not yet implemented as condition' ! gx%bmperr=4207; goto 1000 ! UNFINISHED if(stvnorm.ne.1) then write(*,*)'Only normallizing per mole implemented' gx%bmperr=4207; goto 1000 endif ! ie=0 means no element specification ie=0 if(cmix(3).eq.0) then ! condition is HM=value sph=0 else ! condition is HM(phase#set)=value ! UNFINISHED, does not converge ! gx%bmperr=4207; goto 1000 sph=cmix(3); scs=cmix(4) endif ! dH=\sum_alpha FU(alpha)(dG/y_i-Td2G/dTdy_i)c_iA\mu_A + ! (-Td2G/dT2 + \sum_i (dG/dy_i - Td2G/dTdY_i)c_iT)dT + ... ! +\sum_alpha (G-TdG/dT)\delta FU(alpha) = ! \sum_alpha FU(alpha)\sum_i(dG/dy_i-Td2G/dTdy_i)c_iG + H-\tilde H allocate(xcol(nz2),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 24: ',errall gx%bmperr=4370; goto 1000 endif xcol=zero totam=zero notf=0 check1=zero check2=zero notdone=.TRUE. if(.not.allocated(mamu1)) then ! it will be deallocated when leaving this subroutine ?? allocate(mamu1((meqrec%nrel)),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 25: ',errall gx%bmperr=4370; goto 1000 endif endif ! current value of molar enthalpy if(sph.eq.0) then call get_state_var_value('HM ',hmval,encoded,ceq) totalmol=one else ! current value of molare enthalpy for a phase call get_phase_name(sph,scs,encoded) name='HM('//encoded jj=len_trim(name) name(jj+1:)=')' call get_state_var_value(name,hmval,encoded,ceq) endif call get_state_var_value('N ',totalmol,encoded,ceq) hmval=hmval/ceq%rtn ! this is not yet implemented write(*,*)'hmval, totalmol: ',hmval, totalmol if(gx%bmperr.ne.0) goto 1000 hmallph: do jph=1,meqrec%nstph ! sum over all stable phases jj=meqrec%stphl(jph) pmi=>phr(jj) ! if phase is not fixed there is a column in xcol for variable amount ! This has to be done before loop of elements if(pmi%phasestatus.ne.PHFIXED) notf=notf+1 if(sph.gt.0) then ! if a phase is specified, skip all other phases if(.not.(sph.eq.phr(jj)%iph .and. scs.eq.phr(jj)%ics)) & cycle hmallph pham=one else pham=pmi%curd%amfu endif ! moles formula unit of phase allocate(hval(pmi%ncc),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 26: ',errall gx%bmperr=4370; goto 1000 endif notdone=.FALSE. ! calculate the terms dG/dy_i - T*d2G/dTdy_i for all constituents do ie=1,pmi%ncc hval(ie)=pmi%curd%dgval(1,ie,1)-& ceq%tpval(1)*pmi%curd%dgval(2,ie,1) enddo write(*,73)'hmval: ',sph,ie,hmval ! write(*,75)'cmuvamanyl: ',(ceq%cmuval(ie),ie=1,meqrec%nrel) ! ncol is increemented for each variable chemical potential ncol=1 ! calculate the terms to be multiplied with the unknown mu(ie) hmallel: do ie=1,meqrec%nrel ! multiply terms with the inverse phase matrix and hval ! but also return values without this in mamu1,mag1,mat1 and map1 needed ! for normalization ... call calc_dgdytermshm(meqrec%nrel,ie,meqrec%tpindep,hval,& mamu,mag,mat,map,mamu1,mag1,mat1,map1,& pmi,ceq%cmuval,meqrec%noofits) if(gx%bmperr.ne.0) goto 1000 ! In this loop we subtract H/N*\sum_B \Delta M_B for all terms ncol2=1 hmloop1: do je=1,meqrec%nrel do ke=1,meqrec%nfixmu if(meqrec%mufixel(ke).eq.je) then ! components with fix chemical potential added to rhs, do not increment ncol2!!! xcol(nz2)=xcol(nz2)+& pham*hmval*mamu1(je)*meqrec%mufixval(ke) ! write(*,102)'fix mu 1: ',nz2,je,pham,mamu1(je),& ! meqrec%mufixval(ke) cycle hmloop1 endif enddo ! mamu(B) = \sum_i \sum_j \sum_A dM^a_B/dy_i dM^a_A z^a_ij xcol(ncol2)=xcol(ncol2)-pham*hmval*mamu1(je) ! write(*,102)'HM jel:',je,ncol2,pham,& ! mamu(je),hmval,mamu1(je),xcol(ncol2) ncol2=ncol2+1 enddo hmloop1 ! calculate a term for each column to be multiplied with chemical potential ! if the potential is fixed add the term to the rhs do ke=1,meqrec%nfixmu if(meqrec%mufixel(ke).eq.ie) then ! components with fix chemical potential added to rhs, do not increment ncol!!! xcol(nz2)=xcol(nz2) + pham*meqrec%mufixval(ke)*mamu(ie) ! write(*,102)'fix mu HM 3:',nz2,ke,pham,& ! meqrec%mufixval(ke),mamu1(ie),xcol(nz2) cycle hmallel endif enddo ! mamu(ie) = \sum_i hval(i) \sum_j \sum_B dM^a_B/dy_j z^a_ij xcol(ncol)=xcol(ncol) - pham*mamu(ie) ! write(*,102)'HM col:',ie,ncol,pham,mamu(ie),xcol(ncol) ncol=ncol+1 ! check1=check1-pham*mamu(ie)*ceq%cmuval(ie) ! write(*,76)'check1: ',ie,check1,pham*mamu(ie)*ceq%cmuval(ie) 76 format(a,i2,6(1pe12.4)) enddo hmallel ! UNFINSHED: problems converging with normallized enthalpy condition ! If T or P are variable, mat and map include \sum_j hval(j) if(tcol.gt.0) then xxx=xcol(tcol) ! gval(2,1) is dG/dT, gval(4,1) is d2G/dT2, sign???? ! the equation above should be better but .... xcol(tcol)=xcol(tcol)+& pham*(ceq%tpval(1)*pmi%curd%gval(4,1)-mat) ! pham*(ceq%tpval(1)*pmi%curd%gval(4,1)-mat+hmval*mat1) ! write(*,102)'HM dt: ',0,tcol,pham,& ! ceq%tpval(1)*pmi%curd%gval(4,1),mat,hmval,mat1,xcol(tcol) endif if(pcol.gt.0) then ! condition on H and variable P xxx=xcol(pcol) ! gval(3,1) is dG/dP, gval(5,1) is d2G/dTdP, sign??? UNFINISHED TEST xcol(pcol)=xcol(pcol)+pham*(map-hmval*map1-& pmi%curd%gval(3,1)-ceq%tpval(1)*pmi%curd%gval(5,1)) endif ! Now the term multipled with change of the amount of the phase, not pham if(pmi%phasestatus.ne.PHFIXED) then xcol(dncol+notf)=xcol(dncol+notf)+pmi%curd%gval(1,1)-& ceq%tpval(1)*pmi%curd%gval(2,1) ! ceq%tpval(1)*pmi%curd%gval(2,1)-hmval ! write(*,102)'HM dn: ',ie,dncol+notf,0.0,& ! pmi%curd%gval(1,1)-ceq%tpval(1)*pmi%curd%gval(2,1),& ! hmval,xcol(dncol+notf) endif ! term to the RHS ! xcol(nz2)=xcol(nz2)+pham*(mag-hmval*mag1) xcol(nz2)=xcol(nz2)+pham*mag ! write(*,102)'HM rhs:',ie,nz2,pham,mag,hmval,mag1,xcol(nz2) ! hval can be differnt for next phase deallocate(hval) enddo hmallph if(sph.gt.0 .and. notdone) then ! if sph.ne.0 it is possible that the specified phase is not stable, check that ! the hallph loop has beed done at least once write(*,*)'Normalized enthalpy condition of unstable phase' ! These values are most probably all zero making system matrix singular write(*,177)'xcol: ',nz2,(xcol(jj),jj=1,nz2) gx%bmperr=4196; goto 1000 endif ! write(*,177)'xcol: ',nz2,(xcol(jj),jj=1,nz2) ! Add difference to the RHS. Totam is summed above, cvalue is prescribed value ! write(*,74)'Enthalpy: ',nrow+1,ceq%tpval(1),ceq%rtn,& ! xcol(nz2),totam,cvalue/ceq%rtn ! xcol(nz2)=xcol(nz2)+totam-cvalue/ceq%rtn xcol(nz2)=xcol(nz2)/totalmol-hmval+cvalue/ceq%rtn ! write(*,75)'RHS: ',xcol(nz2),hmval,cvalue/ceq%rtn,totalmol,& ! ceq%tpval(1) ! test if condition converged, use relative error if(abs(hmval-cvalue/ceq%rtn).gt.ceq%xconv*abs(cvalue)) then write(*,75)'Unconverged enthalpy: ',& hmval*ceq%rtn,cvalue,hmval-cvalue/ceq%rtn if(converged.lt.5) then converged=5 ! write(*,*)'4: converged=5',cerr%nvs cerr%mconverged=converged if(cerr%nvs.lt.10) then cerr%nvs=cerr%nvs+1 cerr%typ(cerr%nvs)=5 cerr%val(cerr%nvs)=hmval cerr%dif(cerr%nvs)=hmval-cvalue/ceq%rtn endif endif endif ! we have one more equation to add to the equilibrium matrix nrow=nrow+1 if(nrow.gt.nz1) stop 'MM too many equations 5B' ! we must divide all terms in the LHS with totalmol do ncol=1,nz1 smat(nrow,ncol)=xcol(ncol)/totalmol enddo smat(nrow,nz2)=xcol(nz2) ! write(*,*)'H conv: ',ceq%tpval(1) ! write(*,74)'hline: ',nrow,xcol ! check1 and check2 should be equal if we set H as current value and release T ! write(*,75)'Check: ',check1,check2 deallocate(xcol) endif ! already calculated above !------------------------------------------------------------------ case(6) ! G ! Gibbs energy, for system or a phase gx%bmperr=4207; goto 1000 if(stvnorm.eq.0) then ! not normallized if(cmix(3).eq.0) then ! condition is G=value sph=0 else ! condition is G(phase#set)=value gx%bmperr=4207; goto 1000 sph=cmix(3); scs=cmix(4) endif ! current value of dG=\sum_A dM_A \mu_A + G -\tilde G=0 allocate(xcol(nz2),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 27: ',errall gx%bmperr=4370; goto 1000 endif xcol=zero !...UNFINISHED gx%bmperr=4207; goto 1000 nrow=nrow+1 if(nrow.gt.nz1) stop 'MM too many equations 6A' do ncol=1,nz2 smat(nrow,ncol)=xcol(ncol) enddo ! set rhs to G^prescribed - G^current ! smat(nrow,nz2)=cvalue deallocate(xcol) else ! normallizing can be M (per mole, 1), W (per mass, 2) or V (per volume, 3?) gx%bmperr=4207; goto 1000 endif !------------------------------------------------------------------ case(7) ! NP ! Amount of phase in moles, use fix phase instead write(*,352)stvix,stvnorm 352 format('Not implemented yet, use set status phase=fix: ',2i5) gx%bmperr=4207; goto 1000 nrow=nrow+1 if(nrow.gt.nz1) stop 'MM too many equations 7A' !------------------------------------------------------------------ case(8) ! BP ! Amount of phase in mass, use fix phase instead write(*,352)stvix,stvnorm gx%bmperr=4207; goto 1000 nrow=nrow+1 if(nrow.gt.nz1) stop 'MM too many equations 8A' !------------------------------------------------------------------ ! 9 and 10 (DG and Q) not allowed as conditions !------------------------------------------------------------------ case(11) ! N or X with or without indices and normalization ! 160818: adding possibility to have several terms a*N(A)-b*N(B)=cvalue 1100 continue if(stvnorm.eq.0) then moffs=0 ! write(*,*)'MM condition for N: ',nterms,sph,sel ! return here for second term 1107 continue if(cmix(3).eq.0) then ! condition is N=fix sel=0; sph=0 elseif(cmix(4+moffs).eq.0) then ! condition is N(A)=fix sel=cmix(3+moffs); sph=0 else ! condition is N(phase#set,A)=fix; how to handle if phase#set not stable? ! write(*,*)'Condition N(phase#set,A)=fix not allowed' ! gx%bmperr=4208; goto 1000 sel=cmix(5+moffs); sph=cmix(3+moffs); scs=cmix(4+moffs) endif ! write(*,*)'Condition on N, N(A) or N(phase,A)',sph,sel ! Formulate equation for total amount N: ! rhs: N-N+\sum_alpha N^a + \sum_i \sum_j dM^a_A/dy_i z^a_ij dG/dy_j ! \sum_B \sum_alpha N^a \sum_i \sum_j dM^_A/dy_i dM^a_B/dy_j*z^a_ij *mu(B) ! \sum_alpha N^a \sum_i d2M^a_A/dTdy_i z^a_ij d2G/dTdy_j *deltaT ! \sum_alpha N^a \sum_i d2M^a_A/dPdy_i z^a_ij d2G/dPdy_j *deltaP ! \sum_A M^a_A *deltaN^a allocate(xcol(nz2),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 28: ',errall gx%bmperr=4370; goto 1000 endif xcol=zero totam=zero ! notf keeps track on entered non-fixed phases with variable amount notf=0 ! THE CALCULATION FOR N= and N(A)= seems OK ! sum over all phases to handle conditions like N(phase#set,A)=fix ! as the phase#set may not be stable ! write(*,*)'Loop for all all phases for condition N=' nallph: do jj=1,meqrec%nphase pmi=>phr(jj) if(sph.eq.0) then ! skip if not stable if(phr(jj)%stable.eq.0) cycle nallph else ! condition is for a specific phase#compset, N(phase#compset,comp)=A if(phr(jj)%iph.ne.sph .or. phr(jj)%ics.ne.scs) cycle nallph write(*,*)'N(phase#set,component) not implemented' gx%bmperr=4207; goto 1000 endif ! moles formula unit of phase set above pham=pmi%curd%amfu ! write(*,*)'MMz pham: ',phr(jj)%iph,pham ! if phase is not fixed there is a column in xcol for variable amount ! This has to be done before loop of elements if(pmi%phasestatus.ne.PHFIXED) notf=notf+1 ncol=1 ! write(*,*)'Loop for elements: ', jj,phr(jj)%iph,phr(jj)%ics,ncol nallel: do ie=1,meqrec%nrel ! if sel=/=0 then skip all components except sel if(sel.gt.0 .and. ie.ne.sel) cycle nallel ! multiply terms with the inverse phase matrix ! This is called for each condition, maybe try to save values ... if(nosave) then call calc_dgdyterms1(meqrec%nrel,ie,meqrec%tpindep,& mamu,mag,mat,map,pmi,ceq%cmuval,meqrec%noofits) else ! this routine which should work in parallel ... call calc_dgdyterms1X(meqrec%nrel,ie,meqrec%tpindep,& mamu,mag,mat,map,pmi,meqrec%noofits) endif if(gx%bmperr.ne.0) goto 1000 ! the call above calculates (A is "ie", z_ij is the inverted phase matrix): ! mamu_A(B=1..nrel) = \sum_i \sum_j dM^a_A/dy_i dM^a_B/dy_j z^a_ij ! mag_A = \sum_i \sum_j dM^a_A/dy_i z^a_ij dG/dy_j ! mat_A = \sum_i \sum_j d2M^a_A/dTdy_i z^a_ij d2G/dTdy_j ! map_A = \sum_i \sum_j d2M^a_A/dPdy_i z^a_ij d2G/dPdy_j ! calculate a term for each column to be multiplied with chemical potential ! if the potential is fixed add the term to the rhs ! goto 8000 .... skipping nloop1 with je fails .... !??????????????????? is this loop needed ?????????????????????? YES !!! ncol=1 nloop1: do je=1,meqrec%nrel do ke=1,meqrec%nfixmu if(meqrec%mufixel(ke).eq.je) then ! components with fix chemical potential added to rhs, do not increment ncol!!! xcol(nz2)=xcol(nz2)+pham*mamu(je)*meqrec%mufixval(ke) ! write(*,102)'fix mu N: ',sel,je,pham,& ! meqrec%mufixval(ke),mamu(je),& ! pham*mamu(je)*meqrec%mufixval(ke),xcol(nz2) cycle nloop1 endif enddo ! mamu(B) = \sum_i \sum_j \sum_A dM^a_B/dy_i dM^a_A z^a_ij xcol(ncol)=xcol(ncol)-pham*mamu(je) ncol=ncol+1 enddo nloop1 ! goto 9000 !9000 continue ! If T or P are variable if(tcol.gt.0) then xxx=xcol(tcol) xcol(tcol)=xcol(tcol)+pham*mat ! write(*,363)'d2G/dTdy 2: ',nrow+1,ie,tcol,& ! xxx,xcol(tcol),pham,mat endif ! condition on N and variable P if(pcol.gt.0) then xxx=xcol(pcol) xcol(pcol)=xcol(pcol)+pham*map ! write(*,363)'MM d2G/dPdyi: ',nrow+1,ie,pcol,& ! xxx,xcol(pcol),pham,map endif ! last columns on lhs are amounts of element ie for all stable non-fix phases ! dncol should indicate last column with potential, can be different for ! derivative, notf is set above if(pmi%phasestatus.ne.PHFIXED) then ! notf indicates the column for amount of a component in stable nonfixed phase ! sum of moles in phase will be multiplied with delta-phase_amount if(sel.gt.0 .and. sel.eq.ie) then xcol(dncol+notf)=pmi%xmol(ie) else xcol(dncol+notf)=xcol(dncol+notf)+pmi%xmol(ie) endif endif ! Maybe this should be included also for fixed phases ....?? YES ! right hand side (rhs) contribution is ! - NP(phase)*\sum_i \sum_j dM(ie)/dy_i * dG/dy_j * z_ij xxx=xcol(nz2) xcol(nz2)=xcol(nz2)-pham*mag enddo nallel ! this is to used on the RHS for compare with prescribed value if(sel.gt.0) then totam=totam+pham*pmi%xmol(sel) else totam=totam+pham*pmi%sumxmol endif ! tafidbug ! write(*,665)xxx,pham,mag,cvalue,totam,& ! xxx-pham*mag+cvalue-totam 665 format('RHS: ',6(1pe12.4)) enddo nallph ! ! 160818: adding code to have several terms ... same as for x below nmany: if(mterms.lt.nterms) then ! this branch if 2 or more terms if(mterms.eq.1) then ! allocate arry to save intermediate results ! -Wuninitialized gave a warning: qmat.dim[0].ubound may be uninitilzed ! when used a few lines below but adding this removed this ... if(.not.allocated(qmat)) then allocate(qmat(nz2),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 29: ',errall gx%bmperr=4370; goto 1000 endif endif qmat=zero evalue=zero endif ! save xcol and then go back and calculate next term ! maybe ccf should be included ??? YES!!! must correct also xterms!!! do ncol=1,nz2 qmat(ncol)=qmat(ncol)+ccf(mterms)*xcol(ncol) enddo evalue=evalue+ccf(mterms)*totam ! write(*,664)'MM nsel1:',moffs,sel,sph,totam,ccf(mterms),& ! cvalue,evalue ! write(*,666)'MM evalue1: ',mterms,evalue,ccf(mterms),totam ! write(*,666)'MM q:',mterms,evalue,(qmat(ncol),ncol=1,nz2) 666 format(a,i2,6(1pe12.4)) ! prepare for next term by incrementing mterms and moffs mterms=mterms+1 moffs=moffs+4 deallocate(xcol) ! deallocate(zcol) goto 1107 elseif(nterms.gt.1) then ! for last term when more than 1 nrow=nrow+1 if(nrow.gt.nz1) then write(*,*)'MM too many equations 11A0',nrow gx%bmperr=4209; goto 1000 endif do ncol=1,nz2 smat(nrow,ncol)=qmat(ncol)+ccf(mterms)*xcol(ncol) enddo evalue=evalue+ccf(mterms)*totam smat(nrow,nz2)=smat(nrow,nz2)-cvalue+evalue ! write(*,664)'MM nsel2:',moffs,sel,sph,totam,ccf(mterms),& ! cvalue,evalue 664 format(a,3i3,6(1pe12.4)) ! write(*,666)'MM evalue: ',mterms,evalue,ccf(mterms),totam ! write(*,666)'MM s:',mterms,evalue,(smat(nrow,ncol),ncol=1,nz2) ! 160818: end code added for N(A)-N(B) else ! only one terms (original code unchanged) ! in xcol are values summed over all phases and components ! then copy summed columns to row nrow in matrix smat nrow=nrow+1 if(nrow.gt.nz1) then write(*,*)'MM too many equations 11A',nrow gx%bmperr=4212; goto 1000 endif do ncol=1,nz2 smat(nrow,ncol)=xcol(ncol) enddo ! add N^prescribed - N^current to rhs (right hand side) xxx=smat(nrow,nz2) ! convergence problems using condition fix phase with amount >0, change sign ... smat(nrow,nz2)=smat(nrow,nz2)-cvalue+totam evalue=totam endif nmany ! tafidbug ! smat(nrow,nz2)=smat(nrow,nz2)+cvalue-totam ! write(*,355)'MM N: ',cvalue,totam,(smat(nrow,jj),jj=1,nz2) 355 format(a,6(1pe12.4)) ! write(*,363)'RHSN: ',nrow,nz2,0,smat(nrow,nz2),xxx,cvalue,totam,& ! cvalue-totam deallocate(xcol) ! relative check for convergence if cvalue>1.0 ! if(abs(totam-cvalue).gt.ceq%xconv*max(1.0d0,abs(cvalue))) then if(abs(evalue-cvalue).gt.ceq%xconv*max(1.0d0,abs(cvalue))) then if(converged.lt.5) then converged=5 cerr%mconverged=converged if(cerr%nvs.lt.10) then cerr%nvs=cerr%nvs+1 cerr%typ(cerr%nvs)=5 cerr%val(cerr%nvs)=cvalue cerr%dif(cerr%nvs)=evalue-cvalue endif ! write(*,*)'5: converged=5',cerr%nvs endif ! endif if(vbug) then if(sel.eq.0) then write(*,266)'Unconverged condition N or N(A): ',sel,& cvalue,evalue,evalue-cvalue else write(*,266)'Unconverged condition N or N(A): ',sel,& cvalue,evalue,evalue-cvalue endif endif endif !---------------------------------------------------------- elseif(stvnorm.gt.1) then ! only normallizing of N with respect to amount of moles (M) is allowed write(*,*)'N can only be normalled with M',stvix,stvnorm,cmix(2) gx%bmperr=4208; goto 1000 else !------------------------------------------------------------ ! condition is x(A)=fix or x(phase,A)=fix or several terms for x(...) ! return here if several terms, value of xxmm ??? moffs=0 1120 continue ! x(A)=fix and x(phase#set,A)=fix conditions. x(A)=N(A)/N; x(ph,A)=N(ph,A)/N(ph) ! above N=fix and N(A)=fix are treated as they have a "simple" summation, ! We must sum over all phases and constituents for the normallizing factor ! definition: X(A)=N(A)/N; ! derivative: dX(A)=dN(A)/N - N(A)/N**2 *dN ! sum dN(A) and dN at the same time and multiply the sums with 1/N ! and -N(A)/N**2 in the end. if(cmix(3+moffs).eq.0) then write(*,*)'Condition NM=fix is illegal' gx%bmperr=4208; goto 1000 elseif(cmix(4+moffs).eq.0) then ! condition is x(A)=fix sel=cmix(3+moffs); sph=0 else ! condition is x(phase#set,A)=fix ! write(*,33)cmix 33 format('Condition x(phase#set,A)=fix?',10i4) sel=cmix(5+moffs); sph=cmix(3+moffs); scs=cmix(4+moffs) endif if(.not.allocated(xxmm)) then ! this call returns the current fractions and total amounts. We need ! to do it only once inside this subroutine. xxmm are deallocated at exit allocate(xxmm(meqrec%nrel),stat=errall) allocate(wwnn(meqrec%nrel),stat=errall) calcmolmass=.FALSE. if(errall.ne.0) then write(*,*)'MM Allocation error 30: ',errall gx%bmperr=4370; goto 1000 endif endif if(.not.calcmolmass) then call calc_molmass(xxmm,wwnn,totalmol,totalmass,ceq) if(gx%bmperr.ne.0) goto 1000 calcmolmass=.TRUE. endif ! two summations, zcol sums the term dN(A); xcol sums dN (as above) allocate(xcol(nz2),stat=errall) allocate(zcol(nz2),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 31: ',errall gx%bmperr=4370; goto 1000 endif xcol=zero zcol=zero totam=zero zval=zero xval=zero ! LOOP FOR ALL PHASES (why not all stable??) ! dncol+notf indicate column for the amount of phases with variable amount notf=0 ! sum over all phases to handle conditions like x(phase#set,A)=fix ! as the phase#set may not be stable bbug=zero xallph: do jj=1,meqrec%nphase pmi=>phr(jj) if(sph.eq.0) then ! skip this phase if not stable and condition not on a specific phase (sph) ! WOW COMPLICATION, I have another test for stability ... suck if(phr(jj)%stable.eq.0) cycle xallph pham=pmi%curd%amfu else ! condition on specific phase, skip this phase if not the right one if(phr(jj)%iph.ne.sph .or. & phr(jj)%ics.ne.scs) cycle xallph ! note this destroys calculated values from calc_molmass above ... call calc_phase_molmass(sph,scs,xxmm,wwnn,& totalmol,totalmass,amount,ceq) calcmolmass=.FALSE. pham=one totalmol=one ! write(*,355)'MM cpm: ',totalmol,amount,pham,xxmm ! totalmol depend on amout of phase stable, irrelevant here if(gx%bmperr.ne.0) goto 1000 endif ! notf indicates the column for the variable amount of the phase if(pmi%phasestatus.ne.PHFIXED) notf=notf+1 xallel: do ie=1,meqrec%nrel ! we cannot skip summation over all element as that is needed for normallizing ! calculate a term for each column to be multiplied with chemical potential ! we must sum xcol for all elemenets and add to zcol for element sel ! if sel=/=0 then we sum also zcol(sel) for all phases if(nosave) then call calc_dgdyterms1(meqrec%nrel,ie,meqrec%tpindep,& mamu,mag,mat,map,pmi,ceq%cmuval,meqrec%noofits) else call calc_dgdyterms1X(meqrec%nrel,ie,meqrec%tpindep,& mamu,mag,mat,map,pmi,meqrec%noofits) endif if(gx%bmperr.ne.0) goto 1000 ! write(*,355)'MM dgdy: ',mamu ncol=1 xloop2: do je=1,meqrec%nrel !--------------------------------------------------------------------- ! BIG TROUBLE HERE FOR FIXED CHEMICAL POTENTIAL !!!!! FIXED NOW ... NO!! ?? ! but still problems combining with other conditions on H etc ... ! it works when we have N(A)=fix (code above) but not with x(A)=fix ! Calculate one column for each component to be multiplied with chem.pot. ! components with fix chemical potential added to rhs, do not increment ncol!!! do ke=1,meqrec%nfixmu ! check for elements with fixed chemical potentials, they go to RHS if(meqrec%mufixel(ke).eq.je) then ! the sign here should be opposite from xcol(ncol)= below ! write(*,*)'In xloop2: ',ie,ke,je,sel,nrow ! xcol(nz2)=xcol(nz2)-& xcol(nz2)=xcol(nz2)+& pham*mamu(je)*meqrec%mufixval(ke) ! bbug=bbug-pham*mamu(je) ! write(*,102)'fix mu xall: ',sel,je,pham,& ! meqrec%mufixval(ke),mamu(je),& ! pham*mamu(je)*meqrec%mufixval(ke),xcol(nz2) ! zcol needed because we have a normallized property (mole fraction) ! NOTE it should be ie here and NOT je ??? and opposite sign from xcol(nz2) if(ie.eq.sel) then zcol(nz2)=zcol(nz2)+& pham*mamu(je)*meqrec%mufixval(ke) ! write(*,102)'fix mu xsel: ',ie,je,pham,& ! meqrec%mufixval(ke),mamu(je),& ! pham*mamu(je)*meqrec%mufixval(ke),zcol(nz2) ! abug=-pham*mamu(je) endif cycle xloop2 endif enddo ! mamu(B) = \sum_i \sum_j dM^a_B/dy_i dM^a_A z^a_ij ! sum over all elements for normallizing xcol(ncol)=xcol(ncol)-pham*mamu(je) if(sel.eq.ie) then ! if this is the specified element sum to zcol zcol(ncol)=zcol(ncol)-pham*mamu(je) endif ncol=ncol+1 enddo xloop2 !----------------------------------------------------------------------- ! If T or P are variable, mat is \sum_i d2G/dy_idT, map is \sum_i d2G/dy_idP if(tcol.gt.0) then xcol(tcol)=xcol(tcol)+pham*mat if(sel.eq.ie) then zcol(tcol)=zcol(tcol)+pham*mat endif ! write(*,363)'d2G/dTdy 3: ',nrow+1,ie,tcol,& ! xxx,xcol(tcol),pham,mat 363 format(a,3i3,6(1pe12.4)) endif if(pcol.gt.0) then xcol(pcol)=xcol(pcol)+pham*map if(sel.eq.ie) then zcol(pcol)=zcol(pcol)+pham*map endif endif ! columns for phase amounts if(pmi%phasestatus.ne.PHFIXED) then ! write(*,*)'MM 363A: ',dncol,notf,ie,sel if(sph.eq.0) then xcol(dncol+notf)=xcol(dncol+notf)+pmi%xmol(ie) ! write(*,*)'MM 363B: ',dncol,notf,ie,xcol(dncol+notf) if(ie.eq.sel) then zcol(dncol+notf)=zcol(dncol+notf)+pmi%xmol(ie) endif endif endif ! right hand side (rhs) contribution is (normallized below) ! - NP(phase)*\sum_i \sum_j dM(ie)/dy_i * dG/dy_j * z_ij xcol(nz2)=xcol(nz2)-pham*mag if(sel.eq.ie) then zcol(nz2)=zcol(nz2)-pham*mag endif enddo xallel ! totam and zval not used !!?? totam=totam+pham*pmi%sumxmol ! UNFINISHED: if sph nonzero next line must be changed to be for sph zval=zval+pham*pmi%xmol(sel) ! sel=cmix(5); sph=cmix(3); scs=cmix(4) ! write(*,*)'MM x(p,c): ',sph,scs,sel,zval enddo xallph !-------------- new code begin ! can handle the case of several terms like x(liquid,S)-x(pyrrh,S)=0 ! x(Mg)-2*x(Si)=0 xterms: if(mterms.lt.nterms) then ! this branch if 2 or more terms if(mterms.eq.1) then ! allocate array for saving intermediate results if(.not.allocated(qmat)) then allocate(qmat(nz2),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 32: ',errall gx%bmperr=4370; goto 1000 endif endif qmat=zero evalue=zero endif ! save zcol and xcol then go back and calculate next term ! corrected by adding ccf factor!! (not needed for x(liq,a)-x(sol,a)=0 .... do ncol=1,nz2 qmat(ncol)=qmat(ncol)+ccf(mterms)*& (zcol(ncol)-xcol(ncol)*xxmm(sel))/totalmol enddo evalue=evalue+ccf(mterms)*xxmm(sel) ! prepare for next term by incrementing mterms and moffs mterms=mterms+1 moffs=moffs+4 ! write(*,1117)'MM 2nd indices: ',moffs,(cmix(jj+moffs),jj=3,6) !1117 format(a,i3,2x,4i3) ! write(*,1118)'MM xxmm:',mterms,sel,xxmm(sel) deallocate(xcol) deallocate(zcol) goto 1120 elseif(nterms.gt.1) then ! for last term of expression nrow=nrow+1 if(nrow.gt.nz1) then write(*,*)'MM too many equations 11B: ',nrow,nz1,meqrec%nfixph gx%bmperr=4209; goto 1000 endif ! insert results in smat ! write(*,1118)'MM endofexp:',mterms,sel,evalue,xxmm(sel) 1118 format(a,2i3,6(1pe12.4)) do ncol=1,nz2 smat(nrow,ncol)=qmat(ncol)+& ccf(mterms)*(zcol(ncol)-xcol(ncol)*xxmm(sel))/totalmol enddo evalue=evalue+ccf(mterms)*xxmm(sel) ! add x^prescribed - x^current to rhs (right hand side) smat(nrow,nz2)=smat(nrow,nz2)-cvalue+evalue !------------------new code end else ! use this else branch when nterms=1, just a single x(a)=value nrow=nrow+1 ! if(bbug.ne.zero) then ! looking for bug with activity conditions ! write(*,16)'abug: ',sel,abug,bbug,xxmm(sel),& ! abug-bbug*xxmm(sel),meqrec%mufixval(1),& ! (abug-bbug*xxmm(sel))*meqrec%mufixval(1) !16 format(a,i3,6(1pe12.4)) ! else ! write(*,16)'nomy : ',sel,zcol(1),xcol(1),& ! xxmm(sel),zcol(1)-xcol(1)*xxmm(sel) ! endif if(nrow.gt.nz1) then write(*,*)'MM too many equations 11B: ',nrow,nz1,meqrec%nfixph gx%bmperr=4209; goto 1000 endif ! in xcol is dN and in zcol dN(A) summed over all phases and components ! calculate the normallized values now ! xmat=1/N*(dN(A) - (N(A)/N)*dN) ! sum zcol and xcol to nrow in smat multiplying xcol with current amount ! and normallizing with total amount, including the RHS (column nz2) do ncol=1,nz2 smat(nrow,ncol)=(zcol(ncol)-xcol(ncol)*xxmm(sel))/totalmol enddo ! subract x^prescribed - x^current to rhs (right hand side) smat(nrow,nz2)=smat(nrow,nz2)-cvalue+xxmm(sel) evalue=xxmm(sel) endif xterms deallocate(xcol) deallocate(zcol) ! phase composition problem ! write(*,355)'MM X: ',cvalue,xxmm(sel),totalmol,pham,& ! (smat(nrow,jj),jj=1,nz2) ! check on convergence ! if(abs(xxmm(sel)-cvalue).gt.ceq%xconv) then if(abs(evalue-cvalue).gt.ceq%xconv) then if(converged.lt.5) then converged=5 ! write(*,*)'6: converged=5',cerr%nvs cerr%mconverged=converged if(cerr%nvs.lt.10) then cerr%nvs=cerr%nvs+1 cerr%typ(cerr%nvs)=5 cerr%val(cerr%nvs)=xxmm(sel) cerr%dif(cerr%nvs)=xxmm(sel)-cvalue endif endif ! write(*,266)'Unconverged condition x(A): ',sel,cvalue,evalue ! if(vbug) write(*,266)'Unconverged condition x(A): ',sel,& ! cvalue,evalue endif endif ! finished conditions on N and X with indices if(allocated(xxmm)) then deallocate(xxmm) deallocate(wwnn) endif ! !------------------------------------------------------------------ case(12) ! B or W ! Amount of component in mass, can have indices and normallization ! code copied from the case(11) for N and X and modified for mass 1200 continue if(stvnorm.eq.0) then if(cmix(3).eq.0) then ! condition is B=fix if(bwarning) then write(*,491) 491 format(' *** WARNING, using B=value as condition can disable',& ' the gridminimizer'/& ' and cause convergence problem. Use N=value instead.') ! Issue this message only once for each calculation bwarning=.FALSE. endif ! write(*,*)'MM condition B=fix: ',stvnorm,cmix(3) sel=0; sph=0 elseif(cmix(4).eq.0) then ! condition is B(A)=fix sel=cmix(3); sph=0 else ! condition is B(phase#set,A)=fix; how to handle if phase#set not stable? write(*,*)'Condition B(phase#set,A)=fix not implemented' gx%bmperr=4208; goto 1000 sel=cmix(5); sph=cmix(3); scs=cmix(4) endif ! Formulate equation for total amount B: each M_A multiplied with mass_A ! rhs: B-B+\sum_alpha N^a + \sum_i \sum_j dM^a_A/dy_i z^a_ij dG/dy_j ! \sum_B \sum_alpha N^a \sum_i \sum_j dM^_A/dy_i dM^a_B/dy_j*z^a_ij *mu(B) ! \sum_alpha N^a \sum_i d2M^a_A/dTdy_i z^a_ij d2G/dTdy_j *deltaT ! \sum_alpha N^a \sum_i d2M^a_A/dPdy_i z^a_ij d2G/dPdy_j *deltaP ! \sum_A M^a_A *deltaN^a allocate(xcol(nz2),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 33: ',errall gx%bmperr=4370; goto 1000 endif xcol=zero totam=zero ! write(*,222)'MM xcol 1',totam,xcol 222 format(a,10(1pe11.3)) ! notf keeps track on entered non-fixed phases with variable amount notf=0 ! not used zval=zero ballph: do jph=1,meqrec%nstph ! sum over all stable phases jj=meqrec%stphl(jph) pmi=>phr(jj) ! if phase is not fixed there is a column in xcol for variable amount if(pmi%phasestatus.ne.PHFIXED) notf=notf+1 ! amount of phase, amfu is moles formula units, abnorm(2) is mass per form.unit pham=pmi%curd%amfu ballel: do ie=1,meqrec%nrel ! if sel=/=0 then skip all components except sel if(sel.gt.0 .and. ie.ne.sel) cycle ! multiply terms with the inverse phase matrix if(nosave) then call calc_dgdyterms1(meqrec%nrel,ie,meqrec%tpindep,& mamu,mag,mat,map,pmi,ceq%cmuval,meqrec%noofits) else call calc_dgdyterms1X(meqrec%nrel,ie,meqrec%tpindep,& mamu,mag,mat,map,pmi,meqrec%noofits) endif if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'Calculated dgdyterms 3: ',mat ! the call above calculates (A is "ie", z_ij is the inverted phase matrix): ! mamu_A(B=1..nrel) = \sum_i \sum_j dM^a_A/dy_i dM^a_B/dy_j z^a_ij ! mag_A = \sum_i \sum_j dM^a_A/dy_i z^a_ij dG/dy_j ! mat_A = \sum_i \sum_j d2M^a_A/dTdy_i z^a_ij d2G/dTdy_j ! map_A = \sum_i \sum_j d2M^a_A/dPdy_i z^a_ij d2G/dPdy_j ncol=1 ! calculate a term for each column to be multiplied with chemical potential ! if the potential is fixed add the term to the rhs bloop1: do je=1,meqrec%nrel do ke=1,meqrec%nfixmu if(meqrec%mufixel(ke).eq.je) then ! components with fix chemical potential added to rhs, do not increment ncol!!! ! NOTE: mamu includes summation of two components, multiply with two masses!!! ! write(*,98)'fix mu b:',sel,je,& ! pham*mamu(je),meqrec%mufixval(ke),mass_of(ie,ceq) xcol(nz2)=xcol(nz2)+& pham*mamu(je)*meqrec%mufixval(ke)*mass_of(ie,ceq) cycle bloop1 endif enddo ! mamu(B) = \sum_i \sum_j \sum_A dM^a_B/dy_i dM^a_A z^a_ij mass_A mass_B ??? xcol(ncol)=xcol(ncol)-pham*mamu(je)*mass_of(ie,ceq) ncol=ncol+1 enddo bloop1 ! If T or P are variable if(tcol.gt.0) then ! xxx=xcol(tcol) xcol(tcol)=xcol(tcol)+pham*mat*mass_of(ie,ceq) ! write(*,363)'d2G/dTdy 4: ',nrow-1,ie,tcol,& ! xxx,xcol(tcol),pham,mat endif if(pcol.gt.0) then ! xxx=xcol(pcol) xcol(pcol)=xcol(pcol)+pham*map*mass_of(ie,ceq) ! write(*,363)'d2G/dPdy: ',nrow-1,ie,pcol,& ! xxx,xcol(pcol),pham,mat endif ! last columns are amounts of element ie for all stable non-fix phases ! for all stable (non fixed) phases we have the mass multiplied with deltaaleph if(pmi%phasestatus.ne.PHFIXED) then ! ?? zval=zval+pmi%xmol(ie)*mass_of(ie,ceq) if(sel.gt.0 .and. sel.eq.ie) then xcol(dncol+notf)=& pmi%xmol(ie)*mass_of(ie,ceq) ! write(*,363)'xcola: ',ncol,ie,0,xcol(ncol),mass_of(ie,ceq) else xcol(dncol+notf)=xcol(dncol+notf)+& pham*pmi%xmol(ie)*mass_of(ie,ceq) endif endif ! right hand side (rhs) contribution is ! - BP(phase)*\sum_i \sum_j dM(ie)/dy_i * dG/dy_j * z_ij xcol(nz2)=xcol(nz2)-pham*mag*mass_of(ie,ceq) ! write(*,222)'MM xcol 2',totam,xcol enddo ballel ! sum of mass in phase will be multiplied with delta-phase_amount ! write(*,202)'sumxmol mm: ',sel,pham,pmi%sumxmol,pmi%sumwmol if(sel.gt.0) then totam=totam+pham*pmi%xmol(sel)*mass_of(sel,ceq) else totam=totam+pham*pmi%sumwmol endif enddo ballph ! write(*,222)'MM xcol 3',totam,xcol !......debug if(.not.allocated(xxmm)) then ! this call returns the current fractions and total amounts. We need ! to do it only once inside this subroutine. xxmm are deallocated at exit allocate(xxmm(meqrec%nrel),stat=errall) allocate(wwnn(meqrec%nrel),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 34: ',errall gx%bmperr=4370; goto 1000 endif call calc_molmass(xxmm,wwnn,totalmol,totalmass,ceq) if(gx%bmperr.ne.0) goto 1000 endif ! if(sel.eq.0) write(*,*)'totalmass: ',totalmass,totam ! ! in xcol are values summed over all phases and components ! copy summed columns to smat nrow nrow=nrow+1 if(nrow.gt.nz1) then write(*,*)'MM too many equations 12A',nrow gx%bmperr=4209; goto 1000 endif do ncol=1,nz2 smat(nrow,ncol)=xcol(ncol) enddo ! write(*,97)'Totalmass B: ',sel,totam,cvalue,totalmass,wwnn(sel) 97 format(a,i4,6(1pe12.4)) ! add B^prescribed - B^current to rhs (right hand side) xxx=smat(nrow,nz2) smat(nrow,nz2)=smat(nrow,nz2)-cvalue+totam ! write(*,363)'RHSB: ',nrow,nz2,0,smat(nrow,nz2),xxx,cvalue,totam,& ! cvalue-totam deallocate(xcol) ! check convergence if(abs(totam-cvalue).gt.ceq%xconv) then ! write(*,266)'Unconverged condition B(A): ',sel,cvalue,zval if(converged.lt.5) then converged=5 ! write(*,*)'7: converged=5',cerr%nvs cerr%mconverged=converged if(cerr%nvs.lt.10) then cerr%nvs=cerr%nvs+1 cerr%typ(cerr%nvs)=5 cerr%val(cerr%nvs)=cvalue cerr%dif(cerr%nvs)=totam-cvalue endif endif endif ! write(*,222)'MM xcol 3',totam,xcol if(vbug) then if(sel.eq.0) then write(*,363)'Condition B=fix',0,0,0,cvalue,totam else write(*,363)'Condition B(a)=fix',sel,0,0,cvalue,totam endif endif ! write(*,223)'MM smat 1',nrow,(smat(nrow,ncol),ncol=1,nz2) 223 format(a,i2,10(1pe11.3)) elseif(stvnorm.ne.2) then ! only normallizing of B with respect to mass (W) is allowed write(*,*)'Allowed normallizing with W only',stvix,stvnorm,cmix(2) gx%bmperr=4208; goto 1000 else !------------------------------- ! Conditions like w(A)=fix, w(phase#set,A)=fix ! B=fix and B(A)=fix treated above as they have a "simple" summation, ! We must sum over all phases and constituents for the normallizing factor ! definition: W(A)=B(A)/B; ! derivative: dW(A)=dB(A)/B - B(A)/N**2 *dB ! sum dB(A) and dB at the same time and multiply the sums with 1/B ! and -B(A)/B**2 in the end. if(cmix(3).eq.0) then write(*,*)'Condition BW=fix is illegal' gx%bmperr=4208; goto 1000 elseif(cmix(4).eq.0) then ! condition is x(A)=fix sel=cmix(3); sph=0 else sel=cmix(5); sph=cmix(3); scs=cmix(4) endif if(.not.allocated(xxmm)) then ! this call returns the current fractions and total amounts. We need ! to do it only once inside this subroutine. xxmm are deallocated at exit allocate(xxmm(meqrec%nrel),stat=errall) allocate(wwnn(meqrec%nrel),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 35: ',errall gx%bmperr=4370; goto 1000 endif calcmolmass=.FALSE. endif if(.not.calcmolmass) then call calc_molmass(xxmm,wwnn,totalmol,totalmass,ceq) if(gx%bmperr.ne.0) goto 1000 calcmolmass=.TRUE. endif ! write(*,267)'wwnn: ',(wwnn(ncol),ncol=1,noel()) ! write(*,267)'xxmm: ',(xxmm(ncol),ncol=1,noel()) ! two summations, zcol sums the term dN(A); xcol sums dN (as above) allocate(xcol(nz2),stat=errall) allocate(zcol(nz2),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 36: ',errall gx%bmperr=4370; goto 1000 endif xcol=zero zcol=zero totam=zero zval=zero xval=zero notf=0 ! wallph: do jph=1,meqrec%nstph ! jj=meqrec%stphl(jph) ! sum over all phases to handle conditions like x(phase#set,A)=fix ! as the phase#set may not be stable wallph: do jj=1,meqrec%nphase pmi=>phr(jj) if(sph.eq.0) then ! skip this phase if not stable and condition not on a specific phase if(phr(jj)%stable.eq.0) cycle wallph pham=pmi%curd%amfu elseif(sph.gt.0) then ! condition on a composition of a phase if(phr(jj)%iph.ne.sph .or. & phr(jj)%ics.ne.scs) cycle wallph ! We need the phase comoposition call calc_phase_molmass(sph,scs,xxmm,wwnn,& totalmol,totalmass,amount,ceq) pham=one ! totalmol=one totalmass=one endif ! pmi=>phr(jj) ! amount formula units of phase, set above ! pham=pmi%curd%amfu if(pmi%phasestatus.ne.PHFIXED) notf=notf+1 wallel: do ie=1,meqrec%nrel ! calculate a term for each column to be multiplied with chemical potential ! we must sum xcol for all elemenets and add to zcol for element sel ! if sel=/=0 then we sum also zcol(sel) for all phases if(nosave) then call calc_dgdyterms1(meqrec%nrel,ie,meqrec%tpindep,& mamu,mag,mat,map,pmi,ceq%cmuval,meqrec%noofits) else call calc_dgdyterms1X(meqrec%nrel,ie,meqrec%tpindep,& mamu,mag,mat,map,pmi,meqrec%noofits) endif if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'Calculated dgdyterms 4: ',mat ncol=1 ! BUG TROUBLE WITH MIXED FIX CHEMICAL POT AND MASS FRACTION CONDITION !!! wloop2: do je=1,meqrec%nrel ! Calculate one column for each component to be multiplied with chem.pot. ! components with fix chemical potential added to rhs, do not increment ncol!!! ! modified in accordance with condition on x do ke=1,meqrec%nfixmu if(meqrec%mufixel(ke).eq.je) then ! write(*,98)'fix mu w:',sel,je,& ! pham*mamu(je),meqrec%mufixval(ke),mass_of(ie,ceq) 98 format(a,2i3,6f12.4) xcol(nz2)=xcol(nz2)+& pham*mamu(je)*meqrec%mufixval(ke)*mass_of(ie,ceq) if(ie.eq.sel) then ! write(*,98)'fix mu u:',sel,ie,& ! pham*mamu(je),meqrec%mufixval(ke),& ! mass_of(ie,ceq) ! VERY STRANGE ... zcol and xcol have both the term added here but ! when calculating with mole frac and fix chem.pot they have different signs!!! zcol(nz2)=zcol(nz2)+& pham*mamu(je)*meqrec%mufixval(ke)*& mass_of(ie,ceq) endif cycle wloop2 endif enddo ! mamu(B) = \sum_i \sum_j dM^a_B/dy_i dM^a_A z^a_ij xcol(ncol)=xcol(ncol)-pham*mamu(je)*mass_of(ie,ceq) if(sel.eq.ie) then zcol(ncol)=zcol(ncol)-pham*mamu(je)*mass_of(ie,ceq) endif ! problem that this reurn whatever for 2nd and higher equilibria ! write(*,*)'mass of: ',ie,mass_of(ie,ceq) ncol=ncol+1 enddo wloop2 ! If T or P are variable if(tcol.gt.0) then xcol(tcol)=xcol(tcol)+pham*mat*mass_of(ie,ceq) if(sel.eq.ie) then zcol(tcol)=zcol(tcol)+pham*mat*mass_of(ie,ceq) endif ! write(*,363)'d2G/dTdy 5: ',nrow-1,ie,tcol,& ! xxx,xcol(tcol),pham,mat endif if(pcol.gt.0) then xcol(pcol)=xcol(pcol)+pham*map*mass_of(ie,ceq) if(sel.eq.ie) then zcol(pcol)=zcol(pcol)+pham*map*mass_of(ie,ceq) endif endif ! last columns are amounts of element ie for all stable non-fix phase, if(pmi%phasestatus.ne.PHFIXED) then if(sph.eq.0) then ! all phases with variable amount, sum over all components xcol(dncol+notf)=xcol(dncol+notf)+& pmi%xmol(ie)*mass_of(ie,ceq) if(ie.eq.sel) then zcol(dncol+notf)=zcol(dncol+notf)+& pmi%xmol(ie)*mass_of(ie,ceq) endif ! else ! no coefficint for phase amount if phase specific composition!! endif endif ! right hand side (rhs) contribution is ! - NP(phase)*\sum_i \sum_j dM(ie)/dy_i * dG/dy_j * z_ij * mass_ie xcol(nz2)=xcol(nz2)-pham*mag*mass_of(ie,ceq) if(sel.eq.ie) then zcol(nz2)=zcol(nz2)-pham*mag*mass_of(ie,ceq) endif enddo wallel ! totam never used ??? if(sel.gt.0) then totam=totam+pham*pmi%xmol(sel)*mass_of(sel,ceq) else totam=totam+pham*pmi%sumwmol endif ! UNFINISHED: if sph=/=0 next line must be changed ! zval=zval+pham*pmi%xmol(sel)*mass_of(sel,ceq) enddo wallph ! in xcol is dB and in zcol dB(A) summed over all phases and components ! calculate the normallized values now ! xmat=dB(A)/B - B(A)*dB/B**2 nrow=nrow+1 if(nrow.gt.nz1) then write(*,*)'MM too many equations 12B',nrow,nz1 gx%bmperr=4209; goto 1000 endif ! write(*,97)'Totalmass W: ',sel,wwnn(sel),cvalue,totalmass,totam ! copy to smat row nrow. totalmass=1 if phase specific composition do ncol=1,nz2 smat(nrow,ncol)=(zcol(ncol)-xcol(ncol)*wwnn(sel))/totalmass enddo ! add W^prescribed - W^current to rhs (right hand side) smat(nrow,nz2)=smat(nrow,nz2)-cvalue+wwnn(sel) deallocate(xcol) deallocate(zcol) ! check on convergence ! write(*,266)'massbalance condition w(A): ',sel,cvalue,wwnn(sel) if(abs(wwnn(sel)-cvalue).gt.ceq%xconv) then if(converged.lt.5) then converged=5 ! write(*,*)'8: converged=5',cerr%nvs cerr%mconverged=converged if(cerr%nvs.lt.10) then cerr%nvs=cerr%nvs+1 cerr%typ(cerr%nvs)=5 cerr%val(cerr%nvs)=wwnn(sel) cerr%dif(cerr%nvs)=wwnn(sel)-cvalue endif ! write(*,*)'8B: converged=5',cerr%nvs endif ! write(*,266)'Unconverged condition w(A): ',sel,cvalue,wwnn(sel) 266 format(a,i3,3(1pe14.6)) ! write(*,267)'wwnn: ',(wwnn(ncol),ncol=1,noel()) ! write(*,267)'xxmm: ',(xxmm(ncol),ncol=1,noel()) !267 format(a,8F9.5) endif ! if(sph.eq.0) then ! write(*,363)'Condition w(A)=fix',sel,0,0,cvalue,wwnn(sel) ! else ! this is not implemented yet ! write(*,363)'Condition w(phase#set,A)=fix',sph,sel,0,cvalue,zval ! endif endif ! finished conditions on B and W with indices if(allocated(xxmm)) then deallocate(xxmm) deallocate(wwnn) endif ! !------------------------------------------------------------------ case(13) ! Y ycond ! Constituent fraction: phase#set, (subl.,) constituent index (over all subl) ! NOTE differences also interesting y(B2,A)-y(B2,A#2) is 2nd order transf ! nterms is number of terms, mterms=1 here moffs=3 ! write(*,*)'MM stvix, mterms & nterms: ',stvix,mterms,nterms,nz2 ! xcol not needed as we have no sums over several phases ! allocate(xcol(nz2)) ! xcol=zero ! we do not use calc_dgdyterms as we have a single constituent yindex ! call calc_dgdyterms1X(meqrec%nrel,ie,meqrec%tpindep,& ! mamu,mag,mat,map,pmi,meqrec%noofits) ! mamu is an array, normally set to zero in calc_dgdyterms ! also mag, mat and map mamu=zero mag=zero mat=zero map=zero dvalue=zero ! this is executed for each iteration, this value must be set earlier ! deltaTycond=2.5d1 yterms: do mterms=1,nterms ! loop for all terms in constion, we may have y_i-y_j =fix ! cmix(3,4,5,6) are for first term, cmix(7,8,9,10) for second etc ! for each term ccf(1..5) gives the factor in front of y ! constituent is cmix(3) (sequental for all sublattices?) ! write(*,*)'MM phase and compset :',cmix(moffs),cmix(moffs+1) ! write(*,'(a,i3,2(1pe12.4))')'MM constituent & value :',& ! cmix(moffs+2),cvalue,ccf(mterms) ! cmix(moffs+4) NOT USED sph=cmix(moffs); scs=cmix(moffs+1) yindex=cmix(moffs+2) findphase: do jj=1,meqrec%nphase ! phase with y condition may not be stable ... loop for all phases ! write(*,*)'MM phase: ',meqrec%nphase,jj,phr(jj)%iph if(phr(jj)%iph.ne.sph .or. phr(jj)%ics.ne.scs) cycle findphase pmi=>phr(jj) ! write(*,*)'MM found phase: ',jj,yindex,phr(jj)%curd%yfr(yindex) ! The equation is \Delta y_i = yknown (or \Delta y_i - \Delta y_j = dyknown) ! we should set up a row where index "i" is known constituent ! \sum_A \sum_k dM_A/dy_i e_ik \mu_A + \sum_k d2G/dy_i dT e_ik \Delta T = ! \sum_k dG/dy_i e_ik +ycurr - yknown ! where e_ij is the inverted phase matrix ! The values of the constituent fractions must be set before calculating e_ij ! this requires some new indicator in meq_onephase ! IF the condition is a difference y_i-y_j=a it will be assumed y_i is correct ! at the start of the calculation and we set y_j=y_i-a before each iteration yallel: do ie=1,meqrec%nrel cib=zero ! write(*,333)'MM dy: ',(pmi%dxmol(ie,jy),jy=1,pmi%ncc) 333 format(a,10(1pe12.4)) do jy=1,pmi%ncc ! \sum_A \sum_k e_ik dM_A/dy_k ! suck the formula below does not work unless y_i correct, suck cib=cib+pmi%invmat(jy,yindex)*pmi%dxmol(ie,jy) ! write(*,'(a,i3,3(1pe12.4))')'MM cib 1: ',jy,cib,& ! pmi%invmat(jy,yindex),pmi%dxmol(ie,jy) enddo mamu(ie)=mamu(ie)+ccf(mterms)*cib ! write(*,*)'MM mamu: ',ie,mamu(ie),cib enddo yallel cib=zero do jy=1,pmi%ncc ! \sum_k e_ik dG/dy_k cib=cib+pmi%invmat(jy,yindex)*pmi%curd%dgval(1,jy,1) ! write(*,'(a,i3,3(1pe12.4))')'MM cib 2: ',jy,cib,& ! pmi%invmat(jy,yindex),pmi%curd%dgval(1,jy,1) enddo ! WoW it works with correct signs! Note: y_presc - y_calc!!! dvalue=-ccf(mterms)*pmi%curd%yfr(yindex) mag=mag+ccf(mterms)*(cib-pmi%curd%yfr(yindex)) ! write(*,373)'MM mag: ',mag,cib,& ! ccf(mterms),-pmi%curd%yfr(yindex),cvalue if(meqrec%tpindep(1)) then ! failed attempt to improve convergence ! ycondTlimit=.true. ! add coefficient for Delta T cib=zero do jy=1,pmi%ncc ! + \sum_k e_ik d2G/dTdy_ik \Delta T cib=cib+pmi%invmat(jy,yindex)*pmi%curd%dgval(2,jy,1) ! OR: + \sum_k e_ik d2G/dTdy_i \Delta T ! I have not tested eithor of these ! cib=cib+pmi%invmat(jy,yindex)*pmi%curd%dgval(2,yindex,1) enddo ! When T is variable with y condition one must restrict change in T !!! mat=mat+ccf(mterms)*cib endif ! write(*,'(a,i2,6(1pe12.4))')'MM mat: ',mterms,& ! ceq%tpval(1),dvalue+cvalue,ccf(mterms),mat,cib if(meqrec%tpindep(2)) then ! add coefficient for Delta P cib=zero do jy=1,pmi%ncc ! + \sum_k e_ik d2G/dPdy_i \Delta P ! I have not tested this cib=cib+pmi%invmat(jy,yindex)*pmi%curd%dgval(3,jy,1) enddo map=map+ccf(mterms)*cib endif exit findphase enddo findphase ! finished this term, any more? moffs=moffs+4 enddo yterms ! add the prescribed value mag=mag+cvalue ! dvalue is the current value which should become cvalue at equilibrium dvalue=dvalue+cvalue ! write(*,373)'MM mamu: ',mat,map,mag,mamu ! write(*,*)'MM nrow mm: ',nrow,nz1,nz2 373 format(a,10(1pe12.4)) !------------------- nrow=nrow+1 if(nrow.gt.nz1) then write(*,*)'MM Too many equations 13' gx%bmperr=4209; goto 1000 endif ! now mamu(1..nrel) are the coefficients for \mu; mat&map is coeff for Delta T&P ! assuming no activity conditionw ... do jj=1,meqrec%nrel smat(nrow,jj)=mamu(jj) enddo ! after exiting loop jj=meqrec%nrel+1 if(meqrec%tpindep(1)) then ! Failed attempt to improve convergence ! smat(nrow,jj)=-5.0D0*mat smat(nrow,jj)=-mat jj=jj+1 endif if(meqrec%tpindep(2)) then smat(nrow,jj)=-map jj=jj+1 endif ! mag is right hand side including y-y smat(nrow,nz2)=mag ! write(*,'(a,i2,6(1pe12.4))')'MM *** ycond:',nrow,(smat(nrow,jj),jj=1,nz2) ! gx%bmperr=4207; goto 1000 ! end select ! ! loop if not the last condition ! write(*,*)'Taking next condition',cmix(1) if(.not.associated(condition,lastcond)) goto 350 !===================================================================== 380 continue ! write whole smat ! used to find ycond .... ! do jj=1,nz1 ! write(*,390)jj,(smat(jj,jy),jy=1,nz2) ! enddo 390 format('#:',i2,6(1pe12.4),6(4x,1pe12.4)) 1000 continue ! we must ?? deallocate all data in the savedrec ! if(allocated(savedrec%save1)) then ! jj=size(saved%save1) ! deallocate(savedrec%save1) ! write(*,*)'MM deallocated saved%save1',jj ! endif ! if(allocated(savedrec%save2)) deallocate(savedrec%save2) ! if(allocated(savedrec%save3)) deallocate(savedrec%save3) ! if(allocated(savedrec%save4)) deallocate(savedrec%save4) ! if(allocated(savedrec%save5)) deallocate(savedrec%save5) return end subroutine setup_equilmatrix !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine meq_onephase !\begin{verbatim} subroutine meq_onephase(meqrec,pmi,ceq) ! this subroutine calculates new constituent fractions for a phase iph+ics ! with given T, P and chemical potentials for the components ! For ionic liquids the sites on the sublattices varies with composition ! THIS IS A FIRST VERSION WITHOUT ANY TRICKS FOR SPEED ! this will check if EEC set and modify G for solid phases with higher entropy ! pmi is pointer to a record in meq_phase, local to this thread ! than the liquid implicit none TYPE(meq_phase), pointer :: pmi TYPE(gtp_equilibrium_data), pointer :: ceq TYPE(meq_setup) :: meqrec !\end{verbatim} integer nrel,i2sly(2),info integer ik,iph,ics,jz,iz,jk,ierr,kk,kkk,ll,lokcs,ncc,loksp,ncl ! integer nd1,nd2,neq,nochange,nsl,nspel,nv,ncon,icon,jxsym,kxsym integer nd1,nd2,neq,nochange,nsl,nspel,nv,ncon,icon,jxsym,errall ! needed for call to get_phase_data integer, dimension(maxsubl) :: nkl integer, dimension(maxconst) :: knr double precision, dimension(5) :: qq double precision, dimension(maxsubl) :: sites ! needed for call to get_species_data integer, dimension(maxspel) :: ielno double precision, dimension(maxspel) :: stoi ! testing lapacl+blas inverting symmetric matrix double precision, allocatable, dimension(:) :: lapack double precision xxxx,yyyy ! minimal y, charge double precision, parameter :: ymin=1.0D-12,ymingas=1.0D-30,qeps=1.0D-30 ! derivative of moles of component wrt y_ks double precision, dimension(maxel) :: addmol ! for mass balance and charge double precision, dimension(maxconst) :: yarr,dqsum ! phase matrix, its inverse is returned as part of pmi double precision, dimension(:,:), allocatable :: pmat double precision qsp,sumsit,ykvot,ysum,qsum,spmass,yva,fion double precision, dimension(:,:), allocatable :: sumion character name*24 ! logical nolapack ! write(*,'(a,5i5)')'in meq_onephase: ',ceq%eqno,& ! pmi%iph,pmi%ics,meqrec%noofits ! set eecextrapol to TRUE when entering, ! set to FALSE inside check_eec if phase has higher entropy than liquid ! I am no longer sure this is needed?? ! eecextrapol=.TRUE. ! Maybe nolapack be removed?? ! nolapack=.TRUE. ! nolapack=.FALSE. iph=pmi%iph ics=pmi%ics nrel=meqrec%nrel ! if(mmdebug.ne.0) write(*,*)'MM meq_onephase 10: ',iph,ics ! for each phase "pmi" set eeccheck=0 at first interation ! THIS IS CURRNTLY NOT USED, will be added later if(meqrec%noofits.eq.1) then pmi%eeccheck=0 elseif(meqrec%tpindep(1).or.meqrec%tpindep(2)) then ! if T or P not conditions set eeccheck=0 at each iteration pmi%eeccheck=0 endif ! extract phase structure ! write(*,*)'MM calling get_phase_data: ',iph ! if(mmdebug.ne.0) then ! write(*,*)'MM meq_onephase 12: ',iph,ics ! gtpdebug=1 ! endif ! get_phase_data modified to ignore nonexisting composition sets call get_phase_data(iph,ics,nsl,nkl,knr,yarr,sites,qq,ceq) ! if(mmdebug.ne.0) then ! write(*,*)'MM meq_onephase 13: ',iph,ics,nsl,gx%bmperr ! gtpdebug=0 ! endif ! write(*,*)'MM back from get_phase_data',gx%bmperr if(gx%bmperr.ne.0) then ! handling of parallel by openMP !$ if(.TRUE.) then ! this is written if parallel !$ write(*,7)'get_phase_data error in meq_onephase: ',iph,ics,& !$ omp_get_thread_num(),gx%bmperr !$ else ! this is written if not parallel write(*,7)'get_phase_data error in meq_onephase: ',iph,ics,gx%bmperr !$ endif 7 format(a,2i3,2x,2i5) goto 1000 endif ! make sure all fractions >ymin and sums in all sublattices are equal to unity nochange=0 ncc=0 ! if(mmdebug.ne.0) write(*,*)'MM meq_onephase 20: ',nsl,ncc do ll=1,nsl ysum=zero ncl=ncc do ik=1,nkl(ll) ncc=ncc+1 if(yarr(ncc).lt.ymin) then if(test_phase_status_bit(iph,PHGAS)) then if(yarr(ncc).lt.ymingas) then yarr(ncc)=ymingas nochange=1 endif else nochange=1 yarr(ncc)=ymin endif endif ysum=ysum+yarr(ncc) enddo ykvot=one/ysum if(abs(ykvot-one).gt.ymingas) then nochange=1 do ik=1,nkl(ll) yarr(ncl+ik)=yarr(ncl+ik)*ykvot enddo endif enddo if(nochange.ne.0) then ! if constitution changed save it. qq will be updated automatically ! write(*,*)'MM calling set_constitution 2:',ceq%eqno,iph,ics call set_constitution(iph,ics,yarr,qq,ceq) if(gx%bmperr.ne.0) then write(*,*)'MM never error 17',iph,ics ! output if compiled with OpenMP !$ write(*,*)'Thread :',ceq%eqname,omp_get_thread_num(),gx%bmperr goto 1000 endif endif ! if(mmdebug.ne.0) write(*,*)'MM meq_onephase 30: ' if(test_phase_status_bit(iph,PHEXCB)) then ! If external charge balance phase matrix has one more line+column pmi%chargebal=1 nd1=ncc+1 ! pmi%charge=qq(2) pmi%curd%netcharge=qq(2) ! if(qq(2).gt.1.0D-8) write(*,*)'Charge: ',iph,ics,qq(2) else pmi%chargebal=0 nd1=ncc ! pmi%charge=zero pmi%curd%netcharge=zero endif !-------------------------- ! sublattice rows, nd2=nd1+1 because I use Lukas matrix inverter nd1=nd1+nsl nd2=nd1+1 ! write(*,*)'MM meq_onephase: allocate pmat',allocated(pmat) ! Allocate phase matrix, one extra dimension if external charge balance ! last column of pmat is left hand side ?? (reminicent from Lukas program) ! allocate(pmat(nd1,nd2)) ! pmat should be a square matrix allocate(pmat(nd1,nd1),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 37: ',errall gx%bmperr=4370; goto 1000 endif ! return dimension of pmi%invmat if(pmi%idim.eq.0) then pmi%idim=nd1 pmi%ncc=ncc allocate(pmi%invmat(nd1,nd1),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 38: ',errall gx%bmperr=4370; goto 1000 endif pmi%invmat=zero ! write(*,*)'Allocated invmat: ',nd1,ncc ! meqrec is not available in this routine ?? but meqrec%nrel passed in call allocate(pmi%xmol(nrel),stat=errall) allocate(pmi%dxmol(nrel,ncc),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 39: ',errall gx%bmperr=4370; goto 1000 endif ! write(*,*)'Allocated phase matrix: ',nd2,noel(),ncc endif ! value of RT should be moved before phase loop ceq%rtn=globaldata%rgas*ceq%tpval(1) !-------------------------------------------------- ! now treat different phase types call get_phase_variance(iph,nv) ! write(*,*)'MM phase variance: ',nv nvzero: if(nv.eq.0) then !------------------------------------- stoichiometric phase, fixed composition ! For stoichiometric phases calculate just G with T and P derivatives ! and driving force. All pmi%dxmol=zero but one must also calculate ! pmi%xmol and save it for all future iterations ! It must also be saved in curd%abnorm(1) ?? done in set_constitution ?? ! write(*,*)'MM xdone: ',pmi%xdone,iph,nv ! if(mmdebug.ne.0) write(*,*)'MM meq_onephase 40: ' if(pmi%xdone.eq.1) goto 90 ! we must call set_constitution once to have correct abnorm etc ! write(*,*)'MM calling set_constitution 3: ',iph,ics call set_constitution(iph,ics,yarr,qq,ceq) qsum=zero dqsum=zero pmi%xmol=zero pmi%dxmol=zero pmi%sumxmol=zero pmi%sumwmol=zero sumsit=zero do ll=1,nsl sumsit=sumsit+sites(ll) enddo kkk=0 sublatt: do ll=1,nsl allconst: do ik=1,nkl(ll) kkk=kkk+1 loksp=knr(kkk) ! call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp,spextra) call get_species_component_data(loksp,nspel,ielno,& stoi,spmass,qsp,ceq) if(gx%bmperr.ne.0) goto 1000 addmol=zero do jz=1,nspel addmol(jz)=stoi(jz) enddo dqsum(kkk)=qsp ! 160820: forgotten to multiply with site ratio??!! qsum=qsum+sites(ll)*qsp do jz=1,nspel if(ielno(jz).gt.0) then ! ignore vacancies, taken care of by using sumsit=qq(1) above pmi%dxmol(ielno(jz),kkk)=zero pmi%xmol(ielno(jz))=pmi%xmol(ielno(jz))+& sites(ll)*addmol(jz) endif enddo enddo allconst enddo sublatt ! if(qsum.ne.zero) then if(abs(qsum).gt.1.0D-14) then ! if qsum not zero this phase should be suspended as it cannot be stable write(*,88)'Stoichiometric phase with net charge: ',iph,ics,qsum 88 format(a,2i4,2(1pe12.4)) endif ! meqrec is not available in this routine ?? do iz=1,nrel pmi%sumxmol=pmi%sumxmol+pmi%xmol(iz) pmi%sumwmol=pmi%sumwmol+pmi%xmol(iz)*mass_of(iz,ceq) enddo ! phase_varres(lokcs)%abnorm already set by set_constitution pmi%xdone=1 ! 90 continue ! lokcs is set inside this subroutine call calcg(iph,ics,2,lokcs,ceq) if (gx%bmperr.ne.0) then ! write(*,91)'calcg error in meq_onephase ',iph,gx%bmperr,ceq%eqno 91 format(a,3i5) goto 1000 endif ! if(mmdebug.ne.0) write(*,*)'MM meq_onephase 45: ' eec1: if(globaldata%sysreal(1).gt.one) then ! EEC check for stoichiometric phases ! gval(1:6,1) are G, G.T, G.P, G.T.T, G.T.P, G.P.P yyyy=zero if(associated(meqrec%pmiliq)) then ! NOTE gval(2,1) is dG/dT i.e. the negative of entropy!! ! write(*,*)'MM eec1A: DS',meqrec%seecliq,& ! pmi%curd%gval(2,1)/pmi%curd%abnorm(1) if(pmi%curd%gval(2,1)/pmi%curd%abnorm(1).lt.meqrec%seecliq) then ! too high entropy, set G=1.0 (avoid 0.0 ...) yyyy=pmi%curd%gval(1,1) pmi%curd%gval(1,1)=one ! write(*,*)'MM eec1B: new G:',pmi%curd%gval(1,1),yyyy endif else ! write(*,*)'MM eec1 No liquid entropy for stoichiometric phase!' endif endif eec1 ! set the inverted phase matrix to zero !!! pmi%invmat=zero ! do ik=1,ncc ! pmi%invmat(ik,ik)=one ! enddo ! maybe some common ending goto 900 endif nvzero !--------------------------------------------- zero some arrays, ideal phase pmi%xmol=zero pmi%dxmol=zero pmi%sumxmol=zero pmi%sumwmol=zero pmi%xdone=-1 ! if(phase_model(iph,ics,PHID,ceq)) then ! write(*,*)'MM test ideal: ',test_phase_status_bit(iph,PHID) ideal: if(test_phase_status_bit(iph,PHID)) then !--------------------------------------------- ideal phase (subst, no excess) ! write(*,*)'Phase is ideal' if(test_phase_status_bit(iph,PHLIQ)) then ! write(*,*)'MM liquid ideal: ',pmi%iph,pmi%ics meqrec%pmiliq=>pmi endif ! if(mmdebug.ne.0) write(*,*)'MM meq_onephase 50: ideal' ! special treatment of ideal phase (gas), sites assumed to be unity ! 1. Calculate M_i and dM_i/dy^s_k and the net charge charge Q and dQ/dy^s_k pmi%xmol=zero pmi%dxmol=zero qsum=zero dqsum=zero ncon=0 do ik=1,nkl(1) loksp=knr(ik) ! call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp,spextra) call get_species_component_data(loksp,nspel,ielno,stoi,spmass,& qsp,ceq) if(gx%bmperr.ne.0) goto 1000 addmol=zero do jk=1,nspel addmol(jk)=stoi(jk) enddo dqsum(ik)=qsp qsum=qsum+qsp*yarr(ik) ! It seems dxmol(element,constituent) is equal to the stoichiometry ! i.e. for a molecule H2O dM_H/dy_H2O=2; dM_O/dy_H2O=1, not 2/3 and 1/3 do jk=1,nspel if(ielno(jk).ne.0) then pmi%dxmol(ielno(jk),ik)=addmol(jk) pmi%xmol(ielno(jk))=pmi%xmol(ielno(jk))+addmol(jk)*yarr(ik) ! else ! bug discovered 2024: substitutional Va means ielno(jk) is 0 ! write(*,*)'Matsmin line 5891: Vacancies have no amount' ! continue endif enddo ncon=ncon+1 enddo ! meqrec is not available in this routine ?? do ik=1,nrel pmi%sumxmol=pmi%sumxmol+pmi%xmol(ik) ! write(*,*)'sumwmol 2: ',pmi%xmol(ik),mass_of(ik,ceq) pmi%sumwmol=pmi%sumwmol+pmi%xmol(ik)*mass_of(ik,ceq) enddo ! now calculate G and all 1st and 2nd derivatives ! This can be speeded up as all 2nd derivatives of constituents are RT/y ! The calculated values are used also in other parts of the code call calcg(iph,ics,2,lokcs,ceq) if(gx%bmperr.ne.0) then write(*,*)'MM Error calculating phase',iph,ics,gx%bmperr goto 1000 endif eec2: if(globaldata%sysreal(1).gt.one) then ! EEC check for ideal phases except gas ! gval(1:6,1) are G, G.T, G.P, G.T.T, G.T.P, G.P.P xxxx=pmi%curd%gval(2,1)/pmi%curd%abnorm(1) if(test_phase_status_bit(iph,PHLIQ)) then if(associated(meqrec%pmiliq)) then ! this is a second liquid if(xxxx.lt.meqrec%seecliq) then meqrec%pmiliq=>pmi meqrec%seecliq=xxxx endif else ! this is the first (or maybe only) liquid composition set meqrec%pmiliq=>pmi meqrec%seecliq=xxxx endif elseif(.not.test_phase_status_bit(iph,PHGAS)) then if(associated(meqrec%pmiliq)) then ! NOTE gval(2,1) is dG/dT i.e. the negative of entropy!! if(xxxx.lt.meqrec%seecliq) then ! G is set to -RT*ideal entropy/RT ! write(*,*)'MM eec2A: ',pmi%curd%gval(1,1) pmi%curd%gval(1,1)=-pmi%curd%gval(2,1) ! no need to set other derivatives endif else write(*,*)'MM eec2 no liquid entropy to test!' endif endif ! write(*,*)'MM eec2B: ',pmi%curd%gval(1,1) endif eec2 ! calculate phase matrix elements ! temporarely ignore that the phase matrix is symmetric ! ceq%phase_varres(lokcs)%... ! gval(1:6,1) are G, G.T, G.P, G.T.T, G.T.P, G.P.P ! dgval(1,1:N,1) are first derivatives of G wrt constituent 1:N ! dgval(2,1:N,1) are second derivatives of G wrt constituent 1:N and T ! dgval(3,1:N,1) are second derivatives of G wrt constituent 1:N and P ! d2gval(ixsym(N*(N+1)/2),1) are 2nd derivatives of G wrt constituents N and M ! Last index is other properties than G like TC, BMAGN etc. ! if(.not.nolapack) then ! if(pmi%chargebal.eq.1) then ! neq=ncon+ll+1 ! allocate(lapack(neq*(neq+1)/2)) ! else ! neq=ncon+ll ! allocate(lapack(neq*(neq+1)/2)) ! endif ! lapack=zero ! endif pmat=zero ! this is for an ideal phase with no excess do ik=1,nkl(1) do jk=ik,nkl(1) ! ll=ixsym(ik,jk) ll=kxsym(ik,jk) pmat(ik,jk)=ceq%phase_varres(lokcs)%d2gval(ll,1) if(jk.gt.ik) pmat(jk,ik)=pmat(ik,jk) ! if(.not.nolapack) lapack(ll)=ceq%phase_varres(lokcs)%d2gval(ll,1) enddo enddo neq=nkl(1) ! write(*,770)(yarr(ik),ik=1,nkl(1)) !770 format('yfrac: ',4(1pe16.8)) ! add one column and row for each sublattice (here only one) neq=neq+1 do jk=1,neq-1 pmat(jk,neq)=one pmat(neq,jk)=one enddo if(pmi%chargebal.eq.1) then ! if external charge balance add one column and one row neq=neq+1 do jk=1,nkl(1) ! this is the row pmat(jk,neq)=dqsum(jk) ! this is the column pmat(neq,jk)=dqsum(jk) enddo endif ! invert the phase matrix (faster routine should be used) IDEAL PHASE ! removed second argument ! call mdinv(nd1,nd2,pmat,pmi%invmat,neq,ierr) call mdinv(nd1,pmat,pmi%invmat,neq,ierr) if(ierr.eq.0) then write(*,*)'MM Numeric problem 1, phase/set: ',iph,ics write(*,*)'Phase matrix singular 1:',pmi%iph,pmi%ics,pmi%ncc,ierr do jk=1,neq write(*,73)(pmat(ik,jk),ik=1,neq) enddo 73 format(1x,6(1pe12.4)) gx%bmperr=4205; goto 1000 endif goto 900 endif ideal !---------------------------------------------- no analytical 2nd derivatives ! phases with models with no analytical second derivatives .... ! if(phase_model(iph,ics,PHNODGDY2,ceq)) then ! if(test_phase_status_bit(iph,PHNODGDY2,ceq)) then if(test_phase_status_bit(iph,PHNODGDY2)) then ! write(*,*)'Models without 2nd derivatives not implemented' gx%bmperr=4206; goto 1000 endif !----------------------------------------------- ionic liquid phase ! write(*,*)'MM test I2SL: ',test_phase_status_bit(iph,PHIONLIQ) ionliq: if(test_phase_status_bit(iph,PHIONLIQ)) then ! write(*,*)'Warning; ionic liquid model not fully implemented' ! Calculate M_A and dM_A/dy_i taking into account that P and Q varies ! call get_phase_data(iph,ics,nsl,nkl,knr,yarr,sites,qq,ceq) if(test_phase_status_bit(iph,PHLIQ)) then meqrec%pmiliq=>pmi ! write(*,*)'MM liquid ionic: ',pmi%iph,pmi%ics endif ! if(mmdebug.ne.0) write(*,*)'MM meq_onephase 55: ' pmi%ionliq=nkl(1) pmi%xmol=zero pmi%dxmol=zero qsum=zero dqsum=zero pmi%sumxmol=zero pmi%sumwmol=zero allocate(sumion(nrel,2),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 40: ',errall gx%bmperr=4370; goto 1000 endif ! pmi%sumiliq=zero ! end extra ncon=0 sumion=zero yva=zero ! write(*,217)'y: ',ncc,(yarr(ik),ik=1,ncc) i2sly=nkl(1)+nkl(2)+1 do ll=1,nsl do ik=1,nkl(ll) ncon=ncon+1 loksp=knr(ncon) ! pmi%ikon(ncon)=loksp ! if only neutrals we can have a single wildcard in first sublattice ... if(loksp.lt.0) then if(ll.eq.1 .and. nkl(1).eq.1) cycle write(*,*)'Illegal wildcard constituent in ionic liquid' gx%bmperr=4197; goto 1000 endif if(btest(pmi%curd%constat(ncon),CONVA)) then ! This is the nypothetical vacancy .... its charge is sites(2) = Q yva=yarr(ncon) ! save its index in isly(1), otherwise that is number of constit+1 i2sly(1)=ncon ! pmi%valency(ncon)=sites(2) ! write(*,*)'Va: ',ncon,yva else ! call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp,spextra) call get_species_component_data(loksp,nspel,ielno,stoi,& spmass,qsp,ceq) if(gx%bmperr.ne.0) goto 1000 ! i2sly is index of first neutral (if any) otherwise number of constit+1 if(qsp.eq.zero .and. i2sly(2).gt.ncon) i2sly(2)=ncon ! write(*,*)'Species: ',ncon,i2sly,qsp ! if(qsp.eq.zero .and. i2sly(2).eq.0) i2sly(2)=ncon ! pmi%valency(ncon)=abs(qsp) ! write(*,*)'charge: ',ncon,qsp do jk=1,nspel notva: if(ielno(jk).gt.0) then ! ignore vacancies in species qsp=sites(ll)*stoi(jk) pmi%dxmol(ielno(jk),ncon)=qsp pmi%xmol(ielno(jk))=pmi%xmol(ielno(jk))+qsp*yarr(ncon) sumion(ielno(jk),ll)=sumion(ielno(jk),ll)+& stoi(jk)*yarr(ncon) ! take into account that the site ratios depend on constitition in corrion_.. ! write(*,21)'ddMA:',jk,ielno(jk),ncon,ll,& ! pmi%dxmol(ielno(jk),ncon),qsp,sites(ll),stoi(jk) !21 format(a,4i3,4(1pe12.4)) ! sums used in calc_dgdyterms1 to handle that sites(ll) depend on constitition ! pmi%sumiliq(ielno(jk),ll)=pmi%sumiliq(ielno(jk),ll)+& ! stoi(jk)*yarr(ncon) ! Hm, the statement above not necessary as below it is already included .... endif notva enddo endif enddo enddo ! save these as needed in calc_dgdyterms ! i2sly(1) is index of vacancy, if no vacancy equal to #of constituents+1 ! i2sly(2) is index if first neutral, if no neutal equal to #of constituents+1 pmi%i2sly=i2sly pmi%yva=yva ! zero matrix pmat=zero !........................................... ! goto 261 ! now handle that site ratios depend on constituent fractions ! (maybe also that the formula unit depend on composition) ! phlista(lokph)%i2slx; lokph=pmi%curd%phlink ! BUT: phlista is private .... ! M_A = P*M'_A + Q*M"_A M'_A and M"_A are in sumion(A,1:2)) ! P=\sum_j (-v_j)y_j + Qy_Va j is anion ! Q=\sum_i v_iy_i i is cation ! if(mmdebug.ne.0) write(*,*)'MM meq_onephase 60: ' icon=0 do ik=1,nkl(1) icon=icon+1 do jk=1,nrel ! for cations: extra dM_A/dyi = v_i*y_Va*M'_A + v_i*M"_A where i is cation qsp=pmi%curd%dpqdy(icon)*(yva*sumion(jk,1)+sumion(jk,2)) ! note dxmol(jk,icon) has been multiplied with sites(1) above .... pmi%dxmol(jk,icon)=pmi%dxmol(jk,icon)+qsp enddo enddo ! i2sly(1) is index of vacancy, i2sly(2) index of first neutral ! If no vacancy or no neutral the corresponding i2sly is ncc+1 do ik=1,nkl(2) icon=icon+1 if(icon.lt.min(i2sly(1),i2sly(2))) then do jk=1,nrel ! for anions: extra dM_A/dyj = (-v_j)*M'_A where j is anion qsp=pmi%curd%dpqdy(icon)*sumion(jk,1) pmi%dxmol(jk,icon)=pmi%dxmol(jk,icon)+qsp ! write(*,654)'Extra term anjon: ',jk,icon,pmi%dxmol(jk,icon),qsp enddo else ! note icon not updated correctly if neutrals, use ncon below exit endif enddo ! take care of a vacancy if(icon.eq.i2sly(1)) then do jk=1,nrel ! for Va: extra dM_A/dyi = Q*M'_A where i is vacancy pmi%dxmol(jk,icon)=sites(2)*sumion(jk,1) ! write(*,654)'Extra term for Va: ',jk,icon,& ! pmi%dxmol(jk,icon),sites(2)*sumion(jk,1) enddo endif ! Derivatives with respect to neutrals have no extra term ! do jk=1,nrel ! write(*,217)'dMA2:',jk,(pmi%dxmol(jk,ik),ik=1,ncc) ! enddo ! one may exit loop above with different values of ncon and icon, ! ncon is the total number of constituents icon=ncon !......................................... end handling P and Q variation 261 continue ! meqrec is not available in this routine ?? do ik=1,nrel pmi%sumxmol=pmi%sumxmol+pmi%xmol(ik) pmi%sumwmol=pmi%sumwmol+pmi%xmol(ik)*mass_of(ik,ceq) enddo ! now calculate G and all 1st and 2nd derivatives ! The calculated values are used also in other parts of the code call calcg(iph,ics,2,lokcs,ceq) if(gx%bmperr.ne.0) then write(*,*)'MM Error calculating G 1: ',iph,ics,lokcs goto 1000 endif ! correction of I2SL second derivatives due to variation of P and Q if(meqrec%noofits.gt.1) then ! NOTE pmat is dimensioned pmat(nd1,nd2) call corriliq_d2gdyidyj(nkl,knr,ceq%cmuval,pmi,ncon,nd1,pmat,ceq) if(gx%bmperr.ne.0) goto 1000 endif eec3: if(globaldata%sysreal(1).gt.one) then ! EEC check for ionic liquid phase (no need to test for PHLIQ) ! gval(1:6,1) are G, G.T, G.P, G.T.T, G.T.P, G.P.P xxxx=pmi%curd%gval(2,1)/pmi%curd%abnorm(1) if(associated(meqrec%pmiliq)) then ! we already have a liquid if(xxxx.gt.meqrec%seecliq) then ! this liquid has higher entropy meqrec%pmiliq=>pmi meqrec%seecliq=xxxx endif else ! save link to liquid with higest entropy meqrec%pmiliq=>pmi meqrec%seecliq=xxxx endif ! write(*,*)'MM eec3: ',meqrec%seecliq,associated(meqrec%pmiliq) endif eec3 ! write(*,17)'pots: ',(ceq%cmuval(ik),ik=1,3) ! do ll=1,nd1 ! write(*,17)'cion: ',(pmat(ll,ik),ik=1,nd1) ! enddo ! calculate phase matrix elements, the second derivatives ! note pmat has some contributions above ?? neq=icon fion=one do ik=1,icon do jk=ik,icon pmat(ik,jk)=fion*pmat(ik,jk)+& ceq%phase_varres(lokcs)%d2gval(kxsym(ik,jk),1) ! ceq%phase_varres(lokcs)%d2gval(ixsym(ik,jk),1) ! remove next line when using a routine inverting a symmetric matrix if(jk.gt.ik) pmat(jk,ik)=pmat(ik,jk) enddo enddo ! Then set the sublattice elements kk=0 do ll=1,nsl do ik=1,nkl(ll) ! set the sublattice columns and rows kk=kk+1 pmat(kk,neq+ll)=one pmat(neq+ll,kk)=one enddo enddo neq=neq+nsl ! write(*,65)'pdim: ',nd1,nd2,neq,ncon,icon,nsl,(nkl(ll),ll=1,nsl) !65 format(a,6i4,10i3) ! do ll=1,nd1 ! write(*,17)'pmat: ',(pmat(ll,ik),ik=1,nd1) 17 format(a,6(1pe12.4)) ! enddo ! invert the phase matrix (faster routine should be used) IONIC LIQUID MODEL ! call mdinv(nd1,nd2,pmat,pmi%invmat,nd1,ierr) ! write(*,*)'Value 2 of nolapsck: ',nolapack,.not.nolapack ! removed 2nd argument call mdinv(nd1,pmat,pmi%invmat,nd1,ierr) if(ierr.eq.0) then ! write(*,*)'MM Numeric problem 2, phase/set: ',iph,ics write(*,*)'Phase matrix singular 2:',pmi%iph,pmi%ics,pmi%ncc,ierr gx%bmperr=4205; goto 1000 endif ! do ll=1,nd1 ! write(*,17)'pinv: ',(pmi%mat(ll,ik),ik=1,nd1) ! enddo ! maybe some common ending goto 900 endif ionliq !------------------------------------------------- all other phase models (CEF) ! For all other phases calculate G and all first and second derivatives ! for current composition 300 continue ! write(*,*)'MM CEF phase?',ceq%eqno ! Calculate M_i and dM_i/dy^s_k and the net charge charge Q and dQ/dy^s_k ! call get_phase_data(iph,ics,nsl,nkl,knr,yarr,sites,qq,ceq) ! how to normalize xmol? use qq(1)!!, it handels vacancies .... ???? ! write(*,*)'MM Phase 1: ',pmi%iph,pmi%ics ! if(test_phase_status_bit(iph,PHLIQ)) then ! write(*,*)'MM liquid other: ',pmi%iph,pmi%ics ! meqrec%pmiliq=>pmi ! endif ! if(mmdebug.ne.0) write(*,*)'MM meq_onephase 70: ' sumsit=one pmi%xmol=zero pmi%dxmol=zero qsum=zero dqsum=zero ncon=0 pmi%sumxmol=zero pmi%sumwmol=zero subll: do ll=1,nsl constll: do ik=1,nkl(ll) ncon=ncon+1 loksp=knr(ncon) ! call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp,spextra) call get_species_component_data(loksp,nspel,ielno,stoi,spmass,qsp,ceq) if(gx%bmperr.ne.0) goto 1000 addmol=zero do jk=1,nspel addmol(jk)=stoi(jk) enddo dqsum(ncon)=sites(ll)*qsp qsum=qsum+sites(ll)*qsp*yarr(ncon) do jk=1,nspel ! write(*,963)'xmol: ',ncon,ik,jk,ielno(jk),sites(ll) !963 format(a,4i3,6(1pe12.4)) if(ielno(jk).gt.0) then ! ignore vacancies ! addmol(jk) can be replaced by stoi(jk) when I know it works .... pmi%dxmol(ielno(jk),ncon)=sites(ll)*addmol(jk) pmi%xmol(ielno(jk))=pmi%xmol(ielno(jk))+& sites(ll)*addmol(jk)*yarr(ncon) endif enddo enddo constll enddo subll ! write(*,*)'MM segmentation fault test 1',nrel ! meqrec is not available in this routine ?? do ik=1,nrel pmi%sumxmol=pmi%sumxmol+pmi%xmol(ik) ! write(*,*)'sumwmol 3:',pmi%xmol(ik),mass_of(ik,ceq) pmi%sumwmol=pmi%sumwmol+pmi%xmol(ik)*mass_of(ik,ceq) enddo ! write(*,*)'MM segmentation fault test 2' ! write(*,92)'onephase 3: ',pmi%iph,nsl,pmi%xdone,pmi%sumxmol,qq(1) !92 format(a,3i3,6(1pe12.4)) ! write(*,17)'Vacanies: ',qq ! do i=1,noel() ! write(*,17)'xm: ',pmi%xmol(i) ! write(*,17)'dxm: ',(pmi%dxmol(i,j),j=1,ncon) ! enddo ! now calculate G and all 1st and 2nd derivatives ! The calculated values are stored and used also in other parts of the code ! write(*,*)'MM segmentation fault test 3',iph,ics call calcg(iph,ics,2,lokcs,ceq) if(gx%bmperr.ne.0) then write(*,11)'MM Error calculating G 2: ',iph,ics,lokcs,gx%bmperr 11 format(a,5i5) goto 1000 endif ! if(mmdebug.ne.0) write(*,*)'MM meq_onephase 80: ' ! write(*,*)'MM segmentation fault 10',globaldata%sysreal(1) eec4: if(globaldata%sysreal(1).gt.one) then ! check of EEC for a CEF phase ! if(pmi%eeccheck.eq.0) then ! This is first iteration or we have variable T or P xxxx=pmi%curd%gval(2,1)/pmi%curd%abnorm(1) ! write(*,*)'MM eec4A: ',meqrec%noofits,associated(meqrec%pmiliq) if(test_phase_status_bit(iph,PHLIQ)) then ! This is a liquid phase if(associated(meqrec%pmiliq)) then ! We have several liquids, take the highest entropy (note xxx is -entropy!) if(xxxx.lt.meqrec%seecliq) then meqrec%pmiliq=>pmi meqrec%seecliq=xxxx endif ! write(*,*)'MM eec4B: second liquid' else ! this is the first (or maybe only) liquid composition set meqrec%pmiliq=>pmi meqrec%seecliq=xxxx endif ! write(*,'(a,l2,5(1pe12.4))')'MM eec4C: liq:',& ! associated(meqrec%pmiliq),meqrec%seecliq,& ! pmi%curd%gval(2,1),pmi%curd%abnorm(1) elseif(.not.test_phase_status_bit(iph,PHGAS)) then ! this is a condensed phase which should have its entropy checked ! NOTE gval(2,1) is dG/dT i.e. the negative of entropy!! if(xxxx.lt.meqrec%seecliq) then ! write(*,*)'MM eec4D S(solid)>S(liquid)',-xxxx,-meqrec%seecliq ! replace G and all derivates with a phase with just configurational entropy ! in the pmi%curd%gval, pmi%curd%dgval and pmi%curd%d2gval yyyy=pmi%curd%gval(1,1) call calc_eec_gibbsenergy(pmi%curd,ceq) if(gx%bmperr.ne.0) goto 1000 endif endif ! write(*,'(a,5(1pe12.4))')'MM eec4F: ',pmi%curd%gval(1,1),yyyy,& ! -meqrec%seecliq,-xxxx ! else ! write(*,*)'MM no EEC' endif eec4 ! calculate phase matrix elements, first and second derivatives ! write(*,*)'MM segmentation fault 19' pmat=zero neq=ncon ! write(*,*)'MM segmentation fault 20' ! here we are calculating CEF models do ik=1,ncon ! OK jxsym=ixsym(ik,ik); kxsym=0 jxsym=ixsym(ik,ik) do jk=ik,ncon ! fatal parallel execution frequently here ... why?? Error message: ! index '0' of dimension 1 of array 'ceq' below lower bound of 1 ! pmat(ik,jk)=ceq%phase_varres(lokcs)%d2gval(ixsym(ik,jk),1) ! modified code: ll=kxsym(ik,jk) ! ll=ixsym(ik,jk) ! OK jxsym=jxsym+kxsym; kxsym=jk ! increment jxsym at the end of the loop ... ! testing replacing ixsym .... too complicated ... if(ll.ne.jxsym) then ! write(*,*)'Problems: ',ik,jk,ll,jxsym stop "Problemns with ixsym" ! else ! write(*,*)'No problems: ',ik,jk,ll,jxsym,kxsym endif ! attempt to avoid a crash !$ if(lokcs.le.0 .or. ll.le.0) then !$ write(*,491)'meq_onephase error: ',lokcs,ll,omp_get_thread_num() 491 format(' *** ',a,4i5) !$ goto 1000 !$ endif pmat(ik,jk)=ceq%phase_varres(lokcs)%d2gval(ll,1) ! if(.not.nolapack) lapack(ll)=ceq%phase_varres(lokcs)%d2gval(ll,1) ! remove next line when using an inversion for symmetric matrix if(jk.gt.ik) pmat(jk,ik)=pmat(ik,jk) ! this is an attempt to avoid calling ixsym ... it works jxsym=jxsym+jk enddo ! write(*,17)'row2A: ',(pmat(ik,jj),jj=1,nd1) enddo ! Then set the sublattice elements ! write(*,*)'MM segmentation fault 20' kk=0 do ll=1,nsl do ik=1,nkl(ll) ! set the sublattice columns and rows kk=kk+1 pmat(kk,neq+ll)=one pmat(neq+ll,kk)=one enddo ! write(*,17)'row3: ',(pmat(ncon+ll,jj),jj=1,nd1) enddo neq=neq+nsl if(pmi%chargebal.eq.1) then ! if external charge balance add one column and one row ! It causes problem to invert the phase matrix below for a phase like ! M2O3 with cations CE+3 and LA+3 as the phase is always neutral ! and the charge balance not needed. neq=neq+1 do jk=1,ncon ! this is the row pmat(jk,neq)=dqsum(jk) ! this is the column pmat(neq,jk)=dqsum(jk) enddo endif ! write the phase matrix on a file ! open(33,file='phasemat.dat ',access='sequential',status='unknown') ! write(33,*)'Phase matrix',nd1 ! do jk=1,nd1 ! write(33,111)jk,(pmat(jk,ll),ll=1,nd1) 111 format('>',i4,1x,4(1pe15.6)) ! enddo ! debug output ! write(*,*)'Phase matrix',nd1,neq,pmi%chargebal ! do j=1,neq ! write(*,17)'pmat: ',(pmat(i,j),i=1,neq) ! enddo ! invert the phase matrix (using LAPACK+BLAS ... 50% faster than with Leo) ! removed 2nd argument ! call mdinv(nd1,nd2,pmat,pmi%invmat,neq,ierr) ! write(*,*)'MM segmentation fault 30' call mdinv(nd1,pmat,pmi%invmat,neq,ierr) if(ierr.eq.0) then write(*,*)'MM Numeric problem 3, phase/set:',iph,ics ! if(ocv()) write(*,556)'Phase matrix singular 3:',meqrec%noofits,& if(pmi%chargebal.eq.1) then ! can be problem with external chargebalance not needed ... call get_phase_name(pmi%iph,1,name) write(*,553)'Try to suspend phase: ',trim(name) 553 format(a,a) endif 556 format(a,6i5) ! emergency fix does not work ... pmi%invmat=zero do jk=1,neq pmi%invmat(jk,jk)=one/neq enddo ! do jk=1,neq ! write(*,18)'3Y mat:',jk,(pmat(ik,jk),ik=1,neq) ! enddo ! do jk=1,neq ! write(*,18)'3Y inv:',jk,(pmi%invmat(ik,jk),ik=1,neq) ! enddo 18 format(a,i3,7(1pe10.2)) ! do jk=1,neq ! write(*,73)(pmat(ik,jk),ik=1,neq) ! enddo gx%bmperr=4205; goto 1000 endif goto 900 !------------------------------------------- 900 continue ! ! if(mmdebug.ne.0) write(*,*)'MM meq_onephase exit: ' goto 1000 !-------------------------------------------- 1000 continue ! write(*,*)'MM exit meq_onephase' return end subroutine meq_onephase !ixsym !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine corriliq_d2gdyidyj !\begin{verbatim} subroutine corriliq_d2gdyidyj(nkl,knr,curmu,pmi,ncc,nd1,pmat,ceq) ! correction of d2G/dy1dy2 for ionic liquid because the formula unit is ! not fixed. This contributes ONLY to the second derivaties of G and ! is not really part of the model itself, only needed when minimizing G implicit none type(gtp_equilibrium_data), pointer :: ceq TYPE(meq_phase), pointer :: pmi integer ncc,nd1,nkl(*),knr(*) double precision curmu(*),pmat(nd1,*) !\end{verbatim} ! corr = \sum_A \mu_A*d2(N_A)/dy_i/dy_k ; i cation, k cation, anion, Va ! N_A = P*\sum_i b_Ai y_i + Q(\sum_j b_Aj y_j + ... ) b_Ai stoich.fact. of A ! P = \sum_j v_j y_j + y_Va Q ! Q = \sum_i v_i y_i ! ! Derivativs of P and Q ! dP/dy_i = y_Va v_i; dP/dy_j = v_j; dP/dy_Va = Q ! dQ/dy_i = v_i dQ/dy_j = zero dQ/dy_Va = zero ! d2P/dy_idy_Va = v_i ! ! d(N_A\mu_A)/dy_i = dP/dy_i\sum_jb_Aj + v_i ! integer icon,jcon,loksp,nspel,ielno(10),el,allions,nobug double precision stoi(10),spmass,qsp1,qsp2,add1,add2,yva,sumcat,bug double precision bugfix !tafidbug ! write(*,*)'Skipping liquid correction' ! goto 1000 ! this correction term affects only second derivatives and thus convergence ! speed and stability. But it seems just to mess up everything. ! ! dpqdy(1..ncc) is the absolute value of the charge of the species ! It is not used as we must get species data, better not to use ... ! i2sly(1) is index of vacancy, i2sly(2) is index of first neutral ! If either is missing it is equal to number of constituents+1 allions=min(pmi%i2sly(1),pmi%i2sly(2)) ! write(*,12)'mu: ',(curmu(i1),i1=1,noel()) 12 format(a,6(1pe12.4)) if(nkl(1).eq.0) then ! no cations (bor anions), only neutrals, no need to calculate anything ! write(*,*)'Liquids without cations have fixed stoichiometry 1.0 goto 1000 endif ! If there are vacancies we save its fraction here, if not set to zero ! if(pmi%i2sly(1).lt.ncc) then if(pmi%i2sly(1).le.ncc) then yva=pmi%curd%yfr(pmi%i2sly(1)) else yva=zero endif ! write(*,11)'corrion 1: ',yva,pmi%i2sly,nkl(1)+nkl(2),allions,ncc 11 format(a,1pe12.4,10i5) ! to simplify testing, 0 means include contribution from pairs of cations nobug=0 bugfix=one sumcat=zero ! just loop for all cations here. Inside this loop we step jcon ! for all constituents up to vacancies or last anion. do icon=1,nkl(1) ! icon=0 ! do i1=1,nkl(1) ! do i1=1,allions-1 ! loop for all cations and anions ! icon=icon+1 loksp=knr(icon) ! call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp1,spextra) call get_species_component_data(loksp,nspel,ielno,stoi,spmass,qsp1,ceq) if(gx%bmperr.ne.0) goto 1000 add2=zero do el=1,nspel ! skip any vacancy in a species, they have zero chemical potential anyway if(ielno(el).gt.0) add2=add2+stoi(el)*curmu(ielno(el)) enddo add1=add2 ! write(*,13)'first cat: ',icon,0,qsp1,add1 13 format(a,2i3,6(1pe12.4)) !-------------------------2nd derivatives wrt two cations jcon=icon do while(jcon.le.nkl(1)) ! loop for all pairs of cations incl twins, nkl(1) is number of cations ! A smart but messy solution is to skip this loop for jcon=icon ... loksp=knr(jcon) ! call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp2,spextra) call get_species_component_data(loksp,nspel,ielno,stoi,& spmass,qsp2,ceq) if(gx%bmperr.ne.0) goto 1000 add2=zero do el=1,nspel if(ielno(el).ne.0) add2=add2+stoi(el)*curmu(ielno(el)) enddo bug=add2 ! sumcat is used below for derivative wrt cation and vacancy if(icon.eq.1) then sumcat=sumcat+pmi%curd%yfr(jcon)*add2 ! write(*,13)'sumcat: ',0,jcon,yva,pmi%curd%yfr(jcon),& ! add2,sumcat endif ! if there are no vacancies the derivative of P is zero wrt two cations ! this is \sum_A dP/dy_icon*b_Ajcon*mu_A+\sum_A dP/dy_jcon*b_Aicon*mu_A if(nobug.eq.0 .and. yva.gt.zero) then add2=bugfix*yva*(qsp1*add2+qsp2*add1) ! if(abs(yva*(add2)).gt.1.0D2) then ! This is a sensitive point for convergence, values of 1.0D+33 found !!! ! But bad converge also when small values, less than 100 ! add2=-1.0D2 ! endif ! write(*,13)'pmat caca: ',icon,jcon,qsp1,yva,bug,add2 ! store value in pmat as correction to d2G/dyidyj pmat(icon,jcon)=-add2 ! tafidbug 2 ! pmat(icon,jcon)=add2 endif jcon=jcon+1 enddo ! ------------------------ 2nd derivative wrt to cation and anion do while(jcon.lt.allions) ! loop for all anions, allions-1 is last anion loksp=knr(jcon) ! call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp2,spextra) call get_species_component_data(loksp,nspel,ielno,stoi,& spmass,qsp2,ceq) if(gx%bmperr.ne.0) goto 1000 add2=zero do el=1,nspel if(ielno(el).ne.0) add2=add2+stoi(el)*curmu(ielno(el)) enddo bug=add2 ! This is \sum_A dP/dy_jcon*b_Aicon*mu_A+\sum_A dQ/dy_icon*b_Ajcon*mu_A ! Note dP/dy = -qsp2 as qsp2 is negative add2=qsp1*add2-qsp2*add1 ! write(*,13)'pmat caan: ',icon,jcon,qsp2,bug,add2 ! store value in pmat as correction to d2G/dyidyj pmat(icon,jcon)=-add2 ! tafidbug 2 ! pmat(icon,jcon)=add2 jcon=jcon+1 enddo !------------- second derivative wrt cation and vacancy ! if(icon.le.nkl(1) .and. jcon.eq.pmi%i2sly(1)) then if(jcon.le.ncc .and. jcon.eq.pmi%i2sly(1)) then ! if no vacancy then i2sly(1)=ncc+1 ! This is \sum_A d2P/dy_icon dy_Va*\sum_k y_k*b_Ak*\mu_A + Q * b_Aicon*\mu_A add2=qsp1*sumcat+pmi%curd%sites(2)*add1 ! It think the line above is correct but the one below works better ... ! add2=qsp1*sumcat ! write(*,13)'pmat cava: ',icon,jcon,qsp1,& ! sumcat,pmi%curd%sites(2),add1,add2 ! store value in pmat as correction to d2G/dyidyj pmat(icon,jcon)=-add2 ! tafidbug 2 ! pmat(icon,jcon)=add2 jcon=jcon+1 endif !------------- second derivative wrt cation and neutral ! is this really correct?? do while(jcon.le.ncc) loksp=knr(jcon) ! call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp2,spextra) call get_species_component_data(loksp,nspel,ielno,stoi,spmass,& qsp2,ceq) if(gx%bmperr.ne.0) goto 1000 add2=zero do el=1,nspel if(ielno(el).ne.0) add2=add2+stoi(el)*curmu(ielno(el)) enddo bug=add2 ! This is \sum_A dQ/dy_icon * b_Ajcon * mu_A, icon is cation and jcon neutal add2=qsp1*add2 ! write(*,13)'pmat cane: ',icon,jcon,qsp1,bug,add2 pmat(icon,jcon)=-add2 ! tafidbug 2 ! pmat(icon,jcon)=add2 jcon=jcon+1 enddo !------------- no other terms enddo ! write(*,*)'Correction to phase matrix from corriliq: ',& ! pmi%curd%phtupx,nobug ! do icon=1,ncc ! write(*,1100)(pmat(icon,jcon),jcon=1,ncc) ! enddo 1100 format(6(1pe12.4)) 1000 continue return end subroutine corriliq_d2gdyidyj !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable logical function same_composition !\begin{verbatim} logical function same_composition(jj,phr,meqrec,ceq,dgm) ! returns .TRUE. if phase phr(jj) has almost exactly the same composition ! as another composition set of the same phase that is stable ! dgm just for debug output ! ============================================================= ! The composition of the phases are compared as ordered phases one can have ! the same constitution but distributed on different sets of sublattices .... ! ============================================================== implicit none integer jj double precision dgm TYPE(meq_phase), dimension(*) :: phr TYPE(meq_setup) :: meqrec TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer jp,jy ! If the difference is larger than xdiff then the compositions are not the same ! double precision, parameter :: xdiff=0.01D0 ! FINETUNING: a large value of xdiff may mean you miss a miscibility gap ! a small value may create bad convergence ! 0.05 fails to find L1_2/A1/L1_0 in Au-Cu ... ! double precision, parameter :: xdiff=0.05D0 ! 0.01 works better for Au-Cu ... maybe other problems ... double precision, parameter :: xdiff=0.01D0 double precision, dimension(maxel) :: xmol1,xmol2,wmass double precision amount,totmol,totmass,xdiffm,xdiffc ! CCI same_composition=.FALSE. ! check if any other compset of the phase stable with same composition call calc_phase_molmass(phr(jj)%iph,phr(jj)%ics,xmol1,wmass,& totmol,totmass,amount,ceq) if(gx%bmperr.ne.0) goto 1000 xdiffm=one ! write(*,*)'MM testing same composition',jj,phr(jj)%iph,phr(jj)%ics ! ?? strange loop limits ?? ! do jp=jj-1,1,-1 do jp=1,meqrec%nphase if(phr(jp)%iph.eq.phr(jj)%iph) then if(phr(jp)%stable.eq.1) then call calc_phase_molmass(phr(jp)%iph,phr(jp)%ics,xmol2,wmass,& totmol,totmass,amount,ceq) if(gx%bmperr.ne.0) goto 1000 do jy=1,meqrec%nrel xdiffc=abs(xmol1(jy)-xmol2(jy)) if(xdiffc.lt.xdiffm) then xdiffm=xdiffc endif if(xdiffc.gt.xdiff) goto 110 ! if(abs(xmol1(jy)-xmol2(jy)).gt.xdiff) goto 110 enddo ! we have found another stable composition set with same composition goto 300 endif elseif(phr(jp)%iph.lt.phr(jj)%iph) then cycle else exit endif 110 continue enddo same_composition=.FALSE. goto 1000 !-------------------------------------------------------- ! we found a stable composition set with the same composition 300 continue same_composition=.TRUE. if(ocv()) write(*,117)'Not added comp.set phase: ',phr(jj)%iph,& phr(jj)%ics,phr(jp)%ics,xdiffm 117 format(a,i3,2i4,2x,1pe12.4) ! One cannot have two composition sets with same composition. ! try to reset this composition set to default constition call set_default_constitution(phr(jj)%iph,phr(jj)%ics,ceq) if(gx%bmperr.ne.0) goto 1000 ! goto 1000 ! 1000 continue return end function same_composition !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine two_stoich_same_comp !\begin{verbatim} recursive subroutine two_stoich_same_comp(irem,iadd,mapx,meqrec,inmap,ceq) ! we have found two phases stable with same composition ! ONLY USED WHEN MAPPING with tie-lines in plane ! ceq is equilibrium record implicit none integer irem,iadd,inmap,mapx type(meq_setup) :: meqrec type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} ! type(map_node), pointer :: mapnode,newnode,oldnext ! type(map_line), pointer :: nodexit type(gtp_equilibrium_data), pointer :: newceq integer nrel,nel,iph,ics,jj,seqx,phfix,lokph,lokcs,phstable,phfixtupix type(gtp_condition), pointer :: pcond,lastcond ! needed for solving a nonlinear equation integer, parameter :: lwa=100 type(gtp_state_variable), target :: axstv1 type(gtp_state_variable), pointer :: axstv integer nv,info,ip double precision newphfra,fvec(5),tol,wa(lwa),value,xv(5),tinit character phases*48 ! logical isotherm integer idum,jdum,savefix(2),saveent ! ! write(*,*)'In two_stoich_same_comp' ! write(*,*)'MM found two stable stochiometric phases with same composition' ! THIS SHOULD NOT BE USED FOR ISOPLETHS ?? ! if(meqrec%nrel.ne.2) then ! How to check if I should use this routine? Only 2 components? ! If we have an activity condition one could have 3 components .... ! write(*,*)'MM This routine should be used only when tie-lines in plane' ! gx%bmperr=4399; goto 1000 ! endif ! call get_state_var_value('X(O) ',value,phases,ceq) ! write(*,806)meqrec%fixph(1,1),meqrec%fixph(2,1),mapx,iadd,value 806 format('MM why fix phase/set: ',i3,i2,' entered: ',i3,', new fix: ',i3,& 1pe12.4) phases=' ' ! in some call iadd can be larger than its dimentsion leading to crash if(iadd.gt.size(meqrec%phr)) then write(*,*)'Error matsmin: calling two_stich_comp; ',iadd,mapx gx%bmperr=4399; goto 1000 endif call get_phasetup_name(meqrec%phr(iadd)%curd%phtupx,phases) ip=len_trim(phases) phases(ip+2:)='and' call get_phasetup_name(meqrec%phr(irem)%curd%phtupx,phases(ip+6:)) if(gx%bmperr.ne.0) goto 1000 write(*,'(a)')'MM two compounds stable at same composition: '//trim(phases) ! new T calculated in this routine should be close to current value tinit=ceq%tpval(1) ! write(*,22)'MM in two_stoich_same_comp: ',irem,iadd,ceq%tpval(1) !22 format(/20('-')/a,2i5,F8.2) ! call list_conditions(kou,ceq) ! We cannot calculate an equilibrium with two phases with exactly the same ! composition. But we can calculate the T where the two stoichiometric ! phases have the same Gibbs energy using the calc_tzero routine! ! Assuming the conditions are not too involved ... but we are dealing with a ! system with tie-lines in the plane, binary or ternary. ! use the variables tzph1 and tzph2 (in matsmin) to specify the phases involved ! DOES NOT WORK IN PARALLEL!! tzph1=irem; tzph2=iadd phases=' ' call get_phasetup_name(tzph1,phases) nv=len_trim(phases) call get_phasetup_name(tzph2,phases(nv+2:)) ! ! write(*,27)'MM two compounds: ',tzph1,tzph2,trim(phases) 27 format(a,2i4,2x,a) nv=1 tol=1.0D-6 ! hybrid1 can solve a system of nonlinear equations by calling ! subroutine tzcalc_stoich(nv,xv,fvec,iflag) is in matsmin.F90 ! the tzceq is a pointer declared in matmin and used in tzcalc_stoich tzceq=>ceq xv(1)=tzceq%tpval(1) call hybrd1(tzcalc_stoich,nv,xv,fvec,tol,info,wa,lwa) if(info.ne.1) then ! info=0 means improper input parameters ! =2 Too many calls to tzcalc_stoich ! =3 tol is too small ! =4 Convergence too slow ! write(*,*)'HYBRD solver return error: ',info if(gx%bmperr.eq.0) gx%bmperr=4371 endif if(gx%bmperr.ne.0) goto 1000 if(abs(ceq%tpval(1)-tinit).gt.2.0D1) then write(*,654)ceq%tpval(1),tinit 654 format('MM Error, too large change in T: ',2F10.2) gx%bmperr=4399; goto 1000 endif ! To have correct chemical potentials we must call meq_sameset again ! But with T fix and phase iadd set dormant ! Now set current value of T as condition ! call list_conditions(kou,ceq) ! loop all conditions until we find T and set it active. ! Maybe remove some other condition?? lastcond=>ceq%lastcondition pcond=>lastcond nv=0 jdum=0 condloop1: do while(.TRUE.) ! loop for all conditions nv=nv+1 ! write(*,*)'State variable: ',nv,pcond%statev,pcond%prescribed if(pcond%statev.eq.1) then ! This is T, the axis condition, set as active with calculated value of T pcond%prescribed=xv(1) if(pcond%active.ne.0) then write(*,77)xv(1) 77 format('Two identical stoichiometric phases want to be stable ',& 'at T=',F10.3) gx%bmperr=4399; goto 1000 endif pcond%active=0 jdum=nv else if(gx%bmperr.ne.0) then write(*,*)'Error extraction axis state variable value',gx%bmperr goto 1000 endif endif pcond=>pcond%next if(associated(pcond,lastcond)) exit condloop1 enddo condloop1 if(jdum.eq.0) then write(*,*)'Error, no condition on T!' gx%bmperr=4399; goto 1000 endif ! extract which phase is fixed (only one) savefix(1)=meqrec%fixph(1,1) savefix(2)=meqrec%fixph(1,2) ! and which is entered jdum=0 do jj=1,meqrec%nphase if(meqrec%phr(jj)%stable.eq.1) then if(meqrec%phr(jj)%iph.eq.savefix(1) .and. & meqrec%phr(jj)%ics.eq.savefix(2)) then ! write(*,*)'MM Fix phase: ',meqrec%fixph(1,1),meqrec%fixph(1,2) cycle endif if(jdum.eq.0) then ! write(*,*)'MM Entered phase',jdum,jj jdum=jj ! elseif(jj.ne.irem) then ! write(*,*)'MM More than one entered phase',jdum,jj endif endif enddo ! we must keep saveent to return the entered phase when generating exits! saveent=jdum ! write(*,*)'MM old fix phase/set and entered: ',meqrec%fixph(1,1),& ! meqrec%fixph(2,1),saveent !meq_sameset and ignore any change of the set of stable phases ! We must call meq_sameset again to have correct chemical potential at this T ! write(*,*)'MU(*) before meq_sameset: ',ceq%cmuval(1),ceq%cmuval(2) ! Now we have calculated T when both stoichiometric phases are stable ! and set this T as condition. ! set the phase iadd as suspend to avoid it will try to be stable meqrec%phr(iadd)%phasestatus=PHSUS meqrec%noofits=0 ! call list_conditions(kou,ceq) ! Strange here we have one degree of freedom! how can we calculate? No check!! ! But we must have a condition on the amount ! mapx set to zero inside this routine. Make sure no error code set!! if(gx%bmperr.ne.0) gx%bmperr=0 ! write(*,*)'MM calling meq_sameset from two_stoich_same_comp' ! write(*,*)'This is a recursive call as we call two_stoich from meq_sameset!' call meq_sameset(idum,jdum,mapx,meqrec,meqrec%phr,inmap,ceq) ! write(*,*)'MU(*) after meq_sameset: ',ceq%cmuval(1),ceq%cmuval(2) if(gx%bmperr.ne.0) then ! write(*,*)'MM Error calling meq_sameset from two_stoich',gx%bmperr goto 1000 endif ! return the entered phase in mapx (maybe not needed?) ! call get_state_var_value('X(O) ',value,phases,ceq) mapx=saveent ! write(*,807)meqrec%fixph(1,1),meqrec%fixph(2,1),mapx,iadd,value 807 format('MM old fix phase/set: ',i3,i2,' entered: ',i3,', new fix: ',i3,& 1pe12.4) ! restore status of new phase found at nodepoint as entered meqrec%phr(iadd)%phasestatus=PHENTERED ! write(*,*)'Conditions for the invariant:' ! call list_conditions(kou,ceq) ! write(*,*)'Exiting two_stoich_same_comp' ! we must set this error code to return to mapping routines ! This means two stoichiometric phases stable an node point gx%bmperr=4364 1000 continue ! Make sure status of new phase found at nodepoint as set as entered meqrec%phr(iadd)%phasestatus=PHENTERED return end subroutine two_stoich_same_comp !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_dgdyterms1 !\begin{verbatim} subroutine calc_dgdyterms1(nrel,ia,tpindep,mamu,mag,mat,map,pmi,& curmux,noofits) ! THIS SUBROUTINE IS NO LONGER USED!? Cannot be used in parallel ! any change must also be made in subroutine calc_dyterms2 and calc_dgdytermsh ! calculate the terms in the deltay expression for amounts of component ia ! ! DM_A = \sum_B mu_B*MAMU(B) - MAG - MAT*dt - MAP*dp ! ! where MAMU=\sum_i dM_A/dy_i*\sum_j invmat(i,j)*dM_B/dy_j ! c_iB=\sum_j invmat(i,j)*dM_B/dy_j etc etc ! ! it may not be very efficient but first get it right .... ! tpindep(1) is TRUE if T variable, tpindep(2) is TRUE if P are variable ! ! >>> ATTENTION, there is a FASTER VERSION calc_dgdyterms1X ! >>> ATTENTION not safe for parallelization .... ! implicit none integer ia,nrel,noofits logical tpindep(2) double precision, dimension(*) :: mamu double precision mag,mat,map double precision curmux(*) ! pmi is the phase data record for this phase type(meq_phase), pointer :: pmi !\end{verbatim} %+ ! these are to be multiplied with mu(ib), nothing, deltaT, deltaP integer iy,jy,ib,nocon,errall ! initial values for saved results OLD VERSION integer :: sameit=0,big1p=0,big2p=0,big1n=0,big2n=0 double precision cig,cit,cip,haha double precision morr double precision, allocatable, dimension(:) :: zib ! ATTENTION, see calc_dgdyterms1X !!!! for better routine double precision, allocatable, dimension(:,:) :: maybesave double precision, allocatable, dimension(:,:) :: save1 double precision, allocatable, dimension(:,:) :: save2 ! NOTE THIS SUBROUTINE IS NO LONGER USED!! save sameit,big1p,big1n,big2p,big2n save save1,save2 logical big ! !----------- ! \sum_i \sum_j e_ij*dM_A/dy_i dG/dy_j ! skip code for saving as that is implemented in calc_dgdytermes1X ! write(*,*)'Using calc_dgdyterms1 without saving' goto 100 ! code below to be ignored ! if(noofits.ne.sameit) then ! new iteration, discard saved values big1p=0; big1n=0 big2p=0; big2n=0 sameit=noofits goto 100 endif ! use save values for the phases with many constituents ! if(test_phase_status_bit(phasetuple(phr(jj)%iph)%ixphase,& if(10*pmi%iph+pmi%ics.eq.big1p) then ! write(*,13)'MM using saved values 1:',noofits,sameit,big1p,big1n,ia 13 format(a,2i5,5x,2i5,5x,3i5) mag=zero mat=zero map=zero do ib=1,nrel mamu(ib)=zero enddo do iy=1,big1n morr=pmi%dxmol(ia,iy) do ib=1,nrel mamu(ib)=mamu(ib)+save1(ib,iy)*morr enddo mag=mag+save1(nrel+1,iy)*morr if(tpindep(1)) mat=mat+save1(nrel+2,iy)*morr if(tpindep(2)) map=map+save1(nrel+3,iy)*morr enddo goto 1000 elseif(10*pmi%iph+pmi%ics.eq.big2p) then ! write(*,13)'MM using saved values 2:',noofits,sameit,big2p,big2n,ia mag=zero mat=zero map=zero do ib=1,nrel mamu(ib)=zero enddo do iy=1,big2n morr=pmi%dxmol(ia,iy) do ib=1,nrel mamu(ib)=mamu(ib)+save2(ib,iy)*morr enddo mag=mag+save2(nrel+1,iy)*morr if(tpindep(1)) mat=mat+save2(nrel+2,iy)*morr if(tpindep(2)) map=map+save2(nrel+3,iy)*morr enddo goto 1000 endif !------------------------------------ calculate as usual 100 continue !---------------------------------- mag=zero mat=zero map=zero ! if(tpindep(2)) then ! write(*,99)'MM d2G/dPdy: ',(pmi%curd%dgval(3,jy,1),jy=1,pmi%ncc) !99 format(a,6(1pe11.3)) ! endif ! noofits=1 means phase is ideal, use only diagonal nocon=pmi%ncc ! if(allocated(zib)) deallocate(zib) allocate(zib(nrel),stat=errall) if(nocon.gt.nrel) then big=.TRUE. if(allocated(maybesave)) deallocate(maybesave) allocate(maybesave(nrel+3,nocon),stat=errall) else big=.FALSE. endif if(errall.ne.0) then write(*,*)'MM Allocation error 41: ',errall gx%bmperr=4370; goto 1000 endif do ib=1,nrel mamu(ib)=zero enddo do iy=1,nocon zib=zero cig=zero; cit=zero; cip=zero do jy=1,nocon haha=pmi%invmat(jy,iy) do ib=1,nrel zib(ib)=zib(ib)+haha*pmi%dxmol(ib,jy) enddo cig=cig+haha*pmi%curd%dgval(1,jy,1) ! always calculate cit because cp debug ?? dgval(2,jy,1) is d2G/dTdy_j if(tpindep(1)) cit=cit+haha*pmi%curd%dgval(2,jy,1) if(tpindep(2)) cip=cip+haha*pmi%curd%dgval(3,jy,1) enddo morr=pmi%dxmol(ia,iy) do ib=1,nrel mamu(ib)=mamu(ib)+zib(ib)*morr if(big) maybesave(ib,iy)=zib(ib) enddo mag=mag+morr*cig if(tpindep(1)) mat=mat+morr*cit if(tpindep(2)) map=map+morr*cip if(big) then maybesave(nrel+1,iy)=cig maybesave(nrel+2,iy)=cit maybesave(nrel+3,iy)=cip endif enddo goto 1000 ! ! Ignore the code for saveing below, use calc_dgdyterms1X ! To speed up calculations we save same values ! what must be saved is what should be multiplied with pmi%dxmol(ia,iy) ! write(*,*)'Checking for saving ',noofits,10*pmi%iph+pmi%ics,nocon if(nocon.le.nrel) goto 1000 ! ATTENTION this is not really used any longer, see calc_dgdyterms1X !!! if(nocon.gt.big1n) then ! save all data for this phase with a large number of constituents big1p=10*pmi%iph+pmi%ics big1n=nocon if(allocated(save1)) deallocate(save1) allocate(save1(nrel+3,nocon),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 42: ',errall gx%bmperr=4370; goto 1000 endif do iy=1,nocon do ib=1,nrel+3 save1(ib,iy)=maybesave(ib,iy) enddo enddo ! write(*,*)'Saved 1 values for ',noofits,big1p,big1n elseif(nocon.gt.big2n) then ! save all data for this phases with a large number of constituents big2p=10*pmi%iph+pmi%ics big2n=nocon if(allocated(save2)) deallocate(save2) allocate(save2(nrel+3,nocon),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 43: ',errall gx%bmperr=4370; goto 1000 endif do iy=1,nocon do ib=1,nrel+3 save2(ib,iy)=maybesave(ib,iy) enddo enddo ! write(*,*)'Saved 2 values for ',noofits,big2p,big2n ! else ! write(*,*)'dgdy not saved: ',noofits,10*pmi%iph+pmi%ics,nocon endif 1000 continue return end subroutine calc_dgdyterms1 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine calc_dgdyterms1X !\begin{verbatim} subroutine calc_dgdyterms1X(nrel,ia,tpindep,mamu,mag,mat,map,pmi,noofits) ! THIS SUBROUTINE using allocatable arrays in phase_varres!! ! any change must also be made in subroutine calc_dyterms2 and calc_dgdytermsh ! calculate the terms in the deltay expression for amounts of component ia ! ! DM_A = \sum_B mu_B*MAMU(B) - MAG - MAT*dt - MAP*dp ! ! where MAMU=\sum_i dM_A/dy_i*\sum_j invmat(i,j)*dM_B/dy_j ! c_iB=\sum_j invmat(i,j)*dM_B/dy_j etc etc ! ! it may not be very efficient but first get it right .... ! tpindep(1) is TRUE if T variable, tpindep(2) is TRUE if P are variable ! ! >>> THIS IS THE PRINCIPAL VERSION of calc_dgdyterms WITH SAVE ! implicit none integer ia,nrel,noofits logical tpindep(2) double precision, dimension(*) :: mamu double precision mag,mat,map ! no longer used ... ! type(saveddgdy), pointer :: saved ! pmi is the phase data record for this phase type(meq_phase), pointer :: pmi !\end{verbatim} %+ ! THIS IS THE ONE CURRENTLY USED IN THE MINIMIZATIONS ! these are to be multiplied with mu(ib), nothing, deltaT, deltaP integer iy,jy,ib,nocon,errall ! initial values for saved results ! integer :: sameit=0,big1p=0,big2p=0,big1n=0,big2n=0 double precision cig,cit,cip,haha double precision morr double precision, allocatable, dimension(:) :: zib ! !----------- ! \sum_i \sum_j e_ij*dM_A/dy_i dG/dy_j ! nocon=pmi%ncc mag=zero mat=zero map=zero do ib=1,nrel mamu(ib)=zero enddo ! the logic here is a bit complicated ... ! At the first iteration the pmi%curd%invsaved is deallocated ! and the pmi%curd%invsavediter set to 0 ! but at first iteration no values are saved ! so all terms calculated at each call ! At the second iteration a new pmi%curd%invsaved is allocated ! and values are calculated and saved and pmi%curd%invsavediter set to 2 ! and these saved values are used in second and later calls ! At later iterations new values are calculated and saved in pmi%curd%invsaved ! at first call if pmi%curd%invsavediter is less than current iteration ! otherwise the saved values are used. ! The first iteration could be improved slightly but I am not sure ! pmi%curd%invsavediter can be trusted at the first iteration. !--------------------------------- if(noofits.le.1) then ! At the first iteration deallocate as we may have new conditions if(allocated(pmi%curd%invsaved)) deallocate(pmi%curd%invsaved) pmi%curd%invsavediter=0 ! write(*,17)'MM dgdycalc1X: ',noofits,pmi%iph,pmi%ics,nocon,ia,& ! pmi%curd%invsavediter,allocated(pmi%curd%invsaved) 17 format(a,6i7,l2,4i4) goto 100 ! UNFINISHED: VALGRIND indicates unititial variable ... elseif(pmi%curd%invsavediter.ne.noofits) then ! no values saved for this phase and iteration, recalcute ! 123456789.12345 ! write(*,17)'MM new iter: ',noofits,pmi%iph,pmi%ics,nocon,ia,& ! pmi%curd%invsavediter,allocated(pmi%curd%invsaved) goto 100 elseif(.not.allocated(pmi%curd%invsaved)) then ! write(*,17)'MM Not allocated?',noofits,pmi%iph,pmi%ics,nocon,ia,& ! pmi%curd%invsavediter,allocated(pmi%curd%invsaved) goto 100 endif ! use save values for the phase ! 123456789.12345 ! write(*,17)'MM using save: ',noofits,pmi%iph,pmi%ics,nocon,ia,& ! pmi%curd%invsavediter,allocated(pmi%curd%invsaved),& ! size(pmi%curd%invsaved) if(allocated(pmi%curd%invsaved)) then do iy=1,nocon morr=pmi%dxmol(ia,iy) do ib=1,nrel mamu(ib)=mamu(ib)+pmi%curd%invsaved(ib,iy)*morr enddo mag=mag+pmi%curd%invsaved(nrel+1,iy)*morr if(tpindep(1)) mat=mat+pmi%curd%invsaved(nrel+2,iy)*morr if(tpindep(2)) map=map+pmi%curd%invsaved(nrel+3,iy)*morr enddo goto 1000 else write(*,*)'MM ERROR: not allocated!',noofits,pmi%iph,pmi%ics,nocon,ia gx%bmperr=4399; goto 1000 endif !------------------------------------ calculate as usual and save at the end 100 continue !---------------------------------- ! next time for same iteration use saved values for this phase ! sameit=noofits ! allocate the pmi%curd%invsaved at first iteration if(noofits.gt.1 .and. .not.allocated(pmi%curd%invsaved)) then allocate(pmi%curd%invsaved(nrel+3,nocon),stat=errall) ! write(*,17)'MM allocate ',noofits,pmi%iph,pmi%ics,nocon,ia,& ! pmi%curd%invsavediter,allocated(pmi%curd%invsaved),& ! nrel,(nrel+3)*nocon,size(pmi%curd%invsaved) endif allocate(zib(nrel),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 44: ',errall gx%bmperr=4370; goto 1000 endif ! ! write(*,17)'MM calculate: ',noofits,pmi%iph,pmi%ics,nocon,ia,& ! pmi%curd%invsavediter,allocated(pmi%curd%invsaved),& ! nrel,(nrel+3)*nocon do iy=1,nocon zib=zero cig=zero; cit=zero; cip=zero do jy=1,nocon haha=pmi%invmat(jy,iy) do ib=1,nrel zib(ib)=zib(ib)+haha*pmi%dxmol(ib,jy) enddo cig=cig+haha*pmi%curd%dgval(1,jy,1) ! always calculate cit because cp debug ?? dgval(2,jy,1) is d2G/dTdy_j if(tpindep(1)) cit=cit+haha*pmi%curd%dgval(2,jy,1) if(tpindep(2)) cip=cip+haha*pmi%curd%dgval(3,jy,1) enddo morr=pmi%dxmol(ia,iy) do ib=1,nrel mamu(ib)=mamu(ib)+zib(ib)*morr if(noofits.gt.1) pmi%curd%invsaved(ib,iy)=zib(ib) enddo mag=mag+morr*cig if(tpindep(1)) mat=mat+morr*cit if(tpindep(2)) map=map+morr*cip if(noofits.gt.1) then pmi%curd%invsaved(nrel+1,iy)=cig pmi%curd%invsaved(nrel+2,iy)=cit pmi%curd%invsaved(nrel+3,iy)=cip endif enddo pmi%curd%invsavediter=noofits ! write(*,17)'MM saveing: ',noofits,pmi%iph,pmi%ics,nocon,ia,& ! pmi%curd%invsavediter,allocated(pmi%curd%invsaved),& ! size(pmi%curd%invsaved) ! 1000 continue return end subroutine calc_dgdyterms1X !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_dgdyterms2 !\begin{verbatim} %- subroutine calc_dgdyterms2(iy,nrel,mamu,mag,mat,map,pmi) ! Called only by meq_calc_phase_derivative ! for the contribution to G for a single phase ! it should be similar to calc_dgdyterms1 implicit none integer iy,nrel double precision mag,mat,map,mamu(*) type(meq_phase), pointer :: pmi !\end{verbatim} %+ ! these are to be multiplied with mu(ib), nothing, deltaT, deltaP ! I am not sure if this is used ... integer jy,ib double precision sum,cig,cit,cip ! ! write(*,*)'entering calc_dgdyterms2: ',iy,nrel,allocated(pmi%invmat) mag=zero do ib=1,nrel sum=zero do jy=1,pmi%ncc sum=sum+pmi%invmat(iy,jy)*pmi%dxmol(ib,jy) enddo mamu(ib)=sum enddo !----------- ! \sum_i \sum_j e_ij*dM_A/dy_i dG/dy_j cig=zero cit=zero cip=zero do jy=1,pmi%ncc cig=cig+pmi%invmat(jy,iy)*pmi%curd%dgval(1,jy,1) cit=cit+pmi%invmat(jy,iy)*pmi%curd%dgval(2,jy,1) cip=cip+pmi%invmat(jy,iy)*pmi%curd%dgval(3,jy,1) enddo mag=cig mat=cit map=cip 1000 continue return end subroutine calc_dgdyterms2 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_dgdytermsh !\begin{verbatim} %- subroutine calc_dgdytermsh(nrel,ia,tpindep,hval,mamu,mag,mat,map,pmi,& curmux,noofits) ! This is a variant of dgdyterms1 including a term multiplied with each ! term (hval) in the summation over the comstituents as needed when calculating ! an equation for fix V or H. If hval(i)=1.0 it should give the same ! results as dgdyterms1 ! ! calculate the terms in the deltay expression for amounts of component ia ! ! DM_A = \sum_B mu_B*MAMU(B) - MAG - MAT*dt - MAP*dp ! ! where MAMU=\sum_i dM_A/dy_i*\sum_j invmat(i,j)*dM_B/dy_j ! c_iB=\sum_j invmat(i,j)*dM_B/dy_j etc etc ! ! it may not be very efficient but first get it right .... ! tpindep(1) is TRUE if T variable, tpindep(2) is TRUE if P are variable implicit none integer ia,nrel,noofits logical tpindep(2) double precision, dimension(*) :: hval,mamu double precision mag,mat,map double precision curmux(*) ! pmi is the phase data record for this phase type(meq_phase), pointer :: pmi !\end{verbatim} %+ ! THIS IS MODIFIED FOR CONDITIONS ON H and related properties ! these are to be multiplied with mu(ib), nothing, deltaT, deltaP ! CHARRGE BALANCE TERM ADDED 150610!!! integer iy,jy,ib,neq double precision sum,cig,cit,cip,cib double precision morr,curmu(maxel),maq ! ! write(*,9)'in calc_dgdytermsh: ',ia,0,0,pmi%chargebal 9 format(a,4i3,6(1pe12.4)) mag=zero do ib=1,nrel sum=zero do iy=1,pmi%ncc cib=zero do jy=1,pmi%ncc cib=cib+pmi%invmat(iy,jy)*pmi%dxmol(ib,jy) enddo sum=sum+cib*hval(iy) ! write(*,11)'termsh mu: ',ib,iy,0,hval(iy),sum 11 format(a,3i2,6(1pe12.4)) enddo mamu(ib)=sum enddo !----------- ! if(noofits.eq.1) then ! curmu=zero ! else do iy=1,nrel curmu(iy)=curmux(iy) enddo ! endif !----------- ! \sum_i \sum_j e_ij*dM_A/dy_i dG/dy_j and other terms ! for phases with extrenal chargebalance we have one more row with index ! number of constituents+sublattices+1 if(pmi%chargebal.eq.1) neq=pmi%ncc+size(pmi%curd%sites)+1 maq=zero mag=zero mat=zero map=zero do iy=1,pmi%ncc cig=zero cit=zero cip=zero do jy=1,pmi%ncc ! I inversed order of iy, jy, does it still converge?? cig=cig-pmi%invmat(jy,iy)*pmi%curd%dgval(1,jy,1) ! write(*,11)'termsh g: ',ia,iy,jy,pmi%invmat(jy,iy),& ! pmi%curd%dgval(1,jy,1),cig ! always calculate cit because cp debug!! ! hval(j)=dG/dy_j-Td2G/dTdy_j or something similar if(tpindep(1)) then cit=cit-pmi%invmat(jy,iy)*pmi%curd%dgval(2,jy,1) ! write(*,11)'termsh t: ',ia,iy,jy,pmi%curd%dgval(2,jy,1),cit endif if(tpindep(2)) cip=cip-pmi%invmat(jy,iy)*pmi%curd%dgval(3,jy,1) enddo ! morr=pmi%dxmol(ia,iy) morr=hval(iy) mag=mag+morr*cig mat=mat+morr*cit map=map+morr*cip ! if(pmi%chargebal.eq.1) maq=maq+morr*pmi%invmat(neq,iy) if(pmi%chargebal.eq.1) maq=maq+morr*pmi%invmat(iy,neq) enddo ! if(pmi%chargebal.eq.1) then ! Looking for the reason of bad convergence with enthalpy condition this ! was investigated but the correction is so small it is ignored. ! For phases with external charge balance there is one more term, e_ig*Q ! number of equations are constituents+sublattices+1 ! neq=pmi%ncc+size(pmi%curd%sites)+1 ! qscale=one ! qscale=1.0D12 ! maq=maq*pmi%curd%netcharge*qscale ! write(*,911)'eiq> ',pmi%curd%phtupx,pmi%chargebal,neq,pmi%ncc,& ! pmi%curd%netcharge,mag,maq,(pmi%invmat(jy,neq),jy=1,neq) ! pmi%curd%netcharge,mag,maq,(pmi%invmat(neq,jy),jy=1,neq) 911 format(a,4i4,3(1pe12.4),/6(1pe12.4)) ! The contribution \sum_i e_iq*Q should be added (or subtracted) from mag ! mag=mag+maq ! endif ! write(*,11)'termsh: ',ia,0,0,mag,mat,map,(mamu(jy),jy=1,nrel) 1000 continue return end subroutine calc_dgdytermsh !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_dgdytermshm !\begin{verbatim} %- subroutine calc_dgdytermshm(nrel,ia,tpindep,hval,mamu,mag,mat,map,& mamu1,mag1,mat1,map1,pmi,curmux,noofits) ! This is a variant of dgdyterms1 including a term multiplied with each ! term (hval) in the summation over the comstituents as needed when calculating ! an equation for fix V or H. If hval(i)=1.0 it should give the same ! results as dgdyterms1 ! ! Probably only one of calc_dgdytermshm or calc_dgdytermsh is needed ! calculate the terms in the deltay expression for amounts of component ia ! ! DM_A = \sum_B mu_B*MAMU(B) - MAG - MAT*dt - MAP*dp ! ! where MAMU=\sum_i dM_A/dy_i*\sum_j invmat(i,j)*dM_B/dy_j ! c_iB=\sum_j invmat(i,j)*dM_B/dy_j etc etc ! ! it may not be very efficient but first get it right .... ! tpindep(1) is TRUE if T variable, tpindep(2) is TRUE if P are variable implicit none integer ia,nrel,noofits logical tpindep(2) double precision, dimension(*) :: hval,mamu,mamu1 double precision mag,mat,map,mag1,mat1,map1 double precision curmux(*) ! pmi is the phase data record for this phase type(meq_phase), pointer :: pmi !\end{verbatim} ! THIS IS MODIFIED FOR CONDITIONS ON H and related properties ! these are to be multiplied with mu(ib), nothing, deltaT, deltaP ! CHARGE BALANCE TERM ADDED 150610!!! integer iy,jy,ib,neq double precision sum,sum1,cig,cit,cip,cib ! these variables are probably redundant double precision morr,curmu(maxel),maq,maq1 ! ! write(*,9)'in calc_dgdytermsh: ',ia,nrel,pmi%ncc,pmi%chargebal 9 format(a,4i3,6(1pe12.4)) mag=zero do ib=1,nrel sum=zero sum1=zero do iy=1,pmi%ncc cib=zero do jy=1,pmi%ncc cib=cib+pmi%invmat(iy,jy)*pmi%dxmol(ib,jy) enddo sum=sum+cib*hval(iy) sum1=sum1+cib*pmi%dxmol(ia,iy) ! write(*,11)'termsh mu: ',ib,iy,0,hval(iy),pmi%dxmol(ia,iy),sum,sum1 11 format(a,3i2,6(1pe12.4)) enddo mamu(ib)=sum mamu1(ib)=sum1 ! write(*,11)'dgdyhm: ',ia,ib,0,mamu(ib),mamu1(ib) enddo !----------- ! if(noofits.eq.1) then ! curmu=zero ! else do iy=1,nrel curmu(iy)=curmux(iy) enddo ! endif !----------- ! \sum_i \sum_j e_ij*dM_A/dy_i dG/dy_j and other terms ! for phases with extrenal chargebalance we have one more row with index ! number of constituents+sublattices+1 if(pmi%chargebal.eq.1) neq=pmi%ncc+size(pmi%curd%sites)+1 maq1=zero mag1=zero mat1=zero map1=zero maq=zero mag=zero mat=zero map=zero do iy=1,pmi%ncc cig=zero cit=zero cip=zero do jy=1,pmi%ncc ! I inversed order of iy, jy, does it still converge?? cig=cig-pmi%invmat(jy,iy)*pmi%curd%dgval(1,jy,1) ! write(*,11)'termsh g: ',ia,iy,jy,pmi%invmat(jy,iy),& ! pmi%curd%dgval(1,jy,1),cig ! always calculate cit because cp debug!! ! hval(j)=dG/dy_j-Td2G/dTdy_j or something similar if(tpindep(1)) then cit=cit-pmi%invmat(jy,iy)*pmi%curd%dgval(2,jy,1) ! write(*,11)'termsh t: ',ia,iy,jy,pmi%curd%dgval(2,jy,1),cit endif if(tpindep(2)) cip=cip-pmi%invmat(jy,iy)*pmi%curd%dgval(3,jy,1) enddo morr=pmi%dxmol(ia,iy) mag1=mag1+morr*cig mat1=mat1+morr*cit map1=map1+morr*cip if(pmi%chargebal.eq.1) maq1=maq1+morr*pmi%invmat(iy,neq) ! morr=hval(iy) mag=mag+morr*cig mat=mat+morr*cit map=map+morr*cip ! if(pmi%chargebal.eq.1) maq=maq+morr*pmi%invmat(neq,iy) if(pmi%chargebal.eq.1) maq=maq+morr*pmi%invmat(iy,neq) enddo 1000 continue return end subroutine calc_dgdytermshm !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine meq_evaluate_all_svfun !\begin{verbatim} subroutine meq_evaluate_all_svfun(kou,ceq) ! evaluate (and list if kou>0) the values of all state variable functions implicit none integer kou TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} ! THIS SUBROUTINE MOVED FROM gtp3D ! if kou<0 no output character actual_arg(10)*24,star*2 integer kf,nsvfun double precision val nsvfun=nosvf() if(kou.gt.0) write(kou,75) 75 format('No Name ',12x,'Value') all: do kf=1,nsvfun ! functions with bit SVFVAL set will be ignored by meq_evaluate_svfun ! write(*,*)'MM meq_svfun: ',kf,svflista(kf)%name,& ! btest(svflista(kf)%status,SVFVAL),ceq%svfunres(kf) star=' ' if(btest(svflista(kf)%status,SVFVAL)) star='**' if(btest(svflista(kf)%status,SVFEXT)) star='<>' ! if(btest(svflista(kf)%status,SVFVAL)) then ! write(*,*)'MM only explit evaluation of: ',trim(svflista(kf)%name) ! if(kou.gt.0) write(kou,77)kf,svflista(kf)%name,svflista(kf)%value,'*' ! if(kou.gt.0) write(kou,77)kf,svflista(kf)%name,ceq%svfunres(kf),'*' ! if(kou.gt.0) write(kou,78)kf,svflista(kf)%name,ceq%svfunres(kf),'**' 78 format(i3,1x,a,1x,1PE15.7,1x,a) !78 format(i3,1x,a,1x,1PE15.8,a,' SVFVAL set') ! cycle all ! endif ! actual arguments needed if svflista(kf)%nactarg>0 ! write(*,*)'MM meq_svfun evaluate ',kf,svflista(kf)%name if(btest(svflista(kf)%status,SVFVAL)) then ! I am not really sure where the last calculated value is ??? ! better to return zero than some arbitrary value val=zero else val=meq_evaluate_svfun(kf,actual_arg,0,ceq) endif ! write(*,*)'MM meq_svfun evaluated: ',val if(gx%bmperr.ne.0) then if(kou.gt.0) then write(kou,76)kf,svflista(kf)%name,gx%bmperr 76 format(i3,1x,a,' cannot be calculated due to error ',i5) if(gx%bmperr.ge.4000 .and. gx%bmperr.le.nooferm) then write(kou,992)trim(bmperrmess(gx%bmperr)) 992 format('Meaning: ',a/) endif endif gx%bmperr=0 elseif(kou.gt.0) then write(kou,77)kf,svflista(kf)%name,val,star 77 format(i3,1x,a,1x,1PE15.7,' ',a) endif ! save the value in current equilibrium ... probably already done ... ceq%svfunres(kf)=val enddo all 1000 continue return end subroutine meq_evaluate_all_svfun !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine meq_get_state_varorfun_value !\begin{verbatim} subroutine meq_get_state_varorfun_value(statevar,value,dummy,ceq) ! used in OCPLOT to extact value of state variable of symbol ! NOTE if a specific function is given only this function evaluated implicit none character statevar*(*),dummy*(*) double precision value TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} character encoded*64,actual_arg(2)*16 integer lrot,mode,olderr ! ! write(*,*)'In meq_get_state_varofun: ',trim(statevar) ! if not derivative this will work call get_state_var_value(statevar,value,encoded,ceq) ! write(*,*)'MM meq_get_state_varofun: ',gx%bmperr,value if(gx%bmperr.ne.0) then ! if error try using meq_evaluate_svfun olderr=gx%bmperr gx%bmperr=0 encoded=statevar call capson(encoded) ! call find_svfun(encoded,lrot,ceq) call find_svfun(encoded,lrot) ! write(*,*)'In meq_get_state_varofun 2: ',& ! trim(statevar),lrot,gx%bmperr,olderr if(gx%bmperr.ne.0) then ! if error here return previous error code ! write(*,*)'In meq_get_state_varofun 3: ',gx%bmperr value=zero gx%bmperr=olderr; goto 1000 else mode=1 actual_arg=' ' ! segmentation fault in this routine call from smp2B for a Cp value ! after shifting to a new maptop record (several STEP/MAP) value=meq_evaluate_svfun(lrot,actual_arg,mode,ceq) endif endif ! return calculated state variable symbol and always set special_circumstances=0 dummy=encoded ! always reset to zero special_circumstances=0 1000 continue return end subroutine meq_get_state_varorfun_value !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable double precision function meq_evaluate_svfun !\begin{verbatim} double precision function meq_evaluate_svfun(lrot,actual_arg,mode,ceq) ! evaluates all funtions as they may depend on each other ! actual_arg are names of phases, components or species as @Pi, @Ci and @Si ! needed in some deferred formal parameters (NOT IMPLEMENTED YET) ! if mode=1 always evaluate, if mode=0 several options implicit none integer lrot,mode character actual_arg(*)*(*) TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} ! THIS SUBROUTINE MOVED FROM gtp3D ! character encoded*60 double precision argval(20) type(gtp_state_variable), target :: tsvr,tsvr2 type(gtp_state_variable), pointer :: svr,svr2 integer jv,jt,istv,ieq,nsvfun,ii double precision value ! ! modified here to handle symbols that can be used as conditions ! write(*,*)'MM: --------- start meq_evaluate_svfun',trim(svflista(lrot)%name) value=zero argval=zero nsvfun=nosvf() ieq=0 istv=0 ! FIRST ALL SYMBOLS ARE EVALUATED HERE ! write(*,*)'MM meq_evaluate_svfun 1 ',lrot,mode,svflista(lrot)%narg ! locate function if(lrot.le.0 .or. lrot.gt.nsvfun) then gx%bmperr=4140; goto 1000 endif ! this seems OK ! write(*,17)'meq_evaluate_svfun 2',lrot,trim(svflista(lrot)%name),& ! svflista(lrot)%narg,& ! btest(svflista(lrot)%status,SVFVAL),& ! btest(svflista(lrot)%status,SVFEXT),& ! btest(svflista(lrot)%status,SVCONST),& ! btest(svflista(lrot)%status,SVFTPF),& ! btest(svflista(lrot)%status,SVFDOT),& ! btest(svflista(lrot)%status,SVNOAM) 17 format(a,i3,2x,a,i3,6l2) if(svflista(lrot)%narg.eq.0) goto 300 ! get values of arguments jv=0 jt=0 100 continue jt=jt+1 istv=svflista(lrot)%formal_arguments(1,jt) ! write(*,*)'MM meq_evaluate_svfun 3A',jt,istv if(istv.gt.-1000 .and. istv.lt.0) then ! istv values between -1000 and -1 are (negative) indices to functions ! istv values less than -1000 are parameter identication symbols ! if eqnoval nonzero it indicates from which equilibrium to get its value ieq=svflista(lrot)%eqnoval !******************************************************************** ! Note!! it should be evaluated!! Not implemented ... ??? !******************************************************************** if(ieq.eq.0) then value=ceq%svfunres(-istv) else value=eqlista(ieq)%svfunres(-istv) endif ! write(*,*)'in meq_evaluate_svfun 3X',ieq,istv,value else ! the need for 1:10 was a new bug discovered in GNU fortran 4.7 and later svr=>tsvr ! inside make_stvrec istv values less than -1000 are converted call make_stvrec(svr,svflista(lrot)%formal_arguments(1:10,jt)) if(gx%bmperr.ne.0) goto 1000 if(svflista(lrot)%formal_arguments(10,jt).eq.0) then ! get state variable or symbol value ... NOTE writing a TYPE wariable !!! ! write(*,*)'MM meq_evaluate_svfun 3D: ',svr call state_variable_val(svr,value,ceq) ! error check at the end of if... else ! if special_circumstances=1 return with error code (supress a value to plot) if(special_circumstances.eq.1) then ! write(*,*)'MM special_circumstances: ',special_circumstances ! error code 4373 means value supressed due to special_circumstances gx%bmperr=4373; goto 1000 endif ! state variable derivative, the denominator is the next variable jt=jt+1 svr2=>tsvr2 ! write(*,*)'MM meq_evaluate_svfun 3W: ',jt,svr call make_stvrec(svr2,svflista(lrot)%formal_arguments(1:10,jt)) ! write(*,77)'MM meq_eval: ',jt,& ! (svflista(lrot)%formal_arguments(ii,jt),ii=1,10) 77 format(a,i2,':',20i5) ! This routine need access to subroutines in the minimizer !!! call meq_state_var_dot_derivative(svr,svr2,value,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'MM back from meq_state_var_dot_derivative',value endif endif if(gx%bmperr.ne.0) goto 1000 jv=jv+1 argval(jv)=value ! write(*,*)'in meq_evaluate_svfun 3B: ',jv,jt,argval(jv) if(jt.lt.svflista(lrot)%narg) goto 100 ! all arguments evaluated (or no arguments needed) 300 continue ! write(*,'(a,5i5,2l2)')'MM in meq_evaluate_svfun 300: ',lrot,mode,ieq,& ! svflista(lrot)%eqnoval,istv,& ! btest(svflista(lrot)%status,SVFVAL),& ! btest(svflista(lrot)%status,SVFEXT),& ! btest(svflista(lrot)%status,SVCONST) modeval: if(mode.eq.0 .and. btest(svflista(lrot)%status,SVFEXT)) then ! if mode=0 and SVFEXT=TRUE use value from equilibrium svflista(lrot)%eqnoval ! write(*,*)'MM symbol mode=0 SVFEXT=TRUE: ',lrot,ieq,istv,argval(1) ieq=svflista(lrot)%eqnoval if(ceq%eqno.eq.ieq) then value=evalf(svflista(lrot)%linkpnode,argval) ! write(*,*)'MM symbol calculated: ',lrot,ieq,istv,argval(1) if(pfnerr.ne.0) then write(*,*)'MM evaluate_svfun putfunerror ',pfnerr gx%bmperr=4141; goto 1000 endif ! why store value in svfunres(-istv) ??? THIS MUST BE WRONG AND UNECESSARY ! we should store the value in the function restult for this equilibrium ceq%svfunres(lrot)=value ! write(*,350)'MM evaluated here: ',ieq,lrot,value else value=eqlista(ieq)%svfunres(lrot) ceq%svfunres(lrot)=value ! write(*,350)'MM value from equilbrium: ',ieq,lrot,value endif elseif(mode.eq.0 .and. btest(svflista(lrot)%status,SVFVAL)) then ! If mode=0 and SVFVAL set then return the stored value ! do not evaluate, just return the stored value in svfv(lrot) !!! ! copy to current ceq!! value=svflista(lrot)%svfv ceq%svfunres(lrot)=value ! write(*,*)'MM in meq_evaluate_svfun 19:',lrot,ieq,value ! write(*,350)'HMS evaluate svfun 2: ',0,lrot,value,svflista(lrot)%svfv 350 format(a,2i4,4(1pe13.5)) ! write(*,*)'MM in meq_evaluate_svfun 20: ',lrot,ieq,ceq%eqno,value elseif(btest(svflista(lrot)%status,SVCONST)) then ! symbol is a constant, just return value value=svflista(lrot)%linkpnode%value ceq%svfunres(lrot)=value ! write(*,*)'MM symbol is a constant',lrot,value else ! if mode=1 always evaluate except if wrong eqilibrium!! ! write(*,*)'in meq_evaluate_svfun 5',argval(1) if(svflista(lrot)%eqnoval.eq.0) then value=evalf(svflista(lrot)%linkpnode,argval) if(pfnerr.ne.0) then write(*,*)'evaluate_svfun putfunerror ',pfnerr gx%bmperr=4141; goto 1000 endif ceq%svfunres(lrot)=value elseif(svflista(lrot)%eqnoval.eq.ceq%eqno) then value=evalf(svflista(lrot)%linkpnode,argval) ! write(*,350)'HMS evaluate svfun 8: ',ieq,lrot,value,ceq%tpval(1) if(pfnerr.ne.0) then write(*,*)'evaluate_svfun putfunerror ',pfnerr gx%bmperr=4141; goto 1000 endif ceq%svfunres(lrot)=value else ieq=svflista(lrot)%eqnoval value=eqlista(ieq)%svfunres(lrot) write(*,360)trim(svflista(lrot)%name),ieq,ceq%eqno 360 format('Attempt to evaluate symbol ',a,& ' for the wrong equilibrium:',2i5) ceq%svfunres(lrot)=value endif endif modeval 1000 continue meq_evaluate_svfun=value return end function meq_evaluate_svfun !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine initiate_meqrec !\begin{verbatim} subroutine initiate_meqrec(svr,svar,meqrec,ceq) ! this is to setup data for a state var derivative calculation ! taken from the normal initialization of an equilibrium calculation ! it also solves a modified equil matrix once to get delta-amounts and mu TYPE(meq_setup), pointer :: meqrec TYPE(gtp_state_variable), pointer :: svr double precision, allocatable :: svar(:) TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} TYPE(meq_phase), pointer :: pmi integer iph,ics,kst,ie,mph,lokph,lokcs,nz1,tcol,pcol,dncol,converged integer ierr,nz2,jel,ztableph1,ztableph2,ztableph3,errall double precision, allocatable :: smat(:,:) double precision xxx ! ! if(mmdebug.ne.0) write(*,*)'MM Entering initiate_meqrec 1' ! NOTE svar must be allocated!! ! svar=zero ! write(*,*)'MM Entering initiate_meqrec 2' if(btest(ceq%status,EQNOEQCAL)) then ! error if no sucessful equilibrium calculation or a failed one ! write(*,*)'No equilibrium calculated, no derivatives' ! allocate(svar(1)); svar(1)=zero gx%bmperr=4198; goto 1000 elseif(btest(ceq%status,EQFAIL)) then ! write(*,*)'Last equilibrium calculation failed, no derivatives' ! allocate(svar(1)); svar(1)=zero gx%bmperr=4198; goto 1000 elseif(btest(ceq%status,EQINCON)) then ! give warning if conditions have changed write(*,15) 15 format('Conditions changed since last equilibrium calc,',& ' values may be wrong.') ! EQNOACS is not used at present but means probably "no automatic comp.set" ! allocate(svar(1)); svar(1)=zero ! gx%bmperr=4198; goto 1000 endif ! meqrec is a pointer to an allocated record! ! allocate(meqrec) ! we must enter data into meqrec here, some set outside ... ! meqrec%typesofcond=2 meqrec%nrel=noel() meqrec%maxsph=noel()+2 meqrec%nfixph=ceq%nfixph meqrec%nfixmu=ceq%nfixmu ! this returns total number of phases including composition sets ! call sumofphcs(meqrec%nphase,ceq) ! meqrec%nphase=totalphcs(ceq) ! if we are calculating a dot_derivative the number of phases in the dynamic ! memory may be different from that in the static memory!! ! if(mmdotder.ne.0) write(*,*)'MM inititate_meqrec, mmdotder nonzero!' meqrec%nphase=nonsusphcs(ceq) if(gx%bmperr.ne.0) goto 1000 allocate(meqrec%phr(meqrec%nphase),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 45: ',errall gx%bmperr=4370; goto 1000 endif ! this means T and P are fixed (not independent) meqrec%tpindep=.FALSE. mph=0 ztableph1=0 ! if(mmdebug.ne.0) write(*,*)'MM initiate_meqrec 20:',noph() ! loop for all phases, we must set values of phase number etc ! meqrec%phr is later called "pmi" meqrec%nstph=0 do iph=1,noph() do ics=1,noofcs(iph) call get_phase_compset(iph,ics,lokph,lokcs) if(mmdotder.ne.0) then ! test if composition set exists!! lokcs is always nonzero ! but if the sites are not allocated the composition set does not exist if(allocated(ceq%phase_varres(lokcs)%sites)) then kst=test_phase_status(iph,ics,xxx,ceq) else ! write(*,*)'MM composition set does not exist!' kst=PHSUS endif else kst=test_phase_status(iph,ics,xxx,ceq) endif ! meqrec%nv=meqrec%nv+1 if(kst.ge.PHDORM) then mph=mph+1 meqrec%phr(mph)%iph=iph ! write(*,*)'phases: ',mph,iph meqrec%phr(mph)%ics=ics ! set number of constituents, DO NOT USE size(...curd%size(yfr)!!! meqrec%phr(mph)%ncc=noconst(iph,ics,ceq) meqrec%phr(mph)%phasestatus=kst meqrec%phr(mph)%ionliq=-1 meqrec%phr(mph)%i2sly=0 if(test_phase_status_bit(iph,PHIONLIQ)) meqrec%phr(mph)%ionliq=1 ! set link to calculated values of G etc. ! call get_phase_compset(iph,ics,lokph,lokcs) meqrec%phr(mph)%curd=>ceq%phase_varres(lokcs) if(kst.ge.PHENTSTAB) then ! this phase has the stable bit set ztableph1=ztableph1+1 ztableph2=lokcs ztableph3=iph meqrec%phr(mph)%stable=1 meqrec%nstph=meqrec%nstph+1 ! store the index of the phase in phr, not the phase number meqrec%stphl(meqrec%nstph)=mph else ! unstable phase meqrec%phr(mph)%stable=0 endif meqrec%phr(mph)%idim=0 ! valgrind found one case xdone was not initiated .... meqrec%phr(mph)%xdone=0 ! else ! nothing to do for suspended or hidden phase endif enddo enddo ! if(mmdebug.ne.0) write(*,*)'MM initiate_meqrec 30:' if(ztableph1.eq.1) then ! if there is a single stable phase, does it have fixed composition? ! write(*,*)'MM a single stable phase',ztableph2 if(size(ceq%phase_varres(ztableph2)%sites)-& size(ceq%phase_varres(ztableph2)%yfr).eq.0) then ! write(*,*)'MM fixed composition: ',ztableph2 xxx=-ceq%tpval(1)*ceq%phase_varres(ztableph2)%gval(4,1) ! The problem here was created somewhere else when the function for a phase ! to be optimized were changed, probably when trying to create ! already existing MAPNODE records. That error not found !! ! Calculate G for this phase !!! ! call calcg(ztableph3,1,2,ztableph2,ceq) allocate(svar(1),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 46: ',errall gx%bmperr=4370; goto 1000 endif ! ATTENTION: THIS IS A VERY TEMPORARY FIX!!!! ! gval(4,1) is the CP of a stoichiometric compound svar(1)=-ceq%tpval(1)*ceq%phase_varres(ztableph2)%gval(4,1) ! write(*,321)'MM fixed composition: ',ztableph2,& ! lokcs,xxx,svar(1),ceq%tpval(1) !321 format(a,2i5,4(1pe12.4)) goto 1000 endif endif meqrec%nphase=mph ! keep memory of adding/removing phases ! write(*,*)'MM total number of phases: ',mph ! copy current values of ceq%complist%chempot(1) to ceq%cmuval, why?? do ie=1,meqrec%nrel ceq%cmuval(ie)=ceq%complist(ie)%chempot(1)/ceq%rtn enddo meqrec%dormlink=0 ! This can be done in PARALLEL for all phases ! nullify liquid pointer nullify(meqrec%pmiliq) ! if(mmdebug.ne.0) write(*,*)'MM initiate_meqrec 40:',meqrec%nphase do mph=1,meqrec%nphase ! loop to calculte and invert the phase matrices pmi=>meqrec%phr(mph) ! write(*,*)'Inverting phase matrix ',mph ! This will calculate all G, dG/dZ1 and d2G/dZ1dZ2 and the inverted phase matrix ! if(mmdebug.ne.0) write(*,*)'MM calling meq_onephase: ',mph call meq_onephase(meqrec,pmi,ceq) if(gx%bmperr.ne.0) then write(*,*)'Error calculating phase matrix' gx%bmperr=4199; goto 1000 endif enddo ! if(mmdebug.ne.0) write(*,*)'MM initiate_meqrec 41:' ! now we will solve a modified phase matrix and calculate svar ! copy part of it from ceq%savesmat, copy also any fix mu and phase ! no problem to allocate as meqrec just allocated if(ceq%nfixmu.gt.0) then meqrec%nfixmu=ceq%nfixmu allocate(meqrec%mufixel(meqrec%nfixmu),stat=errall) do mph=1,ceq%nfixmu meqrec%mufixel(mph)=ceq%fixmu(mph) enddo endif ! if(mmdebug.ne.0) write(*,*)'MM initiate_meqrec 42:' if(ceq%nfixph.gt.0) then meqrec%nfixph=ceq%nfixph allocate(meqrec%fixph(2,meqrec%nfixph),stat=errall) do mph=1,ceq%nfixph meqrec%fixph(1,mph)=ceq%fixph(1,mph) meqrec%fixph(2,mph)=ceq%fixph(2,mph) enddo endif ! negative value of ceq%sysmatdim means no matrix saved nz1=abs(ceq%sysmatdim)+1 allocate(smat(nz1,nz1+1),stat=errall) smat=zero ! if(mmdebug.ne.0) write(*,*)'MM initiate_meqrec 43:' allocate(svar(nz1),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 47: ',errall gx%bmperr=4370; goto 1000 endif ! savesysmat not used, all equations calculated again ! do mph=1,nz1-1 ! do ie=1,nz1-1 ! smat(mph,ie)=ceq%savesysmat(mph,ie) ! enddo ! enddo ! write(*,*)'Saved equil matrix',nz1 ! do jel=1,nz1 ! write(*,86)(smat(jel,nz2),nz2=1,nz1+1) ! enddo !86 format(6(1pe12.4)) ! if(mmdebug.ne.0) write(*,*)'MM initiate_meqrec 44:' tcol=0 pcol=0 ! dncol is number of variable potentials (including T or P if variable) dncol=meqrec%nrel-meqrec%nfixmu converged=-1 if(svr%statevarid.eq.1) then tcol=nz1 meqrec%tpindep(1)=.TRUE. elseif(svr%statevarid.eq.2) then pcol=nz1 meqrec%tpindep(2)=.TRUE. else write(*,*)'Derivatives with respect to T and P allowed only' gx%bmperr=4213; goto 1000 endif !------------------------------------------------------------------- ! if(mmdebug.ne.0) write(*,854)'dncol mm: ',tcol,pcol,dncol,converged,nz1 854 format(a,10i5) call setup_equilmatrix(meqrec,meqrec%phr,nz1,smat,tcol,pcol,& dncol,converged,ceq) ! set all terms in the RHS to zero nz2=nz1+1 do mph=1,nz1 smat(mph,nz2)=zero enddo ! ! Add extra variable Delta-T for all stable phases: this is dG/dT ! This is redundant now?? do mph=1,meqrec%nstph jel=meqrec%stphl(mph) smat(mph,nz1)=-meqrec%phr(jel)%curd%gval(2,1) enddo ! this is the line for Delta T or Delta P, all terms zero except last ! if(mmdebug.ne.0) write(*,*)'MM initiate_meqrec 48:' smat(nz1,nz1)=one smat(nz1,nz2)=one ! check matrix and rhs ! write(*,*)'Equil matrix and solution in MM initiate_meqrec' ! do jel=1,nz1 ! write(*,89)jel,(smat(jel,nz2),nz2=1,nz1+1) ! enddo 89 format('MM qq: ',i2,6(1pe12.4)) ! solve equil matrix ! if(mmdebug.ne.0) write(*,*)'MM initiate_meqrec 50:',nz1 call lingld(nz1,nz1+1,smat,svar,nz1,ierr) if(ierr.ne.0) then write(*,*)'MM initiate_meqrec: error in lingld',ierr,nz1,ceq%eqno ! do jel=1,nz1 ! write(*,89)jel,(smat(jel,nz2),nz2=1,nz1+1) ! enddo ! write(*,89)0,(svar(jel),jel=1,nz1) gx%bmperr=4214; goto 1000 ! else endif ! write(*,89)0,(svar(jel),jel=1,nz1) 1000 continue return end subroutine initiate_meqrec ! allocated svar ?? !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine meq_state_var_dot_derivative !\begin{verbatim} subroutine meq_state_var_dot_derivative(svr1,svr2,value,ceq) ! calculates a state variable value, dot derivative, (in some cases) ! svr1 and svr2 identifies the state variables in (dstv1/dstv2) ! check that svr2 2 is a condition ! value is calculated value ! ceq is current equilibrium ! NOTE that when plotting after a STEP/MAP the number of phases in the ! dynamic memory (ceq) may be different that the static memory ! this is indicated by setting mmdotder nonzero ! implicit none TYPE(gtp_equilibrium_data), pointer :: ceq TYPE(gtp_state_variable), pointer :: svr1,svr2 double precision value !\end{verbatim} ! variables needed to calculate phase inverse TYPE(meq_setup), allocatable, target :: meqrec1 TYPE(meq_setup), pointer :: meqrec ! TYPE(meq_phase), pointer :: pmi TYPE(gtp_condition), pointer :: pcond integer iel,mph,jj,nterm,errall double precision xxx,sumam,summass,sumvol,s298 double precision, allocatable :: svar(:) character dum*128,elsym*2 ! ! this indicate that the number of phases in ceq may be different from ! the static number of phases mmdotder=1 value=zero ! write(*,*)'MM meq_state_var_dot_derivative 1' ! if(svr2%statevarid.ne.1) then ! This if statement added trying to avoid spurious error (caused by -O2??) ! write(dum,*)'In meq_state_var_value_derivative:',& ! svr2%statevarid,ceq%tpval(1) ! endif ! we must check if there is a condition on svr2 pcond=>ceq%lastcondition if(.not.associated(pcond)) then ! write(*,*)'There are no conditions at all!' gx%bmperr=4143; goto 1000 endif ! all conditions have just one term at present nterm=1 call get_condition(nterm,svr2,pcond) if(gx%bmperr.ne.0) then write(*,71) 71 format('To calculate a derivative the state variable after the dot',& ' must be a condition') goto 1000 elseif(pcond%active.eq.1) then ! active=1 means not active write(*,71) goto 1000 endif ! Currently only implemented H.T and HM.T if(.NOT.(svr2%statevarid.eq.1 .or. svr2%statevarid.eq.2)) then write(*,*)'Derivatives with respect to T and P only' gx%bmperr=4213; goto 1000 endif !------------ ! write(*,17)'minimzer: meq_state_var_value_derivative: ',& ! svr1%statevarid,svr1%oldstv,svr1%argtyp,& ! svr2%statevarid,svr2%oldstv,svr2%argtyp !17 format(a,10i4) ! meqrec creates the data structure for the equilibrium data ! this routine also calculated Delta-amount of phases and delta-mu allocate(meqrec1,stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 48: ',errall gx%bmperr=4370; goto 1000 endif ! problems with map7 ??? meqrec1%status=0 meqrec=>meqrec1 ! write(*,88)'MM calling initiate_meqrec',svr2%statevarid,ceq%eqno 88 format(a,2i4) ! indicate this is not an iteration by setting iteration number to -1 meqrec%noofits=-1 ! looking for segmentation fault from CP calculation when plotting ! mmdebug=1 ! initiate_meqrec will ignore nonexisting compostion sets call initiate_meqrec(svr2,svar,meqrec,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'MM back from initiate_meqrec in meq_state_var_dot_derivative' ! mmdebug=0 ! addremloop iel=size(svar) ! write(*,18)(svar(jj),jj=1,iel) 18 format('svar: ',6(1pe12.4),(6x,6e12.4)) if(iel.eq.1) then ! iel=1 means a single stoichiometrc phase stable, svar(1) is CP/RT/T ?? ! There can be a phase specification ... if(svr1%statevarid.ge.6 .and. svr1%statevarid.lt.15 .and. & svr1%argtyp.eq.2) then ! write(*,*)'MM Single stoichiometric phase stable',iel,svr1%argtyp ! nothing done? continue else if(svr1%norm.eq.2) then ! it is HW.T ....! where is mass of the phase? Which phase? Which element? ! write(*,*)'MM single phase stable which phase?' if(noel().eq.1) then call get_element_data(1,elsym,dum(1:24),dum(25:48),summass,& xxx,s298) if(gx%bmperr.ne.0) goto 1000 endif value=svar(1)*ceq%rtn/summass else value=svar(1)*ceq%rtn endif goto 1000 endif endif !--------------- !100 continue ! if no phase specified loop over all stable phases ! write(*,*)'We have initiad meqrec: ',svr1%statevarid if(svr1%statevarid.eq.3 .and. svr2%statevarid.eq.1) then ! This is MU(X).T ! it should simply be svar(svr1.%component) !! ! write(*,*)'MM: MU(A).T: ',svr1%argtyp,svr1%component iel=svr1%component call meq_calc_phase_derivative(svr1,svr2,meqrec,mph,iel,& svar,jj,xxx,ceq) value=xxx*ceq%rtn ! there can be a suffix S ?? ! gx%bmperr=4215; goto 1000 ! CCI already corrected elseif(svr1%statevarid.ge.6 .and. svr1%statevarid.lt.15) then ! This is derivatives of U, S, etc, H has svr1%statevarid=9, oldstv=40 ! Partly DONE: implement H(phase).T and normalizing iel=0 jj=1 sumam=zero summass=zero sumvol=zero ! write(*,*)'MM Calculating H.T',svr1%argtyp,meqrec%nphase ! This "if" statement should be included in the loop below if(svr1%argtyp.eq.2) then ! if argtyp=2 then it is a value for a single phase ! write(*,*)'MM svr1%argtyp 1: ',svr1%argtyp,svr1%phase,svr1%compset fph: do mph=1,meqrec%nphase ! write(*,*)'fphloop: ',mph,meqrec%phr(mph)%iph,meqrec%phr(mph)%ics ! what is meqrec%iphl(mph) ??? ! if(meqrec%iphl(mph).eq.svr1%phase .and.& ! meqrec%icsl(mph).eq.svr1%compset) exit fph if(meqrec%phr(mph)%iph.eq.svr1%phase .and.& meqrec%phr(mph)%ics.eq.svr1%compset) exit fph enddo fph 66 if(mph.gt.meqrec%nphase) then gx%bmperr=4050; goto 1000 endif ! dummy statement to avoid some strange unknown error calculating Cp write(dum,*)'MM svr1%argtyp 2: ',svr1%argtyp,mph,iel call meq_calc_phase_derivative(svr1,svr2,meqrec,mph,iel,& svar,jj,xxx,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'MM HM(phase).T: ',xxx,meqrec%phr(mph)%curd%abnorm(1),& ! meqrec%phr(mph)%curd%amfu ! normalized? svr1%norm>0 if(svr1%norm.ne.0) then if(svr1%norm.eq.1) then ! xxx is HM for one formula unit. if %norm=1 return HM.T value=xxx/meqrec%phr(mph)%curd%abnorm(1) elseif(svr1%norm.eq.2) then ! xxx is HW per mass HW.T value=xxx/meqrec%phr(mph)%curd%abnorm(2) elseif(svr1%norm.eq.3) then ! norm=3 per volume HV.T write(*,*)'Normalizing per volume not implemented: ',svr1%norm gx%bmperr=4399; goto 1000 elseif(svr1%norm.eq.4) then ! norm=4 per formula unit, HF.T value=xxx else ! no other normallizing write(*,*)'Unown normalizing: ',svr1%norm gx%bmperr=4399; goto 1000 endif else ! not normalized value for a single phase, if amount zero return zero if(meqrec%phr(mph)%curd%amfu.eq.zero) then ! elseif %amfu=0 return H.T=0 value=zero else ! else returm HM.T*NP(alpha) ??? value=xxx*meqrec%phr(mph)%curd%amfu/meqrec%phr(mph)%curd%abnorm(1) endif endif goto 77 endif ! sum over all stable phases do mph=1,meqrec%nphase ! ignore phases with zero amount if(meqrec%phr(mph)%curd%amfu.gt.zero) then ! the hope is that the phase amounts in svar are in the same order as ! in svar as ordered in meqrec%phr ... ! SEGMENTATION FAULT on LINUX with -O2 unless write statement at 69 is there ! It happends in macro step1 if you run all macros. No error if just step1 ! STRANGE !!! call meq_calc_phase_derivative(svr1,svr2,meqrec,mph,iel,& svar,jj,xxx,ceq) if(gx%bmperr.ne.0) goto 1000 sumam=sumam+& meqrec%phr(mph)%curd%amfu*meqrec%phr(mph)%curd%abnorm(1) summass=summass+& meqrec%phr(mph)%curd%amfu*meqrec%phr(mph)%curd%abnorm(2) jj=jj+1 ! this dummy write statement is to avoid SEGMENTATION FAULT when -O2 ! The segmentation fault persists also in oc5P if this write removed!! ! write(dum,69)'MM der: ',mph,ceq%tpval(1),value,xxx,& ! meqrec%phr(mph)%curd%amfu 69 format(a,i3,6(1pe14.6)) else xxx=zero endif value=value+xxx enddo if(svr1%norm.eq.1) then ! normallize with respect to number of moles of atoms ! write(*,*)'MM sumam: ',value,sumam value=value/sumam elseif(svr1%norm.eq.2) then ! xxx is HW per mass HW.T value=value/summass elseif(svr1%norm.ne.0) then ! no other normallizing implemented write(*,*)'Illegal normalizing: ',svr1%norm gx%bmperr=4399; goto 1000 endif 77 continue elseif(svr1%statevarid.eq.17) then ! This should be x(phase,element).T ! write(*,*)'MM: X(PHASE,A).T not implemented',svr1%argtyp,svr1%phase,& ! svr1%compset,svr1%component do mph=1,meqrec%nphase if(svr1%phase.eq.meqrec%phr(mph)%iph .and. & svr1%compset.eq.meqrec%phr(mph)%ics) then call meq_slope(mph,svr1,meqrec,value,ceq) write(*,*)'meq_slope: Not implemented x(phase,element).T' gx%bmperr=4215; goto 1000 endif enddo ! write(*,*)'No such phase' ! gx%bmperr=4050 else write(*,900)svr1%statevarid,svr1%argtyp,svr1%phase,svr1%compset,& svr1%component 900 format('MM: this dot derivative not implemented',6i5) gx%bmperr=4215; goto 1000 endif 1000 continue ! meqrec1 deallocated automatically? if(allocated(meqrec1)) deallocate(meqrec1) ! if(svr2%statevarid.ne.1) then ! This if statement added trying to avoid spurious error (caused by -O2??) ! write(dum,*)'MM exit meq_state_var_value_derivative',value ! endif ! reset mmdotder to zero ! write(*,*)'MM exit meq_state_var_dotderivative' mmdotder=0 return end subroutine meq_state_var_dot_derivative !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine meq_calc_phase_derivative !\begin{verbatim} subroutine meq_calc_phase_derivative(svr1,svr2,meqrec,iph,iel,& svar,jj,value,ceq) ! Calculate contribution for one phase, one or all elements ! svr1 and svr2 identifies the state variables in (dstv1/dstv2) ! value is calculated value returned ! iph and iel indicate possible phase or element ! svar is solution to equil matrix, potentials and phase amounts ! jj is an attempt to index phases in svar, starting with 1 ! ceq is current equilibrium ! ! THIS IS UNFINISHED can only handle H.T ! implicit none TYPE(gtp_equilibrium_data), pointer :: ceq TYPE(gtp_state_variable), target :: svr1,svr2 TYPE(meq_setup), pointer :: meqrec integer iph,iel,jj double precision value,svar(*) !\end{verbatim} ! variables needed to calculate phase inverse TYPE(meq_phase), pointer :: pmi integer jy,jel,jz,phncc,errall double precision x1,x2,x3 double precision mag,mat,map,dpham,musum,dy,hconfig double precision, allocatable :: mamu(:) ! ! THE MASTER VERSION OF THIS TABLE in GTP3C.F90 ! symb cmix(2) indices statevarid Property ! U 10 (phase#set) 6 Internal energy (J) ! UM 11 " 6 per mole components ! UW 12 " 6 per kg ! UV 13 " 6 per m3 ! UF 14 " 6 per formula unit ! S 2x " 7 entropy ! V 3x " 8 volume ! H 4x " 9 enthalpy ! A 5x " 10 Helmholtz energy ! G 6x " 11 Gibbs energy ! NP 7x " 12 moles of phase ! BP 8x " 13 mass of moles ! DG 9x " 15 ? Driving force ! Q 19x " 14 ? Internal stability ! N 11x (component/phase#set,component) 16 moles of components ! X 111 " 17 mole fraction of components ! B 12x " 18 mass of components ! W 122 " 19 mass fraction of components ! Y 13 phase#set,constituent#subl 20 constituent fraction ! statevarid=1 is T, 2 is P, 3 is MU, 4 is AC, 5 is LNAC !------------------------------------------------------------ ! write(*,*)'MM meq_calc_phase_derivative',iph,iel allocate(mamu(meqrec%nrel),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 49: ',errall gx%bmperr=4370; goto 1000 endif pmi=>meqrec%phr(iph) value=zero ! CCI hconfig=zero if(iel.lt.0) then ! sum for all elements write(*,*)'sum over elements not implemented' gx%bmperr=4216 elseif(iel.eq.0) then ! independent of element, return for phase musum=zero ! pmi%ncc here is not set correctly ... WHEN? ! phncc=size(pmi%curd%yfr) phncc=pmi%ncc ! PROBLEM 181208: step5 macro: size(pmi%curd%yfr) is 1000 (default) ! but pmi%ncc is 8 (total number of constituents) ! I do not remember why this was changed ! write(*,*)'MM derivative: ',iph,pmi%ncc,phncc ! do jy=1,pmi%ncc do jy=1,phncc ! The loop to handle the contribution from fractions in each phase dZ/dyi dy=zero ! special if just a single element ... if(allocated(pmi%invmat)) then call calc_dgdyterms2(jy,meqrec%nrel,mamu,mag,mat,map,pmi) if(gx%bmperr.ne.0) goto 1000 else ! we have a stoichiometric phase with a single component ?? ! write(*,*)'MM No inverted phase matrix allocated',jy mamu=zero; mag=zero ! gx%bmperr=4399; goto 1000 endif jz=1 if(meqrec%nfixmu.gt.0) then ! if there are fixed potentials such elements should be ignored here ! as there is no value in svar (value is zero as fixed) write(*,*)'Dot derivatives with potential condition not implemented' goto 1000 endif ! sum the contribution for the potentials do jel=1,meqrec%nrel jz=jz+1 dy=dy+mamu(jel)*svar(jel) ! write(*,666)'dy: ',mamu(jel),svar(1),dy enddo dy=dy-mat ! write(*,666)'dy: ',mat,dy ! here we check which state variable we take derivative of, H is 9 ! write(*,*)'MM svr1: ',svr1%statevarid,svr1%norm select case(svr1%statevarid) case default ! state variables 1..5 are potentials, 14-15 not possible to derivate write(*,*)'Illegal state variable id:',svr1%statevarid gx%bmperr=4188; goto 1000 case(6) !U = G + TS - PV = G - T G.T - P G.P write(*,*)'Not implemented yet: ',svr1%statevarid case(7) !S = -G.T hconfig=-pmi%curd%dgval(2,jy,1) case(8) !V = G.P write(*,*)'Not implemented yet: ',svr1%statevarid case(9) !H = G + TS = G - T G.T ! this gives contribution also when plotting H(liq).T and HM(liq).T in step1 ! but it is identical to Thermo-Calc .... thus correct hconfig=pmi%curd%dgval(1,jy,1)-ceq%tpval(1)*pmi%curd%dgval(2,jy,1) case(10) !A = G - PV = G - P G.P write(*,*)'Not implemented yet: ',svr1%statevarid case(11) !G itself, dG/dy hconfig=pmi%curd%dgval(1,jy,1) case(12) !NP phase amount write(*,*)'Not implemented yet: ',svr1%statevarid case(13) !BP phase mass write(*,*)'Not implemented yet: ',svr1%statevarid case(16) !N write(*,*)'Not implemented yet: ',svr1%statevarid case(17) !X write(*,*)'Not implemented yet: ',svr1%statevarid case(18) !B write(*,*)'Not implemented yet: ',svr1%statevarid case(19) !W write(*,*)'Not implemented yet: ',svr1%statevarid case(20) !Y write(*,*)'Not implemented yet: ',svr1%statevarid end select ! if(svr1%statevarid.eq.9) then ! hconfig=pmi%curd%dgval(1,jy,1)-ceq%tpval(1)*pmi%curd%dgval(2,jy,1) ! endif musum=musum+hconfig*dy ! write(*,*)'musum: ',musum,dy enddo x1=zero; x2=zero ! write(*,765)'x3= ',ceq%rtn,pmi%curd%amfu,musum if(svr1%norm.eq.1 .and. svr1%argtyp.eq.2) then ! for HM(phase).T the change in of phase amount should be ignored dpham=zero x3=musum*ceq%rtn else ! extract the change in phase amount (for stable phases!!!) ! we have to take care of fixed chemical potentials, the number of ! elements+1-(#fixed mu) should be the index of dpham, ! the change in phase amount ! The way of indexing with jj is dangerous ... dpham=svar(meqrec%nrel+jj) ! for current amount x3=musum*ceq%rtn*pmi%curd%amfu endif ! write(*,665)'dpham: ',meqrec%nrel,jj,svar(meqrec%nrel+jj-1),& ! svar(meqrec%nrel+jj) 665 format(a,2i3,6(1pe14.6)) ! here we again select the state variable we take derivative of, H is 9 ! write(*,*)'MM svr2: ',svr1%statevarid,svr1%norm select case(svr1%statevarid) case default ! state variables 1..5 are potentials, 14-15 not possible to derivate write(*,*)'Illegal state variable id:',svr1%statevarid gx%bmperr=4188; goto 1000 case(6) !U = G + TS - PV write(*,*)'Not implemented yet: ',svr1%statevarid gx%bmperr=4215 case(7) !S = -dG/dT x1=-ceq%rtn*dpham*pmi%curd%gval(2,1) x2=-ceq%rtn*pmi%curd%amfu*ceq%tpval(1)*pmi%curd%gval(4,1) write(*,*)'Not implemented yet: ',svr1%statevarid gx%bmperr=4215 case(8) !V = dG/dP write(*,*)'Not implemented yet: ',svr1%statevarid gx%bmperr=4215 case(9) !H = G + TS = G - T G.T ! x1 is change in phase amount times H. Skip this if svr1%norm.eq.1 x1=-ceq%rtn*dpham*& (pmi%curd%gval(1,1)-ceq%tpval(1)*pmi%curd%gval(2,1)) ! write(*,666)'x1: ',ceq%rtn,dpham,pmi%curd%gval(1,1),& ! ceq%tpval(1)*pmi%curd%gval(2,1),x1 ! x2 is phase_amount * dH/dT = .. -T*d2G/dT2 = -T ! CCI changed order of tests, does not work for step1 if(dpham.ne.zero) then ! there is a change in phase amounts x2=-ceq%rtn*pmi%curd%amfu*ceq%tpval(1)*pmi%curd%gval(4,1) elseif(svr1%norm.eq.1) then !xCCI if(svr1%norm.eq.1) then ! compared with Thermo-Calc this seems correct, it is just HM(phase).T x2=-ceq%rtn*ceq%tpval(1)*pmi%curd%gval(4,1) ! write(*,444)'Phase: ',iph,x1,x2,x3 !444 format(a,i3,3(1pe14.6)) !xCCI else !xCCI x2=-ceq%rtn*pmi%curd%amfu*ceq%tpval(1)*pmi%curd%gval(4,1) else ! This is H.T or H(phase).T, should be (amount of phase)*HM.T ! when there is no change of amount of phase x2=-ceq%rtn*pmi%curd%amfu*ceq%tpval(1)*pmi%curd%gval(4,1) endif ! CCI end of correction case(10) !A = G - PV write(*,*)'Not implemeneted yet: ',svr1%statevarid case(11) !G itself x1=-ceq%rtn*dpham*pmi%curd%gval(1,1) x2=ceq%rtn*pmi%curd%amfu*pmi%curd%gval(2,1) ! write(*,*)'G.T: ',x1,x2 case(12) !NP phase amount write(*,*)'Not implemeneted yet: ',svr1%statevarid case(13) !BP phase mass write(*,*)'Not implemeneted yet: ',svr1%statevarid case(16) !N moles write(*,*)'Not implemeneted yet: ',svr1%statevarid case(17) !X mole fraction write(*,*)'Not implemeneted yet: ',svr1%statevarid case(18) !B mass write(*,*)'Not implemeneted yet: ',svr1%statevarid case(19) !W mass fraction write(*,*)'Not implemeneted yet: ',svr1%statevarid case(20) !Y constituent fraction write(*,*)'Not implemeneted yet: ',svr1%statevarid end select ! if(svr1%statevarid.eq.9) then ! x1 is change in phase amount times H ! x1=-ceq%rtn*dpham*(pmi%curd%gval(1,1)-ceq%tpval(1)*pmi%curd%gval(2,1)) ! x2 is phase_amount * dH/dT = .. -T*d2G/dT2 = -T ! x2=-ceq%rtn*pmi%curd%amfu*ceq%tpval(1)*pmi%curd%gval(4,1) ! endif ! x3 is phase amount times change in configuration ! x3=ceq%rtn*pmi%curd%amfu*musum ! only derivativs wrt T are allowed!! ! write(*,666)'CP= ',svr1%norm,x1,x2,x3,x1+x2+x3,dpham,pmi%curd%amfu 666 format(a,i3,6(1pe12.4)) ! just to show the error ! value=x2 value=x1+x2+x3 else ! the derivative of the chemical potential of iel wrt T value=svar(iel) ! write(*,*)'Chemical potential: ',iel,value ! gx%bmperr=4215 endif ! 1000 continue return end subroutine meq_calc_phase_derivative !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine meq_slope !\begin{verbatim} subroutine meq_slope(mph,svr,meqrec,value,ceq) ! Test subroutine for x(phase,A).T UNFINISHED TYPE(meq_setup) :: meqrec TYPE(gtp_equilibrium_data), pointer :: ceq TYPE(gtp_state_variable) :: svr double precision value integer mph !\end{verbatim} ! TYPE(meq_phase), pointer :: pmi integer nsl,nkl(10),knr(maxconst) double precision yarr(maxconst),sites(10),qq(5) ! call get_phase_data(svr%phase,svr%compset,nsl,nkl,knr,yarr,sites,qq,ceq) if(gx%bmperr.ne.0) goto 1000 ! UNFINISHED ! 1000 continue return end subroutine meq_slope !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calfun !\begin{verbatim} subroutine calfun(m,n,x,f,info,niter) ! This is called by the LMDIF1 routines and calls an OC subroutine ! as I had problems using EXTERNAL ! M is number of errors ! N is number of variables ! NOTE order of X and F switched in CALFUN and ASSESSMENT_CALFUN !!! integer m,n,info,i,niter double precision f(m),x(n) !\end{veratim} double precision sum ! write(*,*)'MM enter calfun',info,niter,m,n if(info.eq.0) then sum=zero do i=1,m sum=sum+f(i)**2 enddo if(niter.eq.-100) then continue elseif(niter.lt.0) then ! this marks end of optimization output of the individual errors write(*,15)-niter,sum 15 format(/'Final results after ',i3,& ' iteration, the sum of squares',1pe14.6) write(*,16)x 16 format('Scaled param: ',4(1pe14.6)/5(1pe14.6)) write(*,17)f 17 format('Errors: '/6(1pe13.5)) write(*,*) elseif(niter.ge.0) then write(*,18)niter,sum 18 format(/'After ',i4,' iterations the sum of squares',1pe14.6) write(*,19)x 19 format('Scaled param: ',4(1pe16.8)/5(1pe16.8)) endif else ! This routine is in the matsmin.F90 file ! it returns the calculated value of the property to fit ! This call removed and the whole subroutine is probably redundant call assessment_calfun(m,n,f,x) endif return end subroutine calfun !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine assessment_calfun !\begin{verbatim} subroutine assessment_calfun(nexp,nvcoeff,errs,xyz) ! nexp is number of experiments, nvcoeff number of coefficients ! errs is the differences between experiments and value calculated by model ! returned by this subroutine ! xyz are the scaled current model parameter values implicit none integer nexp,nvcoeff double precision errs(*),XYZ(*) ! type(gtp_assessmenthead), pointer :: ash !\end{verbatim} ! firstash is the data structure for assessment head (globally declared) integer i1,i2,iexp,symsym,mode,jj,savix,next double precision xxx,yyy,zzz type(gtp_equilibrium_data), pointer :: equil type(gtp_condition), pointer :: experiment type(gtp_state_variable), pointer :: svrrec character text*24 double precision xa(100) ! ! write(*,*)'MM in assessment_calfun',nexp,nvcoeff ! if(allocated(calcexp)) write(*,*)'Calculating Jacobian' ! 1. copy values of X to the TP coefficinets, loop through all i2=1 do i1=0,size(firstash%coeffstate)-1 ! write(*,*)'MM2 Testing value of firstash%coeffstate',i1 if(firstash%coeffstate(i1).ge.10) then ! write(*,*)'MM3 coefficient ',i1,i2,xyz(i2) ! Attempt to handle that I divide coef with scaling factor ... zzz=xyz(i2)*firstash%coeffscale(i1) xxx=xyz(i2)*firstash%coeffscale(i1) call get_value_of_constant_index(firstash%coeffindex(i1),zzz) ! write(*,16)i2,i1,xyz(i2),firstash%coeffscale(i1),xxx,zzz 16 format('MM4 Opt coeff ',2i4,4(1pe12.4)) savix=i1 call change_optcoeff(firstash%coeffindex(i1),xxx) if(gx%bmperr.ne.0) goto 1000 xa(i2)=xxx i2=i2+1 ! else ! write(*,*)'MM5 coefficient not variable',i1 endif enddo ! 2. calculate all differences, skipping equilibria with weight zero ! the array firstash%eqlista contain pointers to equilibria with experiments 700 continue if(.not.allocated(firstash%eqlista)) then write(kou,*)' *** Warning: no experimental data!' do i1=1,nexp errs(i1)=zero enddo goto 1000 ! else ! write(*,*)'MM6 First equilibrium number: ',firstash%firstexpeq ! write(*,17)size(firstash%eqlista),firstash%firstexpeq 17 format('MM Number of equilibra with experiments: ',i5,', first is ',i3) ! do i1=1,size(firstash%eqlista) ! write(*,21)i1,firstash%eqlista(i1)%p1%eqname !21 format('MM Equilibrium number ',i3,' and name: ',a) ! enddo endif ! Seach for any symbol that should be calculated at a particulat equilibrium ! For example a reference enthalpy. This equilibrium must be calculated ! before any parallel calculation of the others next=-1 do while(next.ne.0) call find_symbol_with_equilno(next,i1) ! write(*,*)' ******* checking for equilibrium to be calculated first' if(i1.gt.0) then if(firstash%eqlista(i1)%p1%weight.gt.zero) then equil=>firstash%eqlista(i1)%p1 ! write(*,*)' ******* equilibrium to be calculated first: ',i1 ! Force recalculation of all TP functions and parameters by changing saved T ! This does not change the value of T used for the equilibrium equil%eq_tpres%tpused(1)=equil%tpval(1)+one ! calculate the equilibria without grid minimizer mode=-1 call calceq3(mode,.FALSE.,equil) if(gx%bmperr.ne.0) then write(kou,33)gx%bmperr,equil%eqno,trim(equil%eqname) gx%bmperr=0 endif text=' ' ! evaluate symbol "next" (which is current!!) with force xxx=evaluate_svfun_old(next,text,1,equil) if(gx%bmperr.ne.0) then gx%bmperr=0 xxx=meq_evaluate_svfun(next,text,1,equil) endif ! we do not need the value here, it is stored at the symbol ! write(*,*)'MM Symbol at equil: ',next,i1,gx%bmperr,xxx endif endif enddo ! loop through all equilibria with experiments ! each can be calculated in parallel iexp=0 if(gx%bmperr.ne.0) then write(*,*)'In assessment_calfun: resting error code: ',gx%bmperr gx%bmperr=0 endif eqloop: do i1=1,size(firstash%eqlista) if(firstash%eqlista(i1)%p1%weight.eq.zero) then ! write(*,29)i1,firstash%eqlista(i1)%p1%eqname 29 format('MM Skipping equilibrium number ',i3,' and name: ',a) cycle eqloop endif ! write(*,30)i1,trim(firstash%eqlista(i1)%p1%eqname) 30 format('MM Assessment_calfun equilibrium number ',i3,' and name: ',a) equil=>firstash%eqlista(i1)%p1 ! Force recalculation of all TP functions and parameters by changing saved T equil%eq_tpres%tpused(1)=equil%tpval(1)+one ! calculate the equilibria without grid minimizer ! write(*,*)'MM calculating equil: ',equil%eqno ! mode=-1 do not use gridmin and check after ... mode=-1 call calceq3(mode,.FALSE.,equil) if(gx%bmperr.ne.0) then write(kou,33)gx%bmperr,equil%eqno,trim(equil%eqname) 33 format(' *** Error ',i5,' calculating equilibrium no: ',i5,& ' with name ',a) gx%bmperr=0 cycle ! else ! write(*,*)'Equilibrium calculated for ',equil%eqname endif ! loop through all experiments, pointer set to first if(.not.associated(equil%lastexperiment)) then ! write(*,*)'No experiments for equilibrium ',equil%eqno cycle eqloop endif experiment=>equil%lastexperiment%next ! current value of the experiment 500 continue iexp=iexp+1 ! write(*,*)'MM Setting pointer to experiment ',& ! allocated(experiment%statvar),iexp nostv: if(.not.allocated(experiment%statvar)) then symsym=experiment%statev text=' ' ! WE MUST EVALUATE ALL SYMBOLS!!! call meq_evaluate_all_svfun(-1,equil) ! write(*,*)'MM symsym: ',symsym xxx=evaluate_svfun_old(symsym,text,1,equil) if(gx%bmperr.ne.0) then gx%bmperr=0 ! write(*,*)'MM using meq_evaluate_svfun',gx%bmperr xxx=meq_evaluate_svfun(symsym,text,1,equil) endif ! write(*,*)'MM value: ',iexp,xxx else svrrec=>experiment%statvar(1) ! write(*,*)'MM exp: ',svrrec%statevarid,svrrec%argtyp ! svrrec%statevarid = 0 means symbol ... ! this can handle state variable symbols also !!?? call state_variable_val(svrrec,xxx,equil) endif nostv if(gx%bmperr.ne.0) then write(kou,*)' *** Error calculating experiment ',& equil%eqno,': ',trim(equil%eqname),symsym,gx%bmperr gx%bmperr=0 errs(iexp)=zero goto 590 endif if(experiment%symlink2.gt.0) then ! added check if uncertainity is a symbol ! xxx=evaluate_svfun_old(istv,' ',mode,ceq) ! xxx=evaluate_svfun_old(symsym,text,1,equil) experiment%uncertainty=& evaluate_svfun_old(experiment%symlink2,' ',1,equil) endif ! write(*,510)'MM errs',iexp,experiment%prescribed,xxx,& ! experiment%uncertainty,equil%weight 510 format(a,i4,6(1pe12.4)) if(allocated(calcexp)) then ! this is to enable calculating RSD at the end of an assessment ! normally calcexp is not allocated!! calcexp(iexp)=xxx ! write(*,555)'Jacobian: ',iexp,(xa(jj),jj=1,i2-1),xxx 555 format(a,i3,6(1pe12.4)) endif if(experiment%experimenttype.eq.0) then ! take the difference between prescribed value errs(iexp)=(experiment%prescribed-xxx)*equil%weight/& experiment%uncertainty ! write(*,*)'MM least.sq: ',iexp,f(iexp) elseif(experiment%experimenttype.eq.100) then ! relative error yyy=1.0D-2*experiment%uncertainty*experiment%prescribed errs(iexp)=(experiment%prescribed-xxx)*equil%weight/yyy elseif(experiment%experimenttype.eq.-1) then ! less than, uncertainty is penalty function factor if(xxx.gt.experiment%prescribed) then errs(iexp)=(xxx-experiment%prescribed)*equil%weight/& experiment%uncertainty else errs(iexp)=zero endif elseif(experiment%experimenttype.eq.1) then ! larger than, uncertainty is penalty function factor if(xxx.lt.experiment%prescribed) then errs(iexp)=(xxx-experiment%prescribed)*equil%weight/& experiment%uncertainty else errs(iexp)=zero endif endif 590 if(.not.associated(experiment,equil%lastexperiment)) then ! if more experiments jump back to 500 experiment=>experiment%next goto 500 endif ! done all experiments for this equilibrium enddo eqloop ! write(*,*)'MM assessment_calfun calculated experiments: ',iexp,nexp ! We have to restore the last value of the last coefficient if(allocated(calcexp)) then ! write(*,*)'MM restore savix: ',savix,zzz call change_optcoeff(firstash%coeffindex(savix),zzz) endif 1000 continue ! write(*,*)'Exit assessment_calfun' return end subroutine assessment_calfun !\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine listoptshort !\begin{verbatim} subroutine listoptshort(lut,mexp,nvcoeff,errs) ! short listing of optimizing variables and result integer lut,mexp,nvcoeff double precision, allocatable, dimension(:) :: errs ! type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: neweq integer i1,i2,j1,j2,j3,neq character name1*24,line*80 double precision xxx,sum type(gtp_condition), pointer :: experiment ! ! list all experiments, only possible if there are experiments ! write(*,*)'MM looking for segfault error in listoptshort' if(mexp.eq.0) then write(lut,666) 666 format(/'No experiments so no results'/) goto 1000 endif ! list experiments, mexp is number of EXPERIMENTS, not equilibria!! write(lut,620)size(firstash%eqlista),mexp 620 format(/'List of ',i5,' equilibria with ',i5,& ' experimental data values'/& ! ' No Equil name Weight Experiment $ calculated',18x,& ' No Equil name Weight Property=experiment $ calculated',13x,& 'Error') j3=0 ! write(*,*)'MM segfault1:',size(firstash%eqlista) allequil: do i1=1,size(firstash%eqlista) ! skip equilibria with zero weight ! write(*,*)'MM segfault error 1' neweq=>firstash%eqlista(i1)%p1 if(neweq%weight.eq.zero) cycle allequil name1=neweq%eqname(1:12) ! LOOP for all experiments for this equilibrium (maybe none??) if(.not.associated(neweq%lastexperiment)) cycle allequil ! write(*,*)'MM segfault error 2' experiment=>neweq%lastexperiment%next if(.not.associated(experiment)) cycle allequil !700 continue i2=neweq%lastexperiment%seqz ! write(*,*)'number of experiments: ',i2 neq=neweq%eqno ! write(*,*)'MM segfault error 3',i2 do j2=1,i2 ! j1 is position in line to write experiment j1=1 line=' ' ! this subroutine returns experiment and calculated value: "H=1000:200 $ 5000" call meq_get_one_experiment(j1,line,j2,neweq) j3=j3+1 ! segmentation fault with errs after PLOT with APPEND but errs is allocated??? ! write(*,*)'MM segfault error 4A',j2,neq,lut,j3 ! write(*,*)'MM segfault error 4B: ',line(1:44) ! write(*,*)'MM segfault error 4C',neweq%weight, size(errs) ! write(*,*)'MM segfault error 4D',j2,errs(j3) ! write(*,*)'MM segfault error 4E' if(neq.gt.0) then write(lut,622)neq,name1(1:15),neweq%weight,line(1:44),errs(j3) 622 format(i4,1x,a,2x,F5.2,1x,a,1x,F6.2) neq=0 else write(lut,623)line(1:44),errs(j3) 623 format(28x,a,1x,F6.2) endif ! list the equilibrium name just for the first (or only) experiment enddo ! write(*,*)'MM segfault error 5' experiment=>experiment%next !590 if(.not.associated(experiment,neweq%lastexperiment)) then ! experiment=>experiment%next ! goto 700 if(j2.lt.i2 .and. .not.associated(experiment)) then write(*,*)'Missing experiment in equilibrium ',neweq%eqno cycle allequil endif ! write(*,*)'MM segfault error 6' enddo allequil ! list sum of squares sum=zero do j1=1,mexp sum=sum+errs(j1)**2 enddo ! same as PARROT j1=mexp-nvcoeff if(j1.gt.0) then write(lut,621)sum,mexp,nvcoeff,j1,sum/j1 else write(lut,621)sum,mexp,nvcoeff,0,zero endif 621 format(/'Final sum of squared errors: ',1pe16.5,& ' using ',i4,' experiments and'/& i3,' coefficient(s). Degrees of freedom: ',i4,& ', normalized error: ',1pe13.4/) 1000 continue return end subroutine listoptshort !700 !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine meq_list_experiments !\begin{verbatim} subroutine meq_list_experiments(lut,ceq) ! list all experiments into text, special to handle derivatives ... implicit none integer lut TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer seqz,ip character text*72 seqz=0 100 continue seqz=seqz+1 ip=1 text=' ' call meq_get_one_experiment(ip,text,seqz,ceq) ! write(*,*)'MM Back from get_one' if(gx%bmperr.ne.0) then ! error code for no more experiments or inactive experiment ! write(*,*)'MM error line 3117: ',gx%bmperr,seqz,text(1:ip) ! speciel error code meaning experiment is not active if(gx%bmperr.eq.7654) then gx%bmperr=0; goto 100 endif gx%bmperr=0; goto 1000 else write(lut,120)seqz,text(1:ip) 120 format('Experiment ',i2,2x,a) endif goto 100 !------------ 1000 continue gx%bmperr=0 return end subroutine meq_list_experiments !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine meq_get_one_experiment !\begin{verbatim} %- subroutine meq_get_one_experiment(ip,text,seqz,ceq) ! list the experiment with the index seqz into text ! It lists also experiments that are not active ?? ! UNFINISHED current value should be appended implicit none integer ip,seqz character text*(*) TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer iterm,symsym,mode TYPE(gtp_condition), pointer :: last,current type(gtp_state_variable), pointer :: svrrec double precision xxx character actual_arg*16 ! if(ip.le.0) ip=1 text(ip:)=' ' if(.not.associated(ceq%lastexperiment)) then write(*,*)'MM No experiments' gx%bmperr=4249; goto 1000 endif last=>ceq%lastexperiment current=>last ! write(*,*)'MM index of last experiment: ',current%seqz 70 continue ! write(*,*)'MM experiment number: ',seqz,current%seqz if(current%seqz.eq.seqz) goto 100 current=>current%next if(.not.associated(current,last)) goto 70 ! no experiment with this index found or it is inactivated gx%bmperr=4131; goto 1000 ! 100 continue if(current%active.eq.1) then ! write(*,*)'MM Experiment not active ' gx%bmperr=4218; goto 1000 endif iterm=1 150 continue ! write(*,*)'MM Testing is symbol or state variable record',& ! allocated(current%statvar) nostv: if(.not.allocated(current%statvar)) then ! an experiment is a symbol!!! Then statvar is not allocated symsym=current%statev ! write(*,*)'MM A symbol, not a state variable for this experiment',symsym ! we must evaluate all state variable functions!! call meq_evaluate_all_svfun(-1,ceq) ! get the symbol name text=svflista(symsym)%name ip=len_trim(text)+1 ! text(ip-1:ip-1)='=' ! write(*,*)'MM experiment: ',text(1:ip),ip else ! write(*,*)'MM This experiment has a state variable record',& ! allocated(current%statvar),allocated(current%indices),iterm symsym=0 svrrec=>current%statvar(1) call encode_state_variable(text,ip,svrrec,ceq) if(iterm.lt.current%noofterms) then iterm=iterm+1; goto 150 endif endif nostv ! write(*,*)'MM ok here',symsym if(current%experimenttype.eq.0 .or. current%experimenttype.eq.100) then ! write = followed by the value ! if(text(ip:ip).ne.' ') ip=ip+1 text(ip:)='=' ip=ip+1 elseif(current%experimenttype.eq.-1) then ! if(text(ip:ip).ne.' ') ip=ip+1 text(ip:)='<' ip=ip+1 elseif(current%experimenttype.eq.1) then ! if(text(ip:ip).ne.' ') ip=ip+1 text(ip:)='>' ip=ip+1 endif ! write(*,*)'MM experiment line 2: ',text(1:ip),ip if(current%symlink1.gt.0) then ! the value is a symbol text(ip:)=svflista(current%symlink1)%name ip=len_trim(text)+1 else ! call wrinum(text,ip,10,0,current%prescribed) call wrinum(text,ip,8,0,current%prescribed) endif ! uncertainty can also be a symbol text(ip:ip)=':' ip=ip+1 ! write(*,*)'MM experiment line 3: ',text(1:ip),ip,current%symlink2 if(current%symlink2.gt.0) then ! the value is a symbol text(ip:)=svflista(current%symlink2)%name ip=len_trim(text)+1 else ! call wrinum(text,ip,10,0,current%uncertainty) call wrinum(text,ip,8,0,current%uncertainty) endif ! write(*,*)'MM ok here 2',symsym,text(1:ip) ! write(*,*)'MM experiment line 2: ',text(1:ip),ip if(current%experimenttype.eq.100) then text(ip:ip)='%' ip=ip+1 endif ! write(*,*)'MM ok here 3',symsym ! add the current value of the experiment after a $ sign ! TROUBLE GETTING WRONG VALUE HERE WHEN USER DEFINED REFERENCE STATES if(symsym.eq.0) then call state_variable_val(svrrec,xxx,ceq) else ! write(*,*)'MM ok here 4',symsym actual_arg=' ' xxx=evaluate_svfun_old(symsym,actual_arg,1,ceq) endif if(gx%bmperr.ne.0) then ! it is maybe a derivative ... ! write(*,*)'MM we cannot evaluate a derivative here ...',gx%bmperr ! but meq_evaluate_svfun not available here ... it is part of the minimizer gx%bmperr=0 actual_arg=' ' mode=1 xxx=meq_evaluate_svfun(symsym,actual_arg,mode,ceq) ! write(*,*)'MM meq_evaluate_svfun, mode=1: ',xxx endif if(gx%bmperr.ne.0) then write(*,*)'MM Error evaluating symbol: ',gx%bmperr text(ip:)=' $ ?? ' ip=ip+5 gx%bmperr=0 else ! write(*,*)'MM experimental state variable value: ',ip,xxx text(ip:)=' $' ip=ip+3 ! call wrinum(text,ip,12,0,xxx) call wrinum(text,ip,8,0,xxx) ! write(*,*)'MM experiment line 3: ',text(1:ip),ip endif ! write(*,*)'MM ok here 5' 1000 continue ! write(*,*)'MM experiment line 4: ',text(1:ip),ip,gx%bmperr return end subroutine meq_get_one_experiment !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_equilibrium_extra !\begin{verbatim} subroutine list_equilibrium_extra(lut,ceq,pun) ! list the extra character variables for calculate symboles and ! list characters (if any), It is used in pmon and is part of matsmin ! because it calls subroutines which need access to calculated results ! If the first non-blank character of ceq%eqextra(3) is 0 (zero) then pun ! will be used as a file number to generate a plotfile with calculated values implicit none integer lut,pun TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer ip,slen,jj,last,kk character tval*24,symbol*24,encoded*24,date*12 double precision xxx,xarr(6) ! write(*,*)'MM calc/list extra: ',ceq%eqname ! tval=' ' symbol=' ' extra: if(allocated(ceq%eqextra)) then ip=1 if(eolch(ceq%eqextra(1),ip)) goto 190 ! write(*,*)'calc "',ceq%eqextra(1)(ip:len_trim(ceq%eqextra(1))),'"',lut calcs: if(ceq%eqextra(1)(ip:ip).ne.' ') then ! this line contains symbols to be calculated ! write(*,*)'MM calc extra: ',ceq%eqextra(1)(1:len_trim(ceq%eqextra(1))) ip=ip-1 100 continue ! Third argument 2 means terminate at a space, not at a comma "," ! because some symbols may contain a comma call getext(ceq%eqextra(1),ip,2,tval,' ',slen) if(tval(1:1).ne.' ') then ! This is for a symbol that is not a dot derivative ... ! call find_svfun(tval,istv,ceq) call meq_get_state_varorfun_value(tval,xxx,symbol,ceq) ! mode=1 ! call meq_evaluate_svfun(tval,' ',mode,ceq) if(gx%bmperr.ne.0) then ! write(*,*)'MM Cannot find symbol: ',tval,' Error reset' gx%bmperr=0 else ! mode=1 ! meq_evaluate_svfun is declared in matsmin ! xxx=meq_evaluate_svfun(istv,' ',mode,ceq) ! xxx=evaluate_svfun_old(istv,' ',mode,ceq) ! if(gx%bmperr.ne.0) then ! write(*,*)'MM Cannot calculate symbol: ',tval,' Error reset' ! gx%bmperr=0; goto 100 ! endif ! symbol empty?? ! write(lut,110)symbol(1:len_trim(symbol)),xxx write(lut,110)tval(1:len_trim(tval)),xxx 110 format(3x,a,'=',1pe16.8) endif goto 100 ! else ! write(*,*)'Found a space at position',ip endif endif calcs 190 continue ip=1 if(eolch(ceq%eqextra(2),ip)) goto 290 lists: if(ceq%eqextra(2)(ip:ip).ne.' ') then ! this line contains state variables and related things to be listed ! write(*,*)'MM list extra: ',ceq%eqextra(2)(1:30) ip=ip-1 200 continue ! Third argument 2 means terminate at a space, not at a comma "," ! because some symbols contains a comma. call getext(ceq%eqextra(2),ip,2,tval,' ',slen) ! write(*,*)'MM variable: ',tval,slen if(tval(1:1).ne.' ') then if(index(tval,'*').gt.0) then write(*,*)'MM Not implemented wildcards' ! call get_many_svar(tval,... else symbol=' ' call get_state_var_value(tval,xxx,symbol,ceq) ! This checks that the phase is stable ... ! call get_stable_state_var_value(tval,xxx,symbol,ceq) if(gx%bmperr.ne.0) then ! write(*,*)'MM Cannot list variable: ',tval,' Error reset' gx%bmperr=0 else write(lut,110)trim(symbol),xxx endif endif goto 200 endif endif lists 290 continue ip=1 if(eolch(ceq%eqextra(3),ip)) goto 390 plots: if(ceq%eqextra(3)(ip:ip).eq.'0') then ! this creates a plot file for calculated values ! This is for plot_data set 0, calculated values' ! next value must be number of columns with data to be plotted!! last=ip+1 call getint(ceq%eqextra(3),last,ip) if(buperr.ne.0) then write(*,*)'MM Cannot extract number of columns' gx%bmperr=4399; goto 1000 endif if(ip.gt.6) then write(*,*)'MM Too many columns in plot_data 0. Max: 6',ip gx%bmperr=4399; goto 1000 endif if(pun.eq.0) then pun=30 ! plotdatafile='oc_many0' ! write(*,*)'Opening oc_many0.plt ' open(pun,file='oc_many0.plt',access='sequential',status='unknown') ! ! extract state variable symbols, first is x axis variable kk=last call getext(ceq%eqextra(3),kk,2,tval,' ',slen) call date_and_time(date) write(pun,305)date(1:4),date(5:6),date(7:8),& trim(tval),trim(ceq%eqextra(3)) 305 format('# GUNPLOT file generated by enter many_equilibria '/& 'set title "Open Calphad 4.0 prerelease: ',a,'-',a,'-',a,& ' with GNUPLOT"'/& '# set terminal pdf color'/& '# set output "whatever"'/& 'set xlabel "',a,'"'/& 'set ylabel "whatever"'/& 'set key bottom right'/& '# ',a/& '# THE DATA LINES MUST BE REPEATED AS MANY TIMES AS',& ' THERE ARE PLOT COMMANDS!') call getext(ceq%eqextra(3),kk,2,tval,' ',slen) if(ip.eq.2) then ! with just two columns write(pun,310)trim(tval) 310 format('plot "-" using 1:2 with points pt 5 ',& 'ps 1.5 title "',a,'"') else ! this first line if 3 or more columns write(pun,311)trim(tval) 311 format('plot "-" using 1:2 with points pt 5 ',& 'ps 1.5 title "',a,'",\') endif ! if ip>4 this for second and further lines until jj is ip-1 do jj=3,ip-1 call getext(ceq%eqextra(3),kk,2,tval,' ',slen) write(pun,312)jj,jj+3,trim(tval) 312 format('"" using 1:',i2,' with points pt ',i2,& ' ps 1.5 title "',a,'",\') enddo ! if ip=3 this is second line, otherwise the last line if(ip.gt.3) then call getext(ceq%eqextra(3),kk,2,tval,' ',slen) write(pun,313)ip,ip+3,trim(tval) 313 format('"" using 1:',i2,' with points pt ',i2,& ' ps 1.5 title "',a,'"') endif ! the line consists of several state variables to be calculated and listed jj=0 320 continue ! write(*,321)trim(ceq%eqextra(3)),last 321 format('3B extract: ',a,i5,' "',a,'"') ! 3rd argument 2 means skipping , only space separators call getext(ceq%eqextra(3),last,2,tval,' ',slen) ! write(*,321)trim(ceq%eqextra(3)),last,trim(tval) if(tval(1:1).eq.' ') then goto 350 elseif(buperr.ne.0) then write(kou,*)'Error reading symbol: ',trim(ceq%eqextra(3)) goto 350 else jj=jj+1 call get_state_var_value(tval,xarr(jj),encoded,ceq) if(gx%bmperr.ne.0) then write(*,*)'Error getting: ',tval goto 350 endif endif goto 320 ! no more values 350 continue else ! This is another line with values for plot_data set 0, file is open jj=0 360 continue call getext(ceq%eqextra(3),last,2,tval,' ',slen) if(tval(1:1).eq.' ') then goto 370 elseif(buperr.ne.0) then write(kou,*)'Error reading symbol: ',trim(ceq%eqextra(3)) goto 370 else jj=jj+1 call get_state_var_value(tval,xarr(jj),encoded,ceq) if(gx%bmperr.ne.0) then write(*,*)'Error getting: ',tval goto 370 endif endif goto 360 ! no more values 370 continue endif ! write the line on the plot_data file if(jj.ne.ip) then write(*,*)'Wrong number of columns',jj,ip endif write(pun,380)(xarr(jj),jj=1,ip) 380 format(6(1pe12.4)) endif plots ! else ! write(*,*)'No extra lines found' endif extra 390 continue 1000 continue end subroutine list_equilibrium_extra !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine equilph1a !\begin{verbatim} subroutine equilph1a(phtup,tpval,ceq) ! equilibrates the constituent fractions of a phase using its current comp. ! phtup is phase tuple ! tpval is T and P ! ceq is a datastructure with all relevant thermodynamic data implicit none double precision tpval(*) TYPE(gtp_phasetuple), pointer :: phtup TYPE(gtp_equilibrium_data), pointer :: ceq TYPE(meq_setup) :: meqrec !\end{verbatim} %+ integer nel,ii,errall double precision, allocatable :: xknown(:),wmass(:),cpot(:) double precision totmol,totmass,amount nel=noel() allocate(xknown(nel),stat=errall) allocate(wmass(nel),stat=errall) allocate(cpot(nel),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 50: ',errall gx%bmperr=4370; goto 1000 endif ! find the current molefractions ! call calc_phase_molmass(phtup%phaseix,phtup%compset,xknown,wmass,& call calc_phase_molmass(phtup%ixphase,phtup%compset,xknown,wmass,& totmol,totmass,amount,ceq) if(gx%bmperr.ne.0) goto 1000 ! extract the current chemical potentials do ii=1,nel cpot=ceq%cmuval(ii) enddo if(gx%bmperr.ne.0) goto 1000 ! create the meqrec structure call equilph1_meqrec(phtup,meqrec,.FALSE.,ceq) if(gx%bmperr.ne.0) goto 1000 ceq%rtn=globaldata%rgas*tpval(1) ! iterate until equilibrium found for this phase call equilph1c(meqrec,meqrec%phr,tpval,xknown,cpot,ceq) deallocate(xknown) deallocate(wmass) 1000 continue return end subroutine equilph1a !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine equilph1b !\begin{verbatim} %- subroutine equilph1b(phtup,tpval,xknown,gval,cpot,tyst,ceq) ! equilibrates the constituent fractions of a phase for mole fractions xknown ! phtup is phase tuple ! tpval is T and P ! ceq is a datastructure with all relevant thermodynamic data ! gval is the Gibbs energy calculated as xknown(i)*cpot(i) ! cpot are the (calculated) chemical potentials ! tyst is TRUE means no outut implicit none ! integer mode TYPE(meq_setup) :: meqrec double precision tpval(*),xknown(*),cpot(*),gval TYPE(gtp_equilibrium_data), pointer :: ceq logical tyst !\end{verbatim} %+ TYPE(gtp_phasetuple), pointer :: phtup integer ii ! extract the current chemical potentials as start values do ii=1,noel() cpot(ii)=ceq%cmuval(ii) enddo if(gx%bmperr.ne.0) goto 1000 ! create the meqrec structure call equilph1_meqrec(phtup,meqrec,.FALSE.,ceq) if(gx%bmperr.ne.0) goto 1000 ! mabe we need RT ? ceq%rtn=globaldata%rgas*tpval(1) ! iterate until equilibrium found for this phase call equilph1c(meqrec,meqrec%phr,tpval,xknown,cpot,ceq) ! write(*,*)'We are in equilph1b',gx%bmperr gval=zero if(gx%bmperr.eq.0) then do ii=1,noel() gval=gval+xknown(ii)*cpot(ii) ! write(*,*)'We are in equilph1b',gval enddo endif 1000 continue return end subroutine equilph1b !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine equilph1c !\begin{verbatim} subroutine equilph1c(meqrec,phr,tpval,xknown,ovar,ceq) ! iterate constituent fractions of a phase for mole fractions xknown ! tpval is T and P ! xknown are mole fractions ! ceq is a datastructure with all relevant thermodynamic data ! ovar are the chemical potentials implicit none ! integer phase double precision tpval(*),xknown(*),ovar(*) TYPE(meq_setup) :: meqrec TYPE(meq_phase), dimension(*), target :: phr TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer nz1,nz2,converged,ierr,jj,nj,nk,nl,errall TYPE(meq_phase), pointer :: pmi double precision, allocatable :: smat(:,:),svar(:),yarr(:),ycorr(:) double precision chargefact,chargerr,pv,qq(5),ys,ycormax2 ! number of variables is number of components + one stable phase nz1=meqrec%nrel+1 nz2=nz1+1 allocate(smat(nz1,nz2),stat=errall) allocate(svar(nz1),stat=errall) ! allocate(ovar(nz1)) ! current values of chemical potentials ! do jj=1,meqrec%nrel ! ovar(jj)=ceq%cmuval(jj) ! enddo allocate(ycorr(phr(1)%ncc),stat=errall) allocate(yarr(phr(1)%ncc),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 51: ',errall gx%bmperr=4370; goto 1000 endif chargefact=one chargerr=one ! write(*,*)'We are in equilph1c: ',phr(1)%iph,phr(1)%ics,gx%bmperr ! we have just one phase in phr, phr must be TARGET pmi=>phr(1) 100 continue converged=0 smat=zero ! invert the phase matrix for pmi call meq_onephase(meqrec,pmi,ceq) if(gx%bmperr.ne.0) goto 1000 ! all ok to here ??? ! setup mass balance equations, note some components may be missing ! This is a simplified setup_equilmatrix using xknown as composition ! call setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,dncol,converged,ceq) call setup_comp2cons(meqrec,phr,nz1,smat,tpval,xknown,converged,ceq) if(gx%bmperr.ne.0) goto 1000 ! debug output as the matrix had changed efter return from subroutine ... ! do nk=1,nz1 ! write(*,111)'smat4: ',nk,(smat(nk,jj),jj=1,nz2) ! enddo ! goto 1000 ! solve the equilibrium matrix, some chemical potentials may be missing call lingld(nz1,nz2,smat,svar,nz1,ierr) if(ierr.ne.0) then write(*,*)'Error solving equilibrium matrix 2',ierr gx%bmperr=4203; goto 1000 endif ! check that svar(1..meqrec%nrel) has converged do jj=1,meqrec%nrel if(abs(svar(jj)-ovar(jj)).gt.1.0D1*ceq%xconv) then ! write(*,103)'chempot7: ',svar(jj),ovar(jj),svar(jj)-ovar(jj) 103 format(a,3(1pe12.4)) converged=7 endif ! use ovar below to correct constitutions. Note ovar is chem.pot/RT ovar(jj)=svar(jj) enddo ! write(*,111)'svar4: ',0,(svar(jj),jj=1,nz1) 111 format(a,i2,6(1pe12.4)) ! check dxmol ... seems OK ! do nk=1,phr(1)%ncc ! write(*,111)'dxmol: ',nk,(phr(1)%dxmol(nl,nk),nl=1,meqrec%nrel) ! enddo ! update constituent fractions in just one phase ! lap: do jj=1 jj=1 ! The current chemical potentials are in ceq%cmuval(i) svar(1..n) ! jj is stable, increment kk but do not make it larger than meqrec%nstph ! save index in meqrec%stphl in jph !!!!!!!!!!! kk never used !!!!!!!!! ! jph=kk ! kk=min(kk+1,meqrec%nstph) ! if phr(jj)%xdone=1 then phase has no composition variation if(phr(jj)%xdone.eq.1) goto 1000 !---------------------------------------------------- ycormax2=zero ! write(*,*)'cc: ',jj,phr(jj)%ncc ! loop for all constituents moody: do nj=1,phr(jj)%ncc ys=zero do nk=1,phr(jj)%ncc pv=zero do nl=1,meqrec%nrel ! ceq%cmuval(nl) is the chemical potential of element nl (divided by RT) ! USE values in svar(nl) ! phr(jj)%dxmol(nl,nk) is the derivative of component nl ! wrt constituent nk ! pv=pv+ceq%complist(nl)%chempot(1)/ceq%rtn*phr(jj)%dxmol(nl,nk) ! write(*,111)'pv1: ',nj,pv,ceq%complist(nl)%chempot(1),& ! ovar(nl) is used instead of complist(nl)%chempot(1) as we do not want to ! change the global values of the chemical potential pv=pv+ovar(nl)*phr(jj)%dxmol(nl,nk) ! write(*,111)'pv1: ',nj,pv,ovar(nl),& ! ceq%rtn,phr(jj)%dxmol(nl,nk) enddo ! write(*,119)'cph1: ',jj,nj,nk,ys,pv,phr(jj)%curd%dgval(1,nk,1),& ! phr(jj)%invmat(nj,nk) 119 format(a,3i3,6(1pe12.4)) pv=pv-phr(jj)%curd%dgval(1,nk,1) ys=ys+phr(jj)%invmat(nj,nk)*pv ! write(*,111)'pv2: ',nj,ys,pv,phr(1)%curd%dgval(1,nk,1),& ! phr(1)%invmat(nj,nk) enddo if(phr(jj)%chargebal.eq.1) then ! For charged phases add a term ! phr(jj)%invmat(phr(jj)%idim,phr(jj)%idim)*Q ys=ys-chargefact*phr(jj)%invmat(nj,phr(jj)%idim)*& phr(jj)%curd%netcharge endif ycorr(nj)=ys if(abs(ycorr(nj)).gt.ycormax2) then ycormax2=ycorr(nj) endif if(abs(ys).gt.ceq%xconv) then ! if the change in any constituent fraction larger than xconv continue iterate if(converged.lt.4) then ! large correction in fraction of constituent fraction of stable phase ! write(*,*)'mm converged 4B: ',jj,nj,ys converged=4 cerr%mconverged=converged if(cerr%nvs.lt.10) then cerr%nvs=cerr%nvs+1 cerr%typ(cerr%nvs)=4 cerr%val(cerr%nvs)=zero cerr%dif(cerr%nvs)=abs(ys) endif ! yss=ys ! yst=phr(jj)%curd%yfr(nj) endif ! elseif(phr(jj)%stable.eq.1) then ! check to find good convergence criteria in Re-V test case ! if(abs(ycorr(nj)).gt.ysmm) then ! jmaxy=jj ! ysmm=abs(ycorr(nj)) ! ysmt=phr(jj)%curd%yfr(nj) ! endif endif yarr(nj)=phr(jj)%curd%yfr(nj)+ycorr(nj) ! write(*,119)'ycorr4: ',jj,nj,phr(jj)%chargebal,& ! yarr(nj),phr(jj)%curd%yfr(nj),ycorr(nj),ys enddo moody ! >>>>>>>>>>>>>>>>>> HERE the new constitution is set <<<<<<<<<<<<<<<<<<<<< ! write(*,112)'YC: ',jj,(ycorr(nj),nj=1,phr(jj)%ncc) ! write(*,112)'YZ: ',meqrec%noofits,(yarr(nj),nj=1,phr(jj)%ncc) 112 format(a,i3,8F8.5) ! write(*,*)'MM calling set_constitution 4: ',phr(jj)%iph,phr(jj)%ics call set_constitution(phr(jj)%iph,phr(jj)%ics,yarr,qq,ceq) if(gx%bmperr.ne.0) goto 1000 ! >>>>>>>>>>>>>>>>>> for all phases <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< meqrec%noofits=meqrec%noofits+1 if(converged.gt.3) then if(meqrec%noofits.le.ceq%maxiter) goto 100 write(*,*)'MM Too many iterations',ceq%maxiter elseif(meqrec%noofits.lt.6) then goto 100 else if(.not.btest(meqrec%status,MMQUIET)) write(*,202)meqrec%noofits 202 format('Calculation required ',i4,' its') endif 1000 continue return end subroutine equilph1c !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine equilph1d !\begin{verbatim} subroutine equilph1d(phtup,tpval,xknown,cpot,tyst,nend,mugrad,mobval,ceq) ! equilibrates the constituent fractions of a phase for mole fractions xknown ! and calculates the Darken matrix and unreduced diffusivities ! phtup is phase tuple ! tpval is T and P ! ceq is a datastructure with all relevant thermodynamic data ! cpot are the (calculated) chemical potentials ! tyst is TRUE means no outut ! nend is the number of values returned in mugrad ! mugrad are the derivatives of the chemical potentials wrt mole fractions?? ! mobval are the mobilities implicit none integer nend logical tyst !CCI double precision, intent ( inout ) :: mugrad(*),mobval(*) double precision tpval(*),xknown(*),cpot(*) !CCI TYPE(gtp_phasetuple), pointer :: phtup TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ TYPE(meq_setup) :: meqrec integer ii ! extract the current chemical potentials as start values do ii=1,noel() cpot(ii)=ceq%cmuval(ii) enddo if(gx%bmperr.ne.0) goto 1000 ! create the meqrec structure ! write(*,17)'MM equilph1d calling equilph1e',(xknown(ii),ii=1,noel()) 17 format(a,10(F6.3)) ! call equilph1_meqrec(phtup,meqrec,.FALSE.,ceq) call equilph1_meqrec(phtup,meqrec,tyst,ceq) if(gx%bmperr.ne.0) goto 1000 ! mabe we need RT ? ceq%rtn=globaldata%rgas*tpval(1) ! iterate until equilibrium found for this phase call equilph1e(meqrec,meqrec%phr,tpval,xknown,cpot,tyst,& nend,mugrad,mobval,ceq) 1000 continue return end subroutine equilph1d !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine equilph1e !\begin{verbatim} %- subroutine equilph1e(meqrec,phr,tpval,xknown,ovar,tyst,& noofend,mugrad,mobval,ceq) ! iterate constituent fractions of a phase for mole fractions xknown ! and calculate derivatives of MU and diffusion coefficients ! tpval is T and P ! xknown are mole fractions ! nrel is the number of components (elements) ! ovar are the chemical potentials ! tyst is TRUE if no output ! mugrad is the derivatives of the chemical potentials wrt mole fractions?? ! mobval are the mobilities ! ceq is a datastructure with all relevant thermodynamic data implicit none integer noofend !CCI double precision, intent ( inout ) :: mugrad(*),mobval(*) double precision tpval(*),xknown(*),ovar(*) !CCI logical tyst TYPE(meq_setup) :: meqrec TYPE(meq_phase), dimension(*), target :: phr TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer nz1,nz2,converged,ierr,jj,nj,nk,nl,is,jt integer lokph,nkl(maxsubl),first(maxsubl+1),current(maxsubl),nsl,nend integer deriv(maxsubl),ql,mend TYPE(meq_phase), pointer :: pmi double precision, allocatable :: smat(:,:),svar(:),yarr(:),delta(:) ! dmuenddy is derivatives of mu for endmembers wrt all constituents double precision, allocatable :: dmuenddy(:,:),muend(:) double precision, allocatable :: py(:) double precision chargefact,chargerr,pv,qq(5),ys,ycormax2,muall double precision sumsum ! ************** change in MODEL_PARAMETER_IDENTIFIER: MQ is now 1300!! ! 800 + cs where cs is the constituent index counted over all sublattices ?? ! can be REDEFINED when new model parameter identifiers was added!!! ! we get the current value (set in gtp3A.F90) by calling getmqindex below integer mqindex,errall ! mqindex is a constant set in gtpini in models/gtp3A.F90 ! number of variables is number of components + one stable phase nz1=meqrec%nrel+1 nz2=nz1+1 allocate(smat(nz1,nz2),stat=errall) allocate(svar(nz1),stat=errall) ! allocate(ovar(nz1)) ! current values of chemical potentials ! do jj=1,meqrec%nrel ! ovar(jj)=ceq%cmuval(jj) ! enddo allocate(delta(phr(1)%ncc),stat=errall) allocate(yarr(phr(1)%ncc),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 52: ',errall gx%bmperr=4370; goto 1000 endif chargefact=one chargerr=one ! we have just one phase in phr, phr must be TARGET pmi=>phr(1) 100 continue converged=0 smat=zero ! invert the phase matrix for pmi call meq_onephase(meqrec,pmi,ceq) if(gx%bmperr.ne.0) goto 1000 ! all ok to here ??? ! setup mass balance equations, note some components may be missing ! This is a simplified setup_equilmatrix using xknown as composition ! call setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,dncol,converged,ceq) call setup_comp2cons(meqrec,phr,nz1,smat,tpval,xknown,converged,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'after setup_comp2cons: ',converged ! debug output as the matrix had changed efter return from subroutine ... ! do nk=1,nz1 ! write(*,111)'smat3: ',nk,(smat(nk,jj),jj=1,nz2) ! enddo ! goto 1000 ! solve the equilibrium matrix, some chemical potentials may be missing call lingld(nz1,nz2,smat,svar,nz1,ierr) if(ierr.ne.0) then write(*,*)'Error solving equilibrium matrix 3',ierr gx%bmperr=4203; goto 1000 endif ! check that svar(1..meqrec%nrel) has converged do jj=1,meqrec%nrel if(abs(svar(jj)-ovar(jj)).gt.1.0D1*ceq%xconv) then ! write(*,103)'chempot: ',svar(jj),ovar(jj),svar(jj)-ovar(jj) 103 format(a,3(1pe12.4)) converged=7 cerr%mconverged=converged if(cerr%nvs.lt.10) then cerr%nvs=cerr%nvs+1 cerr%typ(cerr%nvs)=7 cerr%val(cerr%nvs)=svar(jj) cerr%dif(cerr%nvs)=ovar(jj) endif endif ovar(jj)=svar(jj) enddo ! write(*,111)'svar3: ',0,(svar(jj),jj=1,nz1) 111 format(a,i2,6(1pe12.4)) ! check dxmol ... seems OK ! do nk=1,phr(1)%ncc ! write(*,111)'dxmol: ',nk,(phr(1)%dxmol(nl,nk),nl=1,meqrec%nrel) ! enddo ! update constituent fractions in just one phase ! lap: do jj=1 jj=1 ! The current chemical potentials are in ceq%cmuval(i) svar(1..n) ! jj is stable, increment kk but do not make it larger than meqrec%nstph ! save index in meqrec%stphl in jph !!!!!!!!!!! kk never used !!!!!!!!! ! jph=kk ! kk=min(kk+1,meqrec%nstph) ! if phr(jj)%xdone=1 then phase has no composition variation if(phr(jj)%xdone.eq.1) goto 1000 !---------------------------------------------------- ycormax2=zero ! write(*,*)'cc: ',jj ! loop for all constituents ! write(*,112)'Y0: ',meqrec%noofits,converged,(yarr(nj),nj=1,phr(jj)%ncc) moody: do nj=1,phr(jj)%ncc ys=zero do nk=1,phr(jj)%ncc pv=zero do nl=1,meqrec%nrel ! ceq%cmuval(nl) is the chemical potential of element nl (divided by RT) ! When a chemical potential is fixed use meqrec%mufixval ! phr(jj)%dxmol(nl,nk) is the derivative of component nl ! wrt constituent nk !? pv=pv+ceq%complist(nl)%chempot(1)/ceq%rtn*phr(jj)%dxmol(nl,nk) ! pv=pv+ceq%cmuval(nl)*phr(jj)%dxmol(nl,nk) ! pv=pv+svar(nl)*phr(jj)%dxmol(nl,nk) pv=pv+ovar(nl)*phr(jj)%dxmol(nl,nk) enddo pv=pv-phr(jj)%curd%dgval(1,nk,1) ys=ys+phr(jj)%invmat(nj,nk)*pv ! write(*,111)'pv: ',nj,ys,pv,phr(1)%curd%dgval(1,nk,1),& ! phr(1)%invmat(nj,nk) enddo if(phr(jj)%chargebal.eq.1) then ! For charged phases add a term ! phr(jj)%invmat(phr(jj)%idim,phr(jj)%idim)*Q ys=ys-chargefact*phr(jj)%invmat(nj,phr(jj)%idim)*& phr(jj)%curd%netcharge endif delta(nj)=ys if(abs(delta(nj)).gt.ycormax2) then ycormax2=delta(nj) endif if(abs(ys).gt.ceq%xconv) then ! if the change in any constituent fraction larger than xconv continue iterate if(converged.lt.4) then ! large correction in fraction of constituent fraction of stable phase ! write(*,*)'mm converged 4C: ',jj,nj,ys converged=4 ! yss=ys ! yst=phr(jj)%curd%yfr(nj) endif ! elseif(phr(jj)%stable.eq.1) then ! check to find good convergence criteria in Re-V test case ! if(abs(delta(nj)).gt.ysmm) then ! jmaxy=jj ! ysmm=abs(delta(nj)) ! ysmt=phr(jj)%curd%yfr(nj) ! endif endif yarr(nj)=phr(jj)%curd%yfr(nj)+delta(nj) enddo moody ! >>>>>>>>>>>>>>>>>> HERE the new constitution is set <<<<<<<<<<<<<<<<<<<<< ! write(*,112)'YC: ',jj,(delta(nj),nj=1,phr(jj)%ncc) ! write(*,112)'YY: ',meqrec%noofits,converged,(yarr(nj),nj=1,phr(jj)%ncc) 112 format(a,2i3,8F8.5) ! write(*,*)'MM calling set_constitution 5:',phr(jj)%iph,phr(jj)%ics call set_constitution(phr(jj)%iph,phr(jj)%ics,yarr,qq,ceq) if(gx%bmperr.ne.0) goto 1000 !-------------------------- end of iteration ! check convergence meqrec%noofits=meqrec%noofits+1 if(converged.gt.3) then if(meqrec%noofits.le.ceq%maxiter) goto 100 gx%bmperr=4204 ! write(*,*)'MM Too many iterations',ceq%maxiter goto 1000 elseif(meqrec%noofits.lt.6) then goto 100 else if(.not.btest(meqrec%status,MMQUIET)) write(*,202)meqrec%noofits 202 format('Calculation required ',i4,' its') endif do is=1,meqrec%nrel ovar(is)=svar(is) enddo ! goto 1000 !---------------------------------------------------------- ! When the calculation converged we calculate mugrad and interdiffusivites ! A nontrival expression: ! ! dmu_i/dx_j = 1/N (d2G/dx_i/dx_j - \sum_k x_k (d2G/dx_k/dx_i + d2G/dx_k/dx_j)+ ! \sum_k\sum_m x_k x_m d2G/dx_k/dx_m ) ! ! NOTE THIS IS SYMMETRICAL, dmu_i/dx_j = dmu_j/dx_i. ! If the phase is ideal then d2G/dx_i/dx_j = RT/x_i if i=j, otherwise zero ! This gives for ! dmu_i/dx_i = RT/N * (1-x_i)/x_i ! dmu_i/dx_j = - RT/N (i not equal to j) ! ! We calc sum_k (x_k*d2G/dx_k/dx_i) in delta(i) ! sum_m x_m ( sum_k (x_k*d2G/dx_k/dx_m)) in sumsum ! ! new use of delta !!! delta=zero muall=pmi%curd%gval(1,1) sumsum=zero ! Here we calculate delta(is) = \sum_jt y(jt)*d2G/dy_jt/dy_is and ! sumsum = \sum_m y(is) \sum_jt y(jt)*d2G/dy_jt/dy_is ! The loop of is is for all constituents do is=1,phr(1)%ncc ! The loop for jt are for all constituents in all sublattices do jt=1,phr(1)%ncc ! STRANGE that d2G/dy_Va/dy_Va is zero ... should be 1 (*RT) ...does not matter ! if(is.gt.jt) stop "wrong order 1" ! keep ixsym here as I do not know if jt>is or not delta(is)=delta(is)+pmi%curd%yfr(jt)*pmi%curd%d2gval(ixsym(is,jt),1) ! write(*,*)'d2G/dy/dy: ',is,jt,pmi%curd%d2gval(ixsym(is,jt),1) enddo sumsum=sumsum+pmi%curd%yfr(is)*delta(is) muall=muall-pmi%curd%dgval(1,is,1)*pmi%curd%yfr(is) enddo ! muall = G_m - \sum_i y_i dG/dy_i ! delta(i) = \sum_j y_j d2G/dy_i/dy_j sum for all y_j for one y_i ! sumsum = \sum_i \sum_j y_i y_j d2G/dy_i/dy_j sum for all y_i and y_j !-------------------- summations over all constituents in all sublattices ! now we must generate the endmembers, loop over all sublattices ! but sublattics and number of constituents in each are in the phase record ! and protected ... use a subroutine ... lokph=pmi%curd%phlink call get_phase_structure(lokph,nsl,nkl) if(gx%bmperr.ne.0) goto 1000 ! --------------------------------------------------------------------- substitutional: if(nsl.eq.1) then ! specially simple if nsl=1 (substitutional) noofend=nkl(1) allocate(muend(noofend),stat=errall) ! calculate just mu(endmember) ! loop1: do nend=1,noofend ! muend(nend)=muall+pmi%curd%dgval(1,nend,1) ! loop2: do jt=1,noofend ! the chemical potential has the derivative of the constituent ! muend(nend)=muend(nend)+pmi%curd%dgval(1,jt,1) ! enddo loop2 ! enddo loop1 ! now we calculate dmu(end)/dy_is (just for substitutional) allocate(dmuenddy(noofend,pmi%ncc),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 53: ',errall gx%bmperr=4370; goto 1000 endif dmuenddy=zero ! For a substitutional solution: ! dmu_i/dx_j = 1/N ( d2G/dx_i/dx_j - ! \sum_k x_k d2G/dx_k/dx_i - \sum_k x_k d2G/dx_k/dx_j+ ! \sum_k\sum_m x_k x_m d2G/dx_k/dx_m ) ! NOTE THIS SHOULD BE SYMMETRICAL, dmu_i/dx_j = dmu_j/dx_i. ! use delta(i) and sumsum calculated above ! write(*,*)'Derivatives of chemical potentials',noofend nl=0 loop3: do is=1,noofend muend(is)=muall+pmi%curd%dgval(1,is,1) loop4: do jt=1,noofend ! if(is.gt.jt) stop "wrong order 2" ! keep using ixsym here as I do not know if jt>is dmuenddy(is,jt)=pmi%curd%d2gval(ixsym(is,jt),1)-& delta(is)-delta(jt)+sumsum ! write(*,775)'dd1:',1,is,jt,& ! dmuenddy(is,jt),pmi%curd%d2gval(ixsym(is,jt),1),& ! delta(is),delta(jt),sumsum nl=nl+1 mugrad(nl)=dmuenddy(is,jt)*ceq%rtn enddo loop4 ! write(*,777)'dd: ',(ceq%rtn*dmuenddy(is,jt),jt=1,noofend) !777 format(a,6(1pe12.4)) enddo loop3 ! UNFINISHED ?? I do not divide by N ! write(*,777)'mu: ',(muend(is),is=1,noofend) !------------------- else ! not substitutional below (2 or more sublattices) ! now we have to handle sublattices and endmembers ! nsl is number of sublattices and nkl(1..nsl) the number of const in each noofend=1 is=1 first=0 do nl=1,nsl ! nend is number of endmembers ! here first and current are set to first constituent index in each sublattice noofend=noofend*nkl(nl) first(nl)=is current(nl)=is deriv(nl)=is is=is+nkl(nl) enddo ! we need this to indicate when we reached the end first(nsl+1)=is allocate(muend(noofend),stat=errall) allocate(py(noofend),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 54: ',errall gx%bmperr=4370; goto 1000 endif py=one ! write(*,611)'first: ',nsl,(first(nj),nj=1,nsl) !611 format(a,i2,2x,10i3) ! all partials have this term muend=muall ! write(*,*)'MM muall: ',muall,pmi%curd%gval(1,1) ! The partial Gibbs energy, for each sublattice add one dG/dy_is nend=0 nj=0 allpg: do while(nj.le.nsl) nend=nend+1 ! the partials constituents, G_I, are in current(1..nsl) nlloop: do nl=1,nsl is=current(nl) ! endmembers like 1:1:1, 1:1:2, 1:2:1, 1:2:2, 2:1:1, 2:1:2, 2:2:1, 2:2:2 =8 ! constituents are in current(1..nsl) muend(nend)=muend(nend)+pmi%curd%dgval(1,is,1) enddo nlloop ! generate a new set of constituents in current nj=1 888 continue current(nj)=current(nj)+1 if(current(nj).eq.first(nj+1)) then ! note first(nsl+1) is the end of all constituents current(nj)=first(nj) nj=nj+1 if(nj.le.nsl) goto 888 endif enddo allpg if(.not.tyst) then write(*,881)(muend(jt),jt=1,noofend) 881 format('Calculated potentials for all endmembers/RT: '/6(1x,1pe12.4)) endif !----------------------------------------------------------------------- ! the part below is messy and unfinished !---------------- now the derivative of the partial Gibbs energy ! The partial Gibbs energy, for each sublattice add one dG/dy_is ! the derivative of the partial Gibbs energy wrt all other endmembers .... ! dG_i/dn_J = 1/N_J( \sum_s (d2G/dy_is/dy_js - delta(is) - delta(js)) + sumsum ) ! delta(is) = \sum_s \sum_k y_k d2G/dy_is/dy_k ! sumsum = \sum_k \sum_m y_k y_m d2G/dy_k/dy_m (already added above) !--------------------------------------------------- ! all derivatives of the partial has the sumsum term allocate(dmuenddy(noofend,noofend),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 55: ',errall gx%bmperr=4370; goto 1000 endif dmuenddy=sumsum nj=0 nend=0 allpartg: do while(nj.le.nsl) ! loop for all partial Gibbs energies G_I nend=nend+1 mend=0 ! write(*,773)'Partial: ',nend,(current(nl),nl=1,nsl) allql: do while(nj.le.nsl) ! loop for all constituent endmembers n_J mend=mend+1 ! write(*,773)'Endmember: ',mend,(deriv(nl),nl=1,nsl) !773 format(a,i3,2x,10i3) lattloop: do nl=1,nsl ! loop for all sublattices, skip sublattices with a single constituent?? ! if(nkl(nl).eq.1) cycle lattloop is=current(nl) ! the 2nd derivative of G for constituents in same sublattice jt=deriv(nl) dmuenddy(nend,mend)=dmuenddy(nend,mend)-delta(is)-delta(jt) ! add second derivatives wrt is and all constituents in deriv suckloop: do ql=1,nsl ! keep using ixsym here as I do not know if isceq%phase_varres(phtup%lokvares) ! set phase stable meqrec%phr(1)%stable=1 meqrec%phr(1)%prevam=one meqrec%phr(1)%prevdg=zero meqrec%phr(1)%idim=0 ! number of constituents !!! meqrec%phr(1)%ncc=size(ceq%phase_varres(phtup%lokvares)%yfr) meqrec%dormlink=0 meqrec%status=0 if(tyst) then meqrec%status=ibset(meqrec%status,MMQUIET) else meqrec%status=ibclr(meqrec%status,MMQUIET) endif ! meqrec%noofits=0 ! this replaces call to meq_sameset as we will never change stable phase ! call equilph1c(meqrec,meqrec%phr,tpval,xknown,cpot,ceq) 1000 continue return end subroutine equilph1_meqrec !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine check_eec_old !\begin{verbatim} subroutine check_eec_old(pmisol,pmiliq,meqrec,ceq) ! This checks EEC after calculating all phases if the solid phase has S > S^liq ! it is called if T>globaldata%sysreal(1) (set in user i/f) ! pmisol is pointer to solid data ! pmiliq is pointer to liquid data ! ceq is a datastructure with all relevant thermodynamic data implicit none type(meq_phase), pointer :: pmiliq,pmisol TYPE(gtp_equilibrium_data), pointer :: ceq TYPE(meq_setup) :: meqrec !\end{verbatim} integer sel double precision newg,ssol,sliq,fact,kvot logical :: once=.TRUE. save once ! check if T meqrec%phr(ij) newg=zero do sel=1,meqrec%nrel newg=newg + pmisol%xmol(sel)*ceq%complist(sel)%chempot(1) enddo ! For Al-50%Cr a pure Al-bcc becomes almost stable at 3500 K using 10000 ! pmisol%curd%gval(1,1)=(newg+1.0E4)*pmisol%curd%abnorm(1)/ceq%rtn pmisol%curd%gval(1,1)=(newg+1.0E3)*pmisol%curd%abnorm(1)/ceq%rtn ! but tested for 5000 it still does not become stable. ! pmisol%curd%gval(1,1)=(newg+5.0E3)*pmisol%curd%abnorm(1)/ceq%rtn ! else ! Entropy of solid less than liquid, all is OK endif 1000 continue ! write(*,*)'MM leaving check_eec' return end subroutine check_eec_old !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine tzero !\begin{verbatim} subroutine tzero(iph1,iph2,icond,value,ceq) ! calculates the value of condition "icond" for two phases to have same G implicit none integer iph1,iph2,icond double precision value type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer, parameter :: lwa=100 integer info,nv,ja,jb type(gtp_condition), pointer :: first type(gtp_phase_varres), pointer :: cps1,cps2 double precision xv(5),fvec(5),tol,wa(lwa) ! external tzcalc NOT NEEDED ! ! write(*,'(a,3i4," and ",3i4)')'In tzero!',iph1,phasetuple(iph1)%ixphase,& ! phasetuple(iph1)%lokph,& ! iph2,phasetuple(iph2)%ixphase,phasetuple(iph2)%lokph ! in some way ceq, iph1, iph2 and icond must be transferred to tzcalc tzceq=>ceq ! always use first composition set, iph is also index in phasetuple ! tzph1=phasetuple(iph1)%lokph; tzph2=phasetuple(iph2)%lokph tzph1=iph1; tzph2=iph2 ! find the condition first=>ceq%lastcondition tzcond=>first%next ja=0 do while(.not.associated(first,tzcond)) ! we should only count ACTIVE conditions if(tzcond%active.eq.0) then ja=ja+1 if(ja.eq.icond) goto 100 tzcond=>tzcond%next endif enddo ! the loop above does not find the last condition !!! SUCK if(icond.ne.ja+1) then write(*,*)'No such condition' gx%bmperr=4399; goto 1000 ! else ! the last condition was the selected one endif ! 100 continue ! Set status of all phases except iph1 and iph2 as suspended call change_many_phase_status('* ',-3,zero,ceq) call change_phtup_status(iph1,1,one,ceq) call change_phtup_status(iph2,1,one,ceq) if(gx%bmperr.ne.0) goto 1000 ! start value of condition to vary xv(1)=tzcond%prescribed ! write(*,*)'Found condition, current value ',xv(1) ! do we need to think about parallelization? ! calculate the zero ! write(*,*)'Calling hybrd1',xv(1) nv=1 ! testing tzero calculation with larger composition difference in the phases? ! tol=1.0D-2 this is max difference in G, maybe relative?? ! tzcalc used by hybrd1 to calculate G individually for the two phases tol=1.0D-6 call hybrd1(tzcalc,nv,xv,fvec,tol,info,wa,lwa) if(info.ne.1) then ! info=0 Improper input parameters ! =2 Too many iterations ! =3 tol variable too small ! =4 Too slow progress ! write(*,*)'HYBRD solver return error: ',info if(gx%bmperr.eq.0) gx%bmperr=4371 else endif if(gx%bmperr.ne.0) goto 1000 tzcond%prescribed=xv(1) value=xv(1) 1000 continue ! restore suspeded phases and set no equilibrium ceq%status=ibset(ceq%status,EQINCON) call change_many_phase_status('* ',0,zero,ceq) if(gx%bmperr.eq.0) then ! set amount of the two phases cps1=>tzceq%phase_varres(phasetuple(tzph1)%lokvares) cps2=>tzceq%phase_varres(phasetuple(tzph2)%lokvares) cps1%amfu=one cps2%amfu=one endif return end subroutine tzero !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine tzcalc !\begin{verbatim} subroutine tzcalc(nv,xv,fvec,iflag) ! calculates the value of a condition for two phases to have same G ! called by hybrd1 used by tzero implicit none integer nv,iflag double precision xv(*),fvec(*) !\end{verbatim} type(gtp_phase_varres), pointer :: cps1,cps2 integer mode,lokph1,lokph2,lokvares1,lokvares2 double precision gm1,gm2 ! we transfer the data needed by tzph1,tzph2,tzceq and tzcond !! ! write(*,*)'In tzcalc: ',tzph1,tzph2 ! write(*,*)'Current value of condition: ',tzcond%prescribed,xv(1) ! lokph1=phasetuple(tzph1)%lokph lokph2=phasetuple(tzph2)%lokph lokvares1=phasetuple(tzph1)%lokvares lokvares2=phasetuple(tzph2)%lokvares cps1=>tzceq%phase_varres(lokvares1) cps2=>tzceq%phase_varres(lokvares2) ! mode=0 ! we have to calculate each phase separately and compare G values (per atom) ! Set current value of condition tzcond%prescribed=xv(1) ! write(*,*)'Prescribed condition: ',tzcond%prescribed ! on entry both phases 1 and 2 are entered, suspend phase 2 call change_phtup_status(tzph2,-3,one,tzceq) call calceq3(mode,.FALSE.,tzceq) if(gx%bmperr.ne.0) goto 1100 gm1=cps1%gval(1,1)/cps1%abnorm(1) ! write(*,*)'Phase 1: ',gm1 ! suspend phase 1 and restore 2 call change_phtup_status(tzph1,-3,one,tzceq) call change_phtup_status(tzph2,1,one,tzceq) call calceq3(mode,.FALSE.,tzceq) if(gx%bmperr.ne.0) goto 1100 gm2=cps2%gval(1,1)/cps2%abnorm(1) ! write(*,*)'Phase 2: ',gm2 ! restore phase 1 call change_phtup_status(tzph1,1,one,tzceq) fvec(1)=gm1-gm2 ! maybe relative? No as gm1 and gm2 are divided by RT and around 1.0 ! write(*,'(a,4(1pe12.4))')'tzcalc: ',xv(1),gm1,gm2,fvec(1) ! fvec(1)=cps1%gval(1,1)/cps1%abnorm(1)-cps2%gval(1,1)/cps2%abnorm(1) 1000 continue return 1100 continue ! error quit also calling routine by setting value to zero write(*,*)'Quit tzcalc due to error: ',gx%bmperr fvec(1)=zero; goto 1000 end subroutine tzcalc !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine liquid_eet !\begin{verbatim} subroutine liquid_eet(iph1,iph2,icond,value,ceq) ! calculates the value of condition "icond" when they have equal entropy, EET implicit none integer iph1,iph2,icond double precision value type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer, parameter :: lwa=100 integer info,nv,ja,jb type(gtp_condition), pointer :: first type(gtp_phase_varres), pointer :: cps1,cps2 double precision xv(5),fvec(5),tol,wa(lwa) ! external tzcalc NOT NEEDED ! ! write(*,'(a,3i4," and ",3i4)')'In tzero!',iph1,phasetuple(iph1)%ixphase,& ! phasetuple(iph1)%lokph,& ! iph2,phasetuple(iph2)%ixphase,phasetuple(iph2)%lokph ! in some way ceq, iph1, iph2 and icond must be transferred to tzcalc tzceq=>ceq ! always use first composition set, iph is also index in phasetuple ! tzph1=phasetuple(iph1)%lokph; tzph2=phasetuple(iph2)%lokph tzph1=iph1; tzph2=iph2 ! find the condition first=>ceq%lastcondition tzcond=>first%next ja=0 do while(.not.associated(first,tzcond)) ! we should only count ACTIVE conditions if(tzcond%active.eq.0) then ja=ja+1 if(ja.eq.icond) goto 100 tzcond=>tzcond%next endif enddo ! the loop above does not find the last condition !!! SUCK if(icond.ne.ja+1) then write(*,*)'No such condition' gx%bmperr=4399; goto 1000 ! else ! the last condition was the selected one endif ! 100 continue ! Set status of all phases except iph1 and iph2 as suspended ! call change_many_phase_status('* ',-3,zero,ceq) ! call change_phtup_status(iph1,1,one,ceq) ! call change_phtup_status(iph2,1,one,ceq) ! if(gx%bmperr.ne.0) goto 1000 ! start value of condition to vary xv(1)=tzcond%prescribed ! write(*,*)'Found condition, current value ',xv(1) ! do we need to think about parallelization? ! calculate the zero ! write(*,*)'Calling hybrd1',xv(1) nv=1 ! testing tzero calculation with larger composition difference in the phases? ! tol=1.0D-2 this is max difference in G, maybe relative?? ! eetcalc is used to calculate the entropy difference of the two phases tol=1.0D-6 call hybrd1(eetcalc,nv,xv,fvec,tol,info,wa,lwa) if(info.ne.1) then ! info=0 Improper input parameters ! =2 Too many iterations ! =3 tol variable too small ! =4 Too slow progress write(*,*)'HYBRD solver return error: ',info if(gx%bmperr.eq.0) gx%bmperr=4371 else endif if(gx%bmperr.ne.0) goto 1000 tzcond%prescribed=xv(1) value=xv(1) 1000 continue ! restore suspeded phases and set equilibrium may be onconsistent ! ceq%status=ibset(ceq%status,EQINCON) ! call change_many_phase_status('* ',0,zero,ceq) ! if(gx%bmperr.eq.0) then ! set amount of the two phases ! cps1=>tzceq%phase_varres(phasetuple(tzph1)%lokvares) ! cps2=>tzceq%phase_varres(phasetuple(tzph2)%lokvares) ! cps1%amfu=one ! cps2%amfu=one ! endif return end subroutine liquid_eet !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine eetcalc !\begin{verbatim} subroutine eetcalc(nv,xv,fvec,iflag) ! calculates the value of a condition for two phases to have same entropy ! called by hybrd1 used by liquid_eet implicit none integer nv,iflag double precision xv(*),fvec(*) !\end{verbatim} type(gtp_phase_varres), pointer :: cps1,cps2 integer mode,lokph1,lokph2,lokvares1,lokvares2 double precision sm1,sm2 ! we transfer the data needed by tzph1,tzph2,tzceq and tzcond !! ! write(*,*)'In eetcalc: ',tzph1,tzph2 ! write(*,*)'Current value of condition: ',tzcond%prescribed,xv(1) ! lokph1=phasetuple(tzph1)%lokph lokph2=phasetuple(tzph2)%lokph lokvares1=phasetuple(tzph1)%lokvares lokvares2=phasetuple(tzph2)%lokvares cps1=>tzceq%phase_varres(lokvares1) cps2=>tzceq%phase_varres(lokvares2) ! mode=0 ! we have to calculate the equilibrium and the entropy difference of the phases ! Set current value of condition tzcond%prescribed=xv(1) ! write(*,*)'Prescribed condition: ',tzcond%prescribed ! UNFINISHED BELOW ! on entry both phases 1 and 2 are entered, suspend phase 2 ! call change_phtup_status(tzph2,-3,one,tzceq) call calceq3(mode,.FALSE.,tzceq) if(gx%bmperr.ne.0) goto 1100 ! value is divided by RT sm1=8.31451*tzceq%tpval(1)*cps1%gval(2,1)/cps1%abnorm(1) sm2=8.31451*tzceq%tpval(1)*cps2%gval(2,1)/cps2%abnorm(1) ! fvec(1)=sm1-sm2 ! write(*,'(a,F7.2,F7.4,2(1pe12.4))')'EET: ',xv(1),fvec(1),sm1,sm2 ! 1000 continue return 1100 continue ! error quit also calling routine by setting value to zero ! write(*,*)'Quit eetcalc, most likely there is no EET for this phase' fvec(1)=zero; gx%bmperr=4375 goto 1000 end subroutine eetcalc !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine tzcalc_stoich !\begin{verbatim} subroutine tzcalc_stoich(nv,xv,fvec,iflag) ! calculates the value of a condition for two phases to have same G ! called from smp2A during mapping ! Both phases have the same composition (stoichiometric constraits) implicit none integer nv,iflag double precision xv(*),fvec(*) !\end{verbatim} type(gtp_phase_varres), pointer :: cps1,cps2 integer mode,lokph1,lokph2,lokvares1,lokvares2,moded double precision gm1,gm2 ! we transfer the data needed by tzph1,tzph2,tzceq and tzcond !! ! write(*,*)'In tzcalc: ',tzph1,tzph2 ! write(*,*)'Current value of condition: ',tzcond%prescribed,xv(1) ! ! Tested for U-O with 3 phase ORTHO_A20, TETRA_U C1_MO2: T=942.02 K lokph1=phasetuple(tzph1)%lokph lokph2=phasetuple(tzph2)%lokph lokvares1=phasetuple(tzph1)%lokvares lokvares2=phasetuple(tzph2)%lokvares cps1=>tzceq%phase_varres(lokvares1) cps2=>tzceq%phase_varres(lokvares2) ! mode=0 ! only G values, no derivatives moded=0 ! we have two phases with fixed composition and search T for the same value ! of the Gibbs energy. ! We can directly calculate the Gibbs energy of each phase ! Set current value of condition ! tzcond%prescribed=xv(1) ! write(*,*)'Prescribed condition: ',tzcond%prescribed ! on entry both phases 1 and 2 are entered, suspend phase 2 ! call change_phtup_status(tzph2,-3,one,tzceq) ! call calceq3(mode,.FALSE.,tzceq) ! if(gx%bmperr.ne.0) goto 1100 if(xv(1).lt.1.0D-1) then ! write(*,*)'Attempt to calculate for T less than 1' iflag=-1; gx%bmperr=4187; goto 1000 endif tzceq%tpval(1)=xv(1) call calcg_internal(lokph1,moded,cps1,tzceq) if(gx%bmperr.ne.0) goto 1200 call calcg_internal(lokph2,moded,cps2,tzceq) if(gx%bmperr.ne.0) goto 1200 gm1=cps1%gval(1,1)/cps1%abnorm(1) ! write(*,*)'Phase 1: ',gm1 ! suspend phase 1 and restore 2 ! call change_phtup_status(tzph1,-3,one,tzceq) ! call change_phtup_status(tzph2,1,one,tzceq) ! call calceq3(mode,.FALSE.,tzceq) ! if(gx%bmperr.ne.0) goto 1100 gm2=cps2%gval(1,1)/cps2%abnorm(1) fvec(1)=gm1-gm1 ! write(*,*)'Phase 2: ',gm2 ! restore phase 1 call change_phtup_status(tzph1,1,one,tzceq) fvec(1)=gm1-gm2 ! write(*,'(a,4(1pe12.4))')'tzcalc_stoich: ',xv(1),gm1,gm2,fvec(1) 1000 continue return 1100 continue ! error quit also calling routine by setting value to zero write(*,*)'Quit tzcalc_stoich due to error: ',gx%bmperr iflag=-1; goto 1000 1200 continue write(*,1210)gx%bmperr 1210 format('Error calculating Gibbs energy ',i5) iflag=-1; goto 1000 end subroutine tzcalc_stoich !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_paraeq !\begin{verbatim} subroutine calc_paraeq(tupix,icond,xcond,meqrec,meqrec1,ceq) ! calculates a paraequilibrium between two phases tupix(1&2) ! icond is the index of the fast diffusing element ! xcond are the fractions of the element in the two phases at paraequilibrium implicit none integer tupix(2),icond double precision xcond(2) TYPE(meq_setup), pointer :: meqrec TYPE(meq_setup), allocatable, target :: meqrec1 TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} ! at paraequilibrium the two phases has the same composition (set as conditions) ! except for one element fastel which is a fast diffusion element (such as C) ! It requires solving a nonlinear equation to find a "tie-line" between ! the two phases which have the same composition except for fastel ! We have two variables, the composion of "fastel" in each phase ! We calculate each phase separately with different fractions of fastel, x(C) ! and extract the chemical potential of fastel, mu(C) ! and a "combined" chemical potential for all other elements. ! This is calculated as (G-x(C)*mu(C))/(1-x(C)) where G is the Gibbs energy ! The two function values are the difference of these two potentials ! calculated for each phase ! meqrec is needed for step_paraeq ! integer nv,info,ja,errall integer, parameter :: lwa=20,minus1=-1 double precision fracs(2),fvec(2),wa(lwa),muval,xsave,ntot,nalpha,nbeta,xtest double precision, parameter :: tol=1.0D-10 type(gtp_phasetuple), pointer :: ph1,ph2 type(gtp_condition), pointer :: first,pcond type(gtp_state_variable), target :: p1svr,p2svr type(gtp_state_variable), pointer :: svr character encoded*24,fractions*64,elname*24 type(map_fixph), allocatable :: mapfix logical verbose ! We must passing links and info to paraeqfun, the subroutine called by hybrd1 ! THIS DOES NOT WORK IF CALCULATIONS ARE MADE IN PARALLEL ! tzceq is pointer to equilibrium; tzcond pointer to first condition ! write(*,*)'MM in calc_paraeq',tzph1,tzph2,icond if(.not.allocated(meqrec1)) then ! this is when called from user i/f, step_paraequil allocates before call ! data will be added by calceq7 allocate(meqrec1,stat=errall) if(errall.ne.0) then ! write(*,*)'MM Allocation error 19: ',errall gx%bmperr=4370; goto 1000 endif endif meqrec=>meqrec1 meqrec%status=0 if(allocated(mapfix)) deallocate(mapfix) ! verbose=.FALSE. xcond=zero tzceq=>ceq tzph1=tupix(1); tzph2=tupix(2) ! write(*,*)'MM allocated meqrec1, calling calceq7' ! ! Calculate an equilibrium with the two phases ! call calceq3(minus1,verbose,tzceq) call calceq7(minus1,meqrec,mapfix,tzceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'MM Back from calceq7' ! exctract various values call get_state_var_value('N ',ntot,encoded,tzceq) if(gx%bmperr.ne.0) goto 1000 ! this is quite clumsy ... can it be fixed? call get_component_name(icond,elname,tzceq) ! do not use this routine, requires a tuple record ! call get_phasetuple_name(tzph1,encoded) call get_phasetup_name(tzph1,encoded) fractions='X('//trim(encoded)//','//trim(elname)//') ' call get_state_var_value(fractions,fracs(1),encoded,tzceq) ! call get_state_var_value('X(FCC,C) ',fracs(1),encoded,tzceq) if(gx%bmperr.ne.0) goto 1000 call get_phasetup_name(tzph2,encoded) fractions='X('//trim(encoded)//','//trim(elname)//') ' call get_state_var_value(fractions,fracs(2),encoded,tzceq) ! write(*,*)'MM fraction composition: ',trim(fractions) ! call get_state_var_value('X(BCC,C) ',fracs(2),encoded,tzceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'MM Initial fractions: ',fracs(1),fracs(2) ! tzcond should be the condition for the element tzel first=>ceq%lastcondition%next pcond=>first ja=0 findxcond: do while(.true.) if(pcond%active.eq.1) cycle findxcond ja=ja+1 if(pcond%statvar(1)%argtyp.eq.1) then if(pcond%statvar(1)%component.eq.icond) then tzcond=>pcond p1svr=pcond%statvar(1) p2svr=pcond%statvar(1) ! this is the condition on the total amount of fast diffusing element ?? xsave=pcond%prescribed ! write(*,'(a,F10.6,3i4)')'MM fraction condition',pcond%prescribed,& ! pcond%statvar(1)%statevarid,pcond%statvar(1)%oldstv endif endif ! write(*,*)'MM other conditions: ',ja,pcond%statvar%statevarid,& ! pcond%statvar%component pcond=>pcond%next if(associated(pcond,first)) exit findxcond if(ja.gt.100) then write(*,*)'Eternal loop exit 1',ja gx%bmperr=4399; goto 1000 endif enddo findxcond ! musvr and xsvr are module global variables used by hybrid subroutine ! musvr is typically ! 3 0 0 0 0 1 0 0 1 0 1.0 3 musvr%statevarid=3; musvr%norm=0; musvr%unit=0; musvr%phref=0 musvr%argtyp=1; musvr%phase=0; musvr%compset=0; musvr%component=icond musvr%constituent=0; musvr%coeff=one; musvr%oldstv=3 svr=>musvr call state_variable_val(svr,muval,ceq) if(gx%bmperr.ne.0) goto 1000 ! we should use mole fractions to calculate alloy potential ! The %oldstv is important! But completely undocumented !========================================================= ! This assumes fraction is mole fraction xsvr=musvr xsvr%statevarid=17; xsvr%oldstv=111 ! DO NOT CHANGE xsvr, IT IS USED IN THE CALCULATING ROUTINE !========================================================= nv=2 ! call list_conditions(kou,tzceq) ! !================================== ! ! solve the non-linear equation (this is the simplified call ....) call hybrd1(paraeqfun,nv,fracs,fvec,tol,info,wa,lwa) ! nv number of variables and functions; fracs(nv) values of the fractions ! fvec(nv) returned values of the functions; tol required tolerance ! info returned information of result ! ws is workspace with dimension lwa; lwa integer > nv*(3*n+13)/2 (=2*19/2) if(info.ne.1) then if(info.eq.0) write(*,*)'MM hybrd1 called with illegal arguments' if(info.eq.2) write(*,*)'MM hybrd1 fails too many iterations' if(info.eq.3) write(*,*)'MM hybrd1 fails too high tolerance required' if(info.eq.4) write(*,*)'MM hybrd1 fails too slow progress' gx%bmperr=4399; goto 1000 endif ! the phase amounts should be adjusted to a composition in the middle xsave=0.5*(fracs(1)+fracs(2)) ! return solution: ! write(*,*)'MM conditions at the solution:' ! call list_conditions(kou,tzceq) xcond(1)=fracs(1) xcond(2)=fracs(2) ! We should set the phase amounts to reproduce the overall condition if(xcond(1).gt.xcond(2)) then nalpha=(xsave-xcond(2))/(xcond(1)-xcond(2)) else nalpha=(xsave-xcond(1))/(xcond(2)-xcond(1)) endif nbeta=ntot-nalpha if(nalpha.lt.zero .or. nbeta.lt.zero) then write(*,'(a,5(1x,F10.6))')'Paraequil error:',xsave,xcond,nalpha,nbeta gx%bmperr=4399 else ! set amounts of phases correspondng to condition ! write(*,'(a,2F10.6)')'calc_paraeq: NP(*): ',nalpha,nbeta call change_phase_status(phasetuple(tzph1)%ixphase,& phasetuple(tzph1)%compset,PHENTSTAB,nalpha,tzceq) call change_phase_status(phasetuple(tzph2)%ixphase,& phasetuple(tzph2)%compset,PHENTSTAB,nbeta,tzceq) endif ! 1000 continue ! restore original condition tzcond%prescribed=xsave return end subroutine calc_paraeq ! meqrec !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine paraeqfun !\begin{verbatim} subroutine paraeqfun(nv,fracs,fvec,iflag) ! called by hydrid1 to solve a nonlinear system of equations setup ! by calc_paraeq to calculate the difference in chemical potential ! for a two-phase paraequilibrium. Arguments are: ! nv number of variables, fracs the variable values, fvec the functions ! calculated by this routine implicit none integer nv,iflag double precision fracs(*),fvec(*) !\end{verbatim} integer, parameter :: minus1=-1 double precision gm,mucmat,muamat,mucgro,muagro,xcmat,xcgro,mutest,xtest,val type(gtp_state_variable), pointer :: svr integer ip character encoded*24 logical verbose ! ! The 2 variables are the fractions of the fast diffusing element in 2 phases ! The functions are the chemical potential of the fast diffusing element ! and the "extrapolated" chemical potential of an alloy with zero fraction ! of the fast diffusing element, calculated for each phases as ! (G-x(C)*mu(C))/(1-x(C)) ! where G is the Gibbs energy of the phase and x(C) the fraction of C ! The difference of these potentials calculated for each element in each phase ! should be zero at paraequilibrium. ! THIS ROUTINE DOES NOT WORK IF CALCULATIONS IN PARALLEL ! ! At paraequilibrium the two phases has the same composition (set as conditions) ! except for one element fastel which is a fast diffusion element (such as C) ! It requires solving a nonlinear equation to find a "tie-line" between ! the two phases which have the same composition except for fastel ! We have two variables, the composion of "fastel" in each phase ! We calculate each phase separately with different fractions of fastel, x(C) ! and extract the chemical potential of fastel, mu(C) ! and a "combined" chemical potential for all other elements. ! This is calculated as (G-x(C)*mu(C))/(1-x(C)) where G is the Gibbs energy ! The two function values are the difference of these two potentials ! calculated for each phase ! ! iflag should not be changed except to force termination by setting iflag=-1 ! NOTE tzceq, tzcond, tzph1 and tzph2 global variables in this module! ! fractions must be betwee 1E-12 and 1 if(fracs(1).lt.1.0D-12) fracs(1)=1.0D-12 if(fracs(1).gt.1.0D0) fracs(1)=1.0D0 if(fracs(2).lt.1.0D-12) fracs(2)=1.0D-12 if(fracs(2).gt.1.0D0) fracs(2)=1.0D0 ! write(*,'(a,2(1pe12.4))')'>>>> Paraeqfun 1: ',fracs(1),fracs(2) ! calculate the Gibbs energy and the partial Gibbs energies of each phase ! for the current set of conditions ! It is possible to calculate each phase separately ignoring conditions ! but then it is not trivial to obtain the chemical potentials ! or call calceq2/calceq7 with all phses except one suspended ! verbose=.FALSE. ! write(*,*)'Matrix and growing phases: ',tzph1,tzph2 ! suspend growing phase and calculate normal equilibrium for matrix call change_phase_status(phasetuple(tzph2)%ixphase,& phasetuple(tzph2)%compset,PHSUS,zero,tzceq) if(gx%bmperr.ne.0) goto 1000 ! set condition on composition equal to fracs(1) tzcond%prescribed=fracs(1) ! do ip=1,nooftup() ! if(test_phase_status(phasetuple(ip)%ixphase,phasetuple(ip)%compset,& ! val,tzceq).ge.0) then ! write(*,*)'Stable phase (matrix)',phasetuple(ip)%ixphase,& ! phasetuple(ip)%compset,val ! endif ! enddo ! write(*,*)'Calculating with matrix phase',phasetuple(tzph1)%ixphase,& ! phasetuple(tzph1)%compset ! calceq3 will modify the fraction of components not set as conditions (Fe) call calceq3(minus1,verbose,tzceq) if(gx%bmperr.ne.0) then write(*,*)'Failed calculation for matrix phase',fracs(1),gx%bmperr goto 1000 endif ! extract value of G and MU(C) and calculate M(X)=(G-x(c)*mu(C))/(1-x(C)) ! write(*,*)'Extracting values for matrix phase' call get_state_var_value('GM ',gm,encoded,tzceq) if(gx%bmperr.ne.0) goto 1000 svr=>musvr call state_variable_val(svr,mucmat,tzceq) if(gx%bmperr.ne.0) goto 1000 svr=>xsvr call state_variable_val(svr,xcmat,tzceq) if(gx%bmperr.ne.0) goto 1000 ! check ! call get_state_var_value('MU(C) ',mutest,encoded,tzceq) ! if(gx%bmperr.ne.0) goto 1000 ! call get_state_var_value('X(C) ',xtest,encoded,tzceq) ! if(gx%bmperr.ne.0) goto 1000 ! write(*,'(a,4(1pe12.4))')'Matrix test: ',mucmat,mutest,xcmat,xtest ! muamat=(gm-xcmat*mucmat)/(one-xcmat) ! write(*,'(a,4(1pe12.4))')'Matrix G, x and mu: ',gm,xcmat,mucmat,muamat ! ! suspend matrix phase and calculate normal equilibrium for growing! call change_phase_status(phasetuple(tzph2)%ixphase,& phasetuple(tzph2)%compset,PHENTSTAB,one,tzceq) if(gx%bmperr.ne.0) goto 1000 call change_phase_status(phasetuple(tzph1)%ixphase,& phasetuple(tzph1)%compset,PHSUS,zero,tzceq) if(gx%bmperr.ne.0) goto 1000 ! ! set condition on composition equal to fracs(2) tzcond%prescribed=fracs(2) ! do ip=1,nooftup() ! if(test_phase_status(phasetuple(ip)%ixphase,phasetuple(ip)%compset,& ! val,tzceq).ge.0) then ! write(*,*)'Stable phase (growing)',phasetuple(ip)%ixphase,& ! phasetuple(ip)%compset,val ! endif ! enddo ! write(*,*)'Calculating with growing phase: ',phasetuple(tzph2)%ixphase,& ! phasetuple(tzph2)%compset ! calceq3 will modify the fraction of components not set as conditions (Fe) call calceq3(minus1,verbose,tzceq) if(gx%bmperr.ne.0) then write(*,*)'Failed calculation for growing phase',fracs(2),gx%bmperr goto 1000 endif ! extract value of G and MU(C) and calculate M(X)=(G-x(c)*mu(C))/(1-x(C)) ! write(*,*)'Extracting values for growing phase' ! call get_stable_state_var_value('GM ',gm,encoded,tzceq) call get_state_var_value('GM ',gm,encoded,tzceq) if(gx%bmperr.ne.0) goto 1000 svr=>musvr call state_variable_val(svr,mucgro,tzceq) if(gx%bmperr.ne.0) goto 1000 svr=>xsvr call state_variable_val(svr,xcgro,tzceq) if(gx%bmperr.ne.0) goto 1000 ! test ! call get_state_var_value('MU(C) ',mutest,encoded,tzceq) ! if(gx%bmperr.ne.0) goto 1000 ! call get_state_var_value('X(C) ',xtest,encoded,tzceq) ! if(gx%bmperr.ne.0) goto 1000 ! write(*,'(a,4(1pe12.4))')'Matrix test: ',mucgro,mutest,xcgro,xtest ! we have to use mole fraction, to calculate muamat muagro=(gm-xcgro*mucgro)/(one-xcgro) ! write(*,'(a,4(1pe12.4))')'Growing G, x and mu: ',gm,xcgro,mucgro,muagro fvec(1)=muamat-muagro fvec(2)=mucmat-mucgro ! write(*,'(a,4(1pe12.4))')'>>>> Paraeqfun 9: ',fracs(1),fracs(2),& ! fvec(1),fvec(2) ! restore matrix as entered call change_phase_status(phasetuple(tzph1)%ixphase,& phasetuple(tzph1)%compset,PHENTSTAB,one,tzceq) if(gx%bmperr.ne.0) goto 1000 ! 1000 continue if(gx%bmperr.ne.0) then write(*,*)'MM Error inside paraeqfun',gx%bmperr iflag=-1 endif ! iflag=-1 return end subroutine paraeqfun !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calculate_carefully !\begin{verbatim} subroutine calculate_carefully(mode,ceq) implicit none ! calculate an equilirium carefully (bosses_method) ! step 1: Calculate with gridminimizer and merge (already done) ! Alternatively enter with a set of stable phases ! which has converged at another calculation. ! 2: suspend unstable phases ! 3: calculate with iterative method, ! 4: set all suspended as dormant, ! 5: calculate iterative again to see if any dormant has dgm>0 ! 6: if so set it entered and goto 5 ! 7: set all phases entered ! mode 0 means all step, nonzero may change some of these steps ! mode 1 means set phases entered one by one, largest driving force first integer mode type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer, allocatable, dimension(:) :: phcsstat integer ntups,mtups,itup,lokcs,ns,naa,phmax,saverr,errall double precision dgmax character phname*24 logical again ! 2. loop for all phases to suspend all not stable ! 3. calculate equilibrium with remaining phases without gridminimizer ! 4. loop for all phases to set suspended to dormant ! 5. calculate equilibrium with current set of phases without gridminimizer ! 6. If a dormant phase has dgm>0 set it entered and go back to 5 ! Alternatively do this one by one ! 7. set all dormant phases entered ! ntups=noofphasetuples() ! if error 4363 then reset error code and continue if(gx%bmperr.ne.0) then ! this error means a phase has been restored with positive dgm ! write(*,*)'MM error code set 1:',gx%bmperr if(gx%bmperr.ne.4363) goto 1000 gx%bmperr=0 endif ntups=nooftup() allocate(phcsstat(ntups),stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 57: ',errall gx%bmperr=4370; goto 1000 endif phcsstat=0 ns=0 do itup=1,ntups lokcs=phasetuple(itup)%lokvares if(ceq%phase_varres(lokcs)%dgm.lt.zero) then ! suspend phases with negative dgm ! if already suspended ignore if(ceq%phase_varres(lokcs)%phstate.gt.PHSUS) then ceq%phase_varres(lokcs)%phstate=PHSUS phcsstat(itup)=PHSUS ns=ns+1 endif endif enddo write(*,12)ns 12 format('Phases set suspended except those found stable by gridmin',i5) ! calculate equilibrium with just these phases without grid minimizer call calceq2(0,ceq) if(gx%bmperr.ne.0) then ! this error means a phase has been restored with positive dgm ! write(*,*)'MM error code set 2:',gx%bmperr if(gx%bmperr.ne.4363) goto 900 gx%bmperr=0 endif write(*,17)ntups-ns,ns,' suspended ' 17 format('MM Equilibrium calculated with ',i4,' entered and ',i4,a,'phases') ! set all suspended phases as dormant, maybe some has disapperard ! some composition sets may have disappeared mtups=nooftup() if(ntups-mtups.gt.0) write(*,18)ntups-mtups 18 format('MM deleted ',i3,' composition sets') do itup=1,mtups if(phcsstat(itup).eq.PHSUS) then ! set a suspended phase as dormant lokcs=phasetuple(itup)%lokvares ceq%phase_varres(lokcs)%phstate=PHDORM phcsstat(itup)=PHDORM endif enddo write(*,19) 19 format('Calculating again with all suspended phases set as dormant') ! calculate equilibrium with entered and dormant phases 100 continue again=.false. call calceq2(0,ceq) if(gx%bmperr.ne.0) then ! this error means a phase has been restored with positive dgm write(*,*)'MM error code set 3:',gx%bmperr if(gx%bmperr.ne.4363) goto 900 gx%bmperr=0 endif write(*,17)mtups-ns,ns,' dormant ' ! if mode=0 set all dormant phases with dgm>0 entered ! if mode=1 set the dormant phase with largest dgm>0 as entered ntups=nooftup() naa=0 dgmax=zero phmax=0 do itup=1,ntups if(phcsstat(itup).eq.PHDORM) then lokcs=phasetuple(itup)%lokvares ! maybe enter phases one by one ... if(ceq%phase_varres(lokcs)%dgm.gt.zero) then if(mode.eq.0) then ceq%phase_varres(lokcs)%phstate=PHENTERED phcsstat(itup)=PHENTERED ns=ns-1 naa=naa+1 again=.true. elseif(ceq%phase_varres(lokcs)%dgm.gt.dgmax) then dgmax=ceq%phase_varres(lokcs)%dgm phmax=itup endif endif endif enddo if(mode.eq.1 .and. phmax.gt.0) then ! write(*,*)'MM entering phase with largest driving force ',phmax,dgmax lokcs=phasetuple(phmax)%lokvares ceq%phase_varres(lokcs)%phstate=PHENTERED phcsstat(phmax)=PHENTERED call get_phasetup_name(phmax,phname) ns=ns-1 naa=naa+1 again=.true. write(*,200)trim(phname),dgmax 200 format('MM Setting ',a,' with dgm= ',1pe12.4,' as entered') endif if(again) then if(mode.eq.0) write(*,*)'MM set ',naa,' dormant phases as entered' goto 100 endif ! we have found a solution, set all phases as entered ! or we have an error so restore suspended phases 900 continue if(gx%bmperr.ne.0) then write(*,*)'Calculation not converged, some phases remain as dormant' goto 1000 endif saverr=gx%bmperr gx%bmperr=0 ns=0 ntups=nooftup() ! ntups=noofphasetuples() do itup=1,ntups if(phcsstat(itup).le.PHDORM) then lokcs=phasetuple(itup)%lokvares ceq%phase_varres(lokcs)%phstate=PHENTERED ns=ns+1 endif enddo gx%bmperr=saverr if(ns.gt.0) write(*,'(a,i4,a)')'MM Remaining ',ns,' phases set as entered' 1000 continue return end subroutine calculate_carefully !\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine calctrans !\begin{verbatim} subroutine calctrans(cline,last,ceq) ! calculate a phase transition character cline*(*) integer last type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} character name1*30 integer j1,iph,ics double precision xxx type(gtp_condition), pointer :: pcond type(gtp_state_variable), pointer :: stvr ! write(kou,2090) 2090 format('To calculate when a phase will appear/disappear',& ' by releasing a condition.') if(btest(ceq%status,EQNOEQCAL)) then write(kou,2095) 2095 format('You must make an equilibrium calculation before using',& ' this command.') goto 1000 endif call gparcx('Phase name: ',cline,last,1,name1,' ','?Calculate transform') call find_phase_by_name(name1,iph,ics) if(gx%bmperr.ne.0) goto 1000 j1=test_phase_status(iph,ics,xxx,ceq) if(j1.eq.PHFIXED) then write(kou,*)'Phase status already fixed' goto 1000 endif call list_conditions(kou,ceq) write(kou,2097) 2097 format('You must release one condition, give its number') call gparidx('Condition number',cline,last,j1,1,'?CALCULATE transform') if(j1.le.0 .or. j1.gt.noel()+2) then write(kou,*)'No such condition' goto 1000 endif ! this finds condition with given number call locate_condition(j1,pcond,ceq) if(gx%bmperr.ne.0) goto 1000 if(pcond%active.eq.0) then ! the condition is active, deactivate it! pcond%active=1 else write(kou,*)'This condition is not active!' goto 1000 endif ! Condition released, now set the phase as fix with zero moles call change_phase_status(iph,ics,PHFIXED,xxx,ceq) if(gx%bmperr.ne.0) goto 1000 ! Calculate equilibrium call calceq2(1,ceq) if(gx%bmperr.ne.0) goto 1000 ! get the value of the released condition and set it to the new value stvr=>pcond%statvar(1) call state_variable_val(stvr,xxx,ceq) if(gx%bmperr.ne.0) goto 1000 write(kou,2099)xxx 2099 format('The transition occurs at ',1pe16.8,', set as condition') pcond%prescribed=xxx pcond%active=0 ! set phase back as entered and stable ! write(*,*)'Set phase back as entered' call change_phase_status(iph,ics,PHENTSTAB,zero,ceq) 1000 continue return end subroutine calctrans !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_conf_interval !\begin{verbatim} recursive subroutine calc_conf_interval(lut,unc,ceq) ! Provide some confidence intervals of the results ! lut is output unit ! unc is condition uncertainty in % ! ceq is equilibrium record implicit none integer lut double precision unc type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer ie,je,ip,it,jt,kt,cc,loktup,iph,ics,mode,nterm,kp logical once,noTcond,silent character name*32,text*128 ! max/min for stable phase amounts, chemical potentials double precision, allocatable :: pham(:),phamax(:),phamin(:) double precision, allocatable :: mum(:),mumax(:),mumin(:) double precision, allocatable :: cmax(:),cmin(:) double precision porg,gm,gmin,gmax,sm,smin,smax,gsum,ssum,rtg TYPE(gtp_phase_varres), pointer :: varrec TYPE(gtp_condition), pointer :: pcond,last TYPE(gtp_state_variable), pointer :: svrrec ! write(kou,2) 2 format(/'Providing an estimate of the confidence intervals'/& 'If T is a condition it must be the first'/) ! write(*,*)'Not implemented yet' ! goto 1000 if(unc.gt.1.0D1) then write(*,*)'Condition uncertainties must be less than 10%' goto 1000 endif ! Equilibrium should already be calculated, do not use the grid minimizer call calceq2(0,ceq) if(gx%bmperr.ne.0) then write(*,*)'Please calculate the equilibrium before this command!' ceq%status=ibset(ceq%status,EQFAIL) goto 1000 endif ! allocate arrays: stable phases, potentials (including T) ie=noel() allocate(mum(ie+1),mumin(ie+1)); allocate(mumax(ie+1)) ! ip is phaces, it is tuples, a phase may have more than one composition set ip=noph() it=nooftup() allocate(pham(it),phamin(it)); allocate(phamax(it)) ! conditions is ie+2 allocate(cmin(ie+2)); allocate(cmax(ie+2)) ! list the current equilibrium, maybe replaced by using LIST RESULT before ! this may eventually be provided by case(12) in pmon6 write(lut,*)' *** Conditions:' call list_conditions(lut,ceq) write(lut,*)' *** Some global data:' call list_global_results(lut,ceq) ! mode=1000 means list stable phases with mole fractions in value order mode=1000 once=.TRUE. write(lut,5) 5 format(/' *** Stable phase data:') phloop: do iph=1,ip do ics=1,9 call list_phase_results(iph,ics,mode,lut,once,ceq) ! if a composition set does not exist take next phase if(gx%bmperr.ne.0) then gx%bmperr=0; cycle phloop endif enddo enddo phloop ! loop to collect element data, it is stored in ceq%phase_varres ! write(*,*)'Extracting chemical potentials: ',allocated(ceq%cmuval),& ! size(ceq%cmuval),size(mum) do je=1,ie mum(je)=ceq%cmuval(je) mumin(je)=ceq%cmuval(je) mumax(je)=ceq%cmuval(je) enddo ! maybe T is not a condition? mum(ie+1)=ceq%tpval(1) mumin(ie+1)=ceq%tpval(1) mumax(ie+1)=ceq%tpval(1) gsum=zero; ssum=zero do loktup=1,it ! wow phase_varres(1) is for the SER phase .... ??? ! varrec=>ceq%phase_varres(loktup+1) varrec=>ceq%phase_varres(phasetuple(loktup)%lokvares) if(varrec%dgm.eq.zero) then ! this is a stable phase, its amount can be zero pham(loktup)=varrec%amfu phamin(loktup)=varrec%amfu phamax(loktup)=varrec%amfu gsum=gsum+varrec%amfu*varrec%gval(1,1) ssum=ssum+varrec%amfu*varrec%gval(2,1) else pham(loktup)=varrec%dgm phamin(loktup)=varrec%dgm phamax(loktup)=varrec%dgm endif enddo ! total G and S gm=gsum gmin=gsum gmax=gsum sm=-ssum smin=-ssum smax=-ssum ! loop to list phases close to stability do jt=1,it if(pham(jt).lt.zero .and. pham(jt).gt.-0.1D0) then call get_phasetuple_name(phasetuple(jt),name) write(lut,220)pham(jt),trim(name) 220 format('Phase close to become stable ',1pe12.4,': ',a) endif enddo ! Suppress output from calceq silent=btest(globaldata%status,GSSILENT) globaldata%status=ibset(globaldata%status,GSSILENT) write(lut,230) 230 format(/'Condition=value; +/-phase change relative original equilibrium') ! now loop for all conditions to change each with +/-unc limit ! and calculate extra equilibria to provide a confidence interval ! save results from all and try to provide some estimate noTcond=.TRUE. last=>ceq%lastcondition%next pcond=>last cond: do while(.TRUE.) if(pcond%active.eq.0) then ! condition is active if(pcond%noofterms.gt.1) then ! write(*,*)'Ignoring expressions as conditions' goto 500 elseif(pcond%statev.lt.0) then ! write(*,*)'Ignoring fix phase as conditions' goto 500 endif ! write(*,250)pcond%statev,pcond%prescribed 250 format('State variable index and value: ',i4,1pe12.4,l2) ! special if no T condition if(pcond%statev.eq.1) noTcond=.FALSE. ! ignore P if(pcond%statev.eq.2) goto 500 ! ignore N= (add also B and some others) if(pcond%statev.eq.110) goto 500 ! ignore conditions with a symbol as value if(pcond%symlink1.gt.0) goto 500 ! change condition -unc, calculate without gridmin to avoid creare new comp.sets porg=pcond%prescribed pcond%prescribed=pcond%prescribed*(one-0.01D0*unc) ! save condition value just changed in "text" kp=1 text=' ' svrrec=>pcond%statvar(1) call encode_state_variable(text,kp,svrrec,ceq) if(gx%bmperr.ne.0) goto 1000 text(kp:kp)='=' kp=kp+1 call wrinum(text,kp,10,0,pcond%prescribed) text(kp:kp)=';' kp=max(kp+2,20) ! call list_conditions(lut,ceq) call calceq2(0,ceq) if(gx%bmperr.ne.0) then write(lut,*)'Estimation failed as equilibrium calculation failed' write(*,*)'Estimation failed as equilibrium calculation failed' ceq%status=ibset(ceq%status,EQFAIL) ! restore condition value pcond%prescribed=pcond%prescribed+0.01D0*unc goto 1000 endif ! save change in potentials do je=1,ie if(mumin(je).gt.ceq%cmuval(je)) mumin(je)=ceq%cmuval(je) if(mumax(je).lt.ceq%cmuval(je)) mumax(je)=ceq%cmuval(je) enddo if(noTcond) then ! if T is not a condition save it if(mumin(ie+1).gt.ceq%tpval(1)) mumin(ie+1)=ceq%tpval(1) if(mumax(ie+1).lt.ceq%tpval(1)) mumax(ie+1)=ceq%tpval(1) endif ! save changes in phase amount and stability gsum=zero; ssum=zero do loktup=1,it ! REMEMBER phase_varres(1) is for the SER phase ??? ! varrec=>ceq%phase_varres(loktup+1) ! varrec=>ceq%phase_varres(loktup) varrec=>ceq%phase_varres(phasetuple(loktup)%lokvares) if(varrec%dgm.eq.zero) then ! the ohase is stable if(pham(loktup).lt.zero) then ! the phase was not stable originally call get_phasetuple_name(phasetuple(loktup),name) text(kp:)='+'//name kp=len_trim(text)+2 phamax(loktup)=varrec%amfu else if(phamin(loktup).gt.varrec%amfu) phamin(loktup)=varrec%amfu if(phamax(loktup).lt.varrec%amfu) phamax(loktup)=varrec%amfu endif gsum=gsum+varrec%amfu*varrec%gval(1,1) ssum=ssum+varrec%amfu*varrec%gval(2,1) else ! the phase is not stable if(pham(loktup).ge.zero) then call get_phasetuple_name(phasetuple(loktup),name) text(kp:)='-'//name kp=len_trim(text)+2 phamin(loktup)=varrec%dgm else if(phamin(loktup).gt.varrec%dgm) phamin(loktup)=varrec%dgm if(phamax(loktup).lt.varrec%dgm) phamax(loktup)=varrec%dgm endif endif enddo if(gmin.gt.gsum) gmin=gsum if(gmax.lt.gsum) gmax=gsum if(smin.gt.-ssum) smin=-ssum if(smax.lt.-ssum) smax=-ssum ! list new condition value just calculated, possibly with new phases write(lut,'(a)')trim(text) ! change condition +unc to upper limit ------------------- pcond%prescribed=porg*(one+0.01D0*unc) ! save condition value just changed in "text" kp=1 text=' ' svrrec=>pcond%statvar(1) call encode_state_variable(text,kp,svrrec,ceq) if(gx%bmperr.ne.0) goto 1000 text(kp:kp)='=' kp=kp+1 call wrinum(text,kp,10,0,pcond%prescribed) text(kp:kp)=';' kp=max(kp+2,20) ! call list_conditions(lut,ceq) call calceq2(0,ceq) if(gx%bmperr.ne.0) then write(lut,*)'Estimation failed as equilibrium calculation failed' write(*,*)'Estimation failed as equilibrium calculation failed' ceq%status=ibset(ceq%status,EQFAIL) ! restore condition value pcond%prescribed=pcond%prescribed+0.01D0*unc goto 1000 endif ! save change in potenials do je=1,ie if(mumin(je).gt.ceq%cmuval(je)) mumin(je)=ceq%cmuval(je) if(mumax(je).lt.ceq%cmuval(je)) mumax(je)=ceq%cmuval(je) enddo if(noTcond) then ! note je is ie+1 after loop above if(mumin(ie+1).gt.ceq%tpval(1)) mumin(ie+1)=ceq%tpval(1) if(mumax(ie+1).lt.ceq%tpval(1)) mumax(ie+1)=ceq%tpval(1) endif ! save changes in phase amount and stability gsum=zero; ssum=zero do loktup=1,it varrec=>ceq%phase_varres(phasetuple(loktup)%lokvares) if(varrec%dgm.eq.zero) then ! the phase is stable ! write(*,*)'check: ',loktup,pham(loktup) if(pham(loktup).lt.zero) then ! the phase was not stable originally call get_phasetuple_name(phasetuple(loktup),name) text(kp:)='+'//name kp=len_trim(text)+2 phamax(loktup)=varrec%amfu else if(phamin(loktup).gt.varrec%amfu) phamin(loktup)=varrec%amfu if(phamax(loktup).lt.varrec%amfu) phamax(loktup)=varrec%amfu endif gsum=gsum+varrec%amfu*varrec%gval(1,1) ssum=ssum+varrec%amfu*varrec%gval(2,1) else ! the phase is not stable if(pham(loktup).ge.zero) then call get_phasetuple_name(phasetuple(loktup),name) text(kp:)='-'//name kp=len_trim(text)+2 phamax(loktup)=varrec%amfu else if(phamin(loktup).gt.varrec%dgm) phamin(loktup)=varrec%dgm if(phamax(loktup).lt.varrec%dgm) phamax(loktup)=varrec%dgm endif endif enddo if(gmin.gt.gsum) gmin=gsum if(gmax.lt.gsum) gmax=gsum if(smin.gt.-ssum) smin=-ssum if(smax.lt.-ssum) smax=-ssum ! list new condition value just calculated, possibly with new phases write(lut,'(a)')trim(text) ! restore original condition pcond%prescribed=porg ! next condition endif 500 continue pcond=>pcond%next if(associated(pcond,last)) exit cond enddo cond ! listing variations in potentials write(lut,600) 600 format(/'Variations in chemical potentials/RT:'/& 'Element original min max') do je=1,ie ! there is no way to get element names from index ... suck call get_component_name(je,name,ceq) write(lut,610)name(1:2),mum(je),mumin(je),mumax(je) 610 format(a,10x,1pe14.6,5x,2e12.4) enddo if(noTcond) then write(lut,615)mum(ie+1),mumin(ie+1),mumax(ie+1) 615 format(/'Variation of T:: ',F10.2,5x,2F10.2,' K') endif rtg=globaldata%rgas*ceq%tpval(1) write(lut,620)gm*rtg,gmin*rtg,gmax*rtg,sm*rtg,smin*rtg,smax*rtg 620 format(/'Gibbs energy: ',1pe14.6,5x,2e12.4,' J'/& 'Entropy : ',1pe14.6,5x,2e12.4,' J/K') write(lut,630) 630 format(/'Variations in stable phase amounts:',& ' (negative value means unstable)'/& 'original amount min max') loop7: do jt=1,it iph=phasetuple(jt)%lokph; ics=phasetuple(jt)%compset ! skip phases that are not entered if(test_phase_status(iph,ics,gsum,ceq).lt.-1) cycle loop7 if(phamax(jt).ge.zero) then call get_phasetuple_name(phasetuple(jt),name) write(lut,640)pham(jt),phamin(jt),phamax(jt),trim(name) 640 format(1pe12.4,5x,2e12.4,3x,a) endif enddo loop7 ! of the confidence interval within the condition uncertainties 1000 continue ! resstore silen mode if(.NOT.silent) then globaldata%status=ibclr(globaldata%status,GSSILENT) endif return end subroutine calc_conf_interval !\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine list_stable_phases !\begin{verbatim} subroutine list_stable_phases(text,its,iadd,irem,meqrec,ceq) ! debug listing of stable phases ! meqrec contains all necessary data ... character*(*) text integer its,iadd,irem type(meq_setup) :: meqrec type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer ii,ij,ik double precision gsum,xmol(50),wmass(50),totmol,totmass ! NOTE: phases in stphl should always be in increasing order!! call calc_molmass(xmol,wmass,totmol,totmass,ceq) if(gx%bmperr.ne.0) stop 'Error when calling list_stable_phases' gsum=zero do ii=1,meqrec%nrel gsum=gsum+xmol(ii)*ceq%complist(ii)%chempot(1) enddo write(*,100)text,its,iadd,irem,meqrec%nstph,gsum,totmol,& (meqrec%stphl(ii),ii=1,meqrec%nstph) do ii=2,meqrec%nstph if(meqrec%stphl(ii-1).gt.meqrec%stphl(ii)) then stop 'phases in wrong order!!' endif enddo 100 format(a,i3,2i4,i3,2(1pe12.4),20i4) ! do ii=1,meqrec%nstph,5 ! iph1=meqrec%stphl(ii=1,meqrec%nstph) ! write(*,200)meqrec%phr( ! enddo return end subroutine list_stable_phases !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ end MODULE liboceqplus ================================================ FILE: src/models/OC-isoC.h ================================================ #if !defined __OCASI__ #define __OCASI__ /* Modification history 160829 Bo Sundman Update 2015-2016 Matthias Stratmann and Cristophe Sigli Modifications 2014 Teslos? First version This contains the structure of TYPE variables in OC needed for the OC/TQ OCASI interface NOTE there is also a c_gtp_equilibrium_data structure defined in liboctqisoc.F90 */ typedef struct { int forcenewcalc; double tpused[2]; double results[6]; } tpfun_parres; typedef struct { int splink, phlink, status; char refstate[16]; int *endmember; double tpref[2]; double chempot[2]; double mass, molat; } gtp_components; typedef struct { int lokph, compset, ixphase, lokvares, nextcs; } gtp_phasetuple; typedef struct { int statevarid, norm, unit, phref, argtyp; int phase, compset, component, constituent; double coeff; int oldstv; } gtp_state_variable; typedef struct { int latd, ndd, tnoofxfr, tnoofyfr, varreslink, totdis; char id; double *dsites; int *nooffr; int *splink; int *y2x; double *dxidyj; double fsites; } gtp_fraction_set; //struct gtp_fraction_set; typedef struct { int nextfree, phlink, status2, phstate,phtupx; double abnorm[3]; char prefix[4], suffix[4]; int *constat; double *yfr; double *mmyfr; double *sites; double *dpqdy; double *d2pqdvay; //struct gtp_fraction_set disfra; double amfu, netcharge, dgm; int nprop; int *listprop; double **gval; double ***dgval; double **d2gval; double curlat[3][3]; double **cinvy; double *cxmol; double **cdxmol; double *addg; } gtp_phase_varres; typedef struct gtp_condition { int noofterms, statev, active, iunit, nid, iref, seqz, experimenttype; int symlink1, symlink2; int **indices; double *condcoeff; double *prescribed, current, uncertainity; // should this be a struct ?? gtp_state_variable *statvar; struct gtp_condition *next, *previous; } gtp_condition; typedef struct { int status, multiuse, eqno, next; char eqname[24], comment[72]; double tpval[2], rtn; double weight; double *svfunres; gtp_condition *lastcondition, *lastexperiment; gtp_components *complist; double **compstoi, **invcompstoi; gtp_phase_varres *phase_varres; tpfun_parres *eq_tpres; double *cmuval; double xconv; double gmindif; int maxiter; char eqextra[80]; int sysmatdim, nfixmu, nfixph; int *fixmu; int *fixph; double **savesysmat; } gtp_equilibrium_data; #endif ================================================ FILE: src/models/gtp3.F90 ================================================ ! !*************************************************************** ! General Thermodynamic Package (GTP) ! for thermodynamic modelling and calculations ! MODULE GENERAL_THERMODYNAMIC_PACKAGE ! ! Copyright 2011-2021, Bo Sundman, France ! ! This program is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 2 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this program; if not, write to the Free Software ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! contact person: bo.sundman@gmail.com ! !----------------------------------------------------------------------- ! ! ! for known unfinished/unchecked bugs and parallelization problems ! look for BEWARE ! ! Using open MP parallelization (also added to metlib4.F90 for error code) !$ use OMP_LIB ! use ocnum use metlib use ocparam ! !! overall OC version number character (len=8), parameter :: version=' 6.112 ' ! ! ! data structure for non-encrypted TP functions ! ! use #include rather than include to have preprocessor options ! include "gtp3_dd1.F90" for TP functions without decrypted databases #include "gtp3_dd1.F90" ! ! most global data structure definitions ! ! include "gtp3_dd2.F90" all other data structures #include "gtp3_dd2.F90" ! ! XML elements and attributes #include "gtp3_xml.F90" ! CONTAINS ! 1-5: initialization, how many, find things, get things, set things, !include "gtp3A.F90" #include "gtp3A.F90" ! 12: enter data !include "gtp3B.F90" #include "gtp3B.F90" ! 10: list data !include "gtp3C.F90" #include "gtp3C.F90" ! 11: save and read from files !include "gtp3D.F90" #include "gtp3D.F90" ! 9A: Read/write TDB/UNFORMATTED !include "gtp3E.F90" #include "gtp3E.F90" ! 9B: Read/write XML !include "gtp3EX.F90" !include "gtp3EY.F90" #include "gtp3EX.F90" #include "gtp3EY.F90" ! 7-8: state variable functions, interactive things !include "gtp3F.F90" #include "gtp3F.F90" ! 13-15: status for things, unfinished things, internal stuff !include "gtp3G.F90" #include "gtp3G.F90" ! 16: Additions (magnetic and others) !include "gtp3H.F90" #include "gtp3H.F90" ! 6: calculate things, gtp3XQ for MQMQA !include "gtp3X.F90" #include "gtp3X.F90" #include "gtp3XQ.F90" ! 17-18: Grid minimizer and miscellaneous !include "gtp3Y.F90" #include "gtp3Y.F90" ! 19: TPFUN routines for non-encrypted databases !include "gtp3Z.F90" #include "gtp3Z.F90" END MODULE GENERAL_THERMODYNAMIC_PACKAGE ================================================ FILE: src/models/gtp3A.F90 ================================================ ! ! gtp3A.F90 included in gtp3.F90 ! !**************************************************** ! general subroutines for creating and handling elements, species, phases etc ! accessable externally ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !> size 08.05.2025 !> Master include file gtp3 3 kB !> Declaration of TPfun datastructures gtp3_dd1 5 kB !> Declaration other datastructures gtp3_dd2 115 kB !> Declaration of XML datastructures gtp3_xml 23 kB !> 1. Initialization and reinitiate gtp3A 117 kB !> 2. Number of things gtp3A !> 3. Find things gtp3A !> 4. Get things gtp3A !> 5. Set things gtp3A !> 6. Section: enter data gtp3B 367 kB !> 7. List data ............................ gtp3C 173 kB !> 8. Interactive things gtp3D 93 kB !> 9A. Read and save on files gtp3E 281 kB !> 9B. Read and save on XTDB files gtp3EX 67 kB !> 9C. Read and save on XTDB files gtp3EY 135 kB !> 10. State variable manipulations gtp3F 170 kB !> 11. Status of things gtp3G 79 kB !> 12. Unfinished things gtp3G !> 13. Internal stuff gtp3G !> 14. Additions and model properties gtp3H 178 kB !> 15. Calculate G for a phase gtp3X 246 kB !> 15B. Calculate G for MQMQA gtp3XQ 80 kB !> 16. Grid minimizer gtp3Y 284 kB !> 17. Miscellaneous gtp3Y !> 18. TP functions gtp3Z 140 kB ! ! But subroutines and functions have been added here and there !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine init_gtp !\begin{verbatim} subroutine init_gtp(intvar,dblvar) ! initiate the data structure ! create element and species record for electrons and vacancies ! the allocation of many arrays should be provided calling this routne ! intvar and dblvar will eventually be used for allocations and defaults implicit none integer intvar(*) double precision dblvar(*) !\end{verbatim} character tpname*16,tpfun*80 integer jl,ieq,ip,lrot,npid ! noofel=0; noofsp=0; noofph=0; nooftuples=0 ! write(*,3)' *** init_gtp should read MPID from AppendXTDB',maxel,maxsp,maxph 3 format(a,10i5) ! allocate records for elements allocate(ellista(-1:maxel)) allocate(elements(-1:maxel)) ! allocate records for species allocate(splista(maxsp)) allocate(species(maxsp)) ! allocate records for phases allocate(phlista(0:maxph)) allocate(phases(0:maxph)) phases=0 allocate(phasetuple(0:2*maxph)) do jl=1,2*maxph !CCI (array not scalar) phasetuple(jl)%nextcs=0 !CCI enddo ! phases(0) is refrence phase, evidently this index is never set phases(0)=0 !--------------------------- ! create special element /- ellista(-1)%symbol='/-' ellista(-1)%name='Electron' ellista(-1)%ref_state='Electron_gas' ellista(-1)%mass=zero ellista(-1)%h298_h0=zero ellista(-1)%s298=zero ellista(-1)%status=0 ellista(-1)%alphaindex=-1 ! The electron does not have any corresponing species ellista(-1)%splink=-1 elements(-1)=-1 ! create special elements VA ellista(0)%symbol='VA' ellista(0)%name='Vacancy' ellista(0)%ref_state='Vacuum' ellista(0)%mass=zero ellista(0)%h298_h0=zero ellista(0)%s298=0.0D0 ellista(0)%status=0 ellista(0)%alphaindex=0 ! splink set below ! ellista(0)%splink=0 ! allocate element link array allocate(splista(1)%ellinks(1)) allocate(splista(1)%stoichiometry(1)) splista(1)%symbol='VA' splista(1)%mass=zero splista(1)%charge=zero splista(1)%status=0 splista(1)%quadindex=0 ! set status bits that is is also an element and it is the vacancy splista(1)%status=ibset(splista(1)%status,SPEL) splista(1)%status=ibset(splista(1)%status,SPVA) splista(1)%alphaindex=1 splista(1)%noofel=1 splista(1)%ellinks(1)=0 splista(1)%stoichiometry(1)=one elements(0)=0 noofsp=1 species(1)=1 ! link from element Va to species Va ellista(0)%splink=1 ! write(*,3)'more allocate: ',maxrefs,maxprop,maxeq,maxtpf,maxsvfun allocate(bibrefs(maxrefs)) allocate(propid(maxprop)) ! first free data reference record (static) reffree=1 addrecs=0 !--------------------------------------- noofem=0 noofint=0 noofprop=0 !---------------------------------------- ! initiate equilibrium record list ! dimension arrays for in first equilibrium record including phase_varres allocate(eqlista(maxeq)) do jl=1,maxeq-1 ! new 2019.12.17 zero status word!! eqlista(jl)%status=0 eqlista(jl)%nexteq=jl+1 enddo eqlista(maxeq)%nexteq=-1 eqfree=1 ! create first equilibrium record incl complist call enter_equilibrium('DEFAULT_EQUILIBRIUM ',ieq) if(gx%bmperr.ne.0) then write(*,*)' error in first enter_equilibrium',gx%bmperr goto 1000 endif firsteq=>eqlista(1) ! nullify some pointers because of error entering first nullify(firsteq%lastcondition,firsteq%lastexperiment) ! set phase_varres free list in firsteq. These are always allocated together do jl=1,2*maxph-1 firsteq%phase_varres(jl)%nextfree=jl+1 enddo ! NOTE last phase_varres record used for copy in shiftcompsets firsteq%phase_varres(2*maxph)%nextfree=-1 ! csfree and highcs are declared in gtp3.F90 csfree=1; highcs=0 ! convergence criteria for constituent fractions, 1e-6 works most often ! But one should take care to equilibrate fractions smaller than xconv!!! !CCI call initialize_default_global_parameters(firsteq) !CCI ! initiate tp functions ! write(*,*)'init_gtp: initiate TP fuctions' jl=maxtpf call tpfun_init(jl,firsteq%eq_tpres) !------------------------------------ ! Property records define what can be used as "id" for parameters, the first ! must be G for the "chemical" part. The others are connected to various ! additions or are simply properties that may depend on composition and is ! needed in other contexts, like mobilities, viscosities etc. ! create property id records for G npid=1 ! propid(npid)%symbol='G ' propid(npid)%symbol=modparid(1) propid(npid)%note='Energy ' propid(npid)%status=0 ! This indicates if there are unkown or undefined MPI in a TDB file nundefmpi=0 !============================================================ ! VERY IMPORTANT: The properties defined below must not be equal to state ! variables, or abbreviation of state variables. ! If so they cannot be listed and other errors may occur ! IMPORTANT any changes must be propagated to gtp3F: state_variable_val3 !!! ! after label 200!! ! ! ANY CHANGES HERE MUST BE MADE ALSO IN SUBROUTINE state_variable_val3 ! IN THE RESULTS THE TYPE OF VARIABLE WILL BE STORED USING THE npid INDEX HERE ! OLD SAVE FILES MAY HAVE OTHER MEANING OF npid !! ! !============================================================ ! Mixed Curie/Neel Temperature, set bits that TC and BM cannot depend on T 2 npid=npid+1 ! propid(npid)%symbol='TC ' propid(npid)%symbol=modparid(2) propid(npid)%note='Combined Curie/Neel T' propid(npid)%status=0 ! TC cannot depend on T but on P propid(npid)%status=ibset(propid(npid)%status,IDONLYP) !....................................... ! Average Bohr magneton number 3 npid=npid+1 ! propid(npid)%symbol='BMAG ' propid(npid)%symbol=modparid(3) propid(npid)%note='Average Bohr magneton numb' propid(npid)%status=0 ! BM cannot depend on either T or P ?? propid(npid)%status=ibset(propid(npid)%status,IDNOTP) !....................................... ! Specific Curie temperature 4 npid=npid+1 ! propid(npid)%symbol='CTA ' propid(npid)%symbol=modparid(4) propid(npid)%note='Curie temperature' propid(npid)%status=0 ! CTA cannot depend on either T or P ?? propid(npid)%status=ibset(propid(npid)%status,IDONLYP) !....................................... ! Specific Neel temperature 5 npid=npid+1 ! propid(npid)%symbol='NTA ' propid(npid)%symbol=modparid(5) propid(npid)%note='Neel temperature' propid(npid)%status=0 ! NTA cannot depend on T but on P propid(npid)%status=ibset(propid(npid)%status,IDONLYP) !....................................... ! Individual Bohr magneton number 6 SPECIAL THIS HAS CONSTITUENT INDEX npid=npid+1 ! propid(npid)%symbol='IBM ' propid(npid)%symbol=modparid(6) propid(npid)%note='Individual Bohr magneton numb' ! 123456789.123456789.12345678- propid(npid)%status=0 ! IBM cannot depend on either T or P and it is individual propid(npid)%status=ibset(propid(npid)%status,IDCONSUFFIX) propid(npid)%status=ibset(propid(npid)%status,IDONLYP) !....................................... ! Debye or Einstein temperature 7 npid=npid+1 ! propid(npid)%symbol='LNTH ' propid(npid)%symbol=modparid(7) propid(npid)%note='LN(Debye or Einstein temp)' propid(npid)%status=0 ! LNTH cannot depend on T but on P propid(npid)%status=ibset(propid(npid)%status,IDONLYP) !....................................... 8 ! Molar volume at T=298.15, 1 bar npid=npid+1 ! propid(npid)%symbol='V0 ' propid(npid)%symbol=modparid(8) propid(npid)%note='Volume at T0, P0 ' propid(npid)%status=0 ! Constant independent on temperature or pressure propid(npid)%status=ibset(propid(npid)%status,IDNOTP) !....................................... 9 ! Thermal expansion at 1 bar npid=npid+1 ! propid(npid)%symbol='VA ' propid(npid)%symbol=modparid(9) propid(npid)%note='Thermal expansion ' propid(npid)%status=0 ! Not P dependent, only T dependent propid(npid)%status=ibset(propid(npid)%status,IDONLYT) !....................................... 10 ! Bulk modulus as function of T and P npid=npid+1 ! propid(npid)%symbol='VB ' propid(npid)%symbol=modparid(10) propid(npid)%note='Bulk modulus ' propid(npid)%status=0 !....................................... 11 ! Extra volume parameter npid=npid+1 ! propid(npid)%symbol='VC ' propid(npid)%symbol=modparid(11) propid(npid)%note='Alternative volume parameter' propid(npid)%status=0 !....................................... 12 ! Diffusion volume parameter, suffix S on V create confusion with S as SER? npid=npid+1 ! propid(npid)%symbol='VS ' propid(npid)%symbol=modparid(12) propid(npid)%note='Diffusion volume parameter ' propid(npid)%status=0 !....................................... ! Activation energy of mobility 13 npid=npid+1 ! propid(npid)%symbol='MQ ' propid(npid)%symbol=modparid(13) propid(npid)%note='Mobility activation energy' propid(npid)%status=0 ! MQ is specific for a constituent propid(npid)%status=ibset(propid(npid)%status,IDCONSUFFIX) ! indicate this parameter must not have wildcard constituents nowildcard(1)=npid ! in subroutine equilph1e we use the index of MQ to find mobility values mqindex=npid*100 !....................................... ! RT*ln(Frequency factor of mobility) 14 npid=npid+1 ! propid(npid)%symbol='MF ' propid(npid)%symbol=modparid(14) propid(npid)%note='RT*LN(mobility freq.fact.)' propid(npid)%status=0 ! MF is specific for a constituent propid(npid)%status=ibset(propid(npid)%status,IDCONSUFFIX) ! indicate this parameter must not have wildcard constituents nowildcard(2)=npid !....................................... ! Magnetic mobility factor 15 npid=npid+1 ! propid(npid)%symbol='MG ' propid(npid)%symbol=modparid(15) propid(npid)%note='Magnetic mobility factor' propid(npid)%status=0 ! MG is specific for a constituent propid(npid)%status=ibset(propid(npid)%status,IDCONSUFFIX) ! indicate this parameter must not have wildcard constituents nowildcard(3)=npid !....................................... 13 fd 11 ! Liquid two-state model 16 npid=npid+1 ! propid(npid)%symbol='G2 ' propid(npid)%symbol=modparid(16) propid(npid)%note='Liquid two state parameter' propid(npid)%status=0 !....................................... ! Smooth unit step function (or second Einstein function) 17 npid=npid+1 ! propid(npid)%symbol='THT2 ' propid(npid)%symbol=modparid(17) propid(npid)%note='LN(Smooth step function Tcrit)' propid(npid)%status=0 ! THT2 cannot depend on T but on P propid(npid)%status=ibset(propid(npid)%status,IDONLYP) !....................................... ! Second Einstein delta CP 18 npid=npid+1 ! propid(npid)%symbol='DCP2 ' propid(npid)%symbol=modparid(18) propid(npid)%note='Smooth step function increm.' propid(npid)%status=0 ! DXP2 cannot depend on T but on P propid(npid)%status=ibset(propid(npid)%status,IDONLYP) !....................................... ! Lattice parameter in direction X 19 npid=npid+1 ! propid(npid)%symbol='LPX ' propid(npid)%symbol=modparid(19) propid(npid)%note='Lattice param X axis' propid(npid)%status=0 ! lattice parameters may depend on T and P !....................................... ! Lattice parameter in direction Y 20 npid=npid+1 ! propid(npid)%symbol='LPY ' propid(npid)%symbol=modparid(20) propid(npid)%note='Lattice param Y axis' propid(npid)%status=0 ! lattice parameters may depend on T and P !....................................... ! Lattice parameter in direction Z 21 npid=npid+1 ! propid(npid)%symbol='LPZ ' propid(npid)%symbol=modparid(21) propid(npid)%note='Lattice param Z axis' propid(npid)%status=0 ! lattice parameters may depend on T and P !....................................... ! This is an angle for non-cubic lattices 22 npid=npid+1 ! propid(npid)%symbol='LPTH ' propid(npid)%symbol=modparid(22) propid(npid)%note='Lattice angle TH' propid(npid)%status=0 ! Angle may depend on T and P !....................................... ! This is an elastic "constant" 23 npid=npid+1 ! propid(npid)%symbol='EC11 ' propid(npid)%symbol=modparid(23) propid(npid)%note='Elastic const C11' propid(npid)%status=0 ! The elastic constant may depend on T and P !....................................... ! This is another elastic "constant" 24 npid=npid+1 ! propid(npid)%symbol='EC12 ' propid(npid)%symbol=modparid(24) propid(npid)%note='Elastic const C12' propid(npid)%status=0 ! The elastic constant may depend on T and P !....................................... ! This is yet another elastic "constant" 25 npid=npid+1 ! propid(npid)%symbol='EC44 ' propid(npid)%symbol=modparid(25) propid(npid)%note='Elastic const C44' propid(npid)%status=0 ! The elastic constant may depend on T and P !....................................... ! VERY SPECIAL this model parameter identifier has no addition ! thus no check for addition in enter_parameter subroutine (gtp3B.F90) ! UNIQUAC interaction parameter 26 ! IF THIS IS CHANGED TO ANOTHER NUMBER CHANGES NEEDED IN GTP3B: mpiwarning npid=npid+1 ! propid(npid)%symbol='UQT ' propid(npid)%symbol=modparid(26) propid(npid)%note='UNIQUAC residual parameter ' propid(npid)%status=0 ! UQT is specific for a constituent, 2600+constituent index propid(npid)%status=ibset(propid(npid)%status,IDCONSUFFIX) !....................................... ! Electrical resistivity 27 npid=npid+1 ! propid(npid)%symbol='RHO ' propid(npid)%symbol=modparid(27) propid(npid)%note='Electric resistivity' propid(npid)%status=0 !....................................... f.d. 18 now 28 ! Viscosity 28 npid=npid+1 ! propid(npid)%symbol='VISC ' propid(npid)%symbol=modparid(28) propid(npid)%note='Viscosity' propid(npid)%status=0 !....................................... ! Thermal conductivity as function of T and P: 29 npid=npid+1 ! propid(npid)%symbol='LAMB ' propid(npid)%symbol=modparid(29) propid(npid)%note='Thermal conductivity ' propid(npid)%status=0 !....................................... ! From MatCalc databases 30 npid=npid+1 ! propid(npid)%symbol='HMVA ' propid(npid)%symbol=modparid(30) propid(npid)%note='Enthalpy of vacancy form. ' propid(npid)%status=0 ! this parameter does not depend on T ?? ! propid(npid)%status=ibset(propid(npid)%status,IDONLYP) !....................................... ! Schottky anomaly T 31 npid=npid+1 ! propid(npid)%symbol='TSCH ' propid(npid)%symbol=modparid(31) propid(npid)%note='Schottky anomaly T ' propid(npid)%status=0 ! this parameter does not depend on T ?? propid(npid)%status=ibset(propid(npid)%status,IDONLYP) !....................................... ! Schottky anomaly CP/R 32 npid=npid+1 ! propid(npid)%symbol='CSCH ' propid(npid)%symbol=modparid(32) propid(npid)%note='Schottky anomaly Cp/R. ' propid(npid)%status=0 ! this parameter does not depend on T ?? propid(npid)%status=ibset(propid(npid)%status,IDONLYP) !....................................... ! Modified Quasichemical model coordination factor 33 npid=npid+1 ! propid(npid)%symbol='QCZ' propid(npid)%symbol=modparid(33) propid(npid)%note='MQMQA cluster coord factor (not used)' propid(npid)%status=0 propid(npid)%status=ibset(propid(npid)%status,IDNOTP) !....................................... ! Modified MQMQA parameter factor 34 npid=npid+1 ! propid(npid)%symbol='GG' propid(npid)%symbol=modparid(34) propid(npid)%note='MQMQA excess parameter' propid(npid)%status=0 ! propid(npid)%status=ibset(propid(npid)%status,IDNOTP) !....................................... ! GG npid=npid+1 ! propid(npid)%symbol='GQ' propid(npid)%symbol=modparid(35) propid(npid)%note='MQMQA excess parameter' propid(npid)%status=0 ! propid(npid)%status=ibset(propid(npid)%status,IDNOTP) !....................................... ! Modified MQMQA parameter factor 36 npid=npid+1 ! propid(npid)%symbol=modparid(36) propid(npid)%symbol='GB' propid(npid)%note='MQMQA excess parameter' propid(npid)%status=0 ! This parameter does not depend on T and P ! propid(npid)%status=ibset(propid(npid)%status,IDNOTP) !....................................... ! The array modparid is declared in gtp3_dd2.F90 with 40 items. ! debug output ! do jl=1,npid ! write(*,33)jl,propid(jl)%symbol,trim(propid(jl)%note) !33 format(i3,2x,a4,2x,a) ! enddo !....................................... ! This IF statement should be at the last parameter identifier, maxprop=50 ? if(npid.gt.maxprop) then write(*,*)'Too many parameter identifiers, increase maxprop' gx%bmperr=4250; goto 1000 endif ! write(*,*)'3A number of model parameter identifiers: ',npid ! IMPORTANT any changes must be propagated to gtp3F: state_variable_val3 !!! !....................................... ! IMPORTRANT: When adding more parameter identifiers one should NEVER ! NEVER USE A NAME ENDING IN D as that will be taken as a "disordered" part ! The number of defined properties, should be less than maxprop (=50?) ! IMPORTANT: In the addition records one must use the parameter identifier ! to extract the calculated composition dependent values ! IMPORTANT: in gtp3F new variables must be added to be able to list/plot them ndefprop=npid !------------------------------------------------- !CCI : GSVIRTUAL enables to do calculation with virtual elements globaldata%status=ibclr(globaldata%status,GSVIRTUAL) !CCI ! globaldata record; set gas constant mm globaldata%status=0 ! set beginner, no data, no phase, no equilibrium calculated globaldata%status=ibset(globaldata%status,GSBEG) ! globaldata%status=ibset(globaldata%status,GSADV) globaldata%status=ibset(globaldata%status,GSNODATA) globaldata%status=ibset(globaldata%status,GSNOPHASE) firsteq%status=ibset(firsteq%status,EQNOEQCAL) ! set that dense grid is used by default ! globaldata%status=ibset(globaldata%status,GSXGRID) ! set gas constant and some default values globaldata%name='current' globaldata%rgas=8.31451D0 ! more recent value not used as all TDB file used the old ! globaldata%rgas=8.3144621D0 ! old value of gas constant globaldata%rgasuser=8.31451D0 globaldata%pnorm=one ! zero sysparam and sysreal globaldata%sysparam=0 globaldata%sysreal=zero ! write(*,*)'init_gtp: enter R and RTLNP' ! enter R as TP function tpname='R' ! write(tpfun,777)' 10 8.31451; 20000 N ' !777 format(a) ! call enter_tpfun(tpname,tpfun,lrot,.FALSE.) call store_tpconstant(tpname,globaldata%rgas) if(gx%bmperr.ne.0) goto 1000 tpname='RTLNP' tpfun=' 1 R*T*LN(1.0D-5*P); 20000 N ' ! call store_tpfun(tpname,tpfun,lrot,.FALSE.) call store_tpfun(tpname,tpfun,lrot,-1) if(gx%bmperr.ne.0) goto 1000 ! default minimum fraction bmpymin=ymind ! putfun error code .... should use buperr at least pfnerr=0 !------------------------------------ ! allocate array for state variable function ! write(*,*)'init_gtp: allocate array for state variable functions' allocate(svflista(maxsvfun)) ! number of state variable functions nsvfun=0 ! zero the array with equilibrium index for functions, not used aywhere?? ! pflocal=0 ! enter some useful state variable function tpfun=' R=8.31451;' ip=1 ! write(*,*)'init_gtp: entering function R' call enter_svfun(tpfun,ip,firsteq) ! mark it cannot be amended svflista(1)%status=ibset(svflista(1)%status,SVNOAM) ! mark it is a constant svflista(1)%status=ibset(svflista(1)%status,SVCONST) ! if(gx%bmperr.ne.0) then ! write(*,*)'Error entering R',gx%bmperr ! goto 1000 ! endif ! write(*,*)'Entered symbol R' tpfun=' RT=R*T;' ip=1 ! write(*,*)'init_gtp: entering function RT' call enter_svfun(tpfun,ip,firsteq) ! mark it cannot be amended svflista(2)%status=ibset(svflista(2)%status,SVNOAM) ! if(gx%bmperr.ne.0) then ! write(*,*)'Error entering symbol RT' ! goto 1000 ! endif ! write(*,*)'Entered symbol RT' tpfun=' T_C=T-273.15;' ip=1 ! write(*,*)'init_gtp: entering function T_C' call enter_svfun(tpfun,ip,firsteq) ! mark it cannot be amended svflista(3)%status=ibset(svflista(3)%status,SVNOAM) ! if(gx%bmperr.ne.0) then ! write(*,*)'Error entering symbol T_C' ! goto 1000 ! endif ! we evaluate all symbols to avoid some problems ... no output ! call meq_evaluate_all_svfun(-1,ceq) cannot be used as it is in minimizer ... call evaluate_all_svfun_old(-1,firsteq) ! set working directory (decleared in metlib, used now and again ...) call getcwd(workingdir) ! assessment initiallizing ! write(*,*)'3A Initiallizing firstash', firstash is a pointer ... call assessmenthead(firstash) ! firstash%status=0 ! write(*,*)'firstash allocated: ',firstash%status ! nullify(firstash%prevash) ! nullify(firstash%nextash) ! create the beginnings of a circular list firstash%nextash=>firstash firstash%prevash=>firstash ! set that dense grid used by default ! globaldata%status=ibset(globaldata%status,GSXGRID) ! removed line above as that caused crash in parallel2 WHY???? ! mqmqma exlevel=0 uses the old excess model implementation mqmqa_data%exlevel=0 ! to manually select debug output using LIST MQMQA DEBUG mqmqdebug=.false. mqmqdebug2=.false. ! finished initiating 1000 continue write(*,1001) 1001 format(/'3A unfished preparations for XTDB'/) return END subroutine init_gtp !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !CCI !\addtotable subroutine initialize_default_global_parameters !\begin{verbatim} subroutine initialize_default_global_parameters(firsteq) type(gtp_equilibrium_data), pointer :: firsteq !\end{verbatim} firsteq%type_change_phase_amount = default_typechangephaseamount firsteq%scale_change_phase_amount= default_scalechangephaseamount firsteq%gmindif= default_mingridmin firsteq%precondsolver=default_precondsolver firsteq%splitsolver=default_splitsolver firsteq%xconv=default_xconv firsteq%maxiter=default_maxiter firsteq%gdconv(1)=default_gdconv1 firsteq%gdconv(2)=default_gdconv2 return end subroutine initialize_default_global_parameters !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine assessmenthead !\begin{verbatim} subroutine assessmenthead(ash) ! create an assessment head record and do more (later) type(gtp_assessmenthead), pointer :: ash ! type(gtp_assessmenthead), allocatable :: ash !\end{verbatim} ! it is not good to allocate a pointer, memory loss!! allocate(ash) ash%status=0 return end subroutine assessmenthead !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\addtotable subroutine new_gtp !\begin{verbatim} subroutine new_gtp ! ! DELETES ALL DATA so a new TDB file can be read ! ! this is needed before reading a new unformatted file (or same file again) ! we must go through all records and delete and deallocate each ! separately. Very similar to gtpread implicit none !\end{verbatim} integer isp,j,nel,intv(10),k double precision dblv(10) TYPE(gtp_equilibrium_data), pointer :: ceq type(gtp_phase_varres), pointer :: phdyn ! TYPE(gtp_fraction_set) :: fslink ! write(*,*)'3E Testing segmentation error in new_gtp' if(ocv()) write(*,*)'3E Removing current data' !---------- elementlist, no need to delete, just deallocate below !>>>>> 2: !---------- specieslist, we have to deallocate ?? maybe not ?? !>>>>> 3: if(btest(globaldata%status,GSNODATA)) then if(ocv()) write(*,*)'3E No thermodynamic data to delete' goto 600 endif if(gtp_species_version.ne.2) then write(*,17)'3E *** ERROR species',1,gtp_species_version 17 format(a,' record version error: ',2i4) gx%bmperr=4300; goto 1000 endif ceq=>firsteq ! write(*,*)'3E No segmentation error A' do isp=1,noofsp nel=splista(isp)%noofel deallocate(splista(isp)%ellinks) deallocate(splista(isp)%stoichiometry) if(allocated(splista(isp)%spextra)) deallocate(splista(isp)%spextra) enddo !---------- phases, many records, here we travese all endmembers etc !>>>>> 4 ! write(*,*)'3E No segmentation error B' ! if(gtp_phase_version.ne.1) then ! write(*,17)'3E **** ERROR phase',1,gtp_phase_version ! gx%bmperr=4302; goto 1000 ! endif ! if(gtp_endmember_version.ne.1) then ! write(*,17)'3E **** ERROR endmember',1,gtp_endmember_version ! gx%bmperr=4302; goto 1000 ! endif ! if(gtp_interaction_version.ne.1) then ! write(*,17)'3E **** ERROR interaction',1,gtp_interaction_version ! gx%bmperr=4302; goto 1000 ! endif ! if(gtp_property_version.ne.1) then ! write(*,17)'3E **** ERROR property',1,gtp_property_version ! gx%bmperr=4302; goto 1000 ! endif do j=0,noofph call delphase(j) if(gx%bmperr.ne.0) goto 1000 enddo ! write(*,*)'3E No segmentation error C1' !----------- jump here if no thermodynamic data 600 continue !---------- equilibrium records !>>>>> 50: equilibrium records ! call delete_equil(ceq) ! do j=1,noofeq ! this loop was added in an attempt to get rid of an error occuring with ! 64 bit version, the TP functions was not cleared correctly do j=1,eqfree-1 ceq=>eqlista(j) deallocate(ceq%svfunres) ! write(*,*)'3E No segmentation error C2',j deallocate(ceq%eq_tpres) ! write(*,*)'3E No segmentation error C3',j deallocate(ceq%complist) ! write(*,*)'3E No segmentation error C4',j deallocate(ceq%compstoi) ! write(*,*)'3E No segmentation error C5',j deallocate(ceq%invcompstoi) ! write(*,*)'3E No segmentation error C6',j ! remove valgrind memory leak for conditions call delete_all_conditions(0,ceq) ! clean upp phase_varres records do k=1,size(ceq%phase_varres) phdyn=>ceq%phase_varres(k) if(allocated(phdyn%gval)) then deallocate(phdyn%gval) deallocate(phdyn%dgval) deallocate(phdyn%d2gval) ! write(*,*)'3E No segmentation error C7',j,k endif ! deallocate mqmqa arrays if(allocated(phdyn%mqmqaf%yy1)) then write(*,*)'3E deallocating phase_varres%mqmqaf arrays' ! these arrays allocated in gtp3X.F90 deallocate(phdyn%mqmqaf%yy1) deallocate(phdyn%mqmqaf%dyy1) deallocate(phdyn%mqmqaf%d2yy1) deallocate(phdyn%mqmqaf%yy2) deallocate(phdyn%mqmqaf%dyy2) deallocate(phdyn%mqmqaf%d2yy2) deallocate(phdyn%mqmqaf%ceqf1) deallocate(phdyn%mqmqaf%dceqf1) deallocate(phdyn%mqmqaf%ceqf2) deallocate(phdyn%mqmqaf%dceqf2) deallocate(phdyn%mqmqaf%pair) deallocate(phdyn%mqmqaf%dpair) phdyn%mqmqaf%nquad=0 ! write(*,*)'3A cleaning up some mqmqa data' endif ! set phstate and phlink to zero to avoid segmentation fault when plotting ! after several MAP or STEP commands with different composition sets phdyn%phstate=0 phdyn%phlink=0 enddo ! new implementation of MQMQA if(allocated(phdyn%mqmqaf%xquad)) then deallocate(phdyn%mqmqaf%xquad) deallocate(phdyn%mqmqaf%compvar) endif ! write(*,*)'3E No segmentation error C8',j ! deallocate(ceq%phase_varres) enddo ! write(*,*)'3E No segmentation error D1' ! I am not sure if this really releases all memory, how to check .... ??? ! call deallocate_gtp(intvar,dblvar) deallocate(eqlista) ! write(*,*)'3E No segmentation error D2' !------- deallocate elements, species and phases, will be allocated in init_gtp deallocate(ellista) deallocate(elements) ! do k=1,noofsp ! deallocate(splista(k)%ellinks) ! enddo deallocate(splista) deallocate(species) deallocate(phlista) deallocate(phases) deallocate(phasetuple) ! write(*,*)'3E No segmentation error E' !------ tpfunction expressions and other lists !>>>>> 20: delete tpfuns ! write(*,*)'3E Delete TP funs, just deallocate??',freetpfun ! call delete_all_tpfuns ! I do not think this deletes anything ... tpfuns is an array of pointers ... call tpfun_deallocate if(gx%bmperr.ne.0) then write(*,*)'3E **** ERROR deleting TP functions' endif ! write(*,*)'3E Back from deleting all TP funs, this is fun!!' !------ tpfunction expressions and other lists !>>>>> 30: delete state variable functions deallocate(svflista) ! write(*,*)'3E No segmentation error F' ! call delete_svfuns !---------- delete bibliographic references !>>>>> 40: references deallocate(bibrefs) ! call delete_biblio !------ parameter property records deallocate(propid) !------ other things such as mqmq_data arrays, I cannot deallocate here ! probably many more mqmqa data must be deallocated if(allocated(mqmqa_data%contyp)) then deallocate(mqmqa_data%contyp) if(allocated(mqmqa_data%constoi)) deallocate(mqmqa_data%constoi) if(allocated(mqmqa_data%totstoi)) deallocate(mqmqa_data%totstoi) if(allocated(mqmqa_data%el2ancat)) deallocate(mqmqa_data%el2ancat) if(allocated(mqmqa_data%con2quad)) deallocate(mqmqa_data%con2quad) if(allocated(mqmqa_data%quad2compvar)) deallocate(mqmqa_data%quad2compvar) if(allocated(mqmqa_data%emquad)) deallocate(mqmqa_data%emquad) if(allocated(mqmqa_data%dy_ik)) deallocate(mqmqa_data%dy_ik) mqmqa_data%nconst=0 mqmqa_data%ncon1=0 mqmqa_data%ncon2=0 mqmqa_data%npair=0 ! more to deallocate ......... see also at line 780 above if(allocated(tersys)) deallocate(tersys) ! mqf=>phres%mqmqaf ! write(*,*)'3A cleaning up some more mqmqa data' endif if(allocated(mqmqa_data%pinq)) then deallocate(mqmqa_data%pinq) endif ! these are allocated here and there, if error reading database some may not be if(allocated(mqmqa_data%qfnnsnn)) then deallocate(mqmqa_data%qfnnsnn) deallocate(mqmqa_data%pp) endif if(allocated(mqmqa_data%con2quad)) deallocate(mqmqa_data%con2quad) ! if(allocated(mqmqa_data%quad2con) deallocate(mqmqa_data%quad2con)) ! ! write(*,*)'3E No segmentation error G' !------ map results are deleted separately ! call delete_mapresults(maptop) ! deallocate( .... any more ??? !--------------------------- ! now initiate all lists and a little more if(ocv()) write(*,*)'3E All data structures will be reinitiated' ! intv(1) negative means reinititate with same values as before ! intv(1)=-1 ! write(*,*)'3E No segmentation error H', moved to pmon ! call init_gtp(intv,dblv) ! after return firsteq must be initiated ... maybe it should be done here ?? ! ! Problem when adding EEC, initialization does not work, why? ! Maybe these need initiating? globaldata%sysreal=zero globaldata%sysparam=0 ! For EEC sysreal(1) is set to a value of T ! the MQMQA phase require reduced accuracy for a test in matsmin.F90 ! around line 2223. Sysreal(2) is set to unity here globaldata%mqmqa1=1.0D0 ! globaldata%sysreal(2)=1.0D4 ! But if a MQMQA model phase involved it is set to 1.0D4 ! ! write(*,*)'3E globaldata%encrypted: ',globaldata%encrypted ! initiate Toop/Kohler record counter ! uniqid=0 ! 1000 continue return end subroutine new_gtp !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine deallocate_gtp !\begin{verbatim} subroutine deallocate_gtp(intvar,dblvar) ! deallocate the data structure implicit none integer allocatestatus integer intvar(*) double precision dblvar(*) !\end{verbatim} ! integer jl write(*,*)'3A in deallocate_gtp' deallocate(ellista, STAT = allocateStatus) if (allocateStatus /= 0) then write(kou,*) 'Error during deallocation of ellista' goto 1000 else write(kou,*) 'Deallocation of data ', allocateStatus endif ! flush(6) deallocate(elements) ! deallocate records for species deallocate(splista) deallocate(species) ! deallocate records for phases deallocate(phlista) deallocate(phases) deallocate(phasetuple) deallocate(bibrefs) deallocate(propid) deallocate(eqlista) deallocate(svflista) write(*,*)'3A Deallocate TP funs' call tpfun_deallocate !CCI added this deallocate(firstash) 1000 continue return END subroutine deallocate_gtp !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\addtotable subroutine delphase !\begin{verbatim} subroutine delphase(lokph) ! save data for phase at location lokph (except data in the equilibrium record) ! For phases with disordered set of parameters we must access the number of ! sublattices via firsteq implicit none integer lokph !\end{verbatim} integer level,nsl,noendm type(gtp_endmember), pointer :: emrec,nextem type(gtp_interaction), pointer :: intrec,nextint type(gtp_property), pointer :: proprec,nextprop ! to keep track of interaction records type saveint type(gtp_interaction), pointer :: p1 end type saveint type(saveint), dimension(:), pointer :: stack type(gtp_phase_add), pointer :: addlink,nextadd ! write(*,*)'3E In delphase',lokph if(btest(phlista(lokph)%status1,PHMQMQX)) then write(*,12)phlista(lokph)%name 12 format('The phase ',a,' is present, reinitiate may fail') goto 1000 endif allocate(stack(5)) nsl=phlista(lokph)%noofsubl !>>>>> 6: ! when failed reading database phlista may not be allocated! if(allocated(phlista)) then deallocate(phlista(lokph)%nooffr) deallocate(phlista(lokph)%constitlist) else write(*,*)'3A phlista not allocated!' gx%bmperr=4399; goto 1000 endif emrec=>phlista(lokph)%ordered noendm=0 !>>>>> 6: sublattice info ! we come back here if there are disordered parameters 200 continue ! there can be phases without any parameters ... emlista: do while(associated(emrec)) proprec=>emrec%propointer intrec=>emrec%intpointer nextem=>emrec%nextem !>>>>> 7: after saving links deallocate endmember record with all its content ! write(*,*)'3E deallocate endmember record' deallocate(emrec) ! nextem do not need to be declared as target?? emrec=>nextem emproplista: do while(associated(proprec)) nextprop=>proprec%nextpr !>>>>> 8: endmember property records ! functions and references deallocated separately ! write(*,*)'3E deallocate endmember property record' deallocate(proprec) proprec=>nextprop enddo emproplista ! interaction tree level=0 300 continue intlista: do while(associated(intrec)) !>>>>> 9: interaction record level=level+1 if(level.gt.5) then gx%bmperr=4164; goto 1000 endif ! write(*,*)'3E Pushing ',level stack(level)%p1=>intrec%nextlink nextint=>intrec%highlink proprec=>intrec%propointer ! write(*,*)'3E deallocate interaction record' deallocate(intrec) intproplista: do while(associated(proprec)) nextprop=>proprec%nextpr !>>>>> 10: interaction properties ! write(*,*)'3E deallocate interaction property record' deallocate(proprec) proprec=>nextprop enddo intproplista intrec=>nextint enddo intlista ! pop the link to next interaction if any pop: if(level.gt.0) then ! write(*,*)'3E popping interaction record',level intrec=>stack(level)%p1 nullify(stack(level)%p1) level=level-1 goto 300 endif pop !---- next endmember emrec=>nextem enddo emlista ! no more endmembers, check if the disordered (if any) has been written if(noendm.eq.0) then ! we do not have to care about that nsl is different .... !>>>>> 11: disordered endmembers ! write(*,*)'3E disordered endmembers' emrec=>phlista(lokph)%disordered noendm=1 goto 200 endif ! write(*,*)'3E finished parameter records' !------ additions list 500 continue addlink=>phlista(lokph)%additions addition: do while(associated(addlink)) !>>>>> 12: additions nextadd=>addlink%nextadd if(addlink%type.eq.1) then !>>>>> 12A: delete magnetic addition ... deallocate(addlink%explink) deallocate(addlink) elseif(addlink%type.eq.7) then !>>>>> 12A: delete volume addition ... deallocate(addlink) else write(*,'("3A Addition type ",i2," not deleted ")')addlink%type endif addlink=>nextadd enddo addition ! write(*,*)'3E phase location: ',lokph,size(phlista(lokph)%nooffr),& ! size(phlista(lokph)%constitlist) ! if(lokph.ne.0) then ! problem with phases, cannot deallocate these arrays, why?? ! deallocate(phlista(lokph)%nooffr) ! deallocate(phlista(lokph)%constitlist) ! endif phlista(lokph)%noofcs=0 phlista(lokph)%nooffs=0 ! remove valgrind leak deallocate(stack) ! write(*,*)'all done' 1000 continue return end subroutine delphase !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !> 2. Section: number of things !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable integer function noel !\begin{verbatim} integer function noel() ! number of elements because noofel is private ! should take care if elements are suspended !\end{verbatim} %+ noel=noofel end function noel !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable integer function nosp !\begin{verbatim} %- integer function nosp() ! number of species because noofsp is private ! should take care if species are suspended !\end{verbatim} %+ nosp=noofsp end function nosp !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable integer function noph !\begin{verbatim} %- integer function noph() ! number of phases because noofph is private ! should take care if phases are hidden !\end{verbatim} %+ noph=noofph end function noph !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable integer function noofcs !\begin{verbatim} %- integer function noofcs(iph) ! returns the number of compositions sets for phase iph implicit none integer iph !\end{verbatim} %+ if(iph.le.0 .or. iph.gt.noofph) then gx%bmperr=4050; goto 1000 endif noofcs=phlista(phases(iph))%noofcs 1000 continue return end function noofcs !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable integer function noconst !\begin{verbatim} %- integer function noconst(iph,ics,ceq) ! number of constituents for iph (include single constituents on a sublattice) ! It tests if a constituent is suspended which can be different in each ics. implicit none integer iph,ics TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer lokph,lokcs,noc,jl if(iph.gt.0 .and. iph.le.noofph) then lokph=phases(iph) if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then ! write(*,*)'noconst 1 error 4072' gx%bmperr=4072; goto 1000 elseif(ics.eq.0) then ics=1 endif lokcs=phlista(lokph)%linktocs(ics) if(btest(ceq%phase_varres(lokcs)%status2,CSCONSUS)) then ! some constituents suspended ?? NOT POSSIBLE as not implemented 190923 !!! ! write(*,*)'3A suspended constituents!!',iph,ics,lokph,lokcs write(*,*)'3A suspended constituents: ',phlista(lokph)%tnooffr,& allocated(ceq%phase_varres(lokcs)%constat) if(.not.allocated(ceq%phase_varres(lokcs)%constat)) then noconst=phlista(lokph)%tnooffr else noc=phlista(lokph)%tnooffr do jl=1,phlista(lokph)%tnooffr if(btest(ceq%phase_varres(lokcs)%constat(jl),CONSUS)) then noc=noc-1 endif enddo noconst=noc endif else noconst=phlista(lokph)%tnooffr endif else gx%bmperr=4050 endif 1000 continue return end function noconst !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable integer function nooftup !\begin{verbatim} %- integer function nooftup() ! number of phase tuples !\end{verbatim} %+ implicit none nooftup=nooftuples return end function nooftup !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ ! !\addtotable integer function noofphasetuples !\begin{verbatim} %- ! integer function noofphasetuples_old() ! number of phase tuples REDUNDANT !! !\end{verbatim} ! noofphasetuples_old=nooftuples ! return ! end function noofphasetuples_old ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable integer function nosvf !\begin{verbatim} integer function nosvf() ! number of state variable functions !\end{verbatim} implicit none nosvf=nsvfun return end function nosvf !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable integer function noeq !\begin{verbatim} integer function noeq() ! returns the number of equilibria entered !\end{verbatim} implicit none noeq=eqfree-1 1000 continue return end function noeq !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable integer function nonsusphcs !\begin{verbatim} integer function nonsusphcs(ceq) ! returns the total number of unhidden phases+composition sets ! in the system. Used for dimensioning work arrays and in loops implicit none TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer tphic,iph,ics,lokph double precision xxx tphic=0 do iph=1,noofph lokph=phases(iph) ics=1 if(test_phase_status(iph,ics,xxx,ceq).ne.PHHIDDEN) then ! phase is not hidden do ics=1,phlista(lokph)%noofcs ! if(test_phase_status(iph,ics,xxx,ceq).eq.4) goto 400 if(test_phase_status(iph,ics,xxx,ceq).ne.PHSUS) then tphic=tphic+1 endif ! composition set not suspended ! tphic=tphic+phlista(lokph)%noofcs enddo endif enddo 1000 continue ! write(*,*)'25 A nonsusphcs: ',tphic nonsusphcs=tphic return end function nonsusphcs !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !> 3. Section: find things !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine find_element_by_name !\begin{verbatim} subroutine find_element_by_name(name,iel) ! find an element index by its name, exact fit required implicit none character name*(*) integer iel !\end{verbatim} %+ integer lokel character symbol*2 symbol=name call capson(symbol) do lokel=-1,noofel ! write(*,*)'find_element 1: ',lokel,symbol,' ',ellista(lokel)%symbol if(symbol.eq.ellista(lokel)%symbol) then iel=ellista(lokel)%alphaindex goto 1000 endif enddo iel=-100 gx%bmperr=4042 1000 continue return end subroutine find_element_by_name !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine find_component_by_name !\begin{verbatim} %- subroutine find_component_by_name(name,icomp,ceq) ! BEWARE: one may in the future have different components in different ! equilibria. components are a subset of the species implicit none character*(*) name integer icomp TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer loksp call find_species_record_noabbr(name,loksp) if(gx%bmperr.ne.0) then gx%bmperr=4052; goto 1000 endif ! check that species actually is component do icomp=1,noofel if(ceq%complist(icomp)%splink.eq.loksp) goto 1000 enddo gx%bmperr=4052 1000 continue return end subroutine find_component_by_name !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine find_species_by_name !\begin{verbatim} %- subroutine find_species_by_name(name,isp) ! locates a species index from its name, unique abbreviation ! or exact match needed implicit none character name*(*) integer isp !\end{verbatim} %+ character symbol*24 integer loksp,lensym logical exact exact=.FALSE. symbol=name call capson(symbol) isp=0 do loksp=1,noofsp ! write(*,*)'3A find species 2: ',symbol,splista(loksp)%symbol,loksp if(compare_abbrev(symbol,splista(loksp)%symbol)) then if(isp.eq.0) then isp=splista(loksp)%alphaindex lensym=len_trim(splista(loksp)%symbol) ! write(*,*)'3A abbr match: ',lensym,' <',symbol(1:lensym),'><',& ! splista(loksp)%symbol(1:lensym+1),'>' if(symbol(1:lensym+1).eq.splista(loksp)%symbol(1:lensym+1)) then ! write(*,*)'3A exact match with species name' exact=.TRUE. goto 1000 endif else ! abbreviation is not unique isp=0 exit endif endif enddo if(isp.eq.0) then ! write(*,*)'in find_species_by_name' gx%bmperr=4051 loksp=0 endif 1000 continue return end subroutine find_species_by_name !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine find_species_by_name_exact !\begin{verbatim} %- subroutine find_species_by_name_exact(name,isp) ! locates a species index from its name, exact match needed implicit none character name*(*) integer isp !\end{verbatim} %+ character symbol*24 integer loksp,lensym logical exact symbol=name call capson(symbol) isp=0 do loksp=1,noofsp ! write(*,*)'3A find species exact: ',symbol,splista(loksp)%symbol,loksp lensym=len_trim(splista(loksp)%symbol) if(symbol(1:lensym+1).eq.splista(loksp)%symbol(1:lensym+1)) then isp=splista(loksp)%alphaindex endif enddo if(isp.eq.0) then ! write(*,*)'in find_species_by_name' gx%bmperr=4051 loksp=0 endif 1000 continue return end subroutine find_species_by_name_exact !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine find_species_record !\begin{verbatim} %- subroutine find_species_record(name,loksp) ! locates a species record allowing abbreviations implicit none character name*(*) integer loksp !\end{verbatim} %+ character symbol*24 integer isp,lensp logical exact exact=.FALSE. symbol=name isp=0 call capson(symbol) do loksp=1,noofsp ! write(*,17)'3A find species: ',loksp,splista(loksp)%symbol,name 17 format(a,i3,' "',a,'" "',a,'"') if(compare_abbrev(symbol,splista(loksp)%symbol)) then if(isp.eq.0) then isp=loksp ! it would be enough to compare lengths of species ... lensp=len_trim(splista(loksp)%symbol) if(symbol(1:lensp+1).eq.splista(loksp)%symbol(1:lensp+1)) then ! write(*,*)'3A exact match' exact=.TRUE. goto 1000 endif else ! ambiguous species name but we may find an exact later ... isp=-1 endif endif enddo if(isp.le.0) then ! write(*,*)'Error in find_species_record "',name,'"' gx%bmperr=4051 loksp=0 else loksp=isp endif 1000 continue return end subroutine find_species_record !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine find_species_record_noabbr !\begin{verbatim} %- subroutine find_species_record_noabbr(name,loksp) ! locates a species record no abbreviations allowed implicit none character name*(*) integer loksp !\end{verbatim} %+ character symbol*24 symbol=name call capson(symbol) ! for MQMQA phases with final -Qij the "ij" is ignored ! and no check if the phase is MQMQA do loksp=1,noofsp ! write(*,17)'find species 17B: ',loksp,splista(loksp)%symbol,name !17 format(a,i3,' "',a,'" "',a,'"') if(symbol.eq.splista(loksp)%symbol) goto 1000 enddo ! write(*,*)'Error in find_species_record_noabbr "',name,'"' gx%bmperr=4051 loksp=0 1000 continue return end subroutine find_species_record_noabbr !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine find_species_record_exact !\begin{verbatim} %- subroutine find_species_record_exact(name,loksp) ! locates a species record, exact match needed ! for parameters, V must not be accepted as abbreviation of VA or C for CR implicit none integer loksp character name*(*) !\end{verbatim} integer quad character symbol*24 symbol=name call capson(symbol) ! special for quadrupoles ... they can have a trailing -Qij which may be ! different each time ... quad=index(symbol,'-Q') if(quad.gt.0) then quad=quad-1 else quad=0 endif do loksp=1,noofsp ! write(*,17)'find species 17: ',loksp,splista(loksp)%symbol,name !17 format(a,i3,' "',a,'" "',a,'"') if(quad.gt.0) then if(symbol(1:quad).eq.splista(loksp)%symbol(1:quad)) goto 1000 else ! problem that V was not read from database ... if(symbol.eq.splista(loksp)%symbol) goto 1000 endif enddo ! This message cannot be written as it is used when reading a TDB file ... ! write(kou,*)'Exact match to species name requited' gx%bmperr=4051 loksp=0 1000 continue return end subroutine find_species_record_exact !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine find_phasetuple_by_name !\begin{verbatim} subroutine find_phasetuple_by_name(name,phcsx) ! finds a phase with name "name", returns phase tuple index ! handles composition sets either with prefix/suffix or #digit ! When no pre/suffix nor # always return first composition set implicit none character name*(*) integer phcsx !\end{verbatim} %+ integer iph,ics iph=0 ics=0 phcsx=0 call find_phasex_by_name(name,phcsx,iph,ics) 1000 continue return end subroutine find_phasetuple_by_name !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine find_phase_by_name !\begin{verbatim} %- subroutine find_phase_by_name(name,iph,ics) ! finds a phase with name "name", returns address of phase, first fit accepted ! handles composition sets either with prefix/suffix or #digit ! When no pre/suffix nor # always return first composition set implicit none character name*(*) integer iph,ics !\end{verbatim} %+ integer phcsx phcsx=0 call find_phasex_by_name(name,phcsx,iph,ics) 1000 continue return end subroutine find_phase_by_name !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable integer function find_phasetuple_by_indices !\begin{verbatim} %- integer function find_phasetuple_by_indices(iph,ics) ! subroutine find_phasetuple_by_indices(iph,ics) ! find phase tuple index given phase index and composition set number integer iph,ics !\end{verbatim} %+ integer ij ij=iph if(ij.gt.0 .and. ij.le.nooftuples) then do while(ij.gt.0) if(ics.eq.phasetuple(ij)%compset) then find_phasetuple_by_indices=ij goto 1000 else ij=phasetuple(ij)%nextcs endif enddo endif write(*,*)'Wrong arguments to find_phasetuple_by_indices: ',iph,ics,ij gx%bmperr=4073 1000 continue return end function find_phasetuple_by_indices !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine find_phasex_by_name !\begin{verbatim} %- subroutine find_phasex_by_name(name,phcsx,iph,zcs) ! finds a phase with name "name", returns index and tuplet of phase. ! All phases checked and error return if name is ambiguous ! handles composition sets either with prefix/suffix or #digit or both ! if no # check all composition sets for prefix/suffix ! special if phcsx = -1 and there are several composition sets then ! zcs is set to -(number of composition sets). Used when changing status ! phcsx, iph and zcs are values to return! implicit none character name*(*) integer phcsx,iph,zcs !\end{verbatim} %+ character name1*36,csname*36,name2*24,name3*24,ambname*24 TYPE(gtp_phase_varres), pointer :: csrec integer kp,kcs,lokph,jcs,lokcs,first1,fcs,lcs,ics,lenam,allsets ! set ics to an illegal value ics=-1 allsets=phcsx ! convert to upper case locally name1=name call capson(name1) ambname=name1 ! composition set as #digit kp=index(name1,'#') if(kp.gt.0) then ics=ichar(name1(kp+1:kp+1))-ichar('0') ! negative ics should give error, 0 should be the same as 1 if(ics.eq.0) ics=1 if(ics.lt.1 .or. ics.gt.9) then gx%bmperr=4093; goto 1000 endif allsets=ics name1(kp:)=' ' kcs=ics else ics=1 kcs=0 endif ! write(*,17)trim(name),ics,kcs,kp,noofph 17 format('3A find_phase 3: ',a,2x,10i4) first1=0 loop1: do lokph=1,noofph if(kcs.eq.0) then ! no composition set specified explicitly, all sets must be checked fcs=2; lcs=phlista(lokph)%noofcs ! elseif(kcs.eq.1) then ! fcs=1; lcs=1 elseif(kcs.le.phlista(lokph)%noofcs) then ! we shoud check pre and suffix ... fcs=max(2,kcs); lcs=kcs else ! this phase does not have a composition set kcs cycle loop1 endif name2=phlista(lokph)%name if(kcs.le.1) then if(compare_abbrev(name1,name2)) then if(first1.eq.0) then first1=lokph if(len_trim(name1).eq.len_trim(name2)) then ! exact match, we already know there is a composition set ! write(*,*)'3A exact match',name1(1:len_trim(name1)),lokph goto 300 endif else ! another phase with same abbreviation, phase name is ambiguous write(kou,4121)trim(name1),trim(name2),trim(ambname) 4121 format('Phase abbreviation ambiguous: ',a,' and ',a,2x,a) gx%bmperr=4121 goto 1000 endif endif endif ! if composition set specified check only that set, otherwise all from 2 ! write(*,*)'3A first1: ',first1,fcs,lcs loop2: do jcs=fcs,lcs lokcs=phlista(lokph)%linktocs(jcs) csrec=>firsteq%phase_varres(lokcs) kp=len_trim(csrec%prefix) if(kp.gt.0) then csname=csrec%prefix(1:kp)//'_'//name2 else csname=name2 endif kp=len_trim(csrec%suffix) if(kp.gt.0) csname=csname(1:len_trim(csname))//'_'//& csrec%suffix(1:kp) ! write(*,244)ics,kcs,jcs,kp,fcs,lcs,first1,name1(1:len_trim(name1)),& ! csname(1:len_trim(csname)) 244 format('3A: find_phase: ',7i3,'<',a,'>=?=<',a,'>') if(compare_abbrev(name1,csname)) then if(first1.eq.lokph) then ! match already with first composition set, that is OK cycle loop2 elseif(first1.eq.0) then first1=lokph ics=jcs allsets=ics else ! ambiguous phase name write(kou,4121)1652,trim(name1),trim(csname) gx%bmperr=4121; goto 1000 endif elseif(kcs.gt.1) then ! No mach with phase name including pre/suffix but if user has specified # ! accept also match with original name without pre/suffix if(compare_abbrev(name1,name2)) then if(first1.eq.0) then first1=lokph ics=jcs else ! another phase with same abbreviation, phase name is ambiguous write(kou,4121)1664,trim(name1),trim(name2) gx%bmperr=4121 goto 1000 endif endif endif enddo loop2 enddo loop1 ! write(*,*)'3A first1: ',first1 if(first1.eq.0) then ! no phase found gx%bmperr=4050 goto 1000 endif 300 continue ! first1 is lokph for phase iph=phlista(first1)%alphaindex if(allsets.eq.-1) then ! special to set status: return -(number of composition sets) in zcs if >1 ! DO NOT CHANGE PHCSX lcs=phlista(first1)%noofcs if(lcs.gt.1) then ics=-lcs; zcs=-lcs else ics=1; zcs=1 endif else ! ics set above, return it in zcs zcs=ics phcsx=firsteq%phase_varres(phlista(first1)%linktocs(ics))%phtupx endif gx%bmperr=0 1000 continue return 1100 continue gx%bmperr=4073 goto 1000 END subroutine find_phasex_by_name !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine find_phase_by_name_exact !\begin{verbatim} %- subroutine find_phase_by_name_exact(name,iph,ics) ! finds a phase with name "name", returns address of phase. exact match req. ! handles composition sets either with prefix/suffix or #digit ! no pre/suffix nor # gives first composition set implicit none character name*(*) integer iph,ics !\end{verbatim} character name1*36,csname*36,name2*24 TYPE(gtp_phase_varres), pointer :: csrec integer kp,kcs,iphfound,lokph,jcs,lokcs ! convert to upper case locally name1=name call capson(name1) ! composition set as #digit kp=index(name1,'#') if(kp.gt.0) then ics=ichar(name1(kp+1:kp+1))-ichar('0') ! negative ics should give error, 0 should be the same as 1 if(ics.eq.0) ics=1 if(ics.lt.1 .or. ics.gt.9) then gx%bmperr=4093; goto 1000 endif name1(kp:)=' ' kcs=ics else ics=1 kcs=0 endif ! write(*,17)ics,kcs 17 format('find_phase 3: ',2i4) ! write(*,11)'fpbne 1: ',name,noofph 11 format(a,a,'; ',2i3) iphfound=0 loop1: do lokph=1,noofph name2=phlista(lokph)%name ! write(*,*)'find_phase 2: ',name1,name2 if(compare_abbrev(name1,name2)) then if(ics.le.phlista(lokph)%noofcs) then ! possible phase, if exact match no more checks if(trim(name1).eq.trim(name2)) then iphfound=lokph goto 300 endif if(iphfound.ne.0) then if(trim(name1).eq.trim(name2)) then iphfound=lokph goto 300 else iphfound=-lokph endif else iphfound=lokph endif else ! write(*,18)ics,phlista(lokph)%noofcs 18 format('find_phase 4: ',2i4) gx%bmperr=4072; goto 1000 endif endif enddo loop1 ! write(*,*)'find_phase ',iphfound if(iphfound.lt.0) then ! several phases found write(kou,4121)trim(name1),trim(name2) 4121 format('Several phases found: ',a,' and ',a) gx%bmperr=4121; goto 1000 elseif(iphfound.le.0) then ! no phase found gx%bmperr=4050; goto 1000 else lokph=iphfound goto 300 endif ! if there are composition sets check name including prefix/suffix write(*,*)'find_phase 5: ',lokph,phlista(lokph)%noofcs do jcs=2,phlista(lokph)%noofcs lokcs=phlista(lokph)%linktocs(jcs) csrec=>firsteq%phase_varres(lokcs) kp=len_trim(csrec%prefix) if(kp.gt.0) then csname=csrec%prefix(1:kp)//'_'//name2 else csname=name2 endif kp=len_trim(csrec%suffix) if(kp.gt.0) csname=csname(1:len_trim(csname))//'_'//& csrec%suffix(1:kp) if(compare_abbrev(name1,csname)) then ! if user has provided both # and pre/suffix these must be consistent if(kcs.gt.0 .and. kcs.ne.jcs) goto 1100 ics=jcs goto 300 endif enddo 250 continue ! no phase with this name gx%bmperr=4050 goto 1000 300 continue iph=phlista(lokph)%alphaindex gx%bmperr=0 1000 continue return 1100 continue ! composition set index and pre/suffix does not match gx%bmperr=4073 goto 1000 END subroutine find_phase_by_name_exact !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine find_constituent !\begin{verbatim} subroutine find_constituent(iph,spname,mass,icon) ! find the constituent "spname" of a phase. spname can have a sublattice #digit ! Return the index of the constituent in icon. Additionally the mass ! of the species is returned. implicit none character*(*) spname double precision mass integer iph,icon !\end{verbatim} ! BUG found, asking for a constituent N it returned the constituent NB !!! ! Must search for exact match!!! character spname1*24 integer lokph,kp,ll,kk,loksp,ls,first,jabbr lokph=phases(iph) kp=index(spname,'#') if(kp.gt.0) then ls=ichar(spname(kp+1:kp+1))-ichar('0') spname1=spname(1:kp-1) else ls=0 spname1=spname endif call capson(spname1) icon=0 jabbr=0 first=0 lloop: do ll=1,phlista(lokph)%noofsubl sploop: do kk=1,phlista(lokph)%nooffr(ll) icon=icon+1 if(ls.eq.0 .or. ls.eq.ll) then loksp=phlista(lokph)%constitlist(icon) ! constituent icon is the requested one ?? ! write(*,55)ll,kk,icon,trim(spname1),trim(splista(loksp)%symbol) 55 format('find_const 7: ',3i3,1x,a,2x,a) if(compare_abbrev(spname1,splista(loksp)%symbol)) then ! write(*,*)'3A abbreviation OK: ',trim(spname1),'?',& ! trim(splista(loksp)%symbol),icon if(trim(spname1).eq.trim(splista(loksp)%symbol)) then ! if exact match accept first=loksp; goto 90 elseif(first.eq.0) then ! constituent name is an abbreviation, if only one accept first=loksp jabbr=icon else write(kou,4121)trim(spname1),trim(splista(loksp)%symbol) 4121 format('Specie name abbreviation same ',a,' and ',a) gx%bmperr=4121 goto 1000 endif endif endif ! write(*,*)'3A current: ',icon,first,loksp enddo sploop enddo lloop 90 continue ! write(*,*)'3A current: ',icon,first,loksp,' "',trim(spname1),'"' if(first.eq.0) then ! no such constituent gx%bmperr=4096 else if(jabbr.gt.0) then ! accept unique abbreviation ! write(*,*)'3A abbreviation: ',icon,jabbr,loksp icon=jabbr endif mass=splista(first)%mass endif 1000 continue return end subroutine find_constituent !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine findconst !\begin{verbatim} subroutine findconst(lokph,ll,spix,constix) ! locates the constituent index of species with index spix in sublattice ll ! and returns it in constix. For wildcards spix is -99; return -99 ! THERE MAY ALREADY BE A SIMULAR SUBROUTINE ... CHECK implicit none integer lokph,ll,spix,constix !\end{verbatim} integer nc,l2,loksp if(spix.eq.-99) then constix=-99 goto 1000 endif nc=1 do l2=1,ll-1 ! The number of constituents in each sublattice can vary, add together nc=nc+phlista(lokph)%nooffr(l2) enddo constix=0 do l2=nc,nc+phlista(lokph)%nooffr(ll)-1 loksp=phlista(lokph)%constitlist(l2) if(splista(loksp)%alphaindex.eq.spix) then constix=l2; exit endif enddo if(constix.eq.0) then ! write(*,90)spix,nc 90 format('3B No such constituent with index ',i5,' in sublattice',i3) gx%bmperr=4066; goto 1000 endif 1000 continue return end subroutine findconst !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine findeq !\begin{verbatim} subroutine findeq(name,ieq) ! finds the equilibrium with name "name" and returns its index ! ieq should be the current equilibrium implicit none character name*(*) integer ieq !\end{verbatim} %+ character name2*64 integer jeq name2=name call capson(name2) ! Accept abbreviations of PREVIOUS and FIRST (DEFAULT is the same as the first) jeq=0 if(compare_abbrev(name2,'PREVIOUS ')) then jeq=max(1,ieq-1); goto 200 elseif(compare_abbrev(name2,'FIRST ')) then jeq=1; goto 200 elseif(compare_abbrev(name2,'DEFAULT ')) then jeq=1; goto 200 ! elseif(compare_abbrev(name2,'LAST ')) then ! jeq=1; goto 200 endif 100 jeq=jeq+1 ! write(*,*)'findeq 2: ',jeq,name2 if(jeq.ge.eqfree) then gx%bmperr=4124 goto 1000 endif ! write(*,*)'findeq 3: ',jeq,eqlista(jeq)%eqname if(.not.compare_abbrev(name2,eqlista(jeq)%eqname)) goto 100 ! if(eqlista(jeq)%eqname.ne.name2) goto 100 200 continue ieq=jeq 1000 continue end subroutine findeq !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine selecteq !\begin{verbatim} %- subroutine selecteq(ieq,ceq) ! checks if equilibrium ieq exists and if so set it as current implicit none TYPE(gtp_equilibrium_data), pointer :: ceq integer ieq !\end{verbatim} if(ieq.lt.0 .or. ieq.ge.eqfree) then gx%bmperr=4124 goto 1000 endif ceq=>eqlista(ieq) 1000 continue end subroutine selecteq !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !> 4. Section: get things !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_phase_record !\begin{verbatim} subroutine get_phase_record(iph,lokph) ! given phase index iph this returns the phase location lokph implicit none integer iph,lokph !\end{verbatim} %+ if(iph.lt.1 .or. iph.gt.noofph) then ! write(*,*)'gpr: ',iph,noofph gx%bmperr=4050 else lokph=phases(iph) endif return end subroutine get_phase_record !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_phase_variance !\begin{verbatim} %- subroutine get_phase_variance(iph,nv) ! returns the number of independent variable fractions in phase iph implicit none integer iph,nv !\end{verbatim} %+ integer lokph call get_phase_record(iph,lokph) nv=phlista(lokph)%tnooffr-phlista(lokph)%noofsubl return end subroutine get_phase_variance !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_constituent_location !\begin{verbatim} %- subroutine get_constituent_location(lokph,cno,loksp) ! returns the location of the species record of a constituent ! requred for ionic liquids as phlista is private implicit none integer lokph,loksp,cno !\end{verbatim} %+ loksp=phlista(lokph)%constitlist(cno) return end subroutine get_constituent_location !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_phase_compset !\begin{verbatim} %- subroutine get_phase_compset(iph,ics,lokph,lokcs) ! Given iph and ics the phase and composition set locations are returned ! Checks that ics and ics are not outside bounds. implicit none integer iph,ics,lokph,lokcs !\end{verbatim} %+ if(iph.le.0 .or. iph.gt.noofph) then gx%bmperr=4050; goto 1000 endif lokph=phases(iph) ! find composition set if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then gx%bmperr=4072; goto 1000 elseif(ics.eq.0) then ics=1 endif lokcs=phlista(lokph)%linktocs(ics) 1000 continue return end subroutine get_phase_compset !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_constituent_name !\begin{verbatim} %- subroutine get_constituent_name(iph,iseq,spname,mass) ! find the constituent with sequential index iseq in phase iph ! return name in "spname" and mass in mass implicit none character*(*) spname integer iph,iseq double precision mass !\end{verbatim} integer lokph,loksp if(iph.gt.0 .and. iph.le.noofph) then lokph=phases(iph) else gx%bmperr=4050 goto 1000 endif if(iseq.gt.0 .and. iseq.le.phlista(lokph)%tnooffr) then loksp=phlista(lokph)%constitlist(iseq) spname=splista(loksp)%symbol mass=splista(loksp)%mass else ! write(*,*)'No such constituent' gx%bmperr=4096 endif ! write(*,*)'3A get_constituent_name: ',iph,iseq,' "',trim(spname),'"' 1000 continue return end subroutine get_constituent_name !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_element_data !\begin{verbatim} subroutine get_element_data(iel,elsym,elname,refstat,mass,h298,s298) ! return element data as that is stored as private in GTP implicit none character elsym*2, elname*(*),refstat*(*) double precision mass,h298,s298 integer iel !\end{verbatim} integer lokel if(iel.le.noofel) then lokel=elements(iel) elsym=ellista(lokel)%symbol elname=ellista(lokel)%name refstat=ellista(lokel)%ref_state mass=ellista(lokel)%mass h298=ellista(lokel)%h298_h0 s298=ellista(lokel)%s298 else gx%bmperr=4042 endif end subroutine get_element_data !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine new_element_data !\begin{verbatim} subroutine new_element_data(iel,elsym,elname,refstat,mass,h298,s298) ! set new values in an element record, only mass allowed to change ... implicit none character elsym*2, elname*(*),refstat*(*) double precision mass,h298,s298 integer iel !\end{verbatim} integer lokel if(iel.gt.0 .and. iel.le.noofel) then lokel=elements(iel) ! ellista(lokel)%symbol=elsym ! ellista(lokel)%name)=elname ! ellista(lokel)%ref_state=refstate ellista(lokel)%mass=mass ! ellista(lokel)%h298_h0=h298 ! ellista(lokel)%s298=s298 else gx%bmperr=4042 endif end subroutine new_element_data !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_component_name !\begin{verbatim} subroutine get_component_name(icomp,name,ceq) ! return the name of component icomp implicit none character*(*) name integer icomp TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ if(icomp.gt.noofel) then gx%bmperr=4052 else ! strange error buperr set here when plotting q(phase) in step2.OCM ?? if(buperr.ne.0) then write(*,*)'3A buperr set entering get_component_name',buperr buperr=0 endif name=splista(ceq%complist(icomp)%splink)%symbol ! no reason buperr should be set here ! if(buperr.ne.0) then ! write(*,*)'3A gcn buperr: ',trim(name),buperr ! gx%bmperr=buperr ! endif endif 1000 continue return end subroutine get_component_name !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_species_name !\begin{verbatim} %- subroutine get_species_name(isp,spsym) ! return species name, isp is species number implicit none character spsym*(*) integer isp !\end{verbatim} %+ if(isp.le.0 .or. isp.gt.noofsp) then ! write(*,*)'in get_species_name' gx%bmperr=4051; goto 1000 endif ! loksp=species(isp) ! spsym=splista(loksp)%symbol spsym=splista(species(isp))%symbol 1000 return end subroutine get_species_name !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_species_location !\begin{verbatim} %- subroutine get_species_location(isp,loksp,spsym) ! return species location and name, isp is species number implicit none character spsym*(*) integer isp,loksp !\end{verbatim} if(isp.le.0 .or. isp.gt.noofsp) then ! write(*,*)'in get_species_name' gx%bmperr=4051; goto 1000 endif loksp=species(isp) spsym=splista(loksp)%symbol ! spsym=splista(species(isp))%symbol 1000 return end subroutine get_species_location !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_species_data !\begin{verbatim} subroutine get_species_data(loksp,nspel,ielno,stoi,smass,qsp,nextra,extra) ! return species data, loksp is from a call to find_species_record ! nspel: integer, number of elements in species ! ielno: integer array, element indices ! stoi: double array, stoichiometric factors ! smass: double, mass of species ! qsp: double, charge of the species ! nextra, integer, number of additional values ! extra: double, some additional values like UNIQUAC volume and area implicit none integer, dimension(*) :: ielno double precision, dimension(*) :: stoi,extra integer loksp,nspel,nextra double precision smass,qsp !\end{verbatim} %+ integer jl,iel if(loksp.le.0 .or. loksp.gt.noofsp) then ! write(*,*)'in get_species_data' gx%bmperr=4051; goto 1000 endif nspel=splista(loksp)%noofel elements: do jl=1,nspel iel=splista(loksp)%ellinks(jl) ielno(jl)=ellista(iel)%alphaindex stoi(jl)=splista(loksp)%stoichiometry(jl) enddo elements smass=splista(loksp)%mass qsp=splista(loksp)%charge ! extraproperties for UNIQUAC model (and maybe others) nextra=0 if(allocated(splista(loksp)%spextra)) then nextra=size(splista(loksp)%spextra) do jl=1,nextra extra(jl)=splista(loksp)%spextra(jl) enddo endif 1000 return end subroutine get_species_data !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_species_component_data !\begin{verbatim} %- subroutine get_species_component_data(loksp,nspel,compnos,stoi,smass,qsp,ceq) ! return species data, loksp is from a call to find_species_record ! Here we return stoichiometry using components ! nspel: integer, number of components in species ! compno: integer array, component (species) indices ! stoi: double array, stoichiometric factors ! smass: double, mass of species ! qsp: double, charge of the species implicit none integer, dimension(*) :: compnos double precision, dimension(*) :: stoi(*) integer loksp,nspel double precision smass,qsp TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer jl,iel,jk,ncomp,locomp,nspx integer, allocatable :: components(:) double precision, allocatable :: compstoi(:) ! this can be UNIQUAC parameters: area, volume double precision qextra(10) ! ! if the components are the elements then use get_species_data if(.not.btest(globaldata%status,GSNOTELCOMP)) then call get_species_data(loksp,nspel,compnos,stoi,smass,qsp,nspx,qextra) goto 1000 ! else ! write(*,11)globaldata%status,GSNOTELCOMP !11 format('3A using other components than elements',Z8,i4) endif allocate(components(noofel)) allocate(compstoi(noofel)) components=0 compstoi=zero if(loksp.le.0 .or. loksp.gt.noofsp) then ! write(*,*)'in get_species_data' gx%bmperr=4051; goto 1000 endif nspel=splista(loksp)%noofel elements: do jl=1,nspel ! splista(loksp)%ellinks is the location of the element record in ellista ! To find the element index in alphabetical order use the %alphaindex iel=ellista(splista(loksp)%ellinks(jl))%alphaindex ! ignore vacancies if(iel.le.0) cycle elements allcomp: do jk=1,noofel ! this is a loop for all components ! locomp is the species record of the component if(abs(ceq%invcompstoi(jk,iel)).gt.1.0D-12) then ! the stoichiometry of this component is nonzero for this element ! add to compstoi(jk) ! convert the element to components using the inverted stoichiometry matrix ! for example elements Ca O Si ! components CaO SiO2 O ! matrix components/elemenets Ca O Si ! CaO 1 1 0 ! SiO2 0 2 1 ! O 0 1 0 ! inverted matrix CaO SiO2 O ! Ca 1 0 -1 invmat(1,1) (2,1) (3,1) ! O 0 1 0 ! Si 0 1 -2 ! for Ca return 2 components, 1 * CaO -1 * O ! for SiO return 2 components 1*SiO -1 * O compstoi(jk)=compstoi(jk)+& splista(loksp)%stoichiometry(jl)*ceq%invcompstoi(jk,iel) qsp=splista(loksp)%charge endif enddo allcomp enddo elements ! return components with nonzero stoichiometry. ! Note stoichiometry can be negative ! There are always as many components as elements smass=zero nspel=0 reduce: do jk=1,noofel if(abs(compstoi(jk)).gt.1.0D-12) then nspel=nspel+1 compnos(nspel)=jk stoi(nspel)=compstoi(jk) smass=smass+stoi(nspel)*ceq%complist(jk)%mass ! maybe save species charge in the component record?? ! the lines below needed only if a component is charged !! hopefully never ... locomp=ceq%complist(jk)%splink qsp=qsp+stoi(nspel)*splista(locomp)%charge if(splista(locomp)%charge.ne.zero) then write(*,*)'3A charge: ',loksp,qsp,stoi(nspel),splista(locomp)%charge endif endif enddo reduce 1000 return end subroutine get_species_component_data !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !CCI !\addtotable subroutine get_stoichiometry !\begin{verbatim} subroutine get_stoichiometry(loksp, jl, el_name, stoi) ! Get the stoichiometric coefficient and the name of the jl-th element ! of the loksp-th species ! loksp: index of the species (input integer) ! el_name: name of the element (output character) ! stoi: value of the stoichiometric coefficient (output double precision) implicit none integer, intent(in):: loksp,jl double precision, intent(inout):: stoi character*(*), intent(inout) :: el_name !\end{verbatim} ! el_name=ellista(splista(loksp)%ellinks(jl))%name stoi=splista(loksp)%stoichiometry(jl) ! end subroutine get_stoichiometry !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine set_new_stoichiometry !\begin{verbatim} subroutine set_new_stoichiometry(loksp, new_stoi, ispel) ! provided by Clement Introini ! Change the stoichiometric coefficient of the ispel-th element of loksp-th ! species (the last one when ispel is not given) ! loksp: index of the species (input integer) ! new_stoi: new value of the stoichiometric coefficient (input double precision) ! ispel: index of the element (optional, input integer) implicit none integer, intent(in):: loksp integer, intent(in), optional :: ispel double precision, intent(in):: new_stoi !\end{verbatim} character el_name*12,spe_name*24 integer iel,jl,nspel double precision :: old_stoi ! number of elements in species nspel=splista(loksp)%noofel spe_name = trim(splista(loksp)%symbol) ! if( .not. present(ispel) ) then iel = nspel !change the stoichiometric coefficient of the last element old_stoi=splista(loksp)%stoichiometry(iel) splista(loksp)%stoichiometry(iel)=new_stoi else iel = ispel if (iel.gt.0) then ! Change the stoichiometric coefficient of the ispel-th element old_stoi=splista(loksp)%stoichiometry(iel) splista(loksp)%stoichiometry(iel)=new_stoi ! else ! nothing to be done end if end if el_name=ellista(splista(loksp)%ellinks(iel))%name ! if(ocv()) then ! write(*,*)"set_new_stoichiometry: (species,element,old_stoi,new_stoi)',& ! ' = (",spe_name,",",el_name,",",old_stoi,",",new_stoi,")" ! endif end subroutine set_new_stoichiometry !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable double precision function mass_of !\begin{verbatim} double precision function mass_of(component,ceq) ! return mass of component ! smass: double, mass of species implicit none integer :: component TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} if(component.le.0 .or. component.gt.noofel) then write(*,*)'Calling mass_of with illegal component number: ',component gx%bmperr=4251; goto 1000 endif ! return in kg mass_of=ceq%complist(component)%mass 1000 return end function mass_of !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_phase_name !\begin{verbatim} % subroutine get_phase_name(iph,ics,name) ! Given the phase index and composition set number this subroutine returns ! the name with pre- and suffix for composition sets added and also ! a \# followed by a digit 1-9 if there are more than one composition sets implicit none character name*(*) integer iph,ics !\end{verbatim} %+ character phname*36 integer lokph,lokcs,kp call get_phase_compset(iph,ics,lokph,lokcs) if(gx%bmperr.ne.0) goto 1000 if(ics.eq.1) then name=phlista(lokph)%name if(phlista(lokph)%noofcs.ge.2) then ! this was added 2020.04.02 because a call to change_many_phase_status ! using a phase name returned from this routine will suspend all compsets kp=len_trim(name)+1 name(kp:)='#1' endif else kp=len_trim(firsteq%phase_varres(lokcs)%prefix) if(kp.gt.0) then phname=firsteq%phase_varres(lokcs)%prefix(1:kp)//'_'//& phlista(lokph)%name else phname=phlista(lokph)%name endif kp=len_trim(firsteq%phase_varres(lokcs)%suffix) if(kp.gt.0) then phname(len_trim(phname)+1:)='_'//firsteq%phase_varres(lokcs)%suffix endif phname(len_trim(phname)+1:)='#'//char(ics+ichar('0')) name=phname endif 1000 continue return end subroutine get_phase_name !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_phasetup_name !\begin{verbatim} %- subroutine get_phasetup_name(phtupx,name) ! phasetuple(phtupx)%phase is index to phlista ! the name has pre- and suffix for composition sets added and also ! a \# followed by a digit 2-9 for composition sets higher than 1. implicit none character name*(*) integer phtupx !\end{verbatim} %+ integer phx,phy ! phx=phlista(phasetuple(phtupx)%phaseix)%alphaindex phx=phlista(phasetuple(phtupx)%lokph)%alphaindex call get_phase_name(phx,phasetuple(phtupx)%compset,name) 1000 continue return end subroutine get_phasetup_name !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_phasetuple_name !\begin{verbatim} %- subroutine get_phasetuple_name(phtuple,name) ! phtuple is a phase tuple ! the name has pre- and suffix for composition sets added and also ! a \# followed by a digit 2-9 for composition sets higher than 1. implicit none character name*(*) type(gtp_phasetuple) :: phtuple !\end{verbatim} %+ ! integer phx,phy call get_phase_name(phtuple%ixphase,phtuple%compset,name) 1000 continue return end subroutine get_phasetuple_name !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_phasetup_record !\begin{verbatim} %- subroutine get_phasetup_record(phtx,lokcs,ceq) ! return lokcs when phase tuple known implicit none integer phtx,lokcs TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} if(phtx.lt.1 .or. phtx.gt.nooftuples) then ! write(*,*)'Wrong tuple index',phtx gx%bmperr=4252; goto 1000 endif write(*,*)'Calling get_phasetup_record is redundant' stop ! lokcs=phlista(phasetuple(phtx)%phaseix)%linktocs(phasetuple(phtx)%compset) 1000 continue return end subroutine get_phasetup_record !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable integer function gettupix !\begin{verbatim} integer function gettupix(iph,ics) ! convert phase and compset index to tuple index implicit none integer iph,ics !\end{verbatim} integer ii,tupix ii=ics ! default tupix is phase index tupix=iph loop: do while(ii.gt.1) tupix=phasetuple(tupix)%nextcs if(tupix.le.0) then gx%bmperr=4072; exit loop endif ii=ii-1 enddo loop write(*,'(a,3i5)')'3X gettupix: ',iph,ics,tupix ! gettupix never assigned a value. Is it used?/BoS gettupix=tupix return end function gettupix !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\begin{verbatim} subroutine get_sublattice_number(iph,nsl,ceq) ! return the number of sublattices for phase iph ! nsl: integer, number of sublattices ! ceq: pointer, to current gtp_equilibrium_data record implicit none integer iph,nsl TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer lokph nsl = 1 if(iph.lt.1 .or. iph.gt.noofph) then gx%bmperr=4050; goto 1000 else lokph=phases(iph) endif nsl=phlista(lokph)%noofsubl 1000 continue return end subroutine get_sublattice_number !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\begin{verbatim} subroutine get_sublattice_structure(iph,ics,nsl,nkl,nsites,ceq) ! return the structure of the sublattices for phase iph (ics composition set) ! nsl: integer, number of sublattices ! nkl: integer array, number of constituents in each sublattice ! nsites: double array, number of sites in each sublattice ! ceq: pointer, to current gtp_equilibrium_data record implicit none integer, intent (in) :: iph,ics,nsl integer, dimension(nsl), intent (out) :: nkl !CCI double precision, dimension(nsl), intent (out) :: nsites !CCI TYPE(gtp_equilibrium_data), pointer :: ceq integer :: i, lokph,lokcs, ncs ! if(iph.lt.1 .or. iph.gt.noofph) then gx%bmperr=4050; goto 1000 else lokph=phases(iph) endif if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then gx%bmperr=4072; goto 1000 else ncs=max(ics,1) endif ! extra check if using saved equilibria which may have less composition sets lokcs=phlista(lokph)%linktocs(ncs) if(lokcs.le.0) then write(*,*)'Index of composition set missing, maybe using a saved equil.' gx%bmperr=4072 goto 1000 endif do i=1,nsl nkl(i)=phlista(lokph)%nooffr(i) nsites(i)=ceq%phase_varres(lokcs)%sites(i) enddo 1000 continue return end subroutine get_sublattice_structure !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_constituent_data !CCI (adding ncel) !\begin{verbatim} subroutine get_constituent_data(iph,ics,icons,yarr,charge,csname,ncel,ceq) !CCI ! return the constitution for phase iph (ics composition set) ! yarr: double, fraction of constituent ! charge: integer, charge of constituent ! ncel: integer, number of element in the constituant ! consname: name of the constituent ! ceq: pointer, to current gtp_equilibrium_data record implicit none integer, intent (in) :: iph,ics,icons double precision, intent (inout) :: yarr !CCI (adding ncel) integer, intent (inout) :: charge,ncel !CCI character*(*) , intent (inout) :: csname TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer :: i, lokph,lokcs,ncs,loksp,jl ! if(iph.lt.1 .or. iph.gt.noofph) then gx%bmperr=4050; goto 1000 else lokph=phases(iph) endif if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then gx%bmperr=4072; goto 1000 else ncs=max(ics,1) endif ! extra check if using saved equilibria which may have less composition sets lokcs=phlista(lokph)%linktocs(ncs) if(lokcs.le.0) then write(*,*)'Index of composition set missing, maybe using a saved equil.' gx%bmperr=4072 goto 1000 endif yarr=ceq%phase_varres(lokcs)%yfr(icons) loksp=phlista(lokph)%constitlist(icons) csname=splista(loksp)%symbol if(loksp.gt.0) then charge = splista(loksp)%charge else charge=0.D0 endif !CCI (adding ncel) ncel = splista(loksp)%noofel !CCI 1000 continue return end subroutine get_constituent_data !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_phase_data !\begin{verbatim} subroutine get_phase_data(iph,ics,nsl,nkl,knr,yarr,sites,qq,ceq) ! return the structure of phase iph and constituntion of comp.set ics ! nsl: integer, number of sublattices ! nkl: integer array, number of constituents in each sublattice ! knr: integer array, species location (not index) of constituents (all subl) ! yarr: double array, fraction of constituents (in all sublattices) ! sites: double array, number of sites in each sublattice ! qq: double array, (must be dimensioned at least 5) although only 2 used: ! qq(1) is number of real atoms per formula unit for current constitution ! qq(2) is net charge of phase for current constitution ! ceq: pointer, to current gtp_equilibrium_data record implicit none integer, dimension(*) :: nkl,knr double precision, dimension(*) :: yarr,sites,qq integer iph,ics,nsl TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer lokph,lokcs,kkk,ll,jj,loksp double precision vsum,qsum,ql,vl,yz ! if(iph.lt.1 .or. iph.gt.noofph) then gx%bmperr=4050; goto 1000 else lokph=phases(iph) endif ! if(gtpdebug.ne.0) write(*,*)'3A get_phase_data 1: ',iph,ics,lokph nsl=phlista(lokph)%noofsubl if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then gx%bmperr=4072; goto 1000 elseif(ics.eq.0) then ics=1 endif ! extra check if using saved equilibria which may have less composition sets lokcs=phlista(lokph)%linktocs(ics) if(lokcs.le.0) then write(*,*)'Index of composition set missing, maybe using a saved equil.' gx%bmperr=4072 goto 1000 endif ! if(gtpdebug.ne.0) write(*,*)'3A get_phase_data 10: ',lokcs ! lokcs=phlista(lokph)%cslink ! jcs=ics-1 ! do while(jcs.gt.0) ! lokcs=ceq%phase_varres(lokcs)%next ! if(lokcs.le.0) then ! write(*,*)'get_phase_data error 4072' ! gx%bmperr=4072; goto 1000 ! endif ! jcs=jcs-1 ! enddo ! >>>>> get_phase_data missing: for ionic liquid sites vary with composition vsum=zero qsum=zero kkk=0 if(.not.btest(ceq%phase_varres(lokcs)%status2,CSCONSUS)) then ! CSCONSUS set if a constituent is suspended ... not implemented yet ! if(gtpdebug.ne.0) write(*,*)'3A get_phase_data 20: ',lokph,nsl sublat: do ll=1,nsl nkl(ll)=phlista(lokph)%nooffr(ll) ! if(gtpdebug.ne.0) then ! write(*,*)'3A get_phase_data 21: ',lokcs,ll,nkl(ll),& ! allocated(ceq%phase_varres(lokcs)%sites),& ! size(ceq%phase_varres(lokcs)%sites) ! endif if(.not.allocated(ceq%phase_varres(lokcs)%sites)) then ! This can happen for plotting when different dynamic ceq ! have different number of composition sets write(*,777)trim(phlista(lokph)%name),ics 777 format('3A site array for phase: ',a,' set ',i2,' not allocated') gx%bmperr=4399; goto 1000 endif ! we get strange error "index 1 or array ceq above bound of 0" if(size(ceq%phase_varres(lokcs)%sites).lt.1) then ! write(*,*)'Strange error when step: ',iph,ics,lokcs,ll gx%bmperr=4253; goto 1000 endif ! write(*,17)'3 A Strange error: ',iph,ics,lokcs,ll,& ! size(ceq%phase_varres(lokcs)%sites) ! another strange error "below lower bound of 4 ..." ! I do not now how to check for a lower boundary ... 17 format(a,10i6) sites(ll)=ceq%phase_varres(lokcs)%sites(ll) ! if(gtpdebug.ne.0) write(*,*)'3A get_phase_data 25: ',sites(ll) ql=zero vl=zero ! if(gtpdebug.ne.0) write(*,*)'3A get_phase_data 30: ',& ! ll,nkl(ll),sites(ll) const: do jj=1,nkl(ll) kkk=kkk+1 loksp=phlista(lokph)%constitlist(kkk) knr(kkk)=loksp yz=ceq%phase_varres(lokcs)%yfr(kkk) yarr(kkk)=yz if(loksp.gt.0) then ! loksp is -99 for wildcards. ionic liquid can have that in first sublattice ql=ql+yz*splista(loksp)%charge if(btest(splista(loksp)%status,SPVA)) then vl=yz endif endif enddo const vsum=vsum+sites(ll)*(one-vl) qsum=qsum+sites(ll)*ql enddo sublat ! if(gtpdebug.ne.0) write(*,*)'3A get_phase_data 40: ',vsum qq(1)=vsum qq(2)=qsum ! write(*,*)'get_phase_data: ',qq(1),qq(2) else ! >>>> unfinished handle the case with suspended constituents ! write(*,*)'get_phase_data with suspended constituents not implemented' gx%bmperr=4080; goto 1000 endif ! 1000 continue ! if(gtpdebug.ne.0) write(*,*)'3A get_phase_data exit: ',iph,ics return end subroutine get_phase_data !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_phase_structure !\begin{verbatim} %- subroutine get_phase_structure(lokph,nsl,nkl) ! return the number of sblattices and constituents in each. ! nsl: integer, number of sublattices ! nkl: integer array, number of constituents in each sublattice ! USED when calculating derivatives of chemical potentials and diffusion coef implicit none integer, dimension(*) :: nkl integer lokph,nsl !\end{verbatim} integer ii if(lokph.le.0 .or. lokph.gt.noofph) then ! write(*,*)'You are way off your head' gx%bmperr=4050; goto 1000 endif nsl=phlista(lokph)%noofsubl do ii=1,nsl nkl(ii)=phlista(lokph)%nooffr(ii) enddo 1000 continue return end subroutine get_phase_structure !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable integer function get_phtuplearray !\begin{verbatim} integer function get_phtuplearray(phcs) ! copies the internal phase tuple array to external software ! function value set to number of tuples type(gtp_phasetuple), dimension(*) :: phcs !\end{verbatim} %+ integer iz do iz=1,nooftuples ! phasetuple(iz)%phase is lokph!!! .... probably never used ... phcs(iz)=phasetuple(iz) ! phcs(iz)%phase=phasetuple(iz)%phase ! phcs(iz)%compset=phasetuple(iz)%compset enddo 1000 continue get_phtuplearray=nooftuples return end function get_phtuplearray !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !> 5. Set things !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine set_constitution !\begin{verbatim} subroutine set_constitution(iph,ics,yfra,qq,ceq) ! set the constituent fractions of a phase and composition set and the ! number of real moles and mass per formula unit of phase ! returns number of real atoms in qq(1), charge in qq(2) and mass in qq(3) ! for ionic liquids sets the number of sites in the sublattices implicit none double precision, dimension(*) :: yfra,qq integer iph,ics TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer lokph,lokcs,ll,ml,ic,loksp,jl,locva,zl,zel double precision charge,spat,asite,bsite,badd,yz,yva,sumat,asum,bsum,csum ! double precision charge1,bion1,ionsites(2) double precision charge1,bion1,compsum,comp1 ! The mass is not calculated correctly in version 2, attempt to fix double precision bliq1 type(gtp_phase_varres), pointer :: phres ! This is needed if we have other components than the elements double precision, allocatable :: compam(:),elam(:),iliqcats(:) ! TYPE(gtp_fraction_set), pointer :: disrec logical ionicliq ! write(*,*)'3A In set_constitution ...',ceq%eqno,iph,ics if(iph.le.0 .or. iph.gt.noofph) then gx%bmperr=4050; goto 1000 endif lokph=phases(iph) if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then gx%bmperr=4072; goto 1000 elseif(ics.eq.0) then ics=1 endif lokcs=phlista(lokph)%linktocs(ics) ! write(*,*)'3A segmentation fault 1',iph,ics,lokcs ionicliq=btest(phlista(lokph)%status1,PHIONLIQ) if(ionicliq) then ! default values of i2slx phlista(lokph)%i2slx(1)=phlista(lokph)%tnooffr+1 phlista(lokph)%i2slx(2)=phlista(lokph)%tnooffr+1 yva=zero locva=0 endif !---- if(btest(globaldata%status,GSNOTELCOMP)) then allocate(elam(noofel)) allocate(compam(noofel)) elam=zero compam=zero if(ionicliq) then ! we must save the amounts on sublattice 1 as we do not know the sites allocate(iliqcats(noofel)) iliqcats=zero endif endif ! write(*,*)'3A segmentation fault 10',lokcs if(ocv()) write(*,8)'3Ay:',iph,ics,& (yfra(ic),ic=1,phlista(lokph)%tnooffr) 8 format(a,2i2,6(1pe11.3)) nosuscon: if(btest(ceq%phase_varres(lokcs)%status2,CSCONSUS)) then ! >>>> unfinished: handle the case when some constituents are suspended ! write(*,*)'set_constitution with suspended constituents not implemented' write(*,*)'suspended const in: ',lokph,lokcs gx%bmperr=4080; goto 1000 else ! no suspended constituents ! As the application program may have errors first make sure than ! the constituents fractions are correct: ! - no negative fractions ! - sum of fractions in each sublattice unity ! if(ocv()) write(*,*)'3A 2: ',ionicliq ic=0 ! write(*,*)'3A segmentation fault 30',phlista(lokph)%noofsubl do ll=1,phlista(lokph)%noofsubl ! write(*,*)'3A sumy 2: ',ll,ic,phlista(lokph)%noofsubl asite=zero do ml=1,phlista(lokph)%nooffr(ll) yz=yfra(ic+ml) if(yz.lt.bmpymin) yz=bmpymin ceq%phase_varres(lokcs)%yfr(ic+ml)=yz asite=asite+yz enddo ! make sure sum of fractions is unity in each sublattice do ml=1,phlista(lokph)%nooffr(ll) ceq%phase_varres(lokcs)%yfr(ic+ml)=& ceq%phase_varres(lokcs)%yfr(ic+ml)/asite enddo ! write(*,13)'3A y: ',ll,ic,asite,bmpymin,& ! (ceq%phase_varres(lokcs)%yfr(ic+ml),& ! ml=1,phlista(lokph)%nooffr(ll)) 13 format(a,2i2,2(1pe12.4),1x,4(1pe12.4)) ic=ic+phlista(lokph)%nooffr(ll) enddo !-------- ll=1; ml=0; asum=zero; bsum=zero; csum=zero; charge=zero ! write(*,*)'3A segmentation fault 40' if(ionicliq) then ! For ionic liquid we do not know the number of sites asite=one bion1=zero else asite=ceq%phase_varres(lokcs)%sites(ll) endif ! what is bsite used for??? bsite=asite; badd=zero spat=zero allcon: do ic=1,phlista(lokph)%tnooffr yz=ceq%phase_varres(lokcs)%yfr(ic) ! if(ocv()) write(*,*)'3A 3: ',ic,yz notva: if(btest(ceq%phase_varres(lokcs)%constat(ic),CONVA)) then ! the constituent is the vacancy ! i2slx(1) should be set to the index of vacancies (if any) if(ionicliq) phlista(lokph)%i2slx(1)=ic locva=ic yva=yz else ! sum charge and for constituents with several atoms spat sum number of atoms loksp=phlista(lokph)%constitlist(ic) charge=charge+bsite*yz*splista(loksp)%charge ! derivates of sites for ionic liquid model ! if(ocv()) write(*,*)'3A 4: ',loksp,charge if(ionicliq) then ceq%phase_varres(lokcs)%dpqdy(ic)=abs(splista(loksp)%charge) ! if(ocv()) write(*,*)'3A dpqdy: ',& ! ic,abs(splista(loksp)%charge) ! i2slx(2) should be set to the index of the first neutral (if any) if(splista(loksp)%charge.eq.zero .and.& phlista(lokph)%i2slx(2).gt.ic) & phlista(lokph)%i2slx(2)=ic endif ! add the mass of the constituents badd=badd+bsite*yz*splista(loksp)%mass ! write(*,56)'3A badd: ',iph,loksp,splista(loksp)%mass,yz,bsite,badd 56 format(a,2i3,6(1pe12.4)) sumat=zero ! This is summing atoms per formula unit of the phase do jl=1,splista(loksp)%noofel sumat=sumat+splista(loksp)%stoichiometry(jl) enddo !-------------------------------------------------------------- if(btest(globaldata%status,GSNOTELCOMP)) then ! When there are other components than the elements we must sum the number ! of each atom, not just the total. elam was alloctated and zeroed above do jl=1,splista(loksp)%noofel ! NOTE that the ellinks specify the location, not alphabetically!! ! we must use %alphaindex to have the alphabetical index of the element ?? YES zel=ellista(splista(loksp)%ellinks(jl))%alphaindex ! FOR IONIC LIQUID MODEL asite is unity and must be updatated below!! elam(zel)=elam(zel)+yz*splista(loksp)%stoichiometry(jl)*asite ! write(*,14)'3A elam: ',zel,yz,& ! splista(loksp)%stoichiometry(jl),(elam(zl),zl=1,noofel),& ! trim(splista(loksp)%symbol) !14 format(a,i2,5(1pe11.3),2x,a) enddo ! write(*,*)'3A NOTELCOMP: ',compsum,trim(splista(loksp)%symbol) ! csum=csum+yz*compsum endif spat=spat+yz*sumat ! check sum number of atoms for ionic liquid ! if(sumat.gt.1) then ! write(*,7)'spat: ',lokph,splista(loksp)%noofel,sumat,yz,spat !7 format(a,2i3,3F10.4) ! endif ! write(*,11)loksp,yz,splista(loksp)%mass,badd,bsum 11 format('set_const 3: ',i3,4(1PE15.7)) endif notva ! ml is constituent number in this sublattice, ic for all sublattices ml=ml+1 ! if(ocv()) write(*,*)'3A 5: ',ml newsubl: if(ml.ge.phlista(lokph)%nooffr(ll)) then ! next sublattice ionliq: if(ionicliq) then ! for ioniq liquids the number of sites is the charge on opposite sublattice if(ll.eq.1) then ! Q=\sum_i v_i y_i = charge ! write(*,88)'ionliq: ',ll,badd,bion1 88 format(a,i3,6(1pe12.4)) ceq%phase_varres(lokcs)%sites(2)=charge ! write(*,*)'Ionic 2: ',ceq%phase_varres(lokcs)%sites(2) ! bsite=one charge1=charge charge=zero ! same the mass of the constituents on first sublattice bliq1=badd badd=zero ! initiate vacancy and neutral indices beyond last index (already done??) phlista(lokph)%i2slx=phlista(lokph)%tnooffr+1 if(btest(globaldata%status,GSNOTELCOMP)) then iliqcats=elam elam=zero endif elseif(ll.eq.2) then ! P=\sum_j (-v_j)y_j + Qy_Va. Note charge is total charge and valences ! on 2nd sublattice is negative ! Now we know number of sites on sublattice 1, update asum and bsum ! Cryptic programming ... sumat is here set to sites on first sublattice sumat=-charge+charge1*yva ceq%phase_varres(lokcs)%sites(1)=sumat ! write(*,*)'Ionic 1: ',ceq%phase_varres(lokcs)%sites(1) asum=asum*sumat bsum=bion1*sumat charge=zero if(btest(globaldata%status,GSNOTELCOMP)) then elam=elam+sumat*iliqcats endif ! write(*,88)'3A iliq: ',ll,badd,bion1,bsum,sumat,yva ! new way to calculate mass of ionic liquid bsum=sumat*bliq1+ceq%phase_varres(lokcs)%sites(2)*badd ! write(*,66)'3A ilmass: ',ll,ceq%phase_varres(lokcs)%sites,& ! bliq1,badd,bsum 66 format(a,i3,6(1pe12.4)) badd=zero else ! write(*,*)'Ionic liquid must have two sublattices',ll gx%bmperr=4255; goto 1000 endif endif ionliq ! note: for ionic liquid previous values of asum and bsum are updated ! when fractions in sublattice 2 have been set asum=asum+asite*spat bsum=bsum+badd ! write(*,33)'3A g:',lokcs,ll,asum,asite,spat 33 format(a,2i2,6(1pe12.4)) ! write(*,39)'set_con: ',ll,ml,asum,asite,spat !39 format(a,2i5,3(1pe12.4)) ! write(*,12)'set_const 12: ',ll,asum,asite,bsum,badd !12 format(a,i3,4(1pe12.4)) if(ll.lt.phlista(lokph)%noofsubl) then ll=ll+1; ml=0 ! asite=phlista(lokph)%sites(ll); spat=zero asite=ceq%phase_varres(lokcs)%sites(ll) spat=zero; bion1=badd; badd=zero ! if ionic liquid bsite must be 1.0 when summing second sublattice. Why??? if(.not.ionicliq) bsite=asite endif endif newsubl enddo allcon ! write(*,33)'3A h:',lokcs,ll,asum,asite,spat endif nosuscon ! write(*,*)'3A NO segmentation fault 100' ! save charge, number of moles and mass of real atoms per formula unit ! write(*,33)'3A isum:',lokcs,0,charge,asum,bsum,asite,spat ceq%phase_varres(lokcs)%netcharge=charge ceq%phase_varres(lokcs)%abnorm(2)=bsum if(btest(globaldata%status,GSNOTELCOMP)) then ! Now we can convert the amount of atoms to amount of components ! use ceq%invcompstoi to convert to components ! write(*,279)'3A elsm: ',iph,asum,(elam(zl),zl=1,noofel) 279 format(a,i3,6(1pe12.4)) csum=zero do zl=1,noofel comp1=zero ! write(*,278)'3A inv: ',(ceq%invcompstoi(zl,zel),zel=1,noofel) 278 format(a,6(1pe12.4)) do zel=1,noofel comp1=comp1+ceq%invcompstoi(zl,zel)*elam(zel) enddo compam(zl)=comp1 csum=csum+compam(zl) enddo ! write(*,*)'3A segmentation fault 200' ! write(*,277)'3A cpam: ',iph,csum,(compam(zl),zl=1,noofel) 277 format(a,i3,6(1pe12.4)) ! abnorm(3) is the number of moles of user defined components ! write(*,299)'3A comp/FU: ',iph,ics,asum,csum 299 format(a,2i3,4(1pe12.4)) ceq%phase_varres(lokcs)%abnorm(1)=csum ceq%phase_varres(lokcs)%abnorm(3)=asum else ! if elements are constituents then set abnorm(3)=abnorm(1) ceq%phase_varres(lokcs)%abnorm(1)=asum ceq%phase_varres(lokcs)%abnorm(3)=asum endif ! write(*,*)'3A sety: ',lokcs,ceq%phase_varres(lokcs)%abnorm(1) if(ionicliq .and. locva.gt.0) then ! the ionic liquid vacancy charge is the number of sites on second subl. ceq%phase_varres(lokcs)%dpqdy(locva)=ceq%phase_varres(lokcs)%sites(2) ! if(ocv()) write(*,*)'3A dpqdy(va): ',& ! locva,ceq%phase_varres(lokcs)%sites(2) endif ! if(ionicliq) then ! write(*,301)'3A xsc:',lokcs,asum,bsum,ceq%phase_varres(lokcs)%sites,& ! charge1 !301 format(a,i3,6(1pe12.4)) ! write(*,301)'3A y: ',ic,ceq%phase_varres(lokcs)%yfr ! endif ! write(*,*)'3A NO segmentation fault 300' qq(1)=asum qq(2)=charge qq(3)=bsum ! write(*,*)'3A segmentation fault 301' ! set disordered fractions if any if(btest(phlista(lokph)%status1,phmfs)) then !now set disordered fractions if any ! write(*,*)'3A call calc_disfrac for: ',lokph,lokcs call calc_disfrac(lokph,lokcs,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'3A segmentation fault 311',lokph,lokcs endif 314 format(a,8F8.3) ! added for the new MQMQA asymmetrical excess ! we must copy yfra to quad fractions and calculate some internal variables ! this routine is in gtp3XQ ! write(*,*)'Testing PHMQMQX bit' if(btest(phlista(lokph)%status1,PHMQMQX)) then if(mqmqa_data%exlevel.lt.100) mqmqa_data%exlevel=100 if(mqmqxcess) write(*,*)'3A This phase has PHMQMQX set,',& ' calling set_quadfractions',lokcs phres=>ceq%phase_varres(lokcs) ! the second argument means to list call set_quadfractions(phres,mqmqxcess,yfra) endif 1000 continue ! write(*,*)'3A no segmentation fault at exit' ! if(ionicliq) write(*,*)'3A s_c: ',phlista(lokph)%i2slx return end subroutine set_constitution !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine set_reference_state !\begin{verbatim} subroutine set_reference_state(icomp,iph,tpval,ceq) ! set the reference state of a component to be "iph" at tpval implicit none integer icomp,iph double precision, dimension(2) :: tpval TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} ! NOTE if elements have mixed reference state EQMIXED is set and SER used ! That applies to integral properties like G, S but not MU or AC integer nsl,nkl(maxsubl),knr(maxconst),splink,j1,ie,elink integer ll,jj,nrel,lokph,noendm,jerr,lokres,ny,endmemx,endmemxy,ics double precision sites(maxsubl),qq(5),yarrsave(maxconst),xsum,gmin,gval double precision, dimension(:), allocatable :: yarr,xcomp,xmol integer, dimension(:), allocatable :: maxjj,jend,jendsave double precision tpsave(2),molat,saveg(6) ! iph negative means remove current reference state if(iph.lt.0) then if(allocated(ceq%complist(icomp)%endmember)) then ! I do not understand the code here any longer but this gave error ! as unallocated when I tried to ser reference state back to SER deallocate(ceq%complist(icomp)%endmember) ! else ! write(*,4)icomp,ceq%complist(icomp)%phlink !4 format('3A This component has no previous reference state: ',2i4) endif ceq%complist(icomp)%phlink=0 ceq%complist(icomp)%tpref=zero ceq%complist(icomp)%refstate='SER (default)' goto 1000 endif ! calculate the composition of the component in mole fractions nrel=noel() allocate(xcomp(nrel)) splink=ceq%complist(icomp)%splink xcomp=zero xsum=zero do j1=1,splista(splink)%noofel elink=splista(splink)%ellinks(j1) ie=ellista(elink)%alphaindex xcomp(ie)=splista(splink)%stoichiometry(j1) xsum=xsum+xcomp(ie) enddo ! write(*,17)'3A srs x1: ',iph,xsum,(xcomp(ie),ie=1,nrel) ! do ie=1,splista(splink)%noofel changed 190710/BoS do ie=1,nrel xcomp(ie)=xcomp(ie)/xsum enddo ! write(*,17)'3A srs x2: ',iph,xsum,(xcomp(ie),ie=1,nrel) 17 format(a,i3,15(f5.2)) ! find suitable endmember with correct composition and lowest G ! Note that lowest G is calculated at current T, may be different at another T ! WE CAN HAVE SEVERAL SUBLATTICES ... call get_phase_data(iph,1,nsl,nkl,knr,yarrsave,sites,qq,ceq) if(gx%bmperr.ne.0) goto 1000 allocate(maxjj(0:nsl)) allocate(jend(1:nsl)) allocate(jendsave(1:nsl)) ! generate all endmembers, maybe there is a better way ... ! and set unity fraction in yarr and check composition ny=0 maxjj(0)=1 do ll=1,nsl ny=ny+nkl(ll) maxjj(ll)=ny enddo allocate(yarr(ny)) yarr=zero jj=1 do ll=1,nsl yarr(jj)=one jend(ll)=jj jj=jj+nkl(ll) enddo allocate(xmol(nrel)) ! lokph=phases(iph) ! we must save the gval for lokres (composition set 1) ics=1 call get_phase_compset(iph,ics,lokph,lokres) if(gx%bmperr.ne.0) goto 1000 gmin=1.0D5 noendm=0 tpsave=ceq%tpval if(tpval(1).gt.zero) then ! negative tpval means current temperature, else use tpval(1) ceq%tpval(1)=tpval(1) endif ! write(*,*)'3A tp: ',tpval(1),ceq%tpval(1) ceq%tpval(2)=tpval(2) do ie=1,6 saveg(ie)=ceq%phase_varres(lokres)%gval(ie,1) enddo ! write(*,912)'3G Saved G: ',lokres,ceq%phase_varres(lokres)%gval(1,1),& ! saveg(1) !---------------------------------------------- ! return here for each endmember endmemx=0 200 continue ! write(*,*)'3G endm: ',(jend(jj),jj=1,nsl) ! write(*,17)'3G srs y: ',iph,(yarr(jj),jj=1,ny) call set_constitution(iph,1,yarr,qq,ceq) if(gx%bmperr.ne.0) goto 900 ! this subroutine converts site fractions in phase iph, compset 1 ! to mole fractions of components (or elements ??? ) endmemx=endmemx+1 call calc_phase_mol(iph,xmol,ceq) if(gx%bmperr.ne.0) goto 900 ! write(*,202)'3A srs xem: ',iph,endmemx,(xmol(ie),ie=1,nrel) 202 format(a,2i4,15(F5.2)) do jj=1,nrel if(abs(xmol(jj)-xcomp(jj)).gt.1.0D-12) goto 250 enddo !-------------------------------------------------- ! we have an endmember with the correct composition call calcg(iph,1,0,lokres,ceq) if(gx%bmperr.ne.0) goto 900 gval=ceq%phase_varres(lokres)%gval(1,1)/qq(1) ! write(*,222)'3A srs gval: ',iph,qq(1),gval,gmin,ceq%tpval(1) 222 format(a,i3,F10.3,3(1pe12.4)) if(gval.lt.gmin) then ! we should check if electrically neutral ?? noendm=noendm+1 gmin=gval jendsave=jend molat=qq(1) endmemxy=endmemx ! write(*,229)'3G min: ',gmin,jendsave 229 format(a,1pe12.4,10i4) endif 250 continue ! change constitution .... quit when all endmembers done ll=nsl ! should this always be 0? maxjj(0)=0 260 continue ! jend is the current endmember jj=jend(ll) yarr(jj)=zero jj=jj+1 if(jj.gt.maxjj(ll)) then jend(ll)=maxjj(ll-1)+1 yarr(jend(ll))=one ll=ll-1 ! if ll becomes zero here all endmemebrs have been generated (?) if(ll.ge.1) goto 260 else jend(ll)=jj yarr(jj)=one goto 200 endif !---------------------------------------------- if(noendm.eq.0) then ! if no endmember found this phase cannot be reference phase ! write(*,*)'This phase cannot be reference state for for this component' gx%bmperr=4256; goto 900 endif !----------------------------------------------- ! Now we store the reference state and set some bits ! mark that conditions and equilibrium may not be consistent ceq%status=ibset(ceq%status,EQINCON) ! endmemx and endmemxy redundant ! write(*,808)'3G reference state endmember',lokph,endmemxy,jendsave 808 format(a,i3,2x,10i3) ! If all OK then save phase location, endmember array, T and P ceq%complist(icomp)%phlink=lokph if(.not.allocated(ceq%complist(icomp)%endmember)) then ! if the user changes reference state do not allocate again ! write(*,*)'3A Allocating endmember for this reference state' allocate(ceq%complist(icomp)%endmember(nsl)) endif ! write(*,*)'3A refendm: ',icomp,size(ceq%complist),noofel ceq%complist(icomp)%endmember=jendsave ! allocate(ceq%complist(icomp)%endmember(1)) ! ceq%complist(icomp)%endmember=endmemxy ! molat is probably redundant as calcg_endmember returns for one mole component ceq%complist(icomp)%molat=molat ! Note tpval(1) can be negative indicating current T ceq%complist(icomp)%tpref=tpval ceq%complist(icomp)%refstate=phlista(lokph)%name ! NEW 2019.12.02 unless all elements have the same phase and T as reference ! we must set the EQMIXED bit in the CEQ record to enforce use of SER ! for integral properties like G, H etc. Element specific MU etc not affected allel: do ie=1,noofel if(ceq%complist(ie)%refstate.ne.ceq%complist(icomp)%refstate) exit allel if(ceq%complist(ie)%tpref(1).ne.ceq%complist(icomp)%tpref(1)) exit allel if(ceq%complist(ie)%tpref(2).ne.ceq%complist(icomp)%tpref(2)) exit allel ! write(*,*)'3A mixed: ',ie,ceq%complist(ie)%tpref,& ! ceq%complist(ie)%refstate enddo allel ! if loop finishes without exit then ie=noofel+1 (Fortran standard) ! and all elements have the same reference state if(ie.le.noofel) then ! different phase or T in the elements ! write(*,*)'3A setting mixed bit' ceq%status=ibset(ceq%status,EQMIXED) else ! all elements have the same reference phase and T ! write(*,*)'3A clearing mixed bit' ceq%status=ibclr(ceq%status,EQMIXED) endif !------------------------------------------------------- ! restore original constitution of compset 1 ! write(*,*)'3A gval: ',gval 900 continue ceq%tpval=tpsave jerr=gx%bmperr; gx%bmperr=0 call set_constitution(iph,1,yarrsave,qq,ceq) if(jerr.ne.0) then gx%bmperr=jerr endif ! restore original values of G and derivatives do ie=1,6 ceq%phase_varres(lokres)%gval(ie,1)=saveg(ie) enddo ! write(*,912)'3G Restored G: ',lokres,ceq%phase_varres(lokres)%gval(1,1),& ! saveg(1) 912 format(a,i5,6(1pe12.4)) 1000 continue return end subroutine set_reference_state !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine amend_components !\begin{verbatim} subroutine amend_components(line,ceq) ! amend the set of components implicit none character line*(*) type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer c1,c2,c3,i1,i2,nspel,ierr,lokph,lokcs,nspx integer, allocatable :: ielno(:),loksp(:) double precision, allocatable :: stoi(:),smass(:),yarr(:) double precision qsp,spextra(10),qq(5) double precision, allocatable :: matrix(:,:),imat(:,:) character name*24 type(gtp_condition), pointer :: pcond,qcond,last type(gtp_equilibrium_data), pointer :: curceq ! allocate(loksp(noofel)) allocate(ielno(noofel)) allocate(stoi(noofel)) allocate(smass(noofel)) allocate(matrix(noofel,noofel)) matrix=zero c2=1 do c1=1,noel() c3=c2+index(line(c2:),' ') name=line(c2:c3-1) ! write(*,*)'3A name: "',trim(name),'"',c3,c1,' "',trim(line(c3:)),'"' c2=c3 call find_species_record_exact(name,loksp(c1)) if(gx%bmperr.ne.0) goto 1000 call get_species_data(loksp(c1),nspel,ielno,stoi,& smass(c1),qsp,nspx,spextra) if(qsp.gt.zero) then write(*,*)'Charged species must not be components' gx%bmperr=4399; goto 1000 endif do i1=1,nspel matrix(ielno(i1),c1)=stoi(i1) enddo ! do i1=1,nspel ! matrix(c1,ielno(i1))=stoi(i1) ! enddo enddo ! do c1=1,noofel ! write(*,70)'3A mat: ',c1,(matrix(c2,c1),c2=1,noofel) ! enddo 70 format(a,i1,6(1pe12.4)) ! check that the matrix has an inverse allocate(imat(noofel,noofel)) ! removed second index as not used! ! call mdinvold(noofel,noofel+1,matrix,imat,noofel,ierr) call mdinvold(noofel,matrix,imat,noofel,ierr) if(ierr.eq.0) then ! write(*,*)'Error inverting component matrix, dependent components' gx%bmperr=4362; goto 1000 endif ! do c1=1,noofel ! write(*,70)'3A imt: ',c1,(imat(c2,c1),c2=1,noofel) ! enddo ! gx%bmperr=4399 ! write(*,*)'3A *** All seems OK so far ... but only testing yet' ! goto 1000 !---------------------------------------------------------- ! We have a new set of components!! ! At present (and maybe forever) use the same components in all equilibria ... do c1=1,noofel do c2=1,noofel ceq%compstoi(c2,c1)=matrix(c2,c1) ceq%invcompstoi(c2,c1)=imat(c2,c1) ! set bit GSNOTELCOMP if there are non-zero off-diagonal terms in invcompstoi if(c1.ne.c2 .and. imat(c2,c1).ne.zero) then globaldata%status=ibset(globaldata%status,GSNOTELCOMP) endif enddo ! enddo ! enter the components, no alphabetical order ... ?? ! do c1=1,noofel ceq%complist(c1)%splink=loksp(c1) ceq%complist(c1)%phlink=0 ceq%complist(c1)%tpref(1)=2.9815D2 ceq%complist(c1)%tpref(2)=1.0D5 ceq%complist(c1)%mass=smass(c1) enddo ! delete all conditions and experiments in all equilibria ! the argument 0 means only conditions and experiments deleted, ! not the ceq itself ! write(*,*)'3A deleting all conditions in all equilibria',eqfree-1 do c1=1,eqfree-1 curceq=>eqlista(c1) call delete_all_conditions(0,curceq) ! delete if there are some extra things if(allocated(curceq%eqextra)) deallocate(curceq%eqextra) enddo ! we must go through all (stoichiometric?) phases and set a new ! value for abnorm(1) and (3) ! write(*,*)'3A update asum and csum for all phases' do c1=1,noofph ! the value stored in phases(i) is the location of phase record!! lokph=phases(c1) do c2=1,phlista(lokph)%noofcs lokcs=phlista(lokph)%linktocs(c2) c3=size(ceq%phase_varres(lokcs)%yfr) if(.not.allocated(yarr)) then allocate(yarr(c3)) endif yarr=ceq%phase_varres(lokcs)%yfr ! this will update abnorm(1) and (3) for THIS equilibrium ... loop for all?? call set_constitution(c1,c2,yarr,qq,ceq) enddo deallocate(yarr) enddo 1000 continue ! deallocate temporary things (maybe default?) deallocate(loksp) deallocate(ielno) deallocate(stoi) deallocate(smass) deallocate(matrix) return end subroutine amend_components !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ ================================================ FILE: src/models/gtp3B.F90 ================================================ ! ! gtp3B included in gtp3.F90 ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !> 6. Section: enter data !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine store_element !\begin{verbatim} subroutine store_element(symb,name,refstate,mass,h298,s298) ! Creates an element record after checks. ! symb: character*2, symbol (it can be a single character like H or V) ! name: character, free text name of the element ! refstate: character, free text name of reference state. ! mass: double, mass of element in g/mol ! h298: double, enthalpy difference between 0 and 298.14 K ! s298: double, entropy at 298.15 K implicit none CHARACTER*(*) symb,name,refstate DOUBLE PRECISION mass,h298,s298 !\end{verbatim} CHARACTER symb2*2,symb24*24 integer knr(1),jl,jjj,kkk,nsl,loksp,lokph,nycomp,emodel double precision stoik(1) character ch1*1,model*24,phname*24,const(1)*24 logical dummy if(.not.allowenter(1)) then gx%bmperr=4125 goto 1000 endif emodel=0 ! check input data 100 continue call capson(symb) if(ucletter(symb(1:1))) then if(len(symb).ge.2) then if(ucletter(symb(2:2)) .or. symb(2:2).eq.' ') then goto 200 endif else goto 200 endif endif ! element name error, must be only letters (except /- already entered) ! write(6,*)'new element not allowed ',symb,gx%bmperr gx%bmperr=4033 goto 1000 200 continue ! check if element already entered symb2=symb(1:2) ! write(*,202)'3B new element 1: ',symb,symb2 202 format(a,'"',a,'"',a,'"') reallynew: do jl=0,noofel if(symb2.eq.ellista(jl)%symbol) then gx%bmperr=4034 goto 1000 endif enddo reallynew ! element name is not really needed but must start with letter ! write(*,12)symb,name,refstate,mass,h298,s298 !12 format('3B new_el: "',a,'"',a,'"',a,'"',3(1PE12.4)) call capson(name) if(name(1:1).ne.' ') then ! allow empty element state if(.not.ucletter(name(1:1))) then gx%bmperr=4035 goto 1000 endif endif 300 continue ! reference state must start with letter, no other check call capson(refstate) if(refstate(1:1).ne.' ') then ! allow empty reference state if(.not.ucletter(refstate(1:1))) then ! error here when 1/2_MOLE_O2(G) etc .... model=refstate refstate='GAS_'//trim(model) ! gx%bmperr=4036 ! goto 1000 endif endif 400 continue ! mass, h298-h0 and s298 must not be negative if(mass.lt.zero) then gx%bmperr=4037 goto 1000 endif if(h298.lt.zero) then gx%bmperr=4038 goto 1000 endif if(s298.lt.zero) then gx%bmperr=4039 goto 1000 endif ! All OK, increment noofel and store values in record noofel noofel=noofel+1 if(noofel.gt.maxel) then gx%bmperr=4040 goto 1000 endif ! ensure that symbol has no strange characters ! write(*,202)'3B new element 1B: ',symb,symb2 ellista(noofel)%symbol=' ' ellista(noofel)%symbol=symb ellista(noofel)%name=name ellista(noofel)%ref_state=refstate ellista(noofel)%mass=mass ellista(noofel)%h298_h0=h298 ellista(noofel)%s298=s298 ellista(noofel)%status=0 ellista(noofel)%alphaindex=noofel ! value 0 is H298, 1 H0, 2 G ellista(noofel)%refstatesymbol=0 ! Now create corresponding species noofsp=noofsp+1 if(noofel.gt.maxsp) then gx%bmperr=4041 goto 1000 endif ellista(noofel)%splink=noofsp ! write(*,202)'3B new element 1C: ',symb,symb2 symb24=' ' symb24=symb2 ! write(*,77)symb,symb2,symb24 !77 format('3B new element 77: ',a,'"',a,'"',a,'"') splista(noofsp)%symbol=symb24 splista(noofsp)%mass=mass splista(noofsp)%charge=zero splista(noofsp)%status=0 splista(noofsp)%status=ibset(splista(noofsp)%status,SPEL) splista(noofsp)%alphaindex=noofsp splista(noofsp)%noofel=1 ! allocate allocate(splista(noofsp)%ellinks(1)) allocate(splista(noofsp)%stoichiometry(1)) splista(noofsp)%ellinks(1)=noofel splista(noofsp)%stoichiometry(1)=one ! return with error code 0 i.e. no error ! gx%bmperr=0 ! rearrange ELEMENTS and SPECIES to maintain these in alphabetical order elements(noofel)=noofel call alphaelorder species(noofsp)=noofsp splista(noofsp)%quadindex=0 call alphasporder ! As this is an element add the species to the component list of firsteq !------------------------------------------------ ! Beware that the alphabetical order may have changed. jjj used later jjj=ellista(noofel)%alphaindex if(jjj.lt.noofel) then ! write(*,*)'3B TDB MUST HAVE ELEMENTS IN ALPHABETICAL ORDER!',jjj,noofel do kkk=noofel,jjj+1,-1 firsteq%complist(kkk)%splink=firsteq%complist(kkk-1)%splink firsteq%complist(kkk)%phlink=firsteq%complist(kkk-1)%phlink firsteq%complist(kkk)%refstate=firsteq%complist(kkk-1)%refstate firsteq%complist(kkk)%tpref=firsteq%complist(kkk-1)%tpref firsteq%complist(kkk)%mass=firsteq%complist(kkk-1)%mass enddo else jjj=noofel endif ! %splink is location of species firsteq%complist(jjj)%splink=noofsp firsteq%complist(jjj)%phlink=0 ! do not copy element reference state name here firsteq%complist(jjj)%refstate='SER (default)' firsteq%complist(jjj)%tpref(1)=2.9815D2 firsteq%complist(jjj)%tpref(2)=1.0D5 ! copy mass of component from species record firsteq%complist(jjj)%mass=mass ! check ! call compmassbug(firsteq) ! NOTE jjj is used below when adding this element to reference phase ! also set the stoichiometry matrix, just the diagonal. Also the inverse firsteq%compstoi(noofel,noofel)=one firsteq%invcompstoi(noofel,noofel)=one ! write(*,*)'3B new_el: ',noofel,name,symb24 nycomp=noofel if(noofel.eq.1) then ! create reference phase with index 0 ! phname='ELEMENT_REFERENCE_PHASE ' ! if preblems this may be created several times ... phname='SELECT_ELEMENT_REFERENCE' nsl=1 knr(1)=1 ! const(1)=name const(1)=symb24 stoik(1)=one model='NON_MIXING' ch1='Z' call enter_phase(phname,nsl,knr,const,stoik,model,ch1,dummy,emodel) if(gx%bmperr.ne.0) goto 1000 ! set phase hidden as it should never be included in calculations lokph=0 phlista(lokph)%status1=ibset(phlista(lokph)%status1,phhid) ! add all additions ?? else ! Add the element to the reference phase (phase 0) by extending the ! constituent list (and many other arrays) loksp=firsteq%complist(jjj)%splink call add_to_reference_phase(loksp) if(gx%bmperr.ne.0) goto 1000 endif if(noofel.gt.0) then ! clear the nodata bit globaldata%status=ibclr(globaldata%status,GSNODATA) endif ! if(gx%bmperr.ne.0) goto 1000 1000 continue ! write(*,*)'3B created new species: ',noofsp,splista(noofsp)%symbol return END subroutine store_element !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine enter_species !\begin{verbatim} subroutine enter_species(symb,noelx,ellist,stoik) ! creates a new species ! symb: character*24, name of species, often equal to stoichiometric formula ! noelx: integer, number of elements in stoichiometric formula (incl charge) ! ellist: character array, element names (electron is /-) ! stoik: double array, must be positive except for electron. implicit none character symb*(*),ellist(*)*(*) integer noelx double precision stoik(*) !\end{verbatim} double precision mass,charge integer elindex(10) integer loksp,noelxx,jl,jk if(.not.allowenter(1)) then ! write(kou,11) 11 format('3B entering species may create problems',& ' when there are phases entered') ! gx%bmperr=4125 ! goto 1000 endif call capson(symb) ! write(*,*)'3B Entering ',symb,noelx if(.not.ucletter(symb(1:1))) then gx%bmperr=4044 goto 1000 endif if(noelx.le.0 .or. noelx.gt.10) then gx%bmperr=4045 goto 1000 endif ! check if there is a period "." in the species, that is a common error! if(index(symb,'.').gt.0) then gx%bmperr=4044; goto 1000 endif ! check symb is unique ! call find_species_record(symb,loksp) call find_species_record_noabbr(symb,loksp) if(gx%bmperr.eq.0) then ! If we do not get error speces already entered !! ! strange error reading cadarache database, what is this? BoS 2020-01-30 ! do jl=1,noofsp ! write(*,*)'3B entered species ',jl,splista(jl)%symbol ! enddo gx%bmperr=4049; goto 1000 endif mass=zero charge=zero noelxx=noelx checkel: do jl=1,noelx loopel: do jk=-1,noofel if(ellist(jl).eq.ellista(jk)%symbol) goto 200 enddo loopel ! an unknown element gx%bmperr=4046 goto 1000 200 continue elindex(jl)=jk if(jk.ge.0) then !CCI : when GSVIRTUAL is added, negative stoichiometry is allowed (numerically) if( (stoik(jl).lt.zero) .and. & (.not.btest(globaldata%status,GSVIRTUAL))) then !CCI gx%bmperr=4047 goto 1000 else mass=mass+stoik(jl)*ellista(jk)%mass endif else ! this is the electron, save negative of stoick as charge negative ! the electron is not counted as "element" when storing charge=-stoik(jl) noelxx=noelxx-1 if(jl.ne.noelx) then ! this must be the last element .... otherwise problem storing stoik gx%bmperr=4048 goto 1000 endif endif ! write(6,*)'enter_species 2: ',symb,jl,mass,charge enddo checkel noofsp=noofsp+1 if(noofsp.gt.maxsp) then gx%bmperr=4125 goto 1000 endif ! store species data splista(noofsp)%symbol=symb splista(noofsp)%mass=mass splista(noofsp)%charge=charge splista(noofsp)%alphaindex=noofsp splista(noofsp)%noofel=noelxx splista(noofsp)%status=0 ! with MQMQA model this links species to quad index splista(noofsp)%quadindex=0 if(charge.ne.zero) then splista(noofsp)%status=ibset(splista(noofsp)%status,SPION) endif ! allocate allocate(splista(noofsp)%ellinks(noelxx)) allocate(splista(noofsp)%stoichiometry(noelxx)) loop2: do jl=1,noelxx splista(noofsp)%ellinks(jl)=elindex(jl) splista(noofsp)%stoichiometry(jl)=stoik(jl) ! write(*,12)noofsp,splista(noofsp)%ellinks(jl),& ! splista(noofsp)%stoichiometry(jl) 12 format('3B species: ',2i5,F7.4) enddo loop2 ! return with no error gx%bmperr=0 ! add species last and rearrange species(noofsp)=noofsp call alphasporder ! NOTE the array spextra is allocated with AMEND SPECIES command ! error: continue would be a nice use of non-digit labels .... 1000 continue ! write(*,*)'3B exit enter species: ',noofsp,splista(noofsp)%quadindex return END subroutine enter_species !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine enterphase !\begin{verbatim} subroutine enterphase(cline,last) ! interactive entering of phase character cline*(*) integer last ! type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} character name1*24,text*256,name3*24,model*72,phtype*1,ch1*1,cmodel*72 integer nsl,defnsl,icon,ll,jp,loop,entropymodel,jj,nend double precision sites(9) character (len=34) :: quest1='Number of sites on sublattice xx: ' ! constituent indices in a phase integer, dimension(maxconst) :: knr ! array with constituents in sublattices when entering a phase character, dimension(maxconst) :: const*24 logical once,dummy ! ! this is called from pmon or TDB file call gparcx('Phase name: ',cline,last,1,name1,' ','?Enter phase') ! ionic liquid require special sorting of constituents on anion sublattice call capson(name1) ! check legal phase name allowed if(.not.proper_symbol_name(name1,0)) then write(*,*)'3B Illegal phase name'; goto 1000 endif defnsl=1 if(name1(1:4).eq.'GAS ') then phtype='G' model='IDEAL' elseif(name1(1:7).eq.'LIQUID ') then phtype='L' model='RKM' elseif(name1(1:9).eq.'IONIC_LIQ') then phtype='L' model='I2SL' defnsl=2 else ! default .... phtype='S' model='CEF' endif ! NEW question about model, passed on to enter_phase call gparcdx('Model: ',cline,last,1,cmodel,model,'?Enter phase model') if(buperr.ne.0) goto 900 model=cmodel entropymodel=0 call capson(model) ! defnsl is default number of sublattices if(model(1:5).eq.'I2SL ') then phtype='L' defnsl=2 elseif(model(1:6).eq.'MQMQA ') then phtype='Q' entropymodel=2 defnsl=1 elseif(model(1:6).eq.'MQMQX ') then ! attempt to add new variant of the MQMQA model with complete excess model phtype='X' entropymodel=2 defnsl=1 elseif(model(1:4).eq.'QCE ') then entropymodel=3 defnsl=1 elseif(model(1:5).eq.'TISR ') then entropymodel=5 defnsl=1 elseif(model(1:5).eq.'SROT ') then entropymodel=6 defnsl=1 elseif(model(1:6).eq.'CVMCE ') then entropymodel=4 defnsl=1 endif ! We are here only when interactive entering of the model! ! write(*,*)'gtp3B debug 1: ',trim(model),xtdbmqmqa sites=one ! write(*,*)'3B model: ',trim(model),' ',phtype if(model(1:6).eq.'IDEAL ' .or. model(1:4).eq.'RKM ' .or. & model(1:5).eq.'SROT ' .or. & model(1:5).eq.'TISR ' .or. model(1:6).eq.'CVMCE ' .or. & model(1:4).eq.'QCE ' .or. model(1:6).eq.'MQMQA ' .or. & model(1:6).eq.'MQMQX ') then ! ideal, regular and quasichemical models have 1 sublattice with 1 site nsl=1 elseif(model.eq.'I2SL ') then ! I2SL has tw0 sublattices with variable number of sites nsl=2 else call gparidx('Number of sublattices: ',cline,last,nsl,defnsl,& '?Enter phase subl') if(buperr.ne.0) goto 900 endif if(nsl.le.0) then write(kou,*)'At least one configurational space!!!' goto 1000 elseif(nsl.ge.10) then write(kou,*)'Maximum 9 sublattices' goto 1000 endif ! these checks are redundant? ! if((model(1:4).eq.'QCE ' .or. model(1:6).eq.'MQMQA ') .and. nsl.ne.1) then if((model(1:4).eq.'QCE ' .or. model(1:4).eq.'MQMQ') .and. nsl.ne.1) then write(*,*)'The liquid quasichemical model has two sites' gx%bmperr=4399; goto 1000 elseif(model(1:5).eq.'I2SL ' .and. nsl.ne.2) then write(*,*)'A ionic liquid model must have two sublattices' gx%bmperr=4399; goto 1000 endif icon=0 sloop: do ll=1,nsl ! 'Number of sites on sublattice xx: ' ! 123456789.123456789.123456789.123 ! write(*,*)'3B model5: "',trim(model),'"' if(model(1:4).eq.'RKM ' .or. model(1:6).eq.'IDEAL ') then ! ideal and RKM models have one set of sites with 1 place ... sites(1)=one elseif(model(1:4).eq.'QCE ' .or. model(1:6).eq.'CVMCE ' .or. & model(1:5).eq.'SROT ') then call gparrdx('Number of bonds: ',cline,last,sites(1),6.0D0,& 'Enter phase bonds') if(buperr.ne.0) goto 900 elseif(model(1:4).eq.'MQMQ') then ! this model has quadruplets as independent fractions and use ! excess models with asymmetric composition depdent variables sites(1)=1.0d0 elseif(model(1:5).ne.'I2SL ') then ! For all other models ask for sublattuces and sites once=.true. 4042 continue write(quest1(31:32),4043)ll 4043 format(i2) call gparrdx(quest1,cline,last,sites(ll),one,& '?Enter phase sites') if(buperr.ne.0) goto 900 if(sites(ll).le.1.0D-6) then write(kou,*)'Number of sites must be larger than 1.0D-6' if(once) then once=.false. goto 4042 else goto 1000 endif endif endif ! Now ask for constituents, special for MQMQA and MQMQX ! All quadrupoles, each followed by bonds? ! input looks line NA/O 3 6 NA/F 6 6 NA,SI/O 3 12 6 SI/F,O 6 3 1.5 etc ! write(*,*)'gtp3B debug 2: ',model,xtdbmqmqa ! if((model(1:4).eq.'MQMQA ' .not.xtdbmqmqa) then if(model(1:4).eq.'MQMQ' .and. .not.xtdbmqmqa) then ! entering MQMQA constituent with the phase no longer possible ! write(*,*)'gtp3B error entering MQMQA constituents with phase' gx%bmperr=4399; goto 1000 ! ! this code was used when MQMQA species were entered together with the phase ! but this is no longer possible to enter interactively, only by database loop=0 mqmqloop: do while(.true.) call gparcx('MQMQA quadrupoles: ',cline,last,5,text,' ',& 'Enter phase constit') if(text(1:1).eq.' ') exit mqmqloop write(*,*)' *** reading mqmqa_constituents',trim(text) ! write(*,*)'3B mqmqa quads: ',trim(text) ! clear any previous content in const const=' ' ! -nend set to 0 at first call, then incremented for each FNN endmember found call mqmqa_constituents(text,const,nend,loop) if(gx%bmperr.ne.0) goto 1000 loop=1 enddo mqmqloop if(gx%bmperr.ne.0) goto 1000 if(nend.le.0) then write(*,*)'3B MQMQA phase has no constituents' gx%bmperr=4399; goto 1000 endif ! After entering all quadruplets ! this replaces species locations in the quadrupoles by endemember indices ! write(*,*)'3B const: ',trim(const(loop),loop=1,) ! in mqmqa_rearrance const is an arry const(*)*24 ..... call mqmqa_rearrange(const) if(gx%bmperr.ne.0) goto 1000 knr=mqmqa_data%nconst goto 4100 elseif(model(1:6).eq.'MQMQA ') then ! this code used when MQMQA species are entered separately write(*,*)'MQMQA constituent entered explicitly' gx%bmperr=1000; goto 1000 endif ! ! This can require several lines, to allow that use 4 which means up to ; once=.true. 4045 continue if(nsl.eq.1) then call gparcx('Constituents: ',cline,last,4,text,';',& 'Enter phase constit') elseif(model(1:5).eq.'I2SL ') then if(ll.eq.1) then call gparcx('Cation constituents: ',& cline,last,4,text,';','?Enter phase constit') else call gparcx('Anions and neutals constituents: ',& cline,last,4,text,';','?Enter phase constit') endif else ! write(*,'(a,i2)')'Give for sublattice ',ll write(*,'(a,i2)')'Constituents in sublattice ',ll call gparcx('Constituents: ',& cline,last,4,text,';','?Enter phase constit') endif if(buperr.ne.0) goto 900 if(text(1:1).eq.';') then ! the user has not specified any constituents if(once) then write(*,*)'3B No constituents? Try again' once=.false.; goto 4045 else write(*,4057) 4057 format('3B There must be at least one constituent in',& ' each sublattice') goto 1000 endif endif knr(ll)=0 jp=1 4047 continue if(eolch(text,jp)) goto 4049 if(model(1:5).eq.'I2SL ' .and. ll.eq.1 & .and. knr(1).eq.0) then ! a very special case: a single "*" is allowed on 1st sublattice for ionic liq if(text(jp:jp).eq.'*') then icon=icon+1 const(icon)='*' knr(1)=1 cycle sloop endif endif call getname(text,jp,name3,1,ch1) if(buperr.eq.0) then icon=icon+1 const(icon)=name3 knr(ll)=knr(ll)+1 ! write(*,66)'constituent: ',knr(ll),icon,jp,const(icon) 66 format(a,3i3,a) ! increment jp to bypass a separating , jp=jp+1 goto 4047 elseif(once) then ! write(kou,*)'Input error ',buperr,', at ',jp,', please reenter' buperr=0; once=.false.; goto 4045 else goto 1000 endif buperr=0 4049 continue enddo sloop 4100 continue call enter_phase(name1,nsl,knr,const,sites,model,phtype,dummy,entropymodel) if(gx%bmperr.ne.0) goto 1000 900 continue if(buperr.ne.0) gx%bmperr=buperr 1000 continue ! write(*,*)'3B leave enterphase' return end subroutine enterphase !\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine enter_phase !\begin{verbatim} ! NEW VERSION WITH MQMQA CONSTITUENTS ENTERED BEFORE PHASE INITIALLY subroutine enter_phase(name,nsl,knr,const,sites,model,phtype,warning,emodel) ! creates the data structure for a new phase ! name: character*24, name of phase ! nsl: integer, number of sublattices (range 1-9) ! knr: integer array, number of constituents in each sublattice ! const: character array, constituent (species) names in sequential order ! sites: double array, number of sites on the sublattices ! model: character, some fixed parts, some free text ! phtype: character*1, specifies G for gas, L for liquid, X for new MQMQA ! emodel: for entropy model and maybe more ! THING TO FIX: an I2SL phase with no cations should be accepted but ! as a regular solution with 1 site for neutrals, no anions allowed! ! When reading the database the first sublattice will be empty ! Added nullifying toptoop implicit none character name*(*),model*(*),phtype*(*) integer nsl,emodel integer, dimension(*) :: knr double precision, dimension(*) :: sites character, dimension(*) :: const*(*) logical warning !\end{verbatim} type(gtp_phase_add), pointer :: addrec character ch1*1,conname*24 double precision formalunits,endch integer kconlok(maxconst),kalpha(maxconst),iord(maxconst),klok(maxconst) integer iva(maxconst),endm(maxsubl),endm0(maxsubl+1) logical externalchargebalance,tupix integer iph,kkk,lokph,ll,nk,jl,jk,mm,lokcs,nkk,nyfas,loksp,tuple,bothcharge integer s1,mqm1(20),mqm2(20),s2,s3,s4,s5,minus,s8,iq ! logicals for models later stored in phase record logical i2sl,QCE,uniquac,mqm,clusterr,nocations,cvmtfs,cvmtfl ! csfree and highcs for finding phase_varres record if(.not.allowenter(2)) then gx%bmperr=4125 goto 1000 endif ! if I2SL phase with no cation ! if(nsl.eq.2) write(*,'(i3,2x,2i3)')'3B phase: ',nsl,knr(1),knr(2) ! if(emodel.ne.0) then ! write(*,'(a,3i5,F7.3)')'3B emodel phase: ',emodel,nsl,knr(1),sites(1) ! endif i2sl=.FALSE. QCE=.FALSE. mqm=.FALSE. uniquac=.FALSE. ! write(*,4)trim(name),nsl,(const(jk),jk=1,nsl) 4 format('3B In enter_phase: ',a,2x,i1,' "',9a,'"') ! phase with tetrahedron CVM configurational entropy cvmtfs=.FALSE. cvmtfl=.FALSE. ! this will be set to TRUE if no cations for the I2SL liquid. ! changes are needed also when calculating with such a liquid nocations=.FALSE. ! check input call capson(name) ! if(.not.ucletter(name)) then if(.not.proper_symbol_name(name,0)) then write(*,*)'3B Error for phase name: ',name(1:min(24,len(name))) gx%bmperr=4053; goto 1000 endif ! name unique? call find_phase_by_name_exact(name,iph,kkk) ! write(6,*)'new phase 1A ',name,nsl,gx%bmperr,const(1) if(gx%bmperr.eq.0) then ! if phase found then error as name not unique ... but check explicitly lokph=phases(iph) if(name.eq.phlista(lokph)%name) then gx%bmperr=4054 goto 1000 endif ! name was not exactly the same, accept this phase name also else gx%bmperr=0 endif ! Check above confirm new phase is not abbreviation of existing phases, now ! add check that no existing phase is an abbreviation of the new phase name ambig2: do ll=1,noofph nk=len_trim(phlista(ll)%name) if(name(1:nk).eq.trim(phlista(ll)%name)) then write(*,63)trim(phlista(ll)%name),trim(name) 63 format(/'3B WARNING: An existing phase "',a,& '" is short for new phase "',a,'"'/& 'Phase names should be unique') ! This is for warning about when reading TDB files warning=.TRUE. ! gx%bmperr=4054; goto 1000 endif enddo ambig2 if(nsl.lt.1 .or. nsl.gt.maxsubl) then gx%bmperr=4056 goto 1000 endif site1: do ll=1,nsl if(sites(ll).le.zero) then ! write(6,*)' new phase 1B: ',name,ll,nsl,sites(ll) gx%bmperr=4057 goto 1000 endif enddo site1 nk=0 knrtest: do ll=1,nsl if(knr(ll).lt.1 .or. knr(ll).gt.maxconst) then write(*,*)'3B enter phase error:',ll,knr(ll),maxconst gx%bmperr=4058; goto 1000 endif if(ll.ge.2 .and. knr(ll).gt.maxcons2) then gx%bmperr=4059; goto 1000 endif nk=nk+knr(ll) enddo knrtest nkk=nk ! write(6,*)' enter_phase 3: ',name,nsl,nkk,noofsp ! set bit for quasichemical and ionic liquid model! call capson(model) ! write(*,'(a,a,2x,a)')'gtp3B line 724 model7: ',trim(model),phtype if(model(1:5).eq.'I2SL ') then i2sl=.TRUE. elseif(model(1:4).eq.'QCE ') then QCE=.TRUE. elseif(model(1:6).eq.'MQMQA ' .or. phtype.eq.'X') then ! FactSage modified quasichemical model ! write(*,*)'3B entering MQMQA phase',nk mqm=.TRUE. ! we must call mqmqa_rearrange to fix mqmqa constituents ... ! const is an array with the names of all constituents of the mqmqa phase ! write(*,13)(trim(const(ll)),ll=1,nk) 13 format('3B MQMQA const: ',10(a,1x)) call mqmqa_rearrange(const) ! write(*,*)'3B in enter_phase, back from mqmqa_rearrange' if(gx%bmperr.ne.0) goto 1000 elseif(model(1:8).eq.'UNIQUAC ') then uniquac=.TRUE. write(*,7) 7 format('3B With this model some of the following questions'& ' are irrelevant'/'but kept for compatibility with other models') elseif(model(1:7).eq.'CVMTFS ') then ! FCC tetrahedron model without LRO (ABBB, AABA, ABAA and BAAA same) cvmtfs=.TRUE. elseif(model(1:7).eq.'CVMTFL ') then ! FCC tetrahedron model with LRO (max 2 elements) cvmtfl=.TRUE. endif externalchargebalance=.false. ! CVMTFS creates its own set of constituents in a special subroutine if(cvmtfs) then ! write(*,*)'3B creating CVMTFS constituents',knr(1) ! This will create new set of constituents! call enter_cvmtfs_phase(name,nsl,knr,const) if(gx%bmperr.ne.0) goto 1000 ! sort the phase in its place, create varres record etc nkk=knr(1) sites(1)=one ! set below ! phlista(lokph)%status1=bset(phlista(lokph)%status1,PHSRO) ! write(*,*)'3B exit cvmtfs: ',nsl,nkk,knr(1) ! goto 370 endif ! check constituents constest: do jl=1,nkk if(jl.eq.1 .and. i2sl) then ! in this case * is allowed on first sublattice!! if(const(1)(1:2).eq.'* ') then kalpha(jl)=-99 kconlok(jl)=-99 cycle constest endif endif call capson(const(jl)) ! write(6,297)'3B enter_phase constituent: ',jl,const(jl),nkk iq=index(const(jl),'-Q') if(iq.gt.0) then iq=iq+1 else iq=min(len_trim(const(jl))+1,len(const(jl))) endif findspecies: do jk=1,noofsp ! why not use any of the several find_species_xyz variants here??? ! write(*,*)'3B iq "',const(jl)(1:iq),'" = "',& ! splista(jk)%symbol(1:iq),'" ',iq if(const(jl)(1:iq).eq.splista(jk)%symbol(1:iq)) then ! write(*,*)'3B at new constituent 300: ',noofsp,jk,const(jl) goto 300 endif enddo findspecies ! write(6,297)' enter_phase constituent error: ',jl,const(jl),jk,nkk 297 format(a,i3,'>',A,'<',2i3) write(kou,*)'Unknown constituent, name must be exact: ',trim(const(jl)) gx%bmperr=4051 goto 1000 ! found species, 300 continue ! write(*,*)'3B constituents entered ' ! check for duplicates in same sublattice kalpha(jl)=splista(jk)%alphaindex ll=1 mm=1 nk=knr(1) 310 continue if(jl.gt.nk) then if(ll.lt.nsl) then ll=ll+1 mm=nk+1 nk=nk+knr(ll) goto 310 else write(*,*)'3B Impossible: constituent index outside range!' gx%bmperr=4257; goto 1000 endif else do mm=mm,jl-1 ! write(*,314)mm,jl,kalpha(mm),kalpha(jl),& ! const(jl)(1:len_trim(const(jl))),name(1:len_trim(name)) 314 format('3B Species: ',4i4,' "',a,'" in ',a) if(kalpha(mm).eq.kalpha(jl)) then write(*,315)trim(name),trim(const(jl)),ll 315 format(' *** Error, the ',a,' phase has constituent ',a,& ' twice in sublattice ',i2) gx%bmperr=4258; goto 1000 endif enddo endif ! for quasichemical model check that costituents with name 'QC_' has 2 elements if((QCE .or. mqm) .and. const(jl)(1:3).eq.'QC_') then if(splista(jk)%noofel.ne.2) then write(*,*)'Quasichemical mixing constituent must have 2 elements' gx%bmperr=4399; goto 1000 endif endif kconlok(jl)=jk ! write(6,73)'3B enter_phase 4B: ',jl,const(jl),jk,kconlok(jl),kalpha(jl) 73 format(A,i3,1x,A6,3I3) ! mark that PHEXCB bit must be set if species has variable charge if(splista(jk)%charge.ne.zero) then externalchargebalance=.true. endif enddo constest ! we should have the check if the phase can be neutral here .... ! a phase with net charge is automatically suspended later ... !-------------------------------------------------------------------------- 370 continue ! the first phase entered is the reference phase created by init_gtp if(noofph.eq.0 .and. phtype(1:1).eq.'Z') then ! phtyp=Z is the reference phase nyfas=0 else ! sort the phase in alphabetical order but always gas (if any) first ! then liquids specified by the phtype letter (G, L, etc) noofph=noofph+1 ! if(nyfas.gt.size(phlista)) then if(noofph.gt.size(phlista)) then ! write(*,*)'3B Too many phases: ',noofph gx%bmperr=4259; goto 1000 endif nyfas=noofph endif ! inititate all data in phlista to try to remove problems with step1 if(nyfas.gt.0) call init_phlista(nyfas) phlista(nyfas)%name=name phlista(nyfas)%status1=0 ! write(*,*)'3B i2sl?',i2sl ionliq: if(i2sl) then ! the external charge balance set above, not needed ! write(*,*)'3B *** ionic liquid entered!!!' externalchargebalance=.FALSE. ! ionic liquid may have phtype='Y', change that to L if(phtype(1:1).eq.'Y') phtype(1:1)='L' if(nsl.ne.2) then ! if entered with only one sublattice then no cations and only neutrals!! write(*,*)'3B Ionic liquid must have 2 sublattices' gx%bmperr=4255; goto 1000 endif phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHIONLIQ) ! constituents in ionic liquid must be sorted in a special way call sort_ionliqconst(lokph,0,knr,kconlok,klok) if(gx%bmperr.ne.0) goto 1000 else ! else link is for all other phases except ionic liquid ! external chargebalance THIS SET BELOW ! if(externalchargebalance) & ! phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHEXCB) ! sort the constituents in each sublattice according to alphaspindex ! write(6,70)5,(kalpha(i),i=1,nkk) ! write(6,70)5,(kconlok(i),i=1,nkk) !70 format('enter_phase ',I2,': ',20I3) nk=1 sort1: do ll=1,nsl call sortin(kalpha(nk),knr(ll),iord(nk)) if(buperr.ne.0) then gx%bmperr=buperr goto 1000 endif ! iord(nk+1:nk+knr(ll)) has numbers 1..knr(ll), add on nk-1 to these ! to be in parity with index of kalpha(nk+1:nk+knr(ll)) adjust: do mm=0,knr(ll)-1 iord(nk+mm)=iord(nk+mm)+nk-1 enddo adjust nk=nk+knr(ll) enddo sort1 ! write(6,70)6,(kalpha(i),i=1,nkk) ! write(6,70)6,(kconlok(iord(i)),i=1,nkk) ! in constituent record store kconlok(iord(i)) ! verify we can find species name ... ! test7: do kk=1,nkk ! write(6,71)kk,iord(kk),kconlok(iord(kk)),splista(kconlok(iord(kk)))%symbol !71 format('enter_phase 7: ',3I3,1x,A) ! enddo test7 do jl=1,nkk klok(jl)=kconlok(iord(jl)) enddo endif ionliq !---------------------------------------- ! write(6,79)8,name,(klok(kk),kk=1,nkk) 79 format('enter_phase ',I2,': ',A6,10I3) ch1=phtype(1:1) call capson(ch1) ! sort the phase in alphabetical but order but first gas, then liquid etc ! legal values of ch1 is G, L, S and C (gas, liquid, solution, compound) ! write(*,*)'3B phase byte: ',ch1 if(ch1.eq.'G') then phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHGAS) model='ideal' elseif(ch1.eq.'L' .or. ch1.eq.'Q' .or. ch1.eq.'X') then ! i2sl had phtype changed to L above, Q and X is the MQMQA model ?? phtype(1:1)='L' phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHLIQ) endif ! Handle option F and B for permutations if(ch1.eq.'F') then ! write(*,*)'3B Setting PHFORD bit' phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHFORD) ! call set_phase_status_bit(lokph,PHFORD) elseif(ch1.eq.'B') then ! write(*,*)'3B Setting PHBORD bit' phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHBORD) ! call set_phase_status_bit(lokph,PHBORD) endif ! :I is used by TC to indicate charge balance needed, ignore if(ch1.eq.' ' .or. ch1.eq.'I') ch1='S' ! ch1='S' phlista(nyfas)%phletter=ch1 phlista(nyfas)%models=model ! if(nyfas.eq.0) then ! continue ! else ! to force the MQMQA phase be treated as liquid in the alphabetical order ,,, ! write(*,*)'3B line 953 enter phase: "',ch1,'" ',mqm if(mqm) then phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHMQMQA) if(ch1.eq.'X') then ! if ch1=X then set PHMQMQX for a more advanced excess model phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHMQMQX) endif ! write(*,960)ch1,mqm 960 format('gtp3B line 960: "',a,'" ',l2) endif if(nyfas.gt.0) then call alphaphorder(tuple) phlista(nyfas)%nooffs=1 else ! uninitiated below for reference phase tuple=0 endif phlista(nyfas)%noofsubl=nsl allocate(phlista(nyfas)%nooffr(nsl)) ! sites stored in phase_varres ! allocate(phlista(nyfas)%sites(nsl)) formalunits=zero do ll=1,nsl phlista(nyfas)%nooffr(ll)=knr(ll) formalunits=formalunits+sites(ll) enddo ! write(*,*)'3B enter_phase 8x: ',nyfas,nkk,sites(1) phlista(nyfas)%tnooffr=nkk ! write(*,*)'3B enter_phase 8y: ',nyfas,phlista(nyfas)%tnooffr ! create constituent record ! write(*,*)'gtp3B line 981 creating constituent list: "',ch1,'"' call create_constitlist(phlista(nyfas)%constitlist,nkk,klok) ! write(*,*)'gtp3B back from creating constituent list: "',ch1,'"' ! in phase_varres we will indicate the VA constituent, indicate in iva valoop: do jl=1,nkk iva(jl)=0 loksp=phlista(nyfas)%constitlist(jl) if(loksp.gt.0) then ! ionic liquid can have a wildcard */-99 as constituent in first sublattice if(btest(splista(loksp)%status,SPVA)) iva(jl)=ibset(iva(jl),CONVA) endif enddo valoop ! write(*,32)'3B phase 14A: ',nyfas,(phlista(nyfas)%constitlist(ll),ll=1,nkk) 32 format(a,i3,50(i3)) ! write(*,33)nkk,(iva(i),i=1,nkk) !33 format('3B enter_phase 14B: ',i3,2x,10i3) ! nprop=10 ! write(*,*)'3B enter_phase parrecords: ',lokcs,nkk,trim(name) call create_parrecords(nyfas,lokcs,nsl,nkk,maxcalcprop,iva,firsteq) ! write(*,*)'3B enter_phase 15: ',nyfas,lokcs,& ! size(firsteq%phase_varres(lokcs)%yfr) if(gx%bmperr.ne.0) goto 1000 ! zero array of pointer to phase_varres record, then set first phlista(nyfas)%linktocs=0 phlista(nyfas)%linktocs(1)=lokcs phlista(nyfas)%noofcs=1 firsteq%phase_varres(lokcs)%phlink=nyfas firsteq%phase_varres(lokcs)%prefix=' ' firsteq%phase_varres(lokcs)%suffix=' ' ! nullify toopfirst and tooplast, set if there are ternary Toop/Kohler models nullify(phlista(nyfas)%tooplast) nullify(phlista(nyfas)%toopfirst) ! Initiated to total number of sites, will be updated in set_condition firsteq%phase_varres(lokcs)%abnorm(1)=formalunits ! ncc no longer part of this record ! firsteq%phase_varres%ncc=nkk ! zero the phstate (means entered and not known (unknown) if stable) firsteq%phase_varres(lokcs)%phstate=0 ! sites must be stored in phase_varres ! if(QCE) then if(model(1:5).eq.'TISR ' .or. model(1:6).eq.'CVMCE ' .or. & model(1:5).eq.'SROT ' .or. & model(1:4).eq.'QCE ' .or. model(1:6).eq.'MQMQA ' .or. & model(1:6).eq.'MQMQX ') then ! very special, we have a quasichemical model, the bonds are in sites(1) ! copy them also to qcbonds ! HM, confusion ... now I store bonds in sites(1) ....2021/02/17 firsteq%phase_varres(lokcs)%qcbonds=sites(1) ! firsteq%phase_varres(lokcs)%qcbonds=one ! in MQMQA all quads share a single set of sites although quad species ! are formally mixing on a two sublattices with one site each ! firsteq%phase_varres(lokcs)%sites(1)=2.0D0 firsteq%phase_varres(lokcs)%sites(1)=one ! Maybe also set %abnorm ??a? ! %abnorm is moles of atoms per formula units (varies with composition) ! NOTE %amfu is moles of formula unit of the phase firsteq%phase_varres(lokcs)%abnorm(1)=one ! write(*,*)'3B MQMQA special abnorm: ',sites(1),one ! write(*,'(a,a,": ",2F7.3)')'3B qcbonds ',model(1:5),sites(1),& ! firsteq%phase_varres(lokcs)%qcbonds else do ll=1,nsl firsteq%phase_varres(lokcs)%sites(ll)=sites(ll) enddo ! this is the model for tetrahedron FCC with just SRO (reduced set of clusters) if(model(1:7).eq.'CVMTFS ') then phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHSSRO) endif if(model(1:7).eq.'CVMTFL ') then phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHCVMTFL) endif endif ! make sure status word and some other links are set firsteq%phase_varres(lokcs)%status2=0 firsteq%phase_varres(lokcs)%phtupx=tuple ! set link to lokcs in phase tuple! ! phasetuple(tuple)%lokvares=lokcs ! write(*,*)'3B new phase tuple: ',nyfas,lokcs,tuple ! If one has made NEW the links are not always zero ! set some phase bits (PHGAS and PHLIQ set above) ! external charge balance etc. ! goto 600 ! ------------------------------------------------------------ ! code below moved here to avoid entring phases with net charge bothcharge=0 ! write(*,*)'3B external charge balance? ',externalchargebalance if(externalchargebalance) then kkk=0 bothcharge=-100 ! do not set PHEXCB if all endmembers have zero charge m2o3(Ce+3,La+3)2(O-2)3 jl=1 endch=zero do ll=1,nsl endm0(ll)=jl endm(ll)=jl jk=phlista(nyfas)%constitlist(jl) endch=endch+splista(jk)%charge*sites(ll) jl=jl+phlista(nyfas)%nooffr(ll) enddo endm0(nsl+1)=phlista(nyfas)%tnooffr+1 500 continue ! write(*,*)'3B checking external chargebalance for: ',trim(name),& ! btest(phlista(nyfas)%status1,PHEXCB) if(abs(endch).gt.1.0D-6) then ! A clumsy check, with ZRO2_TETR we may have (U+4)1(O-2,VA)2 ! with one neutral and one charged (+4) endmember. It should be allowed ... ! We will set this bit any time but we have to check if the phase have ! endmembers with both charges ! write(*,*)'3B charge balance needed for ',trim(name),endch phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHEXCB) if(bothcharge.eq.-100) then if(endch.lt.zero) then bothcharge=-1 else bothcharge=1 endif elseif(bothcharge.lt.0) then if(endch.gt.zero) bothcharge=0 else if(endch.lt.zero) bothcharge=0 endif else ! kkk counts number of neutral endmembers kkk=kkk+1 endif ll=nsl 510 continue if(endm(ll).lt.endm0(ll+1)-1) then jk=phlista(nyfas)%constitlist(endm(ll)) endch=endch-splista(jk)%charge*sites(ll) endm(ll)=endm(ll)+1 jk=phlista(nyfas)%constitlist(endm(ll)) endch=endch+splista(jk)%charge*sites(ll) goto 500 elseif(ll.gt.1) then jk=phlista(nyfas)%constitlist(endm(ll)) endch=endch-splista(jk)%charge*sites(ll) endm(ll)=endm0(ll) jk=phlista(nyfas)%constitlist(endm(ll)) endch=endch+splista(jk)%charge*sites(ll) ll=ll-1 goto 510 endif ! write(*,*)'3B charge balance not needed for ',trim(name) ! goto 530 ! jump here if any endmember has a net charge !520 continue ! jump here if all neutral !530 continue endif ! if a phase with charged constituents cannot be neutral suspend it ! If bothcharge=0 no charged endmember or there are both + and - charges, ! do not suspend ! If bothcharge=-100 there are no charged endmember, do not suspend ! If kkk>0 there is at least one neutral, do not suspend if(bothcharge.ne.0) then if(kkk.eq.0) then write(*,531)trim(name),bothcharge,nkk 531 format('3B *** WARNING: the phase ',a,2i5,' suspended'/& 14x,'as it cannot be electrically neutral') firsteq%phase_varres(lokcs)%phstate=PHSUS endif endif !--------------------------------------- end moved 600 continue ! set net charge to zero firsteq%phase_varres(lokcs)%netcharge=zero if(nsl.eq.1) then if(.not.uniquac) then ! if no sublattices set ideal bit. Will be cleared if excess parameter entered phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHID) endif endif if(nkk.eq.nsl) then ! as many constiuents as sublattice, compound with fix composition phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHNOCV) endif ! quasichemical liquid: indicate status bit for bond clusters in phase_varres ! write(*,*)'3B line 1168 code needed to initiallaze MQMQA, test variable mqm?',& ! mqm,btest(phlista(lokph)%status1,PHMQMQX) if(QCE) then ! clear the ideal bit, the corrected quasichemical model (Hillert et al) phlista(nyfas)%status1=ibclr(phlista(nyfas)%status1,PHID) clusterr=.TRUE. do jk=1,size(phlista(nyfas)%constitlist) ! indexing is tricky ... ll=phlista(nyfas)%constitlist(jk) if(splista(ll)%symbol(1:3).eq.'QC_') then firsteq%phase_varres(lokcs)%constat(jk)=& ibset(firsteq%phase_varres(lokcs)%constat(jk),CONQCBOND) write(*,*)'3B setting bond cluster bit',jk,CONQCBOND clusterr=.FALSE. endif enddo if(clusterr) then write(*,*)'3B Phase with QCE model without any clusters "CQ_" !' gx%bmperr=4399 endif phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHQCE) phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHLIQ) elseif(mqm) then !============================= start of MQMQA constituents write(*,*)'3B entering MQMQA phase',mqm,mqmqa_data%nconst phlista(nyfas)%status1=ibclr(phlista(nyfas)%status1,PHID) ! set the globaldata$mqmqa1 if MQMQX globaldata%mqmqa1=1.0D4 write(kou,*)'3B setting mqmqa1',globaldata%mqmqa1 ! phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHFACTCE) ! write(*,*)'gtp3B line 1186: "',model(1:6),'" ',ch1 phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHMQMQA) if(model(1:6).eq.'MQMQX ') then ! set also excess bit it will be tested below to create new structures phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHMQMQX) endif phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHLIQ) ! code below moved to rearrange_mqmqa ! goto 888 ! we must set correct fraction index in mqmqa_data%contyp(10,i) ! and also set %contyp(11,i) to %contyp(14,i) to sequalial index in sublattice ! The order does not matter but same element should have same index ! mqmqa_data%contyp(10,i) set to order in fraction array ll=0 mqm1=0; mqm2=0 contyp1: do kkk=1,mqmqa_data%nconst loksp=abs(mqmqa_data%contyp(10,kkk)) ! write(*,*)'3B index: ',loksp ! mqmqa_data%contyp(10,kkk) already set here .... mqmqa_data%contyp(10,kkk)=kkk do jk=1,size(phlista(nyfas)%constitlist) if(loksp.eq.phlista(nyfas)%constitlist(jk)) then ! just skip this .... only check we have correct number of species ... ! mqmqa_data%contyp(10,kkk)=jk ll=ll+1 endif enddo ! write(*,555)'todo ',kkk,(mqmqa_data%contyp(jk,kkk),jk=1,14),& ! trim(splista(phlista(nyfas)%constitlist(kkk))%symbol) if(mqmqa_data%contyp(5,kkk).gt.0) then ! fix sublattice index for pair constituents s1=1 sub1: do while(mqm1(s1).gt.0 .and. & mqm1(s1).ne.mqmqa_data%contyp(6,kkk)) s1=s1+1 enddo sub1 mqm1(s1)=mqmqa_data%contyp(6,kkk) ! save original index in 13 mqmqa_data%contyp(13,kkk)=mqmqa_data%contyp(11,kkk) mqmqa_data%contyp(11,kkk)=s1 s1=1 sub2: do while(mqm2(s1).gt.0 .and. & mqm2(s1).ne.mqmqa_data%contyp(7,kkk)) s1=s1+1 enddo sub2 mqm2(s1)=mqmqa_data%contyp(7,kkk) ! save original index in 14 mqmqa_data%contyp(14,kkk)=mqmqa_data%contyp(12,kkk) ! set constituent in second sublattice as negative mqmqa_data%contyp(12,kkk)=-s1 ! else ! for all other quadrpoles these contain species index for bonds ! mqmqa_data%contyp(11,kkk)=0 ! mqmqa_data%contyp(12,kkk)=0 endif ! write(*,555)'done ',kkk,(mqmqa_data%contyp(jk,kkk),jk=1,14) 555 format('3B mqmqa ',a,i2,4i3,2i4,3i3,i4,2x,4i3,1x,a) enddo contyp1 if(ll.ne.size(phlista(nyfas)%constitlist)) then write(*,*)'3B MQMQA constituent fractions problems',ll,& size(phlista(nyfas)%constitlist) gx%bmperr=4399; goto 1000 endif ! finally list constitents ! do s1=1,mqmqa_data%nconst ! conname=splista(phrec%constitlist(mqmqa_data%contyp(10,s1)))%symbol ! conname=mqmqa_data%contyp(10,s1)))%symbol ! connames(s1)=conname ! write(*,3)s1,(mqmqa_data%contyp(ll,s1),ll=1,14),& ! (mqmqa_data%constoi(ll,s1),ll=1,4),& ! trim(splista(phlista(nyfas)%constitlist(s1))%symbol) 3 format('3B mq:',i2,4i3,1x,i3,1x,4i2,1x,i3,1x,4i2,4F5.1,1x,a) ! enddo !888 continue ! write(*,*)'3B mqmqa constituents OK: ',mqmqa_data%nconst !--------------------- code originally in rearrange_mqmqa ! Replace species indices in SNN quadruplets by sublattice fraction order ! do s1=1,mqmqa_data%nconst ! write(*,34)'3B before: ',s1,(mqmqa_data%contyp(s2,s1),s2=1,14) 34 format(a,i2,1x,4i2,1x,i3,1x,4i3,1x,i3,1x,4i3,2x,a) ! enddo ! ! BIG BUG IN THIS LOOP, NOT INITIATED WHEN QUADS ENTERED ! do s1=1,mqmqa_data%nconst ! write(*,3434)s1,(mqmqa_data%contyp(jk,s1),jk=1,14) 3434 format('3B contyp2: ',i3,': ',4i3,1x,i4,1x,4i3,1x,i3,1x,4i3) if(mqmqa_data%contyp(5,s1).eq.0) then ! type(gtp_mqmqa) declared in gtp3_dd2.F90 ! this is a SNN quadruplet with 2 or 4 pair links in %contyp(6..9,s1) ! and species indices in %contyp(11..14,s1) ! replace the species index in 11..14 by sublattuce fraction index in ! %contyp(11..12,pair). The original species indices in %contyp(13..14,pair) ! det galler att halla tungan ratt i mun ... (swedish saying) ! NOTE: indices in 2nd sublattice set as negative!!! ! minus=1 allsubsp: do s2=11,14 s3=mqmqa_data%contyp(s2,s1) ! at index s2 in s2 replace species index s3 with sublattice index, if 0 done if(s3.le.0) exit allsubsp ! if second sublattice set minus=-1 ! if(mqmqa_data%contyp(s2-10,s1).lt.0) minus=-1 ! write(*,*)'3B replace ',s1,' species ',s3,' in position ',s2 do s4=6,9 ! loop all pairs, s4, connected to this SNN for sublattice index of s3 s8=mqmqa_data%contyp(s4,s1) ! write(*,'(a,3i3)')'3B looking in pair: ',s5 if(s8.eq.0) then ! failed to find species s3 in any pair write(*,*)'3B Cannot find a sublattice index order!' gx%bmperr=4399; goto 1000 endif ! s5 is now index of a pair, the index of the pair in %contyp is in pinq(s8) ! and finally in %contyp(13..14,s5) are species indices s5=mqmqa_data%pinq(s8) ! write(*,'(a,3i3)')'3B taking s5 from s8: ',s5 if(s3.eq.mqmqa_data%contyp(13,s5)) then mqmqa_data%contyp(s2,s1)=mqmqa_data%contyp(11,s5) ! write(*,35)'3B sublattice 1 index ',& ! mqmqa_data%contyp(11,s4),' inserted in ',& ! mqmqa_data%contyp(s2,s1) 35 format(a,i3,a,i3) cycle allsubsp elseif(s3.eq.mqmqa_data%contyp(14,s5)) then mqmqa_data%contyp(s2,s1)=mqmqa_data%contyp(12,s5) ! write(*,35)'3B sublattice 2 index ',& ! mqmqa_data%contyp(12,s4),' inserted in ',& ! mqmqa_data%contyp(s2,s1) cycle allsubsp endif enddo enddo allsubsp endif enddo ! ! ******************************** initiating allinone here ! write(*,69)btest(phlista(nyfas)%status1,PHMQMQA),& ! btest(phlista(nyfas)%status1,PHMQMQX) !69 format('gtp3B line 1319 ',2l2) if(btest(phlista(nyfas)%status1,PHMQMQX)) then ! creating excess structures for allinone for MQMQX here? ! write(*,*)'gtp3B line 1322 >>>>>>>> initiate allonone <<<<<<<<<<< ' ! write(*,66)nyfas,phtype 66 format('3B Calling create_asymmetry from enter_phase',i5,2x,a) ! call create_asymmetry(nyfas,knr,const,phtype) ! ! In this routine we create xquad with indices to constituents ! create ternary asymmetric records ! create the binary allinone and initiate varkappa etc. ! endif ! ******************************** initiating done ... some listing? ! ! write(*,*)'3B segmentation fault above ... suck' ! ! do s1=1,mqmqa_data%nconst ! s2=phlista(nyfas)%constitlist(mqmqa_data%contyp(10,s1)) ! conname=splista(s2)%symbol ! write(*,34)'3B final: ',s1,(mqmqa_data%contyp(s2,s1),s2=1,14),& ! conname ! enddo ! stop 'testing' !============================= end of MQMQA constituents elseif(uniquac) then phlista(nyfas)%status1=ibclr(phlista(nyfas)%status1,PHID) phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHUNIQUAC) phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHLIQ) elseif(emodel.eq.4) then ! this is the CVM or QC model with LRO ! NOTE emodel 2 and 3 are treaded with different IFs above phlista(nyfas)%status1=ibclr(phlista(nyfas)%status1,PHID) phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHCVMCE) write(*,*)'3B PHCVMCE bit set' elseif(emodel.eq.5) then phlista(nyfas)%status1=ibclr(phlista(nyfas)%status1,PHID) phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHTISR) write(*,*)'3B PHTISR bit set' elseif(emodel.eq.6) then phlista(nyfas)%status1=ibclr(phlista(nyfas)%status1,PHID) phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHSROT) write(*,*)'3B PHSROT bit set' endif ! nullify links, added tooprec 241012/BoS nullify(phlista(nyfas)%additions) nullify(phlista(nyfas)%ordered) nullify(phlista(nyfas)%disordered) nullify(phlista(nyfas)%toopfirst) nullify(phlista(nyfas)%tooplast) ! initiate phcs, the phase composition set counter for nyfas redundant ?? ! (not for reference phase 0) ! if(nyfas.gt.0) phcs(nyfas)=1 if(noofph.gt.0) then ! clear the nophase bit globaldata%status=ibclr(globaldata%status,GSNOPHASE) !---------------------- new code to generate phase tuple array here ! NOTE nooftuples updated in alphaphorder ... for old times sake ! write(*,*)'3B number of phases: ',noofph do ll=1,noofph ! this is index in phlista ! phasetuple(ll)%phaseix=phases(ll) phasetuple(ll)%lokph=phases(ll) phasetuple(ll)%compset=1 ! this is alphabetical index phasetuple(ll)%ixphase=ll ! this is link to higher tuple of same phase phasetuple(ll)%nextcs=0 ! this is the link to phase tuple from the phase jl=phlista(phases(ll))%linktocs(1) firsteq%phase_varres(jl)%phtupx=ll phasetuple(ll)%lokvares=jl enddo !---------------------- new code end endif ! almost always enter volume model1, nyfas is lokph, use alphabetical index if(nyfas.gt.0) then if(.not.(btest(phlista(nyfas)%status1,PHUNIQUAC) .or.& btest(phlista(nyfas)%status1,PHGAS))) then ! write(*,*)'3B enter_phase adding volume model: ',trim(name),nyfas call add_addrecord(nyfas,' ',volmod1) endif endif 1000 continue ! write(*,*)'3B leaving enter_phase' return END subroutine enter_phase !\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine create_asymmetry !\begin{verbatim} subroutine create_asymmetry(lokph,knr,const,phtype) ! creates the data structure for asymmetric excess for MQMQA phase ! called from enter_phase when the MQMQX phase is entered ! lokph phase location ! knr: integer array, number of constituents ! const: character array, constituent (species) names in sequential order ! phtype: character*1, specifies G for gas, L for liquid X for MQMQX implicit none integer lokph character phtype*(*) ! type(phase_varres), pointer :: phres integer, dimension(*) :: knr character, dimension(*) :: const*(*) !\end{verbatim} ! integer ncat,nan,nquad these are global variables double precision x,y integer iva,jva,nva,ivb,ivc ! ! BoS 2025.11.12: when we are here the mqmqa_data already initiated ! that is done in ?? , mqmqa_species, around line 7062 ! for example mqmqa_data%nconst and mqmqa_data%contyp ! but I do not want to fiddle with that routine ! The global variables nquad etc are redundant but kept for the moment ! because I have forgotten most of what I did in 2020-2021 ! ! This routine can probably be integrated in correlate_const_and_quads ! ! write(*,*)'3B start of create_asymmetry phase',lokph ! ! write(*,5)'first',mqmqa_data%nconst,mqmqa_data%ncon1,mqmqa_data%ncon2,& ! mqmqa_data%lcat,mqmqa_data%nquad,mqmqa_data%ncat,& ! mqmqa_data%nan 5 format('3B in create_asymmetry ',a,' check: ',4i4,2x,4i4) ! Make sure these variables are set !! ! write(*,*)'3B calling init_excess_asymm' ! mqmqa_data%nquad=mqmqa_data%nconst mqmqa_data%ncat=mqmqa_data%ncon1 mqmqa_data%nan=mqmqa_data%ncon2 mqmqa_data%lcat=mqmqa_data%ncat*(mqmqa_data%ncat+1)/2 if(mqmqa_data%ncat.gt.9) then write(*,6)mqmqa_data%ncat,10 6 format('3B **** Warning, too many cations: ',i2,' code assume max ',i2) endif ! ! write(*,5)'second',mqmqa_data%nconst,mqmqa_data%ncon1,mqmqa_data%ncon2,& ! mqmqa_data%lcat,mqmqa_data%nquad,mqmqa_data%ncat,& ! mqmqa_data%nan ! nquad=mqmqa_data%nconst ! ncat=mqmqa_data%ncon1 ! nan=mqmqa_data%ncon2 ! lcat=ncat*(ncat+1)/2 ! ! write(*,*)'3B inside create_asymmetry calling correlate_const_and_quads' ! call correlate_const_and_quads(lokph) ! ! phlista is TYPE gtp_phaserecord ! we assume only one anion, WHICH? it is set in mqmqa_data%contyp ! nquad=phlista(lokph)%nooffr(1); x=nquad+0.1; y=0.5*(sqrt(x**2+1.0d0)-1.0d0) ! ncat=y; nan=1 ! write(*,10)trim(phlista(lokph)%name),phlista(lokph)%phletter,nquad,x,y,ncat !10 format('Phase name: ',a,' letter: ',a,' no of const: ',i3,2(1pe12.4),i3) ! There are some data in the mqmqa_data record? ! write(*,20)mqmqa_data%nconst,mqmqa_data%ncon1,mqmqa_data%ncon2,& ! mqmqa_data%exlevel !20 format('3B Some mqmqa_data record data: ',4i4) ! ! these global values are duplicates but may be useful ! ! we have to set mqmqa_data%exlevel to a nonzero value !!!!!!!!!!! mqmqa_data%exlevel=100 ! The values above already set in mqmqa_species, copied here ! write(*,25)mqmqa_data%nconst,nquad,ncat,nan 25 format('3B In create_asymmetry ',5i3) ! ! double precision, allocatable ::qfnnsnn(:) ! write(*,30)size(mqmqa_data%qfnnsnn),(mqmqa_data%qfnnsnn(iva),iva=1,ncat) 30 format('FNN/SNN: ',i3,10(1pe10.2)) ! write(*,*)'3B line 1449 some lines may be needed for ternary asymmetry' ! The code below needed to read TERNARY asymmetry data ! skip code below, done in 3XQ <<<<<<<<<< may be needed for TERNARY asymmetry ! goto 500 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> not used below ! We have to make sure the quads are arranged in cation order !! ! 1 2 3 4 ... n | n+1 ... 2n-1 | 2n | ... | n(n+1)/2 ! 1,1 1,2 1,3 1,4 1,n | 2,2 2,3 .. 2,n | 3,3 3,4 | ... | n,n ! we have the cations in mqmqa_data%contyp(1..4) ! do iva=1,mqmqa_data%nconst ! 11-14 gives element indices but a single cation only once ! write(*,40)iva,(mqmqa_data%contyp(jva,iva),jva=11,14) !40 format('3B: Quad elements: ',i3,2x,4i3) ! enddo ! create a cross reference to make element 1 part of the first n quads ! and the other elements in order ! then element 2 part of the second n-1 quads ! then element 3 part of the third set of n-2 quads ! use ijklx to calculate the index of constituent in xquad ! these allocated (also) in gtp3XQ .... ! allocate(mqmqa_data%con2quad(nquad)) ! allocate(mqmqa_data%quad2con(nquad)) ! maybe quad2con is also needed ?? do nva=1,mqmqa_data%nquad iva=mqmqa_data%contyp(11,nva) ivb=mqmqa_data%contyp(12,nva) ! write(*,*)'contyp: ',nva,iva,ivb if(ivb.gt.0) then ivc=ijklx(iva,ivb,1,1) else ivc=ijklx(iva,iva,1,1) endif ! write(*,*)'contyp: ',nva,iva,ivb,ivc ! mqmqa_data%con2quad(nva)=ivc ! mqmqa_data%quad2con(ivc)=nva enddo ! 500 continue ! ! write(*,510)ncat,nan 510 format(//'3B Calling init_excess_asymm',2i5//) ! ! we need to identify cations and anions ! cations are Cl, F, ? ! call init_excess_asymm(lokph,ncat,nan) call init_excess_asymm(lokph) ! ! write(*,*)'3B Back from init_excess_asymm' ! 1000 continue return end subroutine create_asymmetry !\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine enter_cvmtfs_phase !\begin{verbatim} subroutine enter_cvmtfs_phase(name,nsl,knr,const) ! enter an CVMTFS phase, tetrahedron FCC with just SRO ! name phase name ! nsl sublattices, must be 1 ! knr number of elements, constituents are generated here ! const array of element namees implicit none integer nsl,knr(*) character name*24,const(*)*24 !\end{verbatim} integer ia,ib,ic,id,nq,ne,nn,la,lb,lc,ld integer, allocatable :: lenel(:) character*24, allocatable :: conel(:) character prefix*4,sroname*24,srosp(4)*24 double precision stoisp(4) ! ! write(*,*)'3B creating CVMTFS constituents with ',knr(1),' elements' if(nsl.ne.1) then write(*,*)'The CVMTFS phase has a single set of sites.' gx%bmperr=4399; goto 1000 endif if(knr(1).le.1 .or. knr(1).gt.10) then write(*,*)'The CVMTFS phase has too few or too many elements',knr(1) gx%bmperr=4399; goto 1000 endif ! save names of elements and check they exist! ne=knr(1) allocate(conel(ne)) allocate(lenel(ne)) do ia=1,ne call find_species_record_noabbr(const(ia),ib) if(gx%bmperr.ne.0) goto 1000 conel(ia)=const(ia) lenel(ia)=len_trim(const(ia)) enddo ! create all SRO constituents in a sungle set of sites ! Note duplictates with the different elements on different sites only once ! This means LRO cannot be modeled but reduces the number of constituents ! They must be in a fixed order prefix='Q000' nn=0 do ia=1,ne ! species Q001_AAAA and Q00x_BBBB and Q0xy_CCCC etc if(nn.gt.maxconst) then write(*,*)'3B overflow of SRO constituents',nn gx%bmperr=4399; goto 1000 endif srosp(1)=conel(ia) la=lenel(ia) nn=nn+1 call incnum(prefix) sroname=prefix//'_'//srosp(1)(1:la)//srosp(1)(1:la)//& srosp(1)(1:la)//srosp(1)(1:la) stoisp(1)=one call enter_species(sroname,1,srosp,stoisp) if(gx%bmperr.ne.0) goto 1100 const(nn)=sroname do ib=ia+1,ne ! species Qxyz_AAAB, Qxyz_AABB, Qxyz_ABBB and Qxyz_BBBC etc srosp(2)=conel(ib) lb=lenel(ib) ! AAAB nn=nn+1 call incnum(prefix) sroname=prefix//'_'//srosp(1)(1:la)//srosp(1)(1:la)//& srosp(1)(1:la)//srosp(2)(1:lb) stoisp(1)=0.75D0 stoisp(2)=0.25D0 call enter_species(sroname,2,srosp,stoisp) const(nn)=sroname ! AABB nn=nn+1 call incnum(prefix) sroname=prefix//'_'//srosp(1)(1:la)//srosp(1)(1:la)//& srosp(2)(1:lb)//srosp(2)(1:lb) stoisp(1)=0.5D0 stoisp(2)=0.5D0 call enter_species(sroname,2,srosp,stoisp) const(nn)=sroname ! ABBB nn=nn+1 call incnum(prefix) sroname=prefix//'_'//srosp(1)(1:la)//srosp(2)(1:lb)//& srosp(2)(1:lb)//srosp(2)(1:lb) stoisp(1)=0.25D0 stoisp(2)=0.75D0 call enter_species(sroname,2,srosp,stoisp) if(gx%bmperr.ne.0) goto 1100 const(nn)=sroname do ic=ib+1,ne ! this only if 3 elements or more ! species Qxyz_AABC, Qxyz_ABBC, Qxyz_ABCC and Qxyz_BBBC etc srosp(3)=conel(ic) lc=lenel(ic) ! AABC nn=nn+1 call incnum(prefix) sroname=prefix//'_'//srosp(1)(1:la)//srosp(1)(1:la)//& srosp(2)(1:lb)//srosp(3)(1:lc) stoisp(1)=0.5D0 stoisp(2)=0.25D0 stoisp(3)=0.25D0 call enter_species(sroname,3,srosp,stoisp) const(nn)=sroname ! ABBC nn=nn+1 call incnum(prefix) sroname=prefix//'_'//srosp(1)(1:la)//srosp(2)(1:lb)//& srosp(2)(1:lb)//srosp(3)(1:lc) stoisp(1)=0.25D0 stoisp(2)=0.5D0 stoisp(3)=0.25D0 call enter_species(sroname,3,srosp,stoisp) const(nn)=sroname ! ABCC nn=nn+1 call incnum(prefix) sroname=prefix//'_'//srosp(1)(1:la)//srosp(2)(1:lb)//& srosp(3)(1:lc)//srosp(3)(1:lc) stoisp(1)=0.25D0 stoisp(2)=0.25D0 stoisp(3)=0.5D0 call enter_species(sroname,3,srosp,stoisp) if(gx%bmperr.ne.0) goto 1100 const(nn)=sroname do id=ic+1,ne ! this only if 4 elements or more srosp(4)=conel(id) ld=lenel(id) ! ABCD nn=nn+1 call incnum(prefix) ! sroname=prefix//'_'//srosp(ia)(1:la)//srosp(ib)(1:lb)//& ! srosp(ic)(1:lc)//srosp(id)(1:ld) sroname=prefix//'_'//srosp(1)(1:la)//srosp(2)(1:lb)//& srosp(3)(1:lc)//srosp(4)(1:ld) stoisp(1)=0.25D0 stoisp(2)=0.25D0 stoisp(3)=0.25D0 stoisp(4)=0.25D0 call enter_species(sroname,4,srosp,stoisp) if(gx%bmperr.ne.0) goto 1100 const(nn)=sroname enddo enddo enddo enddo knr(1)=nn ! write(*,*)'3B leaving enter_cvmtfs, constituents: ',knr(1) ! update the number of constituents and their names ... 1000 continue return 1100 continue write(*,1110)'3B error entering cvmtfs species ',nn,trim(sroname),& (trim(srosp(ia)),ia=1,4),stoisp 1110 format(a,i4,1x,a,': ',4(1x,a),4(1pe12.2)) goto 1000 end subroutine enter_cvmtfs_phase !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine sort_ionliqconst !\begin{verbatim} subroutine sort_ionliqconst(lokph,mode,knr,kconlok,klok) ! sorts constituents in ionic liquid, both when entering phase ! and decoding parameter constituents ! order: 1st sublattice only cations ! 2nd: anions, VA, neutrals ! mode=0 at enter phase, wildcard ok in 1st sublattice if neiher anions nor Va ! mode=1 at enter parameter (wildcard allowed, i.e. some kconlok(i)=-1) ! some parameters not allowed, L(ion,A+:B,C), must be L(ion,*:B,C), check! implicit none integer lokph,knr(*),kconlok(*),klok(*),mode !\end{verbatim} integer nk,jl,jk,mm,kkk,ionva,byte integer, dimension(:), allocatable :: kalpha,iord,iva,anion ! allocate(kalpha(knr(1)+knr(2))) allocate(iord(knr(1)+knr(2))) allocate(iva(knr(1)+knr(2))) allocate(anion(knr(1)+knr(2))) ! check1: constituents in sublattice 1 must all have positive charge ! if(mode.eq.1) then ! write(*,17)'3B sl2: ',knr(1),knr(2),(kconlok(mm),mm=1,knr(1)+knr(2)) !17 format(a,2i3,2x,10i3) ! endif do nk=1,knr(1) if(kconlok(nk).lt.0) then ! wildcard give index -99. If mode=0 more checks later kalpha(nk)=-99 elseif(splista(kconlok(nk))%charge.le.zero) then write(*,*)'3B In ionic_liquid only cations on first sublattice' gx%bmperr=4260; goto 1000 else kalpha(nk)=splista(kconlok(nk))%alphaindex endif enddo ! write(*,69)'3B In 1: ',knr(1),(kconlok(mm),mm=1,knr(1)) if(knr(1).gt.1) then call sortin(kalpha,knr(1),iord) if(buperr.ne.0) then gx%bmperr=buperr goto 1000 endif if(mode.eq.0 .and. kalpha(1).lt.0) then ! when entering phase a single wildcard allowed in first sublattice write(*,*)'3B Illegal parameter with wildcard mixed with cations' gx%bmperr=4261; goto 1000 endif do jl=1,knr(1) klok(jl)=kconlok(iord(jl)) enddo else klok(1)=kconlok(1) endif ! write(*,69)'3B 1st: ',knr(1),(kalpha(mm),mm=1,knr(1)) ! check2: constituents in sublattice 1 must be ANIONS, VA and NEUTRALS ! in that order kkk=knr(1) jl=0 jk=0 ionva=0 do nk=1,knr(2) if(mode.eq.0 .and. kconlok(nk+kkk).lt.0) then ! when entering phase no wildcards allowed in second sublattice write(*,*)'3B You cannot enter phase with wildcard on 2nd sublattice' gx%bmperr=4262; goto 1000 elseif(kconlok(nk+kkk).lt.0) then ! wildcard, treat as anion ?? DO NOT ALLOW, what stoichiometry?? write(*,*)'3B Ionic_liq parameter with wildcard on 2nd sublat. illegal' gx%bmperr=4262; goto 1000 ! jk=jk+1 ! anion(jk)=nk elseif(splista(kconlok(nk+kkk))%charge.gt.zero) then write(*,*)'3B No cations allowed on second sublattice' gx%bmperr=4263; goto 1000 elseif(btest(splista(kconlok(nk+kkk))%status,SPVA)) then ! this is the hypothetical vacancy ionva=nk elseif(splista(kconlok(nk+kkk))%charge.eq.zero) then ! neutral species allowed, use iva, must be sorted after all anions and Va jl=jl+1 iva(jl)=nk else ! anion jk=jk+1 anion(jk)=nk endif enddo ! write(*,88)'3B at 1: ',knr(2),(kconlok(knr(1)+mm),mm=1,knr(2)) 88 format(a,i4,2x,20i3) ! There are jl neutrals and jk anions, if vacancies set it as jk+1 ! if wildcard on first sublattice neither ainons nor Va allowed on 2nd if(klok(1).lt.0 .and. (jk.gt.0 .or. ionva.ne.0)) then write(*,*)'3B Only neutrals on second sublattice if wildcard on first' gx%bmperr=4264; goto 1000 endif do nk=1,jk if(anion(nk).gt.nk) then ! shift the anion to position nk, kconlok must be updated if(ionva.eq.nk) then byte=kconlok(kkk+nk) kconlok(kkk+nk)=kconlok(kkk+anion(nk)) ionva=anion(nk) kconlok(kkk+ionva)=byte ! write(*,88)'3B byt 1: ',knr(2),(kconlok(knr(1)+mm),mm=1,knr(2)) else do mm=1,jl if(iva(mm).eq.nk) exit enddo if(mm.gt.jl) stop 'big bug' byte=kconlok(kkk+nk) kconlok(kkk+nk)=kconlok(kkk+anion(nk)) iva(mm)=anion(nk) kconlok(kkk+iva(mm))=byte ! write(*,88)'3B byt 2: ',knr(2),(kconlok(knr(1)+mm),mm=1,knr(2)) endif anion(nk)=nk endif enddo ! write(*,88)'3B at 2: ',knr(2),(kconlok(knr(1)+mm),mm=1,knr(2)) ! now all ions should be in positions 1..jk. Fix position of vacancy ! by moving neiutrals if(ionva.gt.jk+1) then byte=kconlok(kkk+jk+1) kconlok(kkk+jk+1)=kconlok(kkk+ionva) kconlok(kkk+ionva)=byte iva(ionva)=ionva ionva=jk+1 endif ! write(*,88)'3B at 3: ',knr(2),(kconlok(knr(1)+mm),mm=1,knr(2)) ! write(*,69)'3B 2nda: ',jk,& ! (splista(kconlok(kkk+anion(mm)))%alphaindex,mm=1,jk) ! if(ionva.gt.0) & ! write(*,69)'3B 2ndv: ',1,splista(kconlok(kkk+ionva))%alphaindex ! write(*,69)'3B 2ndn: ',jl,& ! (splista(kconlok(kkk+iva(mm)))%alphaindex,mm=1,jl) 69 format(a,i3,2x,10i3,i5,10i3) do mm=1,knr(2) if(kconlok(kkk+mm).lt.0) then kalpha(mm+kkk)=-99 else kalpha(mm+kkk)=splista(kconlok(kkk+mm))%alphaindex endif enddo kkk=knr(1)+1 ! write(*,69)'3B 2ndx: ',knr(2),(kalpha(mm+kkk-1),mm=1,knr(2)) if(jk.gt.1) then ! write(*,69)'3B kalpha: ',jk,(kalpha(kkk+mm-1),mm=1,jk) call sortin(kalpha(kkk),jk,iord) if(buperr.ne.0) then gx%bmperr=buperr; goto 1000 endif ! write(*,69)'3B sort jk: ',jk,(iord(kkk+mm-1),mm=1,jk) do mm=1,jk klok(kkk+mm-1)=kconlok(kkk+iord(mm)-1) enddo elseif(jk.gt.0) then klok(kkk)=kconlok(kkk) endif kkk=kkk+jk if(ionva.gt.0) then klok(kkk)=kconlok(kkk) kkk=kkk+1 endif if(jl.gt.1) then call sortin(kalpha(kkk),jl,iord) if(buperr.ne.0) then gx%bmperr=buperr; goto 1000 endif do mm=1,jl klok(kkk+mm-1)=kconlok(kkk+iord(mm)-1) enddo elseif(jl.gt.0) then klok(kkk)=kconlok(kkk) endif if(mode.eq.1) then ! final check for parameters: ! if only neutrals on sublatice 2 no interaction allowed on sublattice 1 if(jk.eq.0 .and. ionva.eq.0) then if(knr(1).gt.1) then write(*,*)'3B Illegal interaction parameter' gx%bmperr=4265; goto 1000 else ! replace whatever constituent specified in sublattice 1 by wildcard klok(1)=-99 endif endif endif ! write(*,69)'3B al1: ',knr(1)+knr(2),& ! (klok(mm),mm=1,knr(1)+knr(2)) ! write(*,69)'3B al2: ',knr(1)+knr(2),& ! (splista(klok(mm))%alphaindex,mm=1,knr(1)+knr(2)) !---------------------------------------------------------- 1000 continue return end subroutine sort_ionliqconst !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine enter_composition_set !\begin{verbatim} subroutine enter_composition_set(iph,prefix,suffix,icsno) ! adds a composition set to a phase. ! iph: integer, phase index ! prefix: character*4, optional prefix to original phase name ! suffix: character*4, optional suffix to original phase name ! icsno: integer, returned composition set index (value 2-9) ! ceq: pointer, to current gtp_equilibrium_data ! ! BEWARE this must be done in all equilibria (also during parallel processes) ! There may still be problems with equilibria saved during STEP and MAP ! implicit none integer iph,icsno character*(*) prefix,suffix ! TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} ! also update phasetuple array !! csfree,highcs TYPE(gtp_equilibrium_data), pointer :: ceq integer lokph,ncs,nsl,nkk,lokcs,lokcs1,nprop,lastcs,jl,nyttcs integer leq,nydis,tuple,nz,jz character*4 pfix,sfix integer iva(maxconst) TYPE(gtp_phase_varres), pointer :: peq,neq,ndeq logical once ! ! write(*,*)'3B in enter_composition set',iph,phases(iph),nooftuples once=.TRUE. if(iph.le.0 .or. iph.gt.noofph) then gx%bmperr=4050; goto 1000 endif ! not implemented lokph=phases(iph) ncs=phlista(lokph)%noofcs if(ncs.gt.8) then ! max 9 composition sets gx%bmperr=4092; goto 1000 endif ! not available for PHMQMQX phase if(btest(phlista(lokph)%status1,PHMQMQX)) then write(*,*)'3B phases with MQMQX model cannot have extra composition sets' gx%bmperr=4399; goto 1000 endif ceq=>firsteq icsno=ncs+1 ! test if mmy is correct in all existing compsets ! OK here ! do jl=1,ncs ! lokcs=phlista(lokph)%linktocs(jl) ! write(*,7)lokcs,firsteq%phase_varres(lokcs)%mmyfr 7 format('3B mmy: ',i4,10(F6.2)) ! enddo ! collect some data needed nsl=phlista(lokph)%noofsubl nkk=phlista(lokph)%tnooffr lokcs=phlista(lokph)%linktocs(phlista(lokph)%noofcs) lokcs1=lokcs nprop=ceq%phase_varres(lokcs)%nprop lastcs=phlista(lokph)%linktocs(phlista(lokph)%noofcs) ! one must set the VA bit in the constituent status array ivaloop: do jl=1,nkk iva(jl)=ceq%phase_varres(lastcs)%constat(jl) enddo ivaloop ! check that prefix is empty or start with a letter if(biglet(prefix(1:1)).ne.' ' .and. & (biglet(prefix(1:1)).lt.'A' .or. biglet(prefix(1:1)).gt.'Z')) then write(kou,*)'Prefix of composition set must start with a letter' gx%bmperr=4167; goto 1000 endif if(biglet(suffix(1:1)).ne.' ' .and. & (biglet(suffix(1:1)).lt.'A' .or. biglet(suffix(1:1)).gt.'Z')) then write(kou,*)'Suffix of composition set must start with a letter' gx%bmperr=4167; goto 1000 endif !------------------------------------------------------------------ ! begin threadprotected code >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> ! composition sets must be created in all equilibria ! note that indices to phase_varres same in all equilibria ! >>> beware not tested created composition sets with several equilibria ! maybe this call can be replaced by a simple assignment???? ! create_parrecord in GTP3G.F90 update csfree etc ! call create_parrecords(lokph,nyttcs,nsl,nkk,maxcalcprop,iva,ceq) ! call create_parrecords(lokph,nyttcs,nsl,nkk,maxcalcprop,iva,firsteq) call create_parrecords(lokph,nyttcs,nsl,nkk,maxcalcprop,iva,firsteq) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'3B added composition set: ',nyttcs,csfree ! add new tuple at the end and save tuple index tuple=nooftuples+1 ! phasetuple(tuple)%phaseix=phases(iph) phasetuple(tuple)%lokph=phases(iph) phasetuple(tuple)%compset=icsno ! New variables in phase tuple!, phase index and phase_varrres phasetuple(tuple)%ixphase=iph phasetuple(tuple)%lokvares=nyttcs ! nextcs is the index of next phasetuple for same phase leq=iph ! why upper bound error?? do while(leq.le.nooftuples .and. phasetuple(leq)%nextcs.gt.0) leq=phasetuple(leq)%nextcs enddo ! write(*,56)'3B setting nextcs in tuple: ',iph,phases(iph),nyttcs,leq,tuple !56 format(a,10i5) phasetuple(leq)%nextcs=tuple nooftuples=tuple ! write(*,*)'3B Adding phase tuple: ',tuple,iph,phases(iph) ! save index of tuple in new phase_varres record firsteq%phase_varres(nyttcs)%phtupx=tuple ! write(*,31)'3B Phase tuple: ',nyttcs,tuple,iph,icsno,phases(iph) 31 format(a,10i5) ! firsteq%phase_varres(lastcs)%phtupx=tuple ! peq=>eqlista(1)%phase_varres(lastcs) peq=>firsteq%phase_varres(lastcs) ! sum up number of constituents!! nz=phlista(lokph)%tnooffr ! write(*,*)'3B check: ',phlista(lokph)%nooffr,size(peq%yfr) ! write(*,*)'3B added compset: ',iph,icsno,noeq() !------------------------------------------------------------------- ! loop for all equilibria ! write(*,*)'3B allocate composition set in all equilibria',noeq() alleq: do leq=1,noeq() ! LOOP for all equilibria records to add this composition set to phase lokph ! lastcs is the previously last composition set, nyttcs is the new, ! same in all equilibria, also for firsteq (eqlista(1))!! neq=>eqlista(leq)%phase_varres(nyttcs) ! write(*,19)'3B equil loop 1: ',leq,eqlista(leq)%eqno,lokph,icsno,& ! phlista(lokph)%linktocs(icsno),nyttcs,tuple,neq%phlink 19 format(a,10i4) ! why is phlista updated here? It is outside the equilibrium record ... ! phlista(lokph)%linktocs(icsno)=nyttcs neq%phlink=lokph ! write(*,19)'3B equil loop 2: ',phlista(lokph)%linktocs(icsno),neq%phlink ! prefix and suffix, only letters and digits allowed but not checked ... pfix=prefix; sfix=suffix; call capson(pfix); call capson(sfix) neq%prefix=pfix neq%suffix=sfix ! tuple index neq%phtupx=tuple ! initiate the phstate as entered (value 0) neq%phstate=PHENTERED ! increment composition set counter when leq=1, phlista same in all equilibria if(leq.eq.1) then phlista(lokph)%linktocs(icsno)=nyttcs phlista(lokph)%noofcs=phlista(lokph)%noofcs+1 endif ! write(*,19)'3B add tupple: ',leq,nooftuples,tuple,neq%phtupx,icsno,& ! nyttcs,phlista(lokph)%linktocs(icsno),& ! firsteq%phase_varres(nyttcs)%phtupx ! write(*,311)'3B sites: ',leq,iph,icsno,neq%sites ! sites, abnorm and amount formula units if(.not.allocated(neq%sites)) then ! write(*,*)'3B allocation 1: ',nsl allocate(neq%sites(nsl)) endif neq%sites=peq%sites neq%abnorm=peq%abnorm neq%amfu=zero ! copy quasichemical bonds (if any)!! neq%qcbonds=peq%qcbonds ! write(*,311)'3B amfu: ',leq,iph,icsno,neq%amfu,neq%abnorm,peq%abnorm 311 format(a,3i3,6(1pe12.4)) ! NOTE: these allocations below because create_parrecords does not work ... ! fractions and related ! NOTE: peq%yfr in firsteq is allocated maxconst=1000 as it is done ! before any elements entered!!! nz set above!! ! nz=size(peq%yfr) ! write(*,*)'3B allocate yfr: ',allocated(neq%yfr),nz,& ! btest(phlista(lokph)%status1,phmfs) if(.not.allocated(neq%yfr)) then ! write(*,*)'3B ********** 2039 allocate and copy yfr: ',nyttcs,nz allocate(neq%yfr(nz)) neq%yfr=peq%yfr endif ! mmyfr is allocated here ... ! write(*,*)'3B enter_compset: ',allocated(peq%mmyfr) if(allocated(peq%mmyfr)) then if(.not.allocated(neq%mmyfr)) then ! write(*,*)'3B allocation 3: ',nz allocate(neq%mmyfr(nz)) neq%mmyfr=peq%mmyfr endif endif if(allocated(peq%dpqdy)) then ! for ionic liquid, emergency bugfix 2017/02/16 Bo+Karl if(.not.allocated(neq%dpqdy)) then jz=size(peq%dpqdy) allocate(neq%dpqdy(jz)) neq%dpqdy=peq%dpqdy jz=size(peq%d2pqdvay) allocate(neq%d2pqdvay(jz)) neq%d2pqdvay=peq%d2pqdvay endif endif ! end bugfix if(.not.allocated(neq%constat)) then ! important!! constat has identification of the vacancy constituent !! ! write(*,*)'3B allocation 4: ',nz allocate(neq%constat(nz)) neq%constat=peq%constat endif ! copy status word but clear some bits CSDEFCON means default constitution neq%status2=peq%status2 neq%status2=ibclr(neq%status2,CSDEFCON) ! set duplicate bit for auto in all equilibria if(len(suffix).ge.4) then if(suffix.eq.'AUTO') then ! write(*,*)'3B setting bit CSTEMPAR in ',leq,nyttcs neq%status2=ibset(neq%status2,CSTEMPAR) endif endif ! if(.not.allocated(neq%gval)) then ! result arrays should have been allocated in create_parrecords ... ! but I do not call create_parrecords !! ! write(*,83)'3B gval: ',leq,lokph,nyttcs,nprop,nz 83 format(a,10i5) allocate(neq%gval(6,nprop)) allocate(neq%dgval(3,nz,nprop)) allocate(neq%d2gval(nz*(nz+1)/2,nprop)) allocate(neq%listprop(nprop)) endif !------------------- add addg ... if(btest(neq%status2,CSADDG)) then if(.not.allocated(neq%addg)) then ! write(*,*)'3B allocation 6: ',1 allocate(neq%addg(1)) neq%addg(1)=peq%addg(1) endif endif !-------------------- ! write(*,88)'3B cs: ',nz,neq%status2,neq%constat 88 format(a,i2,2x,Z16,2x,10(1x,i3)) ! if there is a disordered fraction set one must copy the fraction set record ! and add a new parrecords to this. lokcs1 is first composition set ! do not forget to increment novarres and highcs disordered: if(btest(phlista(lokph)%status1,phmfs)) then ! copy the old fraction set record to the new !------------------------ does this work??? disfra has a lot of data neq%disfra=peq%disfra !------------------------- yes it works!! ! write(*,*)'3B disfra 1: ',peq%disfra%ndd,neq%disfra%ndd ! write(*,*)'disfra 2: ',peq%disfra%dxidyj(2),neq%disfra%dxidyj(2) !-------------------------------------- nsl=peq%disfra%ndd nkk=peq%disfra%tnoofxfr ! write(*,*)'3B Creating disordered fraction set 1',lokcs1,nyttcs,nkk do jl=1,nkk iva(jl)=ceq%phase_varres(lokcs1)%constat(jl) enddo if(leq.eq.1) then ! allocate a parrecord for DISORDERED FRACTION SET for first equilibrium. ! Then use the same index: nydis, for all other equilibria. ! Maybe this can be made by a simple assignement???? NO !!! call create_parrecords(lokph,nydis,nsl,nkk,maxcalcprop,iva,firsteq) if(gx%bmperr.ne.0) goto 1000 elseif(once) then write(kou,*)'3B creates a composition set in all equilibria' once=.FALSE. ! write(kou,170)trim(eqlista(leq)%eqname),leq,lokcs1,nydis !170 format('3B New composition set in equilibrium ',a,i4,& ! ' with lokcs and nydis index: ',2i4) ! ??????????? but the disordered fraction set is empty?? endif ! write(*,*)'3B disordered phase_varres: ',leq,nydis,csfree ndeq=>eqlista(leq)%phase_varres(nydis) ndeq%phlink=lokph ndeq%prefix=' ' ndeq%suffix=' ' ! sites must be copied to disordered phase_varres ! write(*,*)'3B dsites: ',size(neq%disfra%dsites),size(neq%sites) ndeq%disfra%dsites=peq%disfra%dsites ! some status bits must be set ndeq%status2=ibset(ndeq%status2,CSDFS) neq%status2=ibset(neq%status2,CSDLNK) ! set the link from ordered disfra record to the disordered phase_varres record neq%disfra%varreslink=nydis ! allocate disordered fractions!! ! write(*,*)'3B allocate disordered yfr?',allocated(ndeq%yfr),nkk if(.not.allocated(ndeq%yfr)) then allocate(ndeq%yfr(nkk)) endif ! write(*,*)'3B allocated disordered yfr?',allocated(ndeq%yfr) endif disordered enddo alleq ! end threadprotected code <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< dpqdy !------------------------------------------------- ! write(*,*)'3B Link from ordred ',lastcs,& ! ' to disordered ',ceq%phase_varres(lastcs)%disfra%varreslink ! next=ceq%phase_varres(lastcs)%next ! write(*,*)'3B Link from ordred ',next,& ! ' to disordered ',ceq%phase_varres(next)%disfra%varreslink 1000 continue ! test if mmy is correct in all existing compsets ! OK here also ... ! do jl=1,icsno ! lokcs=phlista(lokph)%linktocs(jl) ! write(*,7)lokcs,firsteq%phase_varres(lokcs)%mmyfr ! enddo ! write(*,*)'3B value of csfree,highcs: ',csfree,highcs return end subroutine enter_composition_set !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine suspend_composition_set !\begin{verbatim} subroutine suspend_composition_set(iph,parallel,ceq) ! the last composition set is suspended in all equilibria ! ! If parallel is TRUE then execution is not in parallel (threaded) ! implicit none integer iph logical parallel type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ TYPE(gtp_phase_varres), pointer :: varres,disvarres integer ics,lokph,lokcs,ncs,nsl,nkk,lastcs,nprop,idisvarres,kcs,leq lokph=phases(iph) ncs=phlista(lokph)%noofcs ! cannot remove composition set 1 or a nonexisting one if(ncs.le.1) goto 1000 lokcs=phlista(lokph)%linktocs(ncs) ! write(*,*)'3B suspend compset ',parallel if(parallel) then ! we have to stop all threads to do anyting with other equilibria, to ! suspend composition sets in other threads, skip that just suspend the ! last composition set of iph in this equilibrium, ceq !$ if(omp_get_num_threads().eq.1) then !$ write(*,*)'3B suspend ',iph,ncs !$ if(btest(ceq%phase_varres(lokcs)%status2,CSTEMPAR)) then !$ ceq%phase_varres(lokcs)%phstate=PHSUS !$ endif !-$ else !-$ write(*,*)' *** Cannot suspend_composition_set in parallel' !$ endif goto 1000 endif ! we have many equilibria but is not running parallel ! suspend last composition set of iph in all equilibria where it is not stable do leq=1,noeq() ! write(*,*)'3B suspend ',iph,ncs,& ! eqlista(leq)%phase_varres(lokcs)%phstate,& ! btest(eqlista(leq)%phase_varres(lokcs)%status2,CSAUTO),& ! btest(eqlista(leq)%phase_varres(lokcs)%status2,CSTEMPAR) if(btest(eqlista(leq)%phase_varres(lokcs)%status2,CSTEMPAR) .and. & eqlista(leq)%phase_varres(lokcs)%phstate.le.PHENTERED) then eqlista(leq)%phase_varres(lokcs)%phstate=PHSUS endif enddo ! 1000 continue end subroutine suspend_composition_set !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine suspend_unstable_sets !\begin{verbatim} subroutine suspend_unstable_sets(mode,ceq) ! suspend extra composition sets that are not stable implicit none integer mode TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer lokph,ics,lokcs ! loop for all phases phases: do lokph=1,noofph if(phlista(lokph)%noofcs.eq.1) cycle phases sets: do ics=2,phlista(lokph)%noofcs ! never change first composition set, even if not stable lokcs=phlista(lokph)%linktocs(ics) if(ceq%phase_varres(lokcs)%phstate.gt.0) cycle sets ceq%phase_varres(lokcs)%phstate=PHSUS enddo sets enddo phases 1000 continue return end subroutine suspend_unstable_sets !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine remove_composition_set !\begin{verbatim} %- subroutine remove_composition_set(iph,force) ! subroutine delete_composition_set(iph,force) ! the last composition set of phase iph is deleted, update csfree and highcs ! SPURIOUS ERRORS OCCUR IN THIS SUBROUTINE ! ! >>>>>>>>>>>>>>>>>>>>>>>>>>>> NOTE <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ! ! Not safe to remove composition sets when more than one equilibrium ! ! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ! ! ! If force is TRUE delete anyway ... very dangerous ... ! implicit none ! ! BEWARE must be for all equilibria but maybe not allowed when threaded ! integer iph,jl,tuple logical force !\end{verbatim} TYPE(gtp_phase_varres), pointer :: varres,disvarres integer ics,lokph,lokcs,ncs,nsl,nkk,lastcs,nprop,idisvarres,kcs,leq ! ! write(*,*)'3B In remove_compsets',iph,csfree,highcs if(iph.le.0 .or. iph.gt.noofph) then gx%bmperr=4050; goto 1000 endif lokph=phases(iph) ncs=phlista(lokph)%noofcs if(ncs.eq.1) then ! cannot remove composition set 1 or a nonexisting one gx%bmperr=4093; goto 1000 else ics=ncs endif if(btest(globaldata%status,GSNOREMCS)) then write(*,*)'3B Not allowed to delete composition sets' gx%bmperr=4211; goto 1000 endif ! write(*,*)'3B Delete highest composition set: ',iph,lokph,ics if(noeq().gt.1) then ! the deletion of composition sets when many equilibia not allowed until ! further testing write(*,*)' Warning, attempt to delete composition set',& ' with many equilibria ignored' goto 1000 if(force) then write(*,*)' *** WARNING: deleting composition sets',& ' in many equilibria may cause errors' else write(*,*)'Attempt to delete composition sets when many equilibria' gx%bmperr=4211; goto 1000 endif endif !$ if(.TRUE.) then ! write(*,*)'Deleting composition sets impossible when running parallel' ! write(*,*)'This subroutine must be executed in sequential' !$ goto 1000 !$ endif ! find the tuple for this phase+compset !CCI tuple = 0 !CCI loop: do jl=1,nooftuples ! write(*,*)'3B tuple compset: ',jl,ics,phasetuple(jl)%compset ! if(phasetuple(jl)%phaseix.eq.lokph) then if(phasetuple(jl)%lokph.eq.lokph) then if(phasetuple(jl)%compset.eq.ics) then tuple=jl; exit loop endif endif enddo loop ! write(*,*)'3B remove composition set: ',iph,ics,lokph,tuple if(tuple.le.0) then ! write(*,*)'No such tuple!!' gx%bmperr=4252; goto 1000 endif ! collect some data nsl=phlista(lokph)%noofsubl nkk=phlista(lokph)%tnooffr lokcs=phlista(lokph)%linktocs(ics) lastcs=lokcs nprop=firsteq%phase_varres(lokcs)%nprop ! write(*,*)'3B Removing varres record: ',lastcs !------------------------------------- ! begin threadprotected code to remove lastcs >>>>>>>>>>>>>>>>>>> ! delete compset ics, shift higher down (not necessary) ! deallocate data in lokcs and return records to free list !------------------------------------- ! We must remove the composition set in all equilibria ! the index to phase_varres is the same in all equilibria!!!! alleq: do leq=1,noeq() varres=>eqlista(leq)%phase_varres(lastcs) ! there can be unallocated phase_varres records below lastcs if(.not.allocated(varres%sites)) cycle alleq deallocate(varres%constat) deallocate(varres%yfr) if(allocated(varres%mmyfr)) then ! this is not allways allocated, clear CSDEFCON bit also varres%status2=ibclr(varres%status2,CSDEFCON) deallocate(varres%mmyfr) endif deallocate(varres%sites) ! these may not be allocated ... ! write(*,*)'3B delete varres dsitesdy: ',leq,lokcs,size(varres%dsitesdy) ! if(size(varres%dsitesdy).gt.1) deallocate(varres%dsitesdy) ! if(size(varres%d2sitesdy2).gt.1) deallocate(varres%d2sitesdy2) deallocate(varres%listprop) deallocate(varres%gval) deallocate(varres%dgval) deallocate(varres%d2gval) ! There is a disordered fraction record .... more to deallocate disordered: if(allocated(varres%disfra%y2x)) then deallocate(varres%disfra%dsites) deallocate(varres%disfra%nooffr) deallocate(varres%disfra%splink) deallocate(varres%disfra%y2x) deallocate(varres%disfra%dxidyj) ! now deallocate and release the phase_varres record with disordered fractions idisvarres=varres%disfra%varreslink disvarres=>eqlista(leq)%phase_varres(idisvarres) ! write(*,*)'3B Deallocationg disordered varres record ',idisvarres deallocate(disvarres%constat) deallocate(disvarres%yfr) if(allocated(disvarres%mmyfr)) then disvarres%status2=ibclr(disvarres%status2,CSDEFCON) deallocate(disvarres%mmyfr) endif deallocate(disvarres%sites) ! these may not be allocated ... ! write(*,*)'3B delete cs dsitesdy: ',leq,size(disvarres%dsitesdy) ! if(size(disvarres%dsitesdy).gt.1) deallocate(disvarres%dsitesdy) ! if(size(disvarres%d2sitesdy2).gt.1) deallocate(disvarres%d2sitesdy2) deallocate(disvarres%listprop) deallocate(disvarres%gval) deallocate(disvarres%dgval) deallocate(disvarres%d2gval) ! BOS 1401227: I do not think this is an error, just ignore ... ! if(size(disvarres%disfra%dsites).gt.0) then ! write(*,*)'ERROR, only one level of disordering allowed',leq,& ! size(disvarres%disfra%dsites) ! stop ! endif else idisvarres=0 endif disordered enddo alleq ! write(*,*)'3B Done all equilibrium records' ! decrement the composition set counter for this phase ! the phlista record is global, not part of the equilibria phlista(lokph)%noofcs=phlista(lokph)%noofcs-1 ! link the released phase_varres record back to free list, ! maintained in firsteq only if(idisvarres.ne.0) then ! there was a disordered phase_varres record, link it into free list ! write(*,*)'3B Free list 2: ',csfree,idisvarres firsteq%phase_varres(idisvarres)%nextfree=csfree csfree=idisvarres ! make used but released firsteq%phase_varres(idisvarres)%status2=& ibset(firsteq%phase_varres(idisvarres)%status2,CSDEL) ! UNFINISHED this is not correct .... idisvarres=newhighcs(.false.) if(idisvarres.eq.highcs) highcs=idisvarres-1 ! write(*,*)'3B removed varres: ',idisvarres,csfree,highcs endif ! link the free phase_varres into the free list !vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! UNFINISHED: the free list for phase_varres is not updated correctly ! The use of csfree is DANGEROUS, there can be unallocated varres recored ! before the record indiceted by csfree ! and allocated after!!! ! write(*,*)'3B Free list 1: ',csfree,lastcs firsteq%phase_varres(lastcs)%nextfree=csfree csfree=lastcs ! mark this record used but deleted firsteq%phase_varres(lastcs)%status2=& ibset(firsteq%phase_varres(lastcs)%status2,CSDEL) ! UNFINISHED this is not correct idisvarres=newhighcs(.false.) if(highcs.eq.lastcs) highcs=lastcs-1 !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! finally shift all composition sets in phlista(lokph)%linktocs ! if last deleted then ics>phlista(lokph)%noofcs do kcs=ics,phlista(lokph)%noofcs phlista(lokph)%linktocs(kcs)=phlista(lokph)%linktocs(kcs+1) enddo ! and zero the last pointer to composition set. phlista(lokph)%linktocs(phlista(lokph)%noofcs+1)=0 ! ! cleaning up phasetuple jl=phasetuple(tuple)%ixphase ! write(*,*) ! write(*,*)'3B cleaning up phase tuple when removing tuple: ',tuple,jl if(phasetuple(tuple)%compset.eq.2) then ! if the removed phasetuple has compset index 2 then zero the link in ! the original phase tuple ... ! write(*,*)'3B link to tuple for compset 2 set to zero: ',tuple phasetuple(jl)%nextcs=0 else jl=phasetuple(jl)%nextcs ! zero the nextcs pointer in the phase tuple pointing to tuple eternity: do while(phasetuple(jl)%nextcs.ne.tuple) if(jl.eq.phasetuple(tuple)%nextcs) then exit eternity endif if(phasetuple(jl)%nextcs.eq.0) then ! write(*,*)'3B No such tuple: ',phasetuple(tuple)%compset,tuple gx%bmperr=4252; goto 1000 endif jl=phasetuple(jl)%nextcs enddo eternity phasetuple(jl)%nextcs=0 endif ! !>>>>>>>>>>>>>>>>> THINK <<<<<<<<<<<<<<<<<<<<<<< ! ! The assumption is that phase tuples are always ordered in increasing ! composition set number. One will always delete the highest number. ! The main problem is to ensure that %nextcs is correct and that the ! nextcs from the first composition set is updated correctly, also when ! phase tuples from other phases are deleted. ! ! write(*,*)'3B Free list 1: ',csfree,highcs,lokcs ! update phasetuple array, overwrite tuple. This means tuples may change phase ! NOTE the first tuple for a phase+compset=1 will never change position. Only ! those created later may be shifted ... but that may be complicated enough ... ! write(*,*)'3B Shifting phase tuples above deleted: ',tuple,nooftuples ! write(*,770)'3B1:',(jl,phasetuple(jl),jl=tuple-1,nooftuples) 770 format(a,3(6i4,';'),(/4x,6i4,';',6i4,';',6i4,';')) ! It is always the last compset of a phase that is removed, ! all nextcs links goes to higher tuples do jl=tuple+1,nooftuples ! phasetuple(jl-1)%phaseix=phasetuple(jl)%phaseix phasetuple(jl-1)%lokph=phasetuple(jl)%lokph phasetuple(jl-1)%compset=phasetuple(jl)%compset phasetuple(jl-1)%ixphase=phasetuple(jl)%ixphase phasetuple(jl-1)%lokvares=phasetuple(jl)%lokvares ! all tuples have moved down one position ... thus nextcs decremented by one if(phasetuple(jl)%nextcs.gt.0) then phasetuple(jl-1)%nextcs=phasetuple(jl)%nextcs-1 else ! unless it is zero in which case it keeps its value phasetuple(jl-1)%nextcs=0 endif ! we must change the link to this tuple starting from ixphase ?? if(phasetuple(jl-1)%compset.eq.2) then ! write(*,*)'3B Changing link to compset 2: ',& ! phasetuple(jl-1)%ixphase,jl-1 phasetuple(phasetuple(jl-1)%ixphase)%nextcs=jl-1 endif ! ! THERE IS SOME ERROR HERE ... macro Nestor-800 with 21 elements returned ! sometimes that a tuple did not exist. ! ! we must change the link in the phase_varres records also!! ! lokph=phasetuple(jl-1)%phaseix lokph=phasetuple(jl-1)%lokph lokcs=phlista(lokph)%linktocs(phasetuple(jl-1)%compset) if(lokcs.le.0) then write(*,*)'3B index pf phase_varres <=0',jl-1,lokph gx%bmperr=4399; goto 1000 endif ! write(*,771)'3B Shifting down ',jl,nooftuples,phasetuple(jl-1)%phaseix,& ! phasetuple(jl-1)%compset,lokph,lokcs !771 format(a,10i5) ! in all equilibrium records, luckily the phase_varres record the same in all!! do leq=1,noeq() eqlista(leq)%phase_varres(lokcs)%phtupx=jl-1 enddo enddo ! write(*,770)'3B2:',(jl,phasetuple(jl),jl=tuple-1,nooftuples) nooftuples=nooftuples-1 ! the last tuple must explicitly have its link set to zero ?? done ! phasetuple(nooftuples)%nextcs=0 ! write(*,*)'3B Warning: phase tuples may have changed phase ...' ! write(*,770)'3B 2: ',(phasetuple(jl),jl=tuple-4,nooftuples) ! end threadprotected code <<<<<<<<<<<<<<<<<<<<<<<< !------------------------- 1000 continue return end subroutine remove_composition_set !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine suspend_somephases !\begin{verbatim} subroutine suspend_somephases(mode,invph,dim1,dim2,ceq) ! This was added to handle calculating restricted equilibria during mapping ! to suspend (mode=1) or restore (mode=0) phases not involved ! in an invariant equilibrium. ! invph is array with phases that are involved, it has dimension (dim1,*) ! the current status is saved and restored implicit none integer mode,dim1,dim2,invph(dim1,*) type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer, save, allocatable, dimension(:) :: phtupixstatus integer, save :: ntup integer ii,jj,kk,lokcs,lokph character phname*24 ii=nooftup() kk=0 if(mode.eq.1) then ! after saving current status suspend all phases not included in invph ! write(*,*)'3B suspending some phases',ii ntup=ii if(allocated(phtupixstatus)) then write(*,*)'3B calls to suspend_somephases cannot be nested' gx%bmperr=4399; goto 1000 else allocate(phtupixstatus(ntup)) endif loop1: do ii=1,ntup lokcs=phasetuple(ii)%lokvares phtupixstatus(ii)=ceq%phase_varres(lokcs)%phstate do jj=1,dim2 ! write(*,*)'3B suspend? ',jj,lokcs,& ! phlista(invph(1,jj))%linktocs(invph(2,jj)),phtupixstatus(ii) ! invph(1,jj) is index in phases (phase and alphabetcal order) ! lokph is the order the phase were entered into phlista (arbitrary) lokph=phases(invph(1,jj)) if(lokcs.eq.phlista(lokph)%linktocs(invph(2,jj))) then ! write(*,'(a,6i5)')'3B not suspending',jj,invph(1,jj),& ! invph(2,jj),phlista(lokph)%linktocs(invph(2,jj)) cycle loop1 endif enddo ! this phase should be suspended kk=kk+1 ceq%phase_varres(lokcs)%phstate=PHSUS enddo loop1 ! write(*,'(a,i3,a,i3)')'3B suspededed ',kk,' phases out of ',ntup elseif(mode.eq.0) then ! restore status of all phases except those in invph ! write(*,*)'3B restoring some phases',ii if(ii.ne.ntup) then write(*,*)'3B number of phases and compsets changed!',ntup,ii stop endif do ii=1,ntup ceq%phase_varres(phasetuple(ii)%lokvares)%phstate=phtupixstatus(ii) enddo ! write(*,'(a,i3,a)')'3B restored phase status for ',ntup,' phases' deallocate(phtupixstatus) else write(*,*)'3B mode must be 0 or 1' gx%bmperr=4399 endif 1000 continue return end subroutine suspend_somephases !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine delete_unstable_compsets !\begin{verbatim} subroutine delete_unstable_compsets(lokph,ceq) ! This was added to explictly delete unstable composition sets with AUTO set ! Compsets will be shifted down if a stable compset is after an unstable ! See subroutine TOTO_AFTER in gtp3Y.F90 ! implicit none integer lokph type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer ii,iph,lokcs write(*,*)'3B delete unstable compsets for phase: ',& trim(phlista(lokph)%name),phlista(lokph)%noofcs ! the first composition sets cannot be deleted even if unstable do ii=phlista(lokph)%noofcs,2,-1 lokcs=phlista(lokph)%linktocs(ii) write(*,100)ii,btest(ceq%phase_varres(lokcs)%status2,CSAUTO),& btest(ceq%phase_varres(lokcs)%status2,CSTEMPAR) 100 format('3A compset: ',i2,' bits: ',2l2) enddo ! call remove_composition_set(iph,.FALSE.) write(*,*)'Not implemented yet' 1000 continue return end subroutine delete_unstable_compsets !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine enter_parameter !\begin{verbatim} subroutine enter_parameter(lokph,typty,fractyp,nsl,endm,nint,lint,ideg,& lfun,refx) ! enter a parameter for a phase from database or interactivly ! enter_parameter_inter(activly) is in gtp3D for some unknown reason ... ! typty is the type of property, 1=G, 2=TC, ... , n*100+icon MQ&const#subl ! for MQMQA it is parameter type and powers >1000 !! ! fractyp is fraction type, 1 is site fractions, 2 disordered fractions ! FRACTYPE no longer supported, has to be determined by sublattices... ! nsl is number of sublattices ! endm has one constituent index for each sublattice ! constituents in endm and lint should be ordered so endm has lowest ! (done by decode_constarr) ! nint is number of interacting constituents (can be zero) ! lint(1,..) is array of sublattice for interactions ! lint(2,..) is array of constituent indices for interactions ! ideg is degree ! lfun is link to function (integer index) if -1 used for listing ! refx is reference (text) ... maybe use this also for MQMQA excess?? ! if this is a phase with permutations all interactions should be in ! the first or the first two identical sublattices (except interstitals) ! a value in endm can be negative to indicate wildcard ! for ionic liquid constituents must be sorted specially implicit none integer, dimension(*) :: endm character refx*(*) integer lokph,fractyp,typty,nsl,nint,ideg,lfun integer, dimension(2,*) :: lint !\end{verbatim} character notext*20,funexp*1024 integer iord(maxsubl),jord(2,maxsubl) integer again,kkk,ll,kk1,mint,kk,lokint,iz,it,kint,ib,jl,zz,highint,sem integer lj,i1,i2,i3,newint,ifri,lokcs,noperm,firstint,listfun,ii,iq,jq integer, dimension(24) :: intperm integer, dimension(:,:), allocatable :: elinks integer, dimension(:,:), allocatable :: intlinks type(gtp_endmember), pointer :: newem,endmemrec,lastem type(gtp_interaction), pointer :: intrec,lastint,newintrec,donotforget type(gtp_interaction), pointer :: linktohigh ! type(gtp_interaction), allocatable, target :: newintrec type(gtp_property), pointer :: proprec,lastprop,savedproplink TYPE(gtp_fraction_set) :: disfra TYPE(gtp_phase_add), pointer :: addrec logical ionliq ! if(gx%bmperr.ne.0) then write(*,*)'3B Error ',gx%bmperr,' set calling enter_parameter, cleared!' gx%bmperr=0 endif fractyp=1 ! write(*,*)'3B In enter_parameter ',typty,nint,ideg if(btest(phlista(lokph)%status1,PHMFS)) then ! for phases with diordered set the number of sublattices can vary .... if(nsl.ne.phlista(lokph)%noofsubl) fractyp=2 ! fractyp=2 has been used to indicate disordered set, that has to be fixed ! write(*,3)trim(phlista(lokph)%name),typty,nsl,nint,fractyp !3 format('Disordered fraction set error for ',a,' value ',4i4/& ! 'Please correct or report to support') ! gx%bmperr=4069; goto 1000 endif ! write(*,'(a,10i5)')'3B param: ',typty,fractyp,lokph,nsl,nint,lfun ! listfun used when calling this routine just to list a parameter listfun=0 if(nsl.ne.phlista(lokph)%noofsubl) then ! check if the phase has a disordered fraction set ! nothing is associated until the forst parameter added!!! ! write(*,7)trim(phlista(lokph)%name),nsl,& ! btest(phlista(lokph)%status1,PHMFS) 7 format('3B Parameter for ',a,' with ',i2,' sublattices ',& 'is part of disordered fraction set: ',l2) if(btest(phlista(lokph)%status1,PHMFS)) then goto 50 else write(*,8)trim(phlista(lokph)%name),nsl 8 format('Parameter fo phase ',a,' has wrong number of sublattice ',i2) ! gx%bmperr=4065; goto 1000 gx%bmperr=4065; goto 2000 endif endif ! this is for site fractions ! write(*,6)'enter_parameter 1: ',lokph,nsl,phlista(lokph)%noofsubl,nint,ideg 6 format(a,10i5) ! if(nsl.ne.phlista(lokph)%noofsubl) then ! parameter may belong to ! if(associated(phlista(lokph)%disordered)) goto 50 ! write(*,9)trim(phlista(lokph)%name),nsl,& ! associated(phlista(lokph)%disordered) ! gx%bmperr=4065; goto 1000 9 format('Wrong number of sublattices in parameter for ',a,i4,l3) ! endif kkk=0 jord=0 sublloop: do ll=1,nsl emloop: do kk=1,phlista(lokph)%nooffr(ll) kk1=kkk+kk ! write(*,12)lokph,nsl,ll,endm(ll),kk1,phlista(lokph)%constitlist(kk1) !12 format('3B enter_parameter 2A: '4I4,5x,2i5) if(endm(ll).eq.phlista(lokph)%constitlist(kk1)) then iord(ll)=kk1 goto 17 endif enddo emloop if(endm(ll).eq.-99) then ! wildcard, sorted at the end iord(ll)=-99 else write(*,1211)trim(phlista(lokph)%name),ll 1211 format('3B error in enter_parameter ',a,i5) ! gx%bmperr=4096; goto 1000 gx%bmperr=4096; goto 2000 endif 17 continue kkk=kkk+phlista(lokph)%nooffr(ll) enddo sublloop ! write(*,13)'3B enter_parameter 2B: ',(iord(ll),ll=1,nsl) 13 format(a,10i4) ! if(nint.eq.2) write(*,*)'enter_parameter 2C: ************************ ' ! end member constituents found, check interaction ! interactions are in sublattice order in lint !80 continue mint=1 23 continue kkk=0 if(mint.le.nint) then do ll=1,nsl if(lint(1,mint).eq.ll) then intloop: do kk=1,phlista(lokph)%nooffr(ll) kkk=kkk+1 ! write(*,15)mint,lint(2,mint),kkk,phlista(lokph)%constitlist(kkk) if(lint(2,mint).eq.phlista(lokph)%constitlist(kkk)) then ! write(*,*)'enter_parameter jord: ',mint,ll,kkk ! write(*,*)'3B Int no, subl, const: ',mint,ll,kkk jord(1,mint)=ll jord(2,mint)=kkk mint=mint+1 ! write(*,*)'3B enter_parameter mint1: ',mint,ll,kkk,nint if(mint.gt.nint) goto 28 goto 23 endif enddo intloop ! a constituent does not exist in sublattice ll ! write(*,16)ll,mint,lint(1,mint),lint(2,mint) ! gx%bmperr=4066; goto 1000 gx%bmperr=4066; goto 2000 endif kkk=kkk+phlista(lokph)%nooffr(ll) enddo endif 28 continue ! write(*,*)'3B enter_parameter mint2: ',mint,nint 15 format('enter_parameter x: ',4I4) 16 format('enter_parameter y: ',4I4) if(mint.lt.nint) then ! write(*,*)'3B enter_param error: ',nint,mint,lint(1,mint),lint(2,mint) gx%bmperr=4067; goto 1000 endif ! write(*,33)'3B epar 1: ',nint,((lint(iq,jq),iq=1,2),jq=1,nint) 33 format(a,i3,' : ',3(2i4,3x)) goto 90 !---------------- ! code below is for disordered fraction types, use fractset record ! one could try to handle both fraction types in the same code but ! that would just make it very very messy 50 continue if(.not.btest(phlista(lokph)%status1,PHMFS)) then ! there are no disordered fraction sets for this phase ! gx%bmperr=4068; goto 1000 gx%bmperr=4068; goto 2000 endif ! write(*,*)'3B adding disordered parameter to ',trim(phlista(lokph)%name) lokcs=phlista(lokph)%linktocs(1) disfra=firsteq%phase_varres(lokcs)%disfra ! number of sublattices in the disordered set ! write(*,*)'3B disordered ',nsl,disfra%ndd if(nsl.ne.disfra%ndd) then ! gx%bmperr=4069; goto 1000 gx%bmperr=4069; goto 2000 endif kkk=0 ! write(*,*)'3B: disordered parameter: ',nsl do ll=1,nsl do kk=1,disfra%nooffr(ll) kk1=kkk+kk ! write(*,12)ll,endm(ll),kk1,disfra%splink(kk1) if(endm(ll).eq.disfra%splink(kk1)) then iord(ll)=kk1 goto 67 endif enddo if(endm(ll).eq.-99) then ! wildcard iord(ll)=-99 else ! write(*,*)'3B in enter_parameter' ! gx%bmperr=4051; goto 1000 gx%bmperr=4051; goto 2000 endif 67 continue kkk=kkk+disfra%nooffr(ll) enddo ! check interaction constituents mint=1 73 continue kkk=0 if(mint.le.nint) then do ll=1,nsl if(lint(1,mint).eq.ll) then do kk=1,disfra%nooffr(ll) kkk=kkk+1 if(lint(2,mint).eq.disfra%splink(kkk)) then jord(1,mint)=ll jord(2,mint)=kkk ! write(*,75)mint,lint(1,mint),lint(2,mint),kkk,ll,jord(1,mint),jord(2,mint) 75 format('ep 75: ',8i4) mint=mint+1 if(mint.gt.nint) goto 78 goto 73 endif enddo ! a constituent does not exist in sublattice ll ! gx%bmperr=4066; goto 1000 gx%bmperr=4066; goto 2000 endif kkk=kkk+disfra%nooffr(ll) enddo endif 78 continue if(mint.lt.nint) then ! gx%bmperr=4067; goto 1000 gx%bmperr=4067; goto 2000 endif !--------------------------------------------------- ! we have found all constituents for the end member and interactions ! now look if there are parameter records, otherwise create them ! try to keep end member records in some order of constituents ... 90 continue ! if(fractyp.eq.2) then ! looking for bug entering 4 sublattice interaction parammeters ... ! write(*,116)'3B: endm & int: ',(iord(ii),ii=1,nsl),& ! (jord(1,ii),jord(2,ii),ii=1,nint) 116 format(a,4i3,' : ',2i3,2x,2i3) ! endif nullify(lastem) !--------------------------------------------- ! check that interactions are in sublattice and alphabetical order!! again=0 intcheck: do lokint=2,nint if(jord(1,lokint).lt.jord(1,lokint-1)) then corrsubl: do iz=1,2 it=jord(iz,lokint) jord(iz,lokint)=jord(iz,lokint-1) jord(iz,lokint-1)=it enddo corrsubl again=1 elseif(jord(1,lokint).eq.jord(1,lokint-1)) then if(jord(2,lokint).lt.jord(2,lokint-1)) then it=jord(2,lokint) jord(2,lokint)=jord(2,lokint-1) jord(2,lokint-1)=it ! write(*,*)'3B interactions: ',jord(2,lokint),jord(2,lokint-1) again=1 elseif(jord(2,lokint).eq.jord(2,lokint-1)) then ! write(*,656)'3B Illegal with same interaction constituent twice',& ! phlista(lokph)%name 656 format(a/' phase: ',a) ! gx%bmperr=4266; goto 1000 gx%bmperr=4266; goto 2000 endif endif enddo intcheck ! write(*,*)'3B Again: ',again if(again.eq.1) goto 90 !--------------------------------------------- ! Make sure the endmember has the alphabetically lowest constituent ! and that the interaction is not the same as the endmember ! write(*,92)'3B endmembers 1: ',(iord(iq),iq=1,nsl) 92 format(a,10i4) ! write(*,93)'3B interaction 1: ',(jord(1,iq),jord(2,iq),iq=1,nint) 93 format(a,5(i6,i4)) placeibloop: do kint=1,nint ! ll is the sublattice with interaction ll=jord(1,kint) placeib: if(jord(2,kint).eq.iord(ll)) then ! write(*,*)'pmod3B: Illegal with interaction with same constituent' ! subroutine enter_parameter(lokph,typty,fractyp,nsl,endm,nint,lint,ideg,& ! lfun,refx) ! write(*,97)lokph,typty,fractyp,nsl,(endm(zz),zz=1,nsl),& ! ideg,nint,(lint(1,zz),lint(2,zz),zz=1,nint) 97 format('pmod3B: Illegal with interaction with same constituent:'/& 3i3,i4,2x,15(i5)) ! gx%bmperr=4266; goto 1000 gx%bmperr=4266; goto 2000 elseif(jord(2,kint).lt.iord(ll)) then ! constituent in iord higher than that in jord, exchange jord and iord. ib=iord(ll) iord(ll)=jord(2,kint) if(kint.eq.nint) then ! there are no more interactions, just put ib in the place of jord(2,kint) jord(2,kint)=ib else ! a bit problematic, we may have to shift constituents in jord moreint: do mint=kint+1,nint if(jord(1,mint).gt.ll) then ! next interaction in another sublattice, put ib in jord(2,mint-1) jord(2,mint-1)=ib else shiftint: if(ib.lt.jord(2,mint)) then ! next interaction is higher, put ib in jord(2,mint-1) jord(2,mint-1)=ib else ! interacting constituent is lower, we must shift constituents down in jord ! It can be done one at a time?? Example: user enter: ! L(fcc,D,E,C,A,B): iord(1)='D', jord(2,*)='A', 'B', 'C', 'E' (ordered above) ! kint=1 replaces iord(1)='A'; look for the place for 'D'; ninit=4 ! loop mint=2 but 'D' is higher than 'B' so shift jord one step making ! jord(2,*)='B', 'C', 'C', 'E'; ! loop mint=3 but D is higher than 'C' so shift jord(2,*)='B', 'C', 'E', 'E'; ! Now 'D' is lesser than 'E' so place it in jord(2,3): ! jord(2,*)='B', 'C', 'D', 'E'; jord(2,mint-1)=jord(2,mint) if(mint.lt.nint .and. jord(1,mint+1).eq.ll) then jord(2,mint)=jord(2,mint+1) else jord(2,mint)=ib endif endif shiftint endif enddo moreint endif endif placeib enddo placeibloop ! write(*,92)'3B endmembers 2: ',(iord(iq),iq=1,nsl) ! write(*,93)'3B interaction 2: ',(jord(1,iq),jord(2,iq),iq=1,nint) !--------------------------------------------- ! there may be permutations for ordered phases ... implemented for fcc only ! probably also for BCC ... intperm=0 ftyp1: if(fractyp.eq.1) then if(btest(phlista(lokph)%status1,PHFORD)) then ! These permutations may require 2 interaction records created ... call fccpermuts(lokph,nsl,iord,noperm,elinks,nint,jord,& intperm,intlinks) ! if(gx%bmperr.ne.0) goto 1000 if(gx%bmperr.ne.0) goto 2000 ! make sure iord is alphabtically ordered to find the correct parameter ! iord(*) and elinks(*,1) are constituent indices, not species indices do jl=1,nsl iord(jl)=elinks(jl,1) enddo elseif(btest(phlista(lokph)%status1,PHBORD)) then call bccpermuts(lokph,nsl,iord,noperm,elinks,nint,jord,& intperm,intlinks) ! if(gx%bmperr.ne.0) goto 1000 if(gx%bmperr.ne.0) goto 2000 ! make sure iord is alphabtically ordered to find the correct parameter ! iord(*) and elinks(*,1) are constituent indices, not species indices ! write(*,76)'3B iord ',(iord(jl),jl=1,nsl) ! write(*,76)'3B elinks ',(elinks(jl,1),jl=1,nsl) 76 format(a,9i4) do jl=1,nsl iord(jl)=elinks(jl,1) enddo else noperm=1 endif else ! fraction type 2 has no permutations noperm=1 endif ftyp1 ! parameters for site fractions if(fractyp.eq.1) then endmemrec=>phlista(lokph)%ordered else endmemrec=>phlista(lokph)%disordered endif ! write(*,91)'3B enter_param 90: ',fractyp,nsl,(iord(ii),ii=1,nsl) 91 format(a,i2,i3,10i4) !--------------------------------------------- ! find endmember record, maybe create ionliq=btest(phlista(lokph)%status1,PHIONLIQ) findem: do while(associated(endmemrec)) if(.NOT.ionliq) then lika:do lj=1,nsl ! iord(lj) can be negative for wildcard. Wildcard endmedmemers at the end i1=iord(lj) if(.not.allocated(endmemrec%fraclinks)) then write(*,*)'3B Phase data structure error' ! gx%bmperr=4399; goto 1000 gx%bmperr=4399; goto 2000 endif i2=endmemrec%fraclinks(lj,1) if(i1.gt.0) then if(i2.lt.0 .or. i1.lt.i2) then ! The new end member record should be inserted before this record goto 100 elseif(i1.gt.i2) then ! continue searching for the end member or place to create it lastem=>endmemrec endmemrec=>endmemrec%nextem cycle findem endif ! here i1<0 elseif(i2.gt.0) then ! continue searching for the end member or place to create it lastem=>endmemrec endmemrec=>endmemrec%nextem cycle findem endif ! It is the same "wildcard" value if both i1 and i2 are negative enddo lika else ! for ionic liquids insert endmembers in order of second sublattice ... ! This is important as we want to calculate all parameters with anions ! before we come to vacancy and neutrals which should be multiplied with Q illika:do lj=nsl,1,-1 ! iord(lj) can be negative for wildcard. Wildcard endmedmemers at the end i1=iord(lj) i2=endmemrec%fraclinks(lj,1) if(i1.gt.0) then if(i2.lt.0 .or. i1.lt.i2) then ! The new end member record should be inserted before this record goto 100 elseif(i1.gt.i2) then ! continue searching for the end member or place to create it lastem=>endmemrec endmemrec=>endmemrec%nextem cycle findem endif ! here i1<0 elseif(i2.gt.0) then ! continue searching for the end member or place to create it lastem=>endmemrec endmemrec=>endmemrec%nextem cycle findem endif ! It is the same "wildcard" value if both i1 and i2 are negative enddo illika endif !------------------------------------------------- ! found end member record with same constituents goto 200 enddo findem ! ! if lfun=-1 we want to list the function and not create anything if(lfun.lt.0) goto 900 ! !--------------------------------------------- ! create endmember record 100 continue ! we have not found any endmember record so we have to insert a record here ! lokem may be nonzero if we exited from findem loop to this label ! this subroutine is in gtp3G (why?) ! elinks is allocated in bccpermut or fccpermut. If no permutation it is not ! allocated which may cause segentation faults if(noperm.gt.1) then if(.not.allocated(elinks)) then write(*,*)'3B permutations but no elinks!' ! gx%bmperr=4399; goto 1000 gx%bmperr=4399; goto 2000 endif elseif(.not.allocated(elinks)) then ! allocate a dummy elinks to avoid segmentation fault compiling with -lefence allocate(elinks(1,1)) endif ! Special for MQMQA, we must store index in mqmqa_data%contyp for the ! endmember !! use %antalem, it is not used anywhere else ! if(btest(phlista(lokph)%status1,PHMQMQA)) then ! write(*,*)'3B creating endmember for MQMQA' ! do i1=1,mqmqa_data%nconst ! write(*,599)i1,(mqmqa_data%contyp(i2,i1),i2=1,14) !599 format('3X contyp: ',i2,1x,4i2,1x,i3,1x,4i2,1x,i2,4i3) ! enddo ! write(*,*)'3B MQMQA index: ',iord(1) ! endif ! this subroutine is in gtp3G.F90 call create_endmember(lokph,newem,noperm,nsl,iord,elinks) ! write(*,*)'3B created endmember, value of nsl: ',nsl,elinks(1) ! if(gx%bmperr.ne.0) goto 1000 if(gx%bmperr.ne.0) goto 2000 if(btest(phlista(lokph)%status1,PHMQMQA)) then newem%antalem=iord(1) ! write(*,*)'3B enter_par: created MQMQA endmember ',lokph,newem%antalem endif ! if(gx%bmperr.ne.0) goto 1000 if(gx%bmperr.ne.0) goto 2000 ! insert link to new from last end member record, lastem. if(.not.associated(lastem)) then if(fractyp.eq.1) then phlista(lokph)%ordered=>newem else phlista(lokph)%disordered=>newem endif else ! emlista(lastem)%next=new lastem%nextem=>newem endif ! insert link from new to next (if lokem=0 this record is the last) newem%nextem=>endmemrec endmemrec=>newem !--------------------------------------------------- ! Here we have found or created the endmember record ! look for or create interaction record, NO WILDCARDS IN INTERACTIONS ! Interacting elements should be in sublattice and alphabetical order!! 200 continue ! write(*,*)'3B enter_parameter mint3: ',mint,nint nullify(linktohigh) lokint=0 ! ! this indicates an MQMQA excess parameter ! if(ideg.ge.1000) write(*,201)lokph,endmemrec%fraclinks(1,1),lfun 201 format(/'3B line 3187 adding MQMQA excess from: ',3i5) ! mqmq: if(btest(phlista(lokph)%status1,PHMQMQX)) then ! mark the phase is not ideal phlista(lokph)%status1=ibclr(phlista(lokph)%status1,PHID) if(nint.eq.0) exit mqmq ! ! only for excess parameters ! write(*,*)'3B Enter MQMQA excess special routine',associated(endmemrec) ! MQMQX has a very special way of handling interactions do not mess with OC call enter_mqmqa_excess_param(lokph,endmemrec,typty,nint,jord,& ideg,lfun,refx) ! ignore the rest if this subroutine, if(mqmqtdb) write(*,*)'3B Back from mqmqa_excess ',& associated(endmemrec%intpointer) goto 2000 endif mqmq ! ! below is the excess for normal phases !============================================================= ! most MQMQA specific below should be removed or commented away ! someint: if(nint.gt.0) then ! when there are interaction records the ideal bit must be cleared phlista(lokph)%status1=ibclr(phlista(lokph)%status1,PHID) ! to locate interaction record, nullify(lastint) mint=1 intrec=>endmemrec%intpointer ! some excess parameters in wrong order for MQMQA, what is lint? ! write(*,202)lokph,nsl,typty,ideg,nint,(lint(2,i3),i3=1,nint) ! fraclinks is fraction index of constituent of MQMQA endmember OUI!!! sem=endmemrec%fraclinks(1,1) ! write(*,202)lokph,nsl,typty,ideg,nint,sem,(jord(2,i3),i3=1,nint) 202 format(/'3B excess parameters:',5i4,', endmem:',i3,' jord: ',10i4) if(.not.associated(intrec)) then ! no interaction record for this endmember, create one unless lfun=-1 ! It seems this record is created but never used so it remains empty ! create_interaction routine is in gtp3G.F90 if(lfun.eq.-1) goto 900 if(intperm(1).gt.0) then if(.not.allocated(intlinks)) then write(*,*)'3B permutations but no intlinks!' ! gx%bmperr=4399; goto 1000 gx%bmperr=4399; goto 2000 endif elseif(.not.allocated(intlinks)) then ! allocate a dummy intlinks to avoid segmentation fault compiling with -lefence allocate(intlinks(1,1)) endif ! this subroutine is in gtp3G.F90 ! write(*,*)'3B calling create_interaction 1' call create_interaction(newintrec,mint,jord,intperm,intlinks) ! if(gx%bmperr.ne.0) goto 1000 if(gx%bmperr.ne.0) goto 2000 ! clear phpalm as it is needed to handle FCC and BCC permutations phlista(lokph)%status1=ibclr(phlista(lokph)%status1,PHPALM) endmemrec%intpointer=>newintrec intrec=>newintrec lastint=>intrec newint=1 else ! problem with MQMQA excess, ordering of ternary parameter not working ! If new excess constituent lower than current this must replace ! current ! write(*,298)intrec%status,intrec%fraclink(1),sem,(jord(2,i3),i3=1,nint) 298 format('3B **** existing interaction: ',i3,5x,10i3) newint=0 firstint=0 endif 300 continue ! write(*,303)'3B at 300A: ',lokph,newint,nint,mint,intrec%status,gx%bmperr 303 format(a,10i3) ! ! interaction records should be ordered according to the sublattice ! with the interaction. For interaction with permutations use the ! sublattice of the first permutation ! WE MUST store interactions in sublattice order and in constituent order ! highint eventually not used ... highint=0 nullify(linktohigh) findint: do while(mint.le.nint) ! write(*,307)'3B At findint: ',mint,nint,newint,highint,& ! intrec%sublattice(1),intrec%fraclink(1),jord(1,mint),jord(2,mint) 307 format(a,4i4,2x,2i3,2x,2i3) if(intrec%sublattice(1).eq.jord(1,mint) .and. & intrec%fraclink(1).eq.jord(2,mint)) then ! write(*,*)'3B interaction levels: ',mint,nint ! found an interaction with same constituent (maybe just created) ! if(mint.eq.nint) then ! This was modified 251128 for MQMQA parameters. First change nint.ge.nint ! created problems for ternary parameters with different degrees ! if(mint.ge.nint) then if(nint.eq.mint) then ! write(*,*)'3B same or higher interaction, level: ',nint,mint nullify(linktohigh) goto 400 elseif(nint.gt.mint) then if(btest(phlista(lokph)%status1,PHMQMQX)) then ! special for the crazy excess parameters in MQMQA ! write(*,*)'3B for MQMQA ceazy excess? ' ! The MQMQA parameters does not use the degree for identical constitutions goto 310 endif ! for ternary composition dependent excess parameters just continue ... ! write(*,*)'3B what to do when nint>mint? ',mint,nint endif lastint=>intrec linktohigh=>intrec intrec=>intrec%highlink ! write(*,*)'3B linktohigh: ',linktohigh%sublattice(1),& ! linktohigh%fraclink(1) ! BUG!! This creates problem entering L(liquid,c,cr,v;0/1/2) ! highint=1 ! BUG !! but it is necessary to create 24 SRO parameter for 4 sublattice FCC mint=mint+1 newint=1 if(.not.associated(intrec)) then ! write(*,*)'3B exit findint here' exit findint endif else ! nint is parameter interaction level, mint is ? ! Problems here when entering 24 reciprocal parameter for SRO in FCC if(mint.eq.nint) then ! error when storing permutations because newint=0 below. Moved it to the end ! but that gave error L(liq,C,Cr,V) was stored as L(Liq,C,Cr,Fe,V) ! Add a check on mint, if mint=nint one cannot store it as higher newint=0 endif ! we must store interactions in sublattice order and in order of constituent ! in jord(2,mint) otherwise we will never be able to find a permutation. if(intrec%sublattice(1).gt.jord(1,mint)) then write(*,*)'3B insering interaction before existing',& associated(linktohigh) exit findint endif nullify(linktohigh) lastint=>intrec intrec=>intrec%nextlink ! write(*,*)'3B exit? ',associated(intrec),associated(linktohigh) if(.not.associated(intrec)) exit findint firstint=1 ! more records on this interaction level ? ! this worked for permutations but gave other errors, see above ! newint=0 endif enddo findint ! we can be here either because mint>nint or no more interaction records ! we must create at least one interactionrecord, newint=0 if same level ! If intrec is associated the nextint link should be set to this 310 continue ! write(*,*)'3B At 310',mint,nint,newint,highint,associated(intrec) if(mint.le.nint) then ! if lfun=-1 and parameter does not exist just skip away if(lfun.eq.-1) goto 900 ! write(*,303)'3B create at 310:',mint,nint,newint,firstint,highint,& ! jord(1,mint),jord(2,mint) if(intperm(1).gt.0) then if(.not.allocated(intlinks)) then write(*,*)'3B permutations but no intlinks!' ! gx%bmperr=4399; goto 1000 gx%bmperr=4399; goto 2000 endif elseif(.not.allocated(intlinks)) then ! allocate a dummy intlinks to avoid segmentation fault compiling with -lefence allocate(intlinks(1,1)) endif ! write(*,*)'3B calling create_interaction in gtp3G' call create_interaction(newintrec,mint,jord,intperm,intlinks) ! if(gx%bmperr.ne.0) goto 1000 if(gx%bmperr.ne.0) goto 2000 ! write(*,312)intperm(1),mint,jord(2,mint) 312 format('3B created expty interaction for',3i3) ! clear PHPALM as calling palmtree is needed to handle FCC and BCC permutations phlista(lokph)%status1=ibclr(phlista(lokph)%status1,PHPALM) if(newint.eq.1) then ! write(*,*)'3B Linking as higher',mint,highint,associated(linktohigh) ! We may have a high link already! Set it as nextlink! ! write(*,*)'3B Using lastint' donotforget=>lastint%highlink lastint%highlink=>newintrec newintrec%nextlink=>donotforget elseif(associated(linktohigh)) then ! write(*,*)'3B Using linktohigh' ! write(*,*)'3B low: ',linktohigh%sublattice(1),linktohigh%fraclink(1) ! write(*,*)'3B low: ',newintrec%sublattice(1),newintrec%fraclink(1) donotforget=>linktohigh%highlink ! write(*,*)'3B low: ',donotforget%sublattice(1),& ! donotforget%fraclink(1) linktohigh%highlink=>newintrec newintrec%nextlink=>donotforget nullify(linktohigh) elseif(associated(intrec)) then ! write(*,*)'3B Linking as previous',mint,highint newintrec%nextlink=>intrec ! write(*,*)'3B Ho ho said the sixth' if(associated(lastint)) then lastint%nextlink=>newintrec else ! this should be linked from the endmember or lower order interaction ! write(*,*)'3B No previous interaction on this level' endmemrec%intpointer=>newintrec endif ! write(*,*)'3B Ha ha said the seventh' else ! write(*,*)'3B Linking as next',mint lastint%nextlink=>newintrec endif ! redundant as newint set to 1 below ... ! newint=0 intrec=>newintrec lastint=>intrec mint=mint+1 ! there may be more interaction records .... but they must all be created ! write(*,*)'gtp3B maybe create more records ...',associated(linktohigh) newint=1 goto 310 endif ! Now we should have found or created the interaction record, ! We may have found the record it should be linked from if nint>mint ! check property list 400 continue ! if(nint.gt.mint) then ! this has higher interaction than current, take %next link. ! write(*,403)sem,(jord(2,ii),ii=1,nont) !403 format('3B looking place of excess:',6i3) ! intrec=>intrec%nextlink ! endif proprec=>intrec%propointer if(.not.associated(proprec)) then ! do not create anything if lfun=-1 if(lfun.eq.-1) goto 900 if(ideg.gt.9) then typty=ideg; ideg=0 ! write(*,*)'3B create excess proprec for MQMQA 1: ',typty,ideg,lfun endif ! write(*,*)'3B create_proprec 1:',typty,ideg,lfun ! create_proprec is in gtp3G.F90 call create_proprec(intrec%propointer,typty,ideg,lfun,refx) ! if(gx%bmperr.ne.0) goto 1000 if(gx%bmperr.ne.0) goto 2000 ! if this is an MQMQA parameter some information in intrec%propinter%asymdata ! must be added here. typty is 34, 35 or 36 if(typty.ge.34 .and. typty.le.36) then ! sem is fraclink of endmember constiuent call create_mqmqa_excessprop(intrec%propointer%asymdata,& sem,nint,jord) endif else ! write(*,*)'3B create additional proprecord for same constituents!' goto 800 endif ! write(*,*)'3B enter_parameter 17: ',lokint,lokem,link else ! Found endmember and there is no interaction ! search the property list, there may not be the correct property! proprec=>endmemrec%propointer if(.not.associated(proprec)) then ! if no property record and lfun=-1 just list parameter equal to zero ! in MQMQA some endmembers have no Gibbs energy of formation!!! if(lfun.lt.0) goto 900 if(ideg.gt.9) then typty=ideg; ideg=0 ! write(*,*)'3B create excess proprec for MQMQA 2: ',typty,ideg,lfun endif ! write(*,*)'3B create_proprec 2: ',typty,ideg,lfun call create_proprec(endmemrec%propointer,typty,ideg,lfun,refx) ! if(gx%bmperr.ne.0) goto 1000 if(gx%bmperr.ne.0) goto 2000 else goto 800 endif endif someint ! all not done !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! goto 1000 !-------------------------------------------------------- ! we found correct parameter record WITH A PROPERTY, now search property list ! This loop both for endmembers and interactions 800 continue do while(associated(proprec)) lastprop=>proprec if(btest(phlista(lokph)%status1,PHMQMQX)) then if(proprec%proptype.eq.typty) then write(*,803)proprec%proptype,typty 803 format('3B adding one more property',2i5) endif elseif(proprec%proptype.eq.typty) then ! With MQMQA one cannot change the expression of a property ! found property record, one should delete old and insert new function ! one must alse change the reference !!! And add the reference if new. ! mode=0 means no change of reference text if reference already exists call capson(refx) notext='*** Not set by user' call tdbrefs(refx,notext,0,ifri) ! write(*,*)'3B value of ideg: ',ideg,proprec%degree if(ideg.le.proprec%degree) then if(lfun.eq.-1) then listfun=proprec%degreelink(ideg) else proprec%degreelink(ideg)=lfun proprec%reference=refx endif elseif(lfun.ge.0) then call extend_proprec(proprec,ideg,lfun) proprec%reference=refx endif if(lfun.eq.-1) goto 900 goto 1000 endif proprec=>proprec%nextpr enddo ! if lfun=-1 we just want to list a the parameter which is zero if(lfun.lt.0) goto 900 ! no record for this property at present, add a new property record if(ideg.gt.9) then ! this is probably an MQMQA parameter typty=ideg; ideg=0 ! write(*,*)'3B create excess proprec for MQMQA 3: ',typty,ideg,lfun endif ! ! ---------------------------------------------------------------------- ! ! write(*,*)'3B create_proprec 3:',typty,ideg,lfun ! lastprop%nextpr will be allocated insde create_proprec savedproplink=>lastprop call create_proprec(lastprop%nextpr,typty,ideg,lfun,refx) ! if(gx%bmperr.ne.0) goto 1000 if(gx%bmperr.ne.0) goto 2000 ! In create_proprec the lastprop%nextpr has been allocated ! ! lastprop=>proprec ! ! if(associated(savedproplink,lastprop)) then ! write(*,*)'3B complicated' ! else ! write(*,*)'3B new record created' ! endif ! intrec%propointer=>savedproplink%nextpr ! if(.not.associated(intrec%propointer)) then ! write(*,*)'3B fundamental illusion lost' ! stop 100 ! endif ! ---------------------------------------------------------------------- ! ! Special for a second MQMQA parameter with same constituents .... ! must be added here. typty is 34, 35 or 36 if(typty.ge.34 .and. typty.le.36) then ! sem is fraclink of endmember constiuent call create_mqmqa_excessprop(intrec%propointer%asymdata,& sem,nint,jord) if(gx%bmperr.ne.0) then write(*,*)'3B error creating a next MQMQA excess parameter' goto 2000 endif endif ! all done and go home ........ not quite .......... goto 1000 !-------------------------------------------------------- ! this is for listing parameter 900 continue write(*,*)'3B list parameter ',lfun,listfun if(listfun.gt.0) then call list_tpfun(listfun,0,funexp) ! for the moment use the TPFUN symbol ... call wrice2(kou,0,12,78,1,funexp) else write(kou,*)'Parameter is zero' endif !---------------------------------------------------------- 1000 continue lastcheck: if(gx%bmperr.eq.0) then ! mark that the phase has at least one parameter phlista(lokph)%status1=ibset(phlista(lokph)%status1,PHHASP) ! if typty not equal 1 check there is an appropriate addition ! skip also typty<=0 .... although that should have created an error ... if(typty.le.1) exit lastcheck ! write(*,*)'3B found parameter id: ',typty if(typty.gt.100) then ! typty>100 means property for a component, remove lower two digits i1=typty/100; zz=i1*100 else zz=typty endif ! write(*,*)'3B searching addition for parameter type: ',zz,typty addrec=>phlista(lokph)%additions addloop: do while(associated(addrec)) checkprop: if(allocated(addrec%need_property)) then do i1=1,size(addrec%need_property) if(addrec%need_property(i1).eq.zz) then ! set the bit that this addition has at least one parameter ! write(*,*)'3B Found addition: ',trim(additioname(addrec%type)) addrec%status=ibset(addrec%status,ADDHAVEPAR) goto 1005 endif enddo endif checkprop addrec=>addrec%nextadd enddo addloop ! propid is an array initiated in gtp3A.F90, zz>100 means component unique ! VERY SPECIAL typty=26ij, zz=26 means UNIQUAC parameter, has no addition!! if(zz.gt.100 .and. i1.eq.26) then if(propid(i1)%symbol.ne.'UQT ') then write(*,*)'3B *** WARNING model parameter identifers confused!' stop endif endif ! we found no addition for this parameter!! if(zz.gt.100) zz=zz/100 ! mpiwarning: if(zz.ne.26) then ! give warning first time only! do i2=1,nundefmpi if(propid(zz)%symbol.eq.undefmpi(i2)) exit mpiwarning enddo ! these are MQMQA excess parameters if(zz.ge.34 .and. zz.le.36) goto 1005 if(nundefmpi.lt.mundefmpi) then nundefmpi=nundefmpi+1 undefmpi(nundefmpi)=propid(zz)%symbol else write(*,*)'3B too many model parameter identifier errors',mundefmpi endif ! write(*,1002)propid(zz)%symbol,trim(phlista(lokph)%name) 1002 format('3B *** Warning parameter ',a,& ' has no addition in ',a,' (or other phases)') endif mpiwarning 1005 continue endif lastcheck if(allocated(intlinks)) deallocate(intlinks) if(allocated(elinks)) deallocate(elinks) ! write(*,*)'3B enter_parameter deallocated: ',gx%bmperr ! write(*,1010)'enter_parameter 77: ',(phlista(lokph)%constitlist(i),i=1,6) !1010 format(A,6I3) 2000 continue ! if(associated(endmemrec%intpointer)) then ! write(*,*)'3B line 3625 Leaving enter_parameter with an excess link',& ! endmemrec%intpointer%antalint ! crash here means the interaction record is there but its property is gone ! write(*,*)'3B line 3625 Value of typty ',& ! (endmemrec%intpointer%propointer%extra ! write(*,*)'without properties',associated(endmemrec%intpointer%propointer) ! endif if(gx%bmperr.ne.0) then write(*,*)'3B Leaving enter_parameter with error ',gx%bmperr endif return end subroutine enter_parameter !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine enter_mqmqa_excess_param !\begin{verbatim} subroutine enter_mqmqa_excess_param(lokph,endmemrec,typty,nint,jord,& ideg,lfun,refx) ! enter an mqmqa excess property linked from an endmember implicit none type(gtp_endmember), pointer :: endmemrec,extraem integer :: lokph, typty, nint, jord(2,*),lfun,ideg character refx*(*) ! nint is number of interaction constituents, lfun is function link !\end{verbatim} %+ ! to avoid messing aruond with the OC normal excess integer, dimension(24) :: intperm integer, dimension(:,:), allocatable :: elinks integer, dimension(:,:), allocatable :: intlinks type(gtp_interaction), pointer :: intrec,lastint,newintrec,linktohigh type(gtp_interaction), pointer :: temp type(gtp_property), pointer :: proprec,lastprop,savedproplink integer ii,ij,mint,sem,level,first,parquad(5) ! The mqmqa excess has no degree and minimum 3 constituents in addition ! to the enemember. Two or 3 of these are A/X type and one AB/X type ! there can be several property records to a single excess record ! ! jord(1,...) are sublattices, MQMQA has only one sublattice ! jord(2,...) are constituents nint is number of interactions ! mint=0 sem=endmemrec%fraclinks(1,1) intrec=>endmemrec%intpointer if(mqmqtdb) then if(associated(intrec)) then write(*,10)mint,nint,lfun,intrec%fraclink(1),sem,(jord(2,ii),ii=1,nint) else write(*,10)mint,nint,lfun,1000,sem,(jord(2,ii),ii=1,nint) endif 10 format(/'3B At ENDMEMBER: ',2i3,i5,5x,i2,5x,i2,2x,6i3) endif ! ! intperm, elinks and intlinks not needed here, used for FCC/BCC permutations intperm(1)=0 allocate(intlinks(1,1)) ! note: endmemrec%intpointer must be nullified when endmember is created ! ! -------------------------------------------------------------------- ! level=-1 ! level -1 means intrec record linked from endmember and ! intrec%nextlin from current endmember%intpointer ! 0 means intrec record is on lower level set %nextlink ! 1 means intrec record is on same level set %highlink nullify(lastint) ! level1 is the first level below endmembers ! newintrec is allocated and mint index and jord fractions ! nint is the number of interactions that must be found or created mint=1 100 continue findint: if(.not.associated(intrec)) then ! there is no record, create one ====================================== ! This can be the first interaction for this endmember or it can be ! added at the end or in the middle of the intrec tree or ! at a level above the previous record ! It must be linked from a previous record or the endmember ! if(associated(lastint)) then ! write(*,150)1,level,mint,nint,lfun,jord(2,mint),& ! lastint%fraclink(1),associated(lastint%nextlink),& ! associated(lastint%highlink) !150 format('3B creating intrec at ',i1,':',4i3,5x,i5,', lastint:',i3,2l2) ! else ! write(*,150)1,level,mint,nint,lfun,jord(2,mint) ! endif call create_interaction(newintrec,mint,jord,intperm,intlinks) if(gx%bmperr.ne.0) goto 1000 ! write(*,155)level,mint,nint,jord(2,mint) !155 format('3B created interaction ',3i3,', for constituent: ',i3) ! set the links to this new interaction record tohere: if(level.eq.-1) then ! if level=-1 this is the first interaction or replaces the previous first ! if(associated(endmemrec%intpointer)) then ! write(*,*)'3B are we here 44?' ! write(*,156)endmemrec%intpointer%fraclink(1) !156 format('3B Inserting at endmember before interaction to ',i3) ! else ! write(*,157)endmemrec%fraclinks(1,1) !157 format('3B First interaction at endmember',i3) ! endif ! write(*,*)'3B are we here 17?' ! write(*,*)'3B bug? ',associated(newintrec) newintrec%nextlink=>endmemrec%intpointer endmemrec%intpointer=>newintrec level=0 ! write(*,*)'3B endmember interaction set to',jord(2,mint) elseif(level.eq.0) then ! we have added a record on a higher level than previous record ! if level=0 the previous record on lower level. set lastint%highlink if(associated(lastint%highlink)) then write(*,*)'3B highlink already set 2',intrec%fraclink(1) stop endif ! write(*,158)lastint%fraclink(1) !158 format('3B Above an interaction to ',i3) lastint%highlink=>newintrec else ! if level=1 we have already found records on this level, set lastint%nextlink ! evidently that link was empty otherwise we had found a record ! write(*,158)lastint%fraclink(1) !159 format('3B After interaction on same level as ',i3) lastint%nextlink=>newintrec endif tohere ! we have a new record which is linked to previous records ! maybe add some data or continue searching up or on same level intrec=>newintrec lastint=>intrec ! write(*,*)'3B do we need more interaction records?',mint,nint data1: if(mint.lt.nint) then ! mint < nint, we need higher order intrec ----------------------------------- ! there are more constituents for this parameter, create higher level mint=mint+1 ! the link back will be to a lower level level=0 ! the highlink should already be nullified and record will be created above nullify(intrec%highlink) intrec=>intrec%highlink goto 100 elseif(mint.eq.nint) then ! If mint=nint this is the last, add property data -------------------------- ! we must save data, there can not be any previous property record typty=ideg; ideg=0 proprec=>intrec%propointer if(associated(proprec)) then do while(associated(proprec%nextpr)) ! there can be several property records proprec=>proprec%nextpr enddo ! this routine is in gtp3G.F90 ! write(*,120)typty,lfun,associated(intrec) !120 format('3B creating property record 1A',2i5,l2) call create_mqmqa_proprec(proprec%nextpr,typty,ideg,lfun,refx) else ! write(*,121)typty,lfun,associated(intrec) !121 format('3B creating property record 1B:',2i5,l2) call create_mqmqa_proprec(intrec%propointer,typty,ideg,lfun,refx) endif if(gx%bmperr.ne.0) then write(*,*)'3B error creating property',gx%bmperr goto 1000 endif ! write(*,*)'3B Back from create propery record',associated(proprec) proprec=>intrec%propointer do while(associated(proprec%nextpr)) ! there can be several property records proprec=>proprec%nextpr enddo ! write(*,*)'3B associated? ',associated(proprec) ! For a MQMQA excess parameter we need to store the index of the AB/X quad ! and which the index of the A/X and B/X (and sometices C/X) quads ! A/X and B/X in alphabetical order, the C/X last ! write(*,334)'yfrac',sem,(jord(2,ii),ii=1,nint) 334 format('3B call convert for constituent ',a,i3,' interactions: ',10i3) call convert_y2quadx(sem,nint,jord,parquad) if(gx%bmperr.ne.0) goto 1000 ! write(*,334)'quad',(parquad(ii),ii=1,nint) ! these are the indices for quad and aymmetric compvar ... ! write(*,*)'3B back from convert_y2quadx 1' proprec%asymdata%quad=parquad(1) proprec%asymdata%alpha=parquad(2) proprec%asymdata%beta=parquad(3) proprec%asymdata%ternary=parquad(4) ! write(*,335)parquad !335 format('3B saved in propery quad mm:',5i3) exit findint else !----------------------------------------------------------------- ! we should never have mint lesser than nint !!! write(*,*)'3B serious error in algorithm mintintrec intrec=>intrec%nextlink level=1 goto 100 elseif(intrec%fraclink(1).eq.jord(2,mint)) then ! we have found an interaction record with correct constituent on this level ! write(*,344)intrec%fraclink(1),jord(2,mint),mint,nint !344 format('3B we have same the constituents',2i3,5x,2i3) if(mint.eq.nint) then ! we have to add a second property!! proprec=>intrec%propointer do while(associated(proprec%nextpr)) ! there can be several property records proprec=>proprec%nextpr enddo typty=ideg; ideg=0 ! add a property record ! write(*,*)'3B adding a second property record 2' call create_mqmqa_proprec(proprec%nextpr,typty,ideg,lfun,refx) if(gx%bmperr.ne.0) then write(*,*)'3B error code',gx%bmperr goto 1000 endif ! add particular MQMQA data TO LAST proprec proprec=>intrec%propointer do while(associated(proprec%nextpr)) ! we need to find the last property record ! THIS WAS TRICKY TO UNDERSTAND!!! proprec=>proprec%nextpr enddo call convert_y2quadx(sem,nint,jord,parquad) if(gx%bmperr.ne.0) goto 1000 proprec%asymdata%quad=parquad(1) proprec%asymdata%alpha=parquad(2) proprec%asymdata%beta=parquad(3) proprec%asymdata%ternary=parquad(4) exit findint else !-------------------------------------------------------------------------- ! go to higher level, %highlink can be empty ! write(*,234)intrec%fraclink(1),mint,nint,associated(intrec%highlink) !234 format('3B goto higher level',3i3,l2) mint=mint+1; level=0 lastint=>intrec intrec=>intrec%highlink goto 100 endif elseif(intrec%fraclink(1).gt.jord(2,mint)) then ! insert new interaction before this one ====================================== ! Maybe also change link from endmember if level=-1 ! write(*,150)2,level,mint,nint,lun,jord(2,mint) call create_interaction(newintrec,mint,jord,intperm,intlinks) if(gx%bmperr.ne.0) goto 1000 if(level.eq.-1) then ! this should be the record linked from the endmember newintrec%nextlink=>endmemrec%intpointer endmemrec%intpointer=>newintrec ! here it is needed !!!! ! write(*,*)'3B endmember interaction set to',jord(2,mint) elseif(level.eq.0) then ! we found this from a lower level, this whould replace highlink in lastint ! and insert that as nextlink in new record ! write(*,370)intrec%fraclink(1),mint,nint !370 format('3B inserting a constituent ',i3,' before current',2i3) if(associated(lastint%highlink)) then newintrec%nextlink=>lastint%highlink lastint%highlink=>newintrec endif else ! just save the link to the new record in lastint%nextlink lastint%nextlink=>newintrec endif intrec=>newintrec lastint=>intrec data2: if(mint.lt.nint) then level=0 goto 100 elseif(mint.eq.nint) then ! write(*,*)'3B create property record 3',mint,nint,lfun ! there can be several property records, this will be added last proprec=>intrec%propointer if(associated(proprec%nextpr)) then do while(associated(proprec%nextpr)) ! there can be several property records proprec=>proprec%nextpr enddo call create_mqmqa_proprec(proprec%nextpr,typty,ideg,lfun,refx) else call create_mqmqa_proprec(intrec%propointer,typty,ideg,lfun,refx) endif if(gx%bmperr.ne.0) goto 1000 ! add particular MQMQA data TO THE LAST RECORD proprec=>intrec%propointer do while(associated(proprec%nextpr)) ! there can be several property records proprec=>proprec%nextpr enddo call convert_y2quadx(sem,nint,jord,parquad) if(gx%bmperr.ne.0) goto 1000 proprec%asymdata%quad=parquad(1) proprec%asymdata%alpha=parquad(2) proprec%asymdata%beta=parquad(3) proprec%asymdata%ternary=parquad(4) exit findint else write(*,*)'3B Algorithm is wrong' stop endif data2 endif order endif findint ! write(*,*)'3B we are here!',associated(intrec),mint,nint,jord(2,1:nint) ! 1000 continue return end subroutine enter_mqmqa_excess_param !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine create_mqmqa_excessprop !\begin{verbatim} subroutine create_mqmqa_excessprop(asymdata,sem,nint,jord) ! creates a particular mqmqa excess property record implicit none type(gtp_asymprop) :: asymdata integer :: sem, nint, jord(2,*) !\end{verbatim} %+ integer ii,jj,pair ! we may have to find species records to find the mixed quad and alphabetical ! write(*,100)asymdata%ppow,asymdata%qpow,asymdata%rpow,sem,& ! (jord(2,ii),ii=1,nint) 100 format('3B in mqmqa_excessprop: powers:',3i2,', const: ',10i3) ! the values needed here have been collected in the path up to here ! Two other emquads should have the same elements as in the quad outside enquads ! They whould be ordered alphabetically in quad_ii and quad_jj ! pair=0 ! semloop: do ii=1,mqmqa_data%ncat ! if(mqmqa_data%emquad(ii).eq.sem) exit semloop ! enddo semloop ! sem is the mixed quad AB/X ! pair=sem ! goto 180 !110 contiinue ! int: do jj=1,nint ! do ii=1,mqmqa_data%ncat ! if(mqmqa_data%emquad(ii).eq.jord(jj)) cycle int ! enddo ! goto 110 ! enddo int ! this interaction constituent is the pair quad !110 pair=jord(jj) ! the pair quad is among jord(1..nint) !120 continue ! ! The quad is the index to the fraction to quads asymdata%quad=1 ! the index to ij and ji composition in allonone asymdata%alpha=1 ! if there is a ternary c/X quad this is the index to the y_ik fraction asymdata%ternary=1 ! powers already set ?? ! write(*,200)asymdata%ppow,asymdata%qpow,asymdata%rpow 200 format('3B powers: ',3i3) ! 1000 continue return end subroutine create_mqmqa_excessprop !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine fccpermuts !\begin{verbatim} subroutine fccpermuts(lokph,nsl,iord,noperm,elinks,nint,jord,intperm,intlinks) ! finds all fcc/hcp permutations needed for this parameter ! The order of elements in the sublattices is irrelevant when one has F or B ! ordering as all permutations are stored in one place (with some exceptions) ! Thus the endmembers are ordered alphabetically in the sublattices and also ! the interaction parameters. Max 2 levels of interactions allowed. implicit none integer, dimension(*) :: iord,intperm integer, dimension(2,*) :: jord integer lokph,nsl,noperm,nint !\end{verbatim} %+ integer l2,ll,ib,again,clink,lshift,mshift,a211 integer odd,inz,ip,iqq1,iqq2,isp,jb,jp,jsp,l3,level1,level2,isp2 integer level2perm,lj,loksp,lsp,niqq1,nl1,nl2,nll,np,nq,nz,iz,jz,kz integer ls,mint character pch*64 integer, dimension(4) :: elal,esame integer, dimension(:,:), allocatable :: elinks integer, dimension(:,:), allocatable :: intlinks logical notsame character carr*64 ! integer, dimension(3) :: esame ! !------------------------------------------------------------------- ! ! This is a very long and messy subroutine and it calls others that are ! equally complicated. It is important it is understandable and correct, ! all possible cases has not been tested. Do not try to simplify it by making ! it more messy, this subroutine is not important for calculating speed ! but the structure it creates is important for speed. ! The corresponing routine for bcc permutations is even worse ... unfinished ... ! !------------------------------------------------------------------- ! ! write(*,7)lokph,nsl,nint,noperm 7 format('3B In fccpermuts: ',4i4) ! if(nint.eq.2) then ! write(*,501)'3B fccpermuts1: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2) ! endif ! I assume the ordering is in the first 4 sublattices, that could be changed if(nsl.lt.4) then write(*,*)'3B There must be at least 4 sublattices for fcc/hcp option' gx%bmperr=4267; goto 1000 endif if(nint.gt.2) then write(*,*)'3B Maximum 2nd level interaction with option F' gx%bmperr=4268; goto 1000 endif ! rearrange constituents in alphabetcal order in the sublattices, ! change interactions also! ! write(*,11)'3B fp1: ',(iord(iz),iz=1,4),nint,((jord(jz,kz),jz=1,2),kz=1,nint) 11 format(a,4i4,' interactions: ',i2,4i4) do l2=1,4 if(iord(l2).gt.0) then loksp=phlista(lokph)%constitlist(iord(l2)) elal(l2)=splista(loksp)%alphaindex else elal(l2)=iord(l2) endif enddo ! write(*,11)'3B fp2: ',(elal(iz),iz=1,4),nint,((jord(jz,kz),jz=1,2),kz=1,nint) again=1 lagain: do while(again.ne.0) ! yet another messy sorting again=0 do l2=1,3 do ll=l2+1,4 equal: if(elal(ll).lt.elal(ll-1)) then again=1 ib=elal(ll) elal(ll)=elal(ll-1) elal(ll-1)=ib ! write(*,*)'3B call 1',ll-1,elal(ll-1) call findconst(lokph,ll-1,elal(ll-1),iord(ll-1)) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'3B call 2',ll,elal(ll) call findconst(lokph,ll,elal(ll),iord(ll)) if(gx%bmperr.ne.0) goto 1000 ! if there are interacting constituents in ll or ll-1 shift them also do lj=1,nint if(jord(1,lj).eq.ll) then ! write(*,21)'3B fpi1: ',lj,jord(1,lj),jord(2,lj) 21 format(a,i2,2i4) jord(1,lj)=ll-1 loksp=phlista(lokph)%constitlist(jord(2,lj)) ib=splista(loksp)%alphaindex ! write(*,*)'3B call 3',ll-1,ib call findconst(lokph,ll-1,ib,jord(2,lj)) if(gx%bmperr.ne.0) goto 1000 ! write(*,21)'3B fpi2: ',lj,jord(1,lj),jord(2,lj) elseif(jord(1,lj).eq.ll-1) then ! write(*,21)'3B fpi3: ',lj,jord(1,lj),jord(2,lj) jord(1,lj)=ll loksp=phlista(lokph)%constitlist(jord(2,lj)) ib=splista(loksp)%alphaindex ! write(*,*)'33B call 4',ll,ib call findconst(lokph,ll,ib,jord(2,lj)) if(gx%bmperr.ne.0) goto 1000 ! write(*,21)'3B fpi4: ',lj,jord(1,lj),jord(2,lj) else ! write(*,23)'3B No interactions in sublattice: ',jord(1,lj) 23 format(a,2i3) endif enddo endif equal enddo enddo enddo lagain ! elements are now ordered in alphabetical order over the sublattices ! find how many equal ! if(nint.eq.2) then ! write(*,501)'3B fccpermuts2A: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2) ! endif esame=0 ib=1 esame(ib)=1 do ll=2,4 if(elal(ll).eq.elal(ll-1)) then esame(ib)=esame(ib)+1 else ib=ib+1 esame(ib)=1 endif enddo if(jord(1,1).ne.jord(1,2)) then ! we can have a case AX:AY:A:A and it should not be changed to AXY:A:A:A !!! notsame=.true. else notsame=.false. endif ! we must rearrange interactions so they are in the first sublattice with ! the same endmember element for each level separately ! This is probably redundant as decode_constarr also sorts do l2=1,nint ib=elal(jord(1,l2)) do ll=1,jord(1,l2)-1 if(elal(ll).eq.ib) then ! write(*,*)'3B Shifting interacting constituent to sublattice: ',ll nll=ll if(l2.eq.2 .and. notsame) then ! if interactions should not be in same sublattice but with the same element ! in the endmember, increment ll to interact in next sublattice. It should ! be the same endmember constituent there! if(ll.eq.jord(1,1)) nll=ll+1 ! write(*,*)'3B nll: ',ll,nll endif jord(1,l2)=nll loksp=phlista(lokph)%constitlist(jord(2,l2)) ib=splista(loksp)%alphaindex ! write(*,*)'3B call 5',nll,ib call findconst(lokph,nll,ib,jord(2,l2)) if(gx%bmperr.ne.0) goto 1000 endif enddo enddo ! if(nint.eq.2) then ! write(*,501)'3B fccpermuts2B: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2) ! endif ! write(*,11)'3B fp3: ',(elal(iz),iz=1,4),nint,((jord(jz,kz),jz=1,2),kz=1,nint) ! write(*,11)'3B fp4: ',(iord(iz),iz=1,4) ! make sure that any interaction is connected to the first possible endmember ! for example A:A,B:B:B should be changed to A,B:A:B:B ! Also A,C:A,B:A:A should be A,B:A,C:A:A to have a unique record do l2=1,nint lj=jord(1,l2) do ll=1,lj-1 ! ll must be less than 4 in this loop equalem: if(elal(ll).eq.elal(lj)) then if(l2.eq.1 .or. .not.notsame) then jord(1,l2)=ll loksp=phlista(lokph)%constitlist(jord(2,l2)) ib=splista(loksp)%alphaindex ! write(*,*)'3B call 6',ll,ib call findconst(lokph,ll,ib,jord(2,l2)) if(gx%bmperr.ne.0) goto 1000 else ! l2 must be 2 here, i.e. second order interaction loksp=phlista(lokph)%constitlist(jord(2,1)) ib=splista(loksp)%alphaindex loksp=phlista(lokph)%constitlist(jord(2,2)) jb=splista(loksp)%alphaindex if(jb.lt.ib) then ! change them so the lowest constituent comes first in sublattice order ! write(*,*)'3B call 7',ll,jb call findconst(lokph,ll,jb,jord(2,1)) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'3B call 8',lj,ib call findconst(lokph,lj,ib,jord(2,2)) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'3B exchange: ',ib,jb,jord(2,1),jord(2,2) else ! The interactions should not be in same sublattice, the next sublattice ! must have the same endmember constituent as jord(1,1), put it there if(ll.eq.jord(1,1)) then nll=ll+1 else nll=ll endif jord(1,l2)=nll loksp=phlista(lokph)%constitlist(jord(2,l2)) ib=splista(loksp)%alphaindex ! write(*,*)'3B call 9',nll,ib call findconst(lokph,nll,ib,jord(2,l2)) if(gx%bmperr.ne.0) goto 1000 endif endif endif equalem enddo enddo ! if(nint.eq.2) then ! write(*,501)'3B fccpermuts2C: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2) ! endif !-------------------------------- ! now we can calculate the number of endmember permutations ! Generate also all endmember links in elinks to be stored in endmember record lshift=phlista(lokph)%nooffr(1) if(esame(1).eq.4) then ! all 4 equal noperm=1 allocate(elinks(nsl,noperm)) do ll=1,nsl elinks(ll,1)=iord(ll) enddo elseif(esame(1).eq.3) then ! first 3 equal, one different: A:A:A:B; A:A:B:A; A:B:A:A; B:A:A:A noperm=4 allocate(elinks(nsl,noperm)) do np=1,noperm do ll=1,nsl elinks(ll,np)=iord(ll) enddo if(np.lt.4) then ! shift the single different element forward step by step ib=iord(4-np)+lshift iord(4-np)=iord(5-np)-lshift iord(5-np)=ib endif enddo elseif(esame(1).eq.2) then if(esame(2).eq.2) then ! the two first equal and also last two: A:A:B:B ! A:B:A:B; A:B:B:A; B:A:B:A; B:B;A:A; B:A:A:B ! I have no idea how to make this into a loop so I handle each separately noperm=6 allocate(elinks(nsl,noperm)) np=1 do ll=1,nsl elinks(ll,np)=iord(ll) enddo ! shift sublattice 2 and 3: A:B:A:B ib=iord(2)+lshift iord(2)=iord(3)-lshift iord(3)=ib np=np+1 do ll=1,nsl elinks(ll,np)=iord(ll) enddo ! shift sublattice 3 and 4: A:B:B:A ib=iord(3)+lshift iord(3)=iord(4)-lshift iord(4)=ib np=np+1 do ll=1,nsl elinks(ll,np)=iord(ll) enddo ! shift sublattice 1 and 2: B:A:B:A ib=iord(1)+lshift iord(1)=iord(2)-lshift iord(2)=ib np=np+1 do ll=1,nsl elinks(ll,np)=iord(ll) enddo ! shift sublattice 2 and 3: B:B:A:A ib=iord(2)+lshift iord(2)=iord(3)-lshift iord(3)=ib np=np+1 do ll=1,nsl elinks(ll,np)=iord(ll) enddo ! shift sublattice 2 and 4 (double lenght): B:A:A:B ib=iord(2)+2*lshift iord(2)=iord(4)-2*lshift iord(4)=ib np=np+1 do ll=1,nsl elinks(ll,np)=iord(ll) enddo else ! the first two equal and last 2 different: A:A:B:C a211=1 noperm=12 allocate(elinks(nsl,noperm)) call fccpe211(1,elinks,nsl,lshift,iord) endif elseif(esame(2).eq.3) then ! first different and last 3 equal: A:B:B:B; B:A:B:B; B:B:A:B; B:B:B:A noperm=4 allocate(elinks(nsl,noperm)) do np=1,noperm do ll=1,nsl elinks(ll,np)=iord(ll) enddo if(np.lt.4) then ! shift the single different element backward step by step ib=iord(np)+lshift iord(np)=iord(np+1)-lshift iord(np+1)=ib endif enddo elseif(esame(2).eq.2) then ! two equal but first and last different a211=2 noperm=12 allocate(elinks(nsl,noperm)) call fccpe211(2,elinks,nsl,lshift,iord) elseif(esame(3).eq.2) then ! first two different but last two equal a211=3 noperm=12 allocate(elinks(nsl,noperm)) call fccpe211(3,elinks,nsl,lshift,iord) else ! all 4 different noperm=24 allocate(elinks(nsl,noperm)) call fccpe1111(elinks,nsl,lshift,iord) endif ! always skip debug output of endmembers for interaction parameters intperm(1)=0 ! if(nint.eq.2) then ! write(*,501)'3B fccpermuts3D: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2) ! endif if(nint.eq.0) goto 200 ! uncomment next line to have debug output goto 200 !-------------------- ! debug output of endmembers after rearranging carr='fp6: ' ib=6 l3=1 do ll=1,4 if(elal(ll).gt.0) then l2=len_trim(splista(species(elal(ll)))%symbol) write(carr(ib:),16)splista(species(elal(ll)))%symbol(1:l2) 16 format(a) ib=ib+l2 else carr(ib:)='*' ib=ib+1 endif 17 continue if(l3.le.nint) then if(jord(1,l3).eq.ll) then loksp=phlista(lokph)%constitlist(jord(2,l3)) l2=len_trim(splista(loksp)%symbol) write(carr(ib:),18)splista(loksp)%symbol(1:l2) 18 format(',',a) ib=ib+l2+1 l3=l3+1 goto 17 endif endif if(ll.lt.4) carr(ib:ib)=':' ib=ib+1 enddo write(*,19)carr(1:ib) write(*,19)' fp7: ',esame,noperm 19 format('3B ',a,4i3,i5) ! More debug output: all endmember permutations do np=1,noperm ! listing indices in constituent list (stored in endmember record) write(*,31)np,(elinks(ll,np),ll=1,nsl) 31 format('3B elinks: ',i3,3x,10i4) enddo do np=1,noperm ! Easier to check listing of permutations using constituent names carr=' ' ib=1 do ll=1,nsl if(elinks(ll,np).gt.0) then loksp=phlista(lokph)%constitlist(elinks(ll,np)) l2=len_trim(splista(loksp)%symbol) write(carr(ib:),32)splista(loksp)%symbol(1:l2) 32 format(a,':') ib=ib+l2+1 else carr(ib:)='*:' ib=ib+2 endif enddo write(*,33)np,carr 33 format('3B emperm ',i3,': ',a) enddo ! debug output of endmembers end !-------------------- 200 continue ! done arranging component array and permutations of endmembers if(nint.eq.0) then goto 1000 endif !=============================================== ! Now the 1st level interactions ... store in intlinks(1..2) allocate(intlinks(2,100)) ! intperm(1)=number of interaction permutations on level 1 for each endmember ! on level 1 each endmember permutation has the same ! intperm(2)=total number of permutation links for level 1 ! intperm(3..) used for 2nd level select case(noperm) case default ! error ! write(*,*)'3B Unknown case for endmemeber permutations: ',noperm gx%bmperr=4269 !---------- case(1) ! A:A:A:A ! if(nint.eq.2) then ! write(*,501)'3B fccpermuts4: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2) ! endif if(jord(1,1).ne.1) then ! write(*,*)'3B Interaction must be in sublattice 1' gx%bmperr=4270; goto 1000 endif intperm(1)=4 intperm(2)=4 clink=jord(2,1) ! set links to interaction with same element in all 4 sublattices do l2=1,4 intlinks(1,l2)=l2 intlinks(2,l2)=clink clink=clink+lshift enddo level1=1 !---------- case(4) ! A:A:A:B and A:B:B:B if(esame(1).eq.3) then if(jord(1,1).eq.1) then ! the interaction must be AX:A:A:B call fccint31(jord,lshift,intperm,intlinks) level1=2 else ! the interaction must be A:A:A:BX intperm(1)=1 intperm(2)=4 intlinks(1,1)=4 intlinks(2,1)=jord(2,1) do ll=2,4 intlinks(1,ll)=5-ll intlinks(2,ll)=intlinks(2,ll-1)-lshift enddo level1=3 endif elseif(jord(1,1).eq.2) then ! the interaction must be A:BX:B:B call fccint31(jord,lshift,intperm,intlinks) level1=4 else ! the interaction must be AX:B:B:B intperm(1)=1 intperm(2)=4 intlinks(1,1)=1 intlinks(2,1)=jord(2,1) do ll=2,4 intlinks(1,ll)=ll intlinks(2,ll)=intlinks(2,ll-1)+lshift enddo level1=5 endif !---------- case(6) ! A:A:B:B call fccint22(jord,lshift,intperm,intlinks) level1=6 !---------- case(12) ! A:A:B:C; A:B:B:C; A:B:C:C if(a211.eq.jord(1,1)) then call fccint211(a211,jord,lshift,intperm,intlinks) level1=7 else ! 2017.03.15, looking for bug and had some difficulties to understand ! here we set the first interaction with one of the single constituents ! we have to find the permutation of the endmember component in 4 sublattices ! starting from sublattice 1. There are 12 endemember permutations ! write(*,666)a211,lshift,jord(1,1),jord(2,1),jord(1,2),jord(2,2) 666 format('3B jord mm: ',2i4,2x,2i4,2x,2i4,' <<<<<<<<<<<<<<<<<<<<<<<<<<') ! jord(1,1) is first interacting sublattice ! jord(2,1) is first interacting constituent index counted from first sublattice intperm(1)=1 intperm(2)=noperm l2=jord(1,1) ! This is the endmember component of the interaction parameter ib=phlista(lokph)%constitlist(elinks(l2,1)) intlinks(1,1)=jord(1,1) intlinks(2,1)=jord(2,1) do ll=2,noperm do l3=1,4 ! search all sublattices for the endmember constituent, ib, skipping wildcards if(elinks(l3,ll).gt.0) then jb=phlista(lokph)%constitlist(elinks(l3,ll)) ! Here is the endmember componenent, add the interaction to same sublattice if(jb.eq.ib) goto 410 endif enddo write(*,*)'3B Cannot find endmember element for premutation ',ll,ib gx%bmperr=4271; goto 1000 410 continue intlinks(1,ll)=l3 mshift=(intlinks(1,ll)-intlinks(1,ll-1))*lshift ! we have to calculate the index of the intreraction component in yarr intlinks(2,ll)=intlinks(2,ll-1)+mshift ! write(*,422)'X',ll,l3,jord(1,1),mshift,intlinks(1,ll),intlinks(2,ll) enddo ! This is used to insert the second interaction (if any) level1=8 endif !---------- case(24) ! A:B:C:D write(*,77) 77 format(' *** CONGRATULATIONS, '/& ' You may be the first to enter a parameter like this!!!') intperm(1)=1 intperm(2)=noperm l2=jord(1,1) ! species number in endmember of interacting sublattice ib=phlista(lokph)%constitlist(elinks(l2,1)) intlinks(1,1)=l2 intlinks(2,1)=jord(2,1) do ll=2,24 do l3=1,4 jb=phlista(lokph)%constitlist(elinks(l3,ll)) if(jb.eq.ib) goto 420 ! write(*,419)'3B elinks,ib: ',ll,l3,ib,jb,elinks(l3,ll) !419 format(a,2i4,2x,3i4) enddo write(*,*)'3B Cannot find endmember element for premutation ',ll,ib gx%bmperr=4271; goto 1000 420 continue intlinks(1,ll)=l3 mshift=(intlinks(1,ll)-intlinks(1,ll-1))*lshift intlinks(2,ll)=intlinks(2,ll-1)+mshift ! write(*,422)'Y',ll,l3,jord(1,1),mshift,intlinks(1,ll),intlinks(2,ll) 422 format('3B option F spec ',a,': ',3i3,2x,i7,2x,2i7) enddo ! level1=9 means not implemented level1=9 end select 500 continue if(nint.eq.1) goto 900 !================================================================ ! 2nd level interaction permutations ! write(*,*)'3B First level interaction type: ',level1 ! write(*,502)'3B elinks and jord: ',elal,((jord(i,j),i=1,2),j=1,2) 501 format(a,2(2i4,2x)) 502 format(a,4(i4),' : ',2(2i4,2x)) ! ! The simplest 2nd level interaction is in the same sublattice as first if(jord(1,2).eq.jord(1,1)) then ! AXY:B:C:D where X and Y are two different constituents (not A) and B, C, D ! can be any constituents. There are no new permutations, just add Y ! write(*,*)'3B shortcut' intperm(3)=1 intperm(4)=1 ! intperm(4+intperm(3)) should be total number of permutations!! ! intperm(2) is number of endmeber+first interaction permutations intperm(5)=2*intperm(2) nz=intperm(2) loksp=phlista(lokph)%constitlist(jord(2,2)) isp=splista(loksp)%alphaindex do np=1,intperm(2) intlinks(1,nz+np)=intlinks(1,np) call findconst(lokph,intlinks(1,np),isp,intlinks(2,nz+np)) if(gx%bmperr.ne.0) goto 1000 enddo ! for debug output goto 900 endif !----------------------------------------------------------- select case(level1) case default !error write(*,*)'3B Unknown case for permutations on level 1: ',level1 gx%bmperr=4272 !----------------------------------------------------------- case(1) ! AXY:A:A:A or AX:AX:A:A or AX:AY:A:A call fccip2A(lokph,jord,intperm,intlinks) if(gx%bmperr.ne.0) goto 1000 !----------------------------------------------------------- case(2) ! AXY:A:A:B or AX:AY:A:B or AX:A:A:BY ! write(*,*)'3B case 2: ',jord(1,2),jord(2,2) if(jord(1,2).eq.4) then ! AX:A:A:BY, there should be 12 permutations, no new on second level intperm(3)=1 intperm(4)=1 intperm(5)=12 nz=intperm(2) loksp=phlista(lokph)%constitlist(jord(2,2)) isp=splista(loksp)%alphaindex do np=1,4 ! sublattice for B the same for 3 permutations do nq=1,3 nz=nz+1 intlinks(1,nz)=5-np call findconst(lokph,5-np,isp,intlinks(2,nz)) if(gx%bmperr.ne.0) goto 1000 enddo enddo else ! AX:AY:A:B call fccip2B(1,lokph,lshift,jord,intperm,intlinks) if(gx%bmperr.ne.0) goto 1000 endif !----------------------------------------------------------- case(3) ! A:A:A:BXY ! never here as taken care by shortcut above ?? if(jord(1,2).ne.jord(1,1)) then ! write(*,*)'3B Thinking error, restructure!' gx%bmperr=4273; goto 1000 endif !----------------------------------------------------------- case(4) ! A:BXY:B:B or A:BX:BY:B; no AY:BX:B:B as that would be case 5 ! A:BX:BY:B call fccip2B(2,lokph,lshift,jord,intperm,intlinks) if(gx%bmperr.ne.0) goto 1000 !----------------------------------------------------------- case(5) ! AX:BY:B:B ! This parameter has just 4 endmember permutations. On this level 3 more ! AX:B:B:B AX:BY:B:B AX:B:BY:B AX:B:B:BY ! B:AX:B:B B:AX:BY:B B:AX:B:BY BY:AX:B:B etc intperm(3)=1 intperm(4)=3 intperm(5)=12 loksp=phlista(lokph)%constitlist(jord(2,2)) isp=splista(loksp)%alphaindex nz=intperm(2) do np=1,4 nll=intlinks(1,np) do ip=1,3 nz=nz+1 nll=nll+1 if(nll.gt.4) nll=1 intlinks(1,nz)=nll call findconst(lokph,nll,isp,intlinks(2,nz)) if(gx%bmperr.ne.0) goto 1000 enddo enddo ! endif !----------------------------------------------------------- ! This is the important the BINARY reciprocal excess parameter case(6) ! AX:A:B:B or A:A:BX:B, 6 endmem and 2 level 1 permutations = 12 ! AX:A:B:B: AX:AX:B:B: 1; 0 totally 6 permutations ! AX:A:B:B: AX:AY:B:B and AY:AX:B:B; 2 additional permutations, totally 24 loksp=phlista(lokph)%constitlist(jord(2,2)) jsp=splista(loksp)%alphaindex if(abs(jord(1,2)-jord(1,1)).gt.1) then ! level 2 interaction with another endmember constituent than level 1 ! AX:A:BY:B; 2 additional permutations, totally 24 ! The endmember permutations will put element B in sublattices: ! 3,4; 2,4; 2,3; 1,3; 1,2; 1,4; If that changes this must be changed too ... intperm(3)=1 intperm(4)=2 intperm(5)=24 nz=intperm(2) nl1=3 nl2=4 do ip=1,6 nz=nz+1 intlinks(1,nz)=nl1 call findconst(lokph,nl1,jsp,intlinks(2,nz)) if(gx%bmperr.ne.0) goto 1000 nz=nz+1 intlinks(1,nz)=nl2 call findconst(lokph,nl2,jsp,intlinks(2,nz)) if(gx%bmperr.ne.0) goto 1000 nz=nz+1 intlinks(1,nz)=nl1 call findconst(lokph,nl1,jsp,intlinks(2,nz)) if(gx%bmperr.ne.0) goto 1000 nz=nz+1 intlinks(1,nz)=nl2 call findconst(lokph,nl2,jsp,intlinks(2,nz)) if(gx%bmperr.ne.0) goto 1000 select case(nl1) case default ! write(*,*)'3B Error in fccpermut, case(lavel1=6), case(nl1)' gx%bmperr=4274; goto 1000 case(1) ! change nl2 to 2 or 4, nl1 should be 1 if(nl2.eq.2) nl2=4 if(nl2.eq.3) nl2=2 case(2) ! change nl2 to 3 if(nl2.eq.3) then nl1=1 nl2=3 else nl2=3 endif case(3) ! change nl1 to 2 nl1=2 end select enddo else ! interaction with same endmember element in 2 different sublattices ! write(*,*)'3B smart?' loksp=phlista(lokph)%constitlist(jord(2,1)) isp=splista(loksp)%alphaindex if(isp.eq.jsp) then ! AX:AX:B:B or A:A:BX:BX, there are 12 permutations of AX:A:B:B on level 1 ! but there are only 6 second level interactions ! The endmember permutations will put element A in sublattices: ! 1,2; 1,3; 1,4; 2,4; 3,4; 2,3; and element B in sublattices: ! 3,4; 2,4; 2,3; 1,3; 1,2; 1,4; intperm(3)=2 intperm(4)=1 intperm(5)=0 intperm(6)=6 nz=intperm(2) if(jord(1,1).eq.1) then nll=2 else nll=4 endif odd=1 do np=1,12 odd=1-odd do jp=1,intperm(4+odd) ! this loop is done 1 or 0 times twice; nll=2,3,4; 4,4,3 // 4,4,3; 3,2,4 nz=nz+1 intlinks(1,nz)=nll call findconst(lokph,nll,jsp,intlinks(2,nz)) if(gx%bmperr.ne.0) goto 1000 ! nz= 13,14,15,16,17,18,19 ! nll= 2, 3, 4, 4, 4, 3, - if jord(1,1)=1 ! nll= 4, 4, 3, 3, 2, 4, - if jord(1,1)=2 select case(nz) case default write(*,*)'3B Error in fccpermut, case(lavel1=6), nz=',nz gx%bmperr=4274; goto 1000 case(13) ! change nll to 3 if 2, else same if(nll.eq.2) nll=3 ! 3 or same case(14) ! the if .., ! if(nll.eq.4) then ! nll=3 ! else ! nll=4 ! endif ! is same as nll=7-nll nll=7-nll case(15,18) ! no change!! continue case(16) if(nll.eq.3) nll=2 case(17) if(nll.eq.4) nll=3 if(nll.eq.2) nll=4 end select enddo enddo ! if the case and loops above works they are smart and easy to understand ??? else ! AX:AY:B:B or A:A:BX:BY ! In this case we have the sume number of level2 permutations as level1 ! Just add an interaction on the other sublattice with same endmember ! The endmember permutations will put element A in sublattices: ! 1,2; 1,3; 1,4; 2,4; 3,4; 2,3; and element B in sublattices: ! 3,4; 2,4; 2,3; 1,3; 1,2; 1,4; ! The first interaction will be with the first of the sublattices, the ! second in the second, just switch intperm(3)=1 intperm(4)=1 intperm(5)=intperm(2) nz=intperm(2) do np=1,6 ! Here AX:AY:B:B and AY:AX:B:B nz=nz+1 nll=intlinks(1,nz-11) nl2=intlinks(1,nz-12) intlinks(1,nz)=nll ! write(*,73)'3B loop 6B: ',np,nll,nl2,nz 73 format(a,10i4) call findconst(lokph,nll,jsp,intlinks(2,nz)) if(gx%bmperr.ne.0) goto 1000 ! set the second interaction in sublattice with level 1 interaction nz=nz+1 intlinks(1,nz)=nl2 call findconst(lokph,nl2,jsp,intlinks(2,nz)) if(gx%bmperr.ne.0) goto 1000 enddo ! if the case and loops above works they are smart and easy to understand ??? endif endif !----------------------------------------------------------- ! Maybe this can wait a little ... case(7) ! AX:A:B:C or A:BX:B:C or A:B:CX:C write(*,*)'3B FCC permutation not yet implemented 7' gx%bmperr=4275 !----------------------------------------------------------- ! Maybe this can wait a little ... NO ! trying to understand what I did 3 years ago .... ! Parameter is actually a reciprocal one ... A:A:BX:CY case(8) ! A:A:BX:C or similar, 12 endmember permutations ! write(*,*)'3B noperm, intperm(1..2): ',noperm,intperm(1),intperm(2) ! do mint=1,noperm ! write(*,661)mint,(elinks(ls,mint),ls=1,4) ! enddo 661 format('3B em permutation: ',i4,(i6,3i4)) ! permutations: 12 ! endmember 1st order 2nd order ! A:A:B:C A:A:BX:C A:A:BX:CY ! A:A:C:B A:A:C:BX A:A:CY:BX ! A:C:A:B A:C:A:BX A:CY:A:BX ! A:C:B:A A:C:BX:A A:CY:BX:A ! A:B:C:A A:BX:C:A A:BX;CY:A ! A:B:A:C etc ! B:A:A:C ! B:A:C:A ! B:C:A:A ! C:B:A:A ! C:A:B:A ! C:A:A:B ! The good news: there are no new permutations!! intperm(3)=1 intperm(4)=1 intperm(5)=12 nz=intperm(2) ! loksp=phlista(lokph)%constitlist(jord(2,2)) ! isp=splista(loksp)%alphaindex loksp=phlista(lokph)%constitlist(jord(2,2)) isp2=splista(loksp)%alphaindex ! jord(2,*) are constituent indices, must be converted to species ! write(*,*)'3B jord: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2) ! B moves as 3, 4, 4, 3, 2, 2, 1, 1, 1, 2, 3, 4 ! C moves as 4, 3, 2, 2, 3, 4, 4, 3, 2, 1, 1, 1 ! do it the hard way ... nz=nz+1 intlinks(1,nz)=4 call findconst(lokph,intlinks(1,nz),isp2,intlinks(2,nz)) if(gx%bmperr.ne.0) goto 1000 nz=nz+1 intlinks(1,nz)=3 call findconst(lokph,intlinks(1,nz),isp2,intlinks(2,nz)) if(gx%bmperr.ne.0) goto 1000 nz=nz+1 intlinks(1,nz)=2 call findconst(lokph,intlinks(1,nz),isp2,intlinks(2,nz)) if(gx%bmperr.ne.0) goto 1000 nz=nz+1 intlinks(1,nz)=2 call findconst(lokph,intlinks(1,nz),isp2,intlinks(2,nz)) if(gx%bmperr.ne.0) goto 1000 nz=nz+1 intlinks(1,nz)=3 call findconst(lokph,intlinks(1,nz),isp2,intlinks(2,nz)) if(gx%bmperr.ne.0) goto 1000 nz=nz+1 intlinks(1,nz)=4 call findconst(lokph,intlinks(1,nz),isp2,intlinks(2,nz)) if(gx%bmperr.ne.0) goto 1000 ! nz=nz+1 intlinks(1,nz)=4 call findconst(lokph,intlinks(1,nz),isp2,intlinks(2,nz)) if(gx%bmperr.ne.0) goto 1000 nz=nz+1 intlinks(1,nz)=3 call findconst(lokph,intlinks(1,nz),isp2,intlinks(2,nz)) if(gx%bmperr.ne.0) goto 1000 nz=nz+1 intlinks(1,nz)=2 call findconst(lokph,intlinks(1,nz),isp2,intlinks(2,nz)) if(gx%bmperr.ne.0) goto 1000 nz=nz+1 intlinks(1,nz)=1 call findconst(lokph,intlinks(1,nz),isp2,intlinks(2,nz)) if(gx%bmperr.ne.0) goto 1000 nz=nz+1 intlinks(1,nz)=1 call findconst(lokph,intlinks(1,nz),isp2,intlinks(2,nz)) if(gx%bmperr.ne.0) goto 1000 nz=nz+1 intlinks(1,nz)=1 call findconst(lokph,intlinks(1,nz),isp2,intlinks(2,nz)) if(gx%bmperr.ne.0) goto 1000 ! Code below is just to check the constituents are correctly sorted ! NOTE jord(2,*) is phase constituent index, not species index pch='G('//trim(phlista(lokph)%name)//',' ip=len_trim(pch)+1 mint=1 do ls=1,4 if(elal(ls).lt.0) then pch(ip:)='*:' else pch(ip:)=trim(splista(species(elal(ls)))%symbol)//':' endif ip=len_trim(pch)+1 if(mint.le.nint .and. jord(1,mint).eq.ls) then loksp=phlista(lokph)%constitlist(jord(2,mint)) isp=splista(loksp)%alphaindex ! write(*,*)'3B test 1: ',mint,jord(1,mint),jord(2,mint),isp ! write(*,*)'3B test 2: ',species(jord(2,mint)) pch(ip-1:)=','//trim(splista(species(isp))%symbol)//':' ip=len_trim(pch)+1 mint=mint+1 endif enddo ! pch(ip-1:)=';0)' ! write(*,503)trim(pch) 503 format(/'3B *** This parameter ',a,' just implemented 8') ! write(*,*)'3B FCC permutation not yet implemented 8' ! gx%bmperr=4275 !----------------------------------------------------------- ! Maybe this can wait a little ... case(9) ! AX:B:C:D or similar write(*,*)'3B FCC permutation not yet implemented 9' gx%bmperr=4275 end select !----------------------------------------------------------- ! done permutations of interactions ! write(*,510)'3B 510: ',(intperm(j),j=1,7) 510 format(a,10i4) !------- debug output of first level interaction permutations 900 continue ! to skip remove comment on next line ! goto 1000 if(nint.eq.2) then ! write(*,905)'3B Permutations of endmem and intlevel 1: ',noperm,& ! intperm(1),intperm(2) ! write(*,905)'3B Permutations of intlevel 2: ',intperm(3),& ! (intperm(3+i),i=1,intperm(3)) 905 format(a,i5,2x,10i4) endif ! these are the base pointers to first and second level permutations iqq1=0 iqq2=intperm(2)+1 inz=0 emdmem: do np=1,noperm ! for each endmember permutation there are intperm(1) level 1 permutations intlev1: do niqq1=1,intperm(1) iqq1=iqq1+1 if(nint.eq.2) then level2=1 if(intperm(3).eq.1) then ! there is a fixed number of 2nd level permutations level2perm=intperm(4) else ! the number of 2nd level interaction varies with the first level, it can be 0 level2perm=intperm(3+niqq1) if(level2perm.eq.0) cycle intlev1 endif else ! no 2nd level interaction iqq2=0 endif 910 continue carr=' ' ib=1 subl: do ll=1,nsl ! endmember constituent, can be wildcard loksp=elinks(ll,np) if(loksp.gt.0) then loksp=phlista(lokph)%constitlist(loksp) lsp=len_trim(splista(loksp)%symbol) carr(ib:)=splista(loksp)%symbol(1:lsp) ib=ib+lsp else carr(ib:ib)='*' ib=ib+1 endif 920 continue if(intlinks(1,iqq1).eq.ll) then ! level 1 interaction constituent ! NOTE: For error checks output of intlinks is more important than the ! constituent name in carr as the link also indicates the sublattice!!! ! if(nint.eq.2) & ! write(*,922)1,iqq1,intlinks(1,iqq1),intlinks(2,iqq1) 922 format('3B intlinks: ',2i5,2x,2i5,2x,3i5) loksp=phlista(lokph)%constitlist(intlinks(2,iqq1)) lsp=len_trim(splista(loksp)%symbol) carr(ib:)=','//splista(loksp)%symbol(1:lsp) ib=ib+lsp+1 endif if(iqq2.gt.0) then if(intlinks(1,iqq2).eq.ll) then ! level 2 interaction constituent ! NOTE: For error checks output of intlinks is more important than the ! constituent name in carr as the link also indicates the sublattice!!! ! write(*,922)2,iqq2,intlinks(1,iqq2),intlinks(2,iqq2),jord(2,2) loksp=phlista(lokph)%constitlist(intlinks(2,iqq2)) lsp=len_trim(splista(loksp)%symbol) carr(ib:)=','//splista(loksp)%symbol(1:lsp) ib=ib+lsp+1 endif endif if(ll.lt.nsl) then carr(ib:)=': ' ib=ib+2 endif enddo subl inz=inz+1 ! write(*,925)inz,carr(1:len_trim(carr)) 925 format('3B inter perm ',i3,': ',a) if(iqq2.gt.0) then ! there are level2perm number of 2nd order permutations level2=level2+1 iqq2=iqq2+1 if(level2.le.level2perm) goto 910 endif enddo intlev1 enddo emdmem !------- debug output end 1000 continue return end subroutine fccpermuts !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine fccip2A !\begin{verbatim} %- subroutine fccip2A(lokph,jord,intperm,intlinks) ! 2nd level interaction permutations for fcc implicit none integer, dimension(*) :: intperm integer, dimension(2,*) :: jord,intlinks integer lokph !\end{verbatim} %+ integer loksp,isp,jsp,ij,nll,ll,iqq,nz,ik ! AX:A:A:A, 2nd level can be AXY:A:A:A, AX:AX:A:A or AX:AY:A:A loksp=phlista(lokph)%constitlist(jord(2,2)) isp=splista(loksp)%alphaindex ! write(*,2)'3B fccip2A1: ',((jord(i,j),i=1,2),j=1,2) !2 format(a,2(2i3,2x)) ! 2nd level interaction in another sublattice, AX:AX:A:A or AX:AY:A:A loksp=phlista(lokph)%constitlist(jord(2,1)) jsp=splista(loksp)%alphaindex ! write(*,*)'3B fccip2A2: ',isp,jsp if(isp.eq.jsp) then ! 2nd level interacting constituent same as first level constituent: ! Level 1: Level2: ! AX:A:A:A; AX:AX:A:A; AX:A:AX:A; AX:A:A:AX 3 permutations ! A:AX:A:A; A:AX:AX:A; A:AX:A:AX 2 permutations ! A:A:AX:A; A:A:AX:AX 1 permutations ! A:A:A:AX; none 0 permutations ! write(*,*)'3B same interaction constituent in different sublattices' intperm(3)=4 intperm(4)=3 intperm(5)=2 intperm(6)=1 intperm(7)=0 intperm(8)=24 iqq=intperm(2) do ij=1,3 ! loop only to 3 as there is no 2nd level permutation for ij=4 nll=intlinks(1,ij) do ll=1,intperm(3+ij) iqq=iqq+1 nll=nll+1 intlinks(1,iqq)=nll if(nll.gt.4) then ! write(*,*)'3B Error in 2nd level interaction of AX:AX:A:A' gx%bmperr=4276; goto 1000 endif call findconst(lokph,intlinks(1,iqq),isp,intlinks(2,iqq)) if(gx%bmperr.ne.0) goto 1000 ! write(*,76)'3B loop:',ij,nll,iqq,intlinks(1,iqq),intlinks(2,iqq) 76 format(a,3i3,2x,2i4) enddo enddo ! debug output ! nc=0 ! nc1=0 ! nc2=intperm(2) ! do lj=1,4 ! do ljj=1,intperm(3+lj) ! nc=nc+1 ! nc1=nc1+1 ! nc2=nc2+1 ! write(*,77)nc,lj,ljj,& ! (intlinks(i,nc1),i=1,2),(intlinks(i,nc2),i=1,2) 77 format('3B AX:AX:A:A: ',i3,2x,2i3,2x,2(2i4,2x)) ! enddo ! enddo else ! If 2nd level interacting element different ! Level 1: Level2: ! AX:A:A:A; AX:AY:A:A; AX:A:AY:A; AX:A:A:AY 3 permutations ! A:AX:A:A; AY:AX:A:A; A:AX:AY:A; A:AX:A:AY 3 permutations ! A:A:AX:A; AY:A:AX:A; A:AY:AX:A; A:A:AX:AY 3 permutations ! A:A:A:AX; AY:A:A:AX; A:AY:A:AX; A:A:AY:AX 3 permutations ! write(*,*)'3B different interaction constituent in different sublattices' intperm(3)=1 intperm(4)=3 intperm(5)=12 nz=intperm(2) do ik=1,4 ! Note that these permutations include AY:AX:A:A linked from AX:A:A:A ! A first level interaction AY:A:A:A is stored in another interaction record ! with no link to this 2nd level interaction. nll=intlinks(1,ik) do ll=1,3 nll=nll+1 if(nll.gt.4) nll=1 nz=nz+1 intlinks(1,nz)=nll call findconst(lokph,nll,isp,intlinks(2,nz)) if(gx%bmperr.ne.0) goto 1000 ! write(*,88)nz,ik,ll,intlinks(1,nz),intlinks(2,nz) 88 format('3B loop: ',3i3,2x,2i5) enddo enddo endif 1000 continue return end subroutine fccip2A !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine fccip2B !\begin{verbatim} %- subroutine fccip2B(lq,lokph,lshift,jord,intperm,intlinks) ! 2nd level interaction permutations for fcc implicit none integer lq,lokph,lshift integer, dimension(*) :: intperm integer, dimension(2,*) :: jord,intlinks !\end{verbatim} %+ integer loksp,isp,jsp,ny,nz,mp,isub2,nll,ip,np ! lq=1 means AX:AY:A:B or AX:AX:A:B ! lq=2 means A:BX:BY:B or A:BX:BX:B ! This parameter has 4 endmember permuts each with 3 permuts on level 1 ! if X is same as Y only 2; 1; 0 loksp=phlista(lokph)%constitlist(jord(2,1)) isp=splista(loksp)%alphaindex loksp=phlista(lokph)%constitlist(jord(2,2)) jsp=splista(loksp)%alphaindex ! write(*,*)'3B fccip2B3: ',isp,jsp if(isp.eq.jsp) then ! Endmember Level 1 Level 2 2; 1; 0; ! A:A:A:B AX:A:A:B AX:AX:A:B AX:A:AX:B ! A:AX:A:B A:AX:AX:B ! A:A:AX:B none ! A:A:B:A AX:A:B:A AX:AX:B:A AX:A:B:AX ! A:AX:B:A A:AX:B:AX ! A:A:B:AX none ! A:B:A:A AX:B:A:A AX:B:AX:A AX:B:A:AX ! A:B:AX:A A:B:AX:AX ! A:B:A:AX none ! B:A:A:A B:AX:A:A B:AX:AX:A B:AX:A:AX ! B:A:AX:A B:A:AX:AX ! B:A:A:AX none ! or the same for endmember A:B:B:B intperm(3)=3 intperm(4)=2 intperm(5)=1 intperm(6)=0 intperm(7)=intperm(2) ny=0 nz=intperm(2) mp=3 ! these loops are frustratingly messy .... but they seem to work ... nploop: do np=1,intperm(2) mp=mp+1 if(lq.eq.1) then ! isub2 is the endmember sublattice occupied by the "different" constituent ! isub2=(20-np)/4 isub2=(15-np)/3 else ! isub2=(3+np)/4 isub2=(2+np)/3 endif ! nll is the sublattice with 1st level interaction ny=ny+1 nll=intlinks(1,ny) ! np = 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12 ! mp = 4, 5, 6, 4, 5, 6, 4, ... ! intperm(mp) = 2, 1, 0, 2, 1, 0, 2, 1, 0, 2, 1, 0 do ip=1,intperm(mp) nll=nll+1 if(nll.eq.isub2) nll=nll+1 nz=nz+1 intlinks(1,nz)=nll ! write(*,13)'3B AX:AX:A:B: ',np,mp,ip,isub2,nz,nll,jsp 13 format(a,4i3,2x,i3,2i5) call findconst(lokph,nll,jsp,intlinks(2,nz)) if(gx%bmperr.ne.0) goto 1000 enddo if(mod(np,3).eq.0) mp=3 enddo nploop else ! Endmember Level 1 Level 2 2; ! A:A:A:B AX:A:A:B AX:AY:A:B AX:A:AY:B ! A:AX:A:B A:AX:AY:B AY:AX:A:B ! A:A:AX:B AY:A:AX:B A:AY:AX:B ! A:A:B:A AX:A:B:A AX:AY:B:A AX:A:B:AY etc ! There are 2 additional permutations for each of the 12 existing, the problem ! is mainly to know in which sublattice to add the interaction intperm(3)=1 intperm(4)=2 intperm(5)=2*intperm(2) ny=0 nz=intperm(2) do np=1,intperm(2) if(lq.eq.1) then ! isub2 is the endmember sublattice occupied by the "different" constituent isub2=(15-np)/3 else ! isub2 should be 1 for np=1..4, 2 for np=4..7 etc isub2=(np+2)/3 endif ! nll is the sublattice with 1st level interaction ny=ny+1 nll=intlinks(1,ny) do ip=1,2 ! set 2nd interaction in sublattice after first interaction. If that ! sublattice is >4 set it in first. If the endmember is the single other ! constituent set it in next. If that is >4 set it in first nll=nll+1 if(nll.gt.4) nll=1 if(nll.eq.isub2) nll=nll+1 if(nll.gt.4) nll=1 nz=nz+1 intlinks(1,nz)=nll ! write(*,13)'3B AX:AY:A:B: ',np,ip,0,isub2,nz,nll,jsp call findconst(lokph,nll,jsp,intlinks(2,nz)) if(gx%bmperr.ne.0) goto 1000 enddo enddo endif 1000 continue return end subroutine fccip2B !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine fccint31 !\begin{verbatim} %- subroutine fccint31(jord,lshift,intperm,intlinks) ! 1st level interaction in sublattice l1 with endmember A:A:A:B or A:B:B:B ! set the sublattice and link to constituent for each endmember permutation ! 1st permutation of endmember: AX:A:A:B; A:AX:A:B; A:A:AX;B 4 0 1 2 ! 2nd permutation of endmember: AX:A:B:A; A:AX:B:A; A:A:B:AX 3 0 1 3 ! 3rd permutation of endmember: AX:B:A:A; A:B:AX:A; A:B:A:AX 3 0 2 3 ! 4th permutation of endmember: B:AX:A:A; B:A:AX:A; B:A:A:AX 1 or 1 2 3 ! 1st permutation of endmember: A:BX:B:B; A:B:BX:B; A:B:B:BX 4 0 1 2 ! 2nd permutation of endmember: BX:A:B:B; B:A:BX:B; B:A:B:BX 1 etc -1 1 2 ! 3rd -1 0 2 ; -1 0 1 ! suck implicit none integer lshift integer, dimension(2,*) :: jord,intlinks integer, dimension(*) :: intperm !\end{verbatim} %+ integer l2,shift0,shift1,shift2,clink,idis,np ! intperm(1)=3 intperm(2)=12 l2=jord(1,1) clink=jord(2,1) idis=0 shift0=0 shift1=1 shift2=2 do np=1,4 intlinks(1,idis+1)=l2+shift0 intlinks(2,idis+1)=clink+shift0*lshift intlinks(1,idis+2)=l2+shift1 intlinks(2,idis+2)=clink+shift1*lshift intlinks(1,idis+3)=l2+shift2 intlinks(2,idis+3)=clink+shift2*lshift idis=idis+3 subl: if(l2.eq.1) then if(np.eq.1) then shift2=3 elseif(np.eq.2) then shift1=2 elseif(np.eq.3) then shift0=1 endif else if(np.eq.1) then shift0=-1 elseif(np.eq.2) then shift1=0 else shift2=1 endif endif subl enddo 1000 return end subroutine fccint31 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine fccint22 !\begin{verbatim} %- subroutine fccint22(jord,lshift,intperm,intlinks) ! 1st level for endmember A:A:B:B with interaction in sublattice jord(1,1) ! 6 permutations of endmember, 2 permutations of interactions, 12 in total ! 1st endmemperm: AX:A:B:B; A:AX:B:B 0 1 ! 2nd endmemperm: AX:B:A:B; A:B:AX:B 0 2 ! 3rd endmemperm: AX:B:B:A; A:B:B:AX 0 3 ! 4th endmemperm: B:AX:B:A; B:A:B:AX 1 3 ! 5th endmemperm: B:B:AX:A; B:B:A:AX 2 3 ! 6th endmemperm: B:AX:A:B; B:A:AX:B or 1 2 ! 1th endmemperm: A:A:BX:B; A:A:B:BX 0 1 ! 2nd endmemperm: A:BX:A:B; A:B:A:BX -1 1 ! 3rd endmemperm: A:BX:B:A; A:B:BX:A -1 0 ! 4th endmemperm: BX:A:B:A; B:A:BX:A -2 0 ! 5th endmemperm: BX:B:A:A; B:BX:A:A -2 -1 ! 6th endmemperm: BX:A:A:B; B:A:A:BX -2 1 implicit none integer lshift integer, dimension(2,*) :: jord,intlinks integer, dimension(*) :: intperm !\end{verbatim} %+ integer shift0,shift1,l2,clink,idis,np ! intperm(1)=2 intperm(2)=12 l2=jord(1,1) clink=jord(2,1) idis=0 shift0=0 shift1=1 do np=1,6 intlinks(1,idis+1)=l2+shift0 intlinks(2,idis+1)=clink+shift0*lshift intlinks(1,idis+2)=l2+shift1 intlinks(2,idis+2)=clink+shift1*lshift idis=idis+2 subl: if(l2.eq.1) then select case(np) case default write(*,*)'3B Case error in fccint22: ',np case(1) !A:B:A:B is next endmember shift1=2 case(2) !A:B:B:A shift1=3 case(3) !B:A:B:A shift0=1 case(4) !B:B:A:A shift0=2 case(5) !B:A:A:B shift0=1 shift1=2 case(6) ! no more end select else select case(np) case default write(*,*)'3B Case error in fccint22: ',np case(1) !A:B:A:B is next endmember shift0=-1 case(2) !A:B:B:A shift1=0 case(3) !B:A:B:A shift0=-2 case(4) !B:B:A:A shift1=-1 case(5) !B:A:A:B shift1=1 case(6) ! no more end select endif subl enddo 1000 continue return end subroutine fccint22 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine fccint211 !\begin{verbatim} %- subroutine fccint211(a211,jord,lshift,intperm,intlinks) ! 1st level interaction in sublattice l1 with endmember like A:A:B:C ! 12 endmember permutations of AABC; ABBC; or ABCC ! 2 interaction permutations for each, 24 in total implicit none integer a211,lshift integer, dimension(2,*) :: jord,intlinks integer, dimension(*) :: intperm !\end{verbatim} %+ integer l2,clink,idis,shift0,shift1,np intperm(1)=2 intperm(2)=24 l2=jord(1,1) if(l2.ne.a211) then ! write(*,*)'3B Error calling fccint211',a211,l2 gx%bmperr=4276; goto 1000 endif clink=jord(2,1) idis=0 shift0=0 shift1=1 ! endmemeber A:A:B:C; first permutation interactions: AX:A:B:C; A:AX:B:C ! endmemeber A:B:B:C; first permutation interactions: A:BX:B:C; A;B:BX:C ! endmemeber A:B:C:C; first permutation interactions: A:B:CX:C; A:B:C:CX do np=1,12 intlinks(1,idis+1)=l2+shift0 intlinks(2,idis+1)=clink+shift0*lshift intlinks(1,idis+2)=l2+shift1 intlinks(2,idis+2)=clink+shift1*lshift idis=idis+2 subl: if(l2.eq.1) then ! endmember A:A:B:C select case(np) case default write(*,*)'3B Case error in fccint211: ',np,a211 case(1) !A:A:C:B is next endmember continue case(2) !A:C:A:B shift1=2 case(3) !A:C:B:A shift1=3 case(4) !A:B:C:A continue case(5) !A:B:A:C shift1=2 case(6) !B:A:A:C shift0=1 case(7) !B:A:C:A shift1=3 case(8) !B:C:A:A shift0=2 case(9) !C:B:A:A continue case(10) !C:A:B:A shift0=1 case(11) !C:A:A:B shift1=2 case(12) ! no more end select elseif(l2.eq.2) then ! endmember A:B:B:C select case(np) case default write(*,*)'3B Case error in fccint211: ',np,a211 case(1) !A:B:C:B is next endmember shift1=2 case(2) !C:B:A;B continue case(3) !C:B:B:A shift1=1 case(4) !B:B:C:A shift0=-1 shift1=0 case(5) !B:B:A:C continue case(6) !B:A:B:C shift1=1 case(7) !B:A:C:B shift1=2 case(8) !C:A:B:B shift0=1 case(9) !A:C:B:B continue case(10) !B:C:A:B shift0=-1 case(11) !B:C:B:A shift1=1 case(12) ! no more end select else ! endmember A:B:C:C select case(np) case default write(*,*)'3B Case error in fccint211: ',np,a211 case(1) !A:C:B:C is next endmember shift0=-1 case(2) !C:A:B:C shift1=0 case(3) !C:B:A:C shift0=-2 case(4) !B:C:A:C shift1=-1 case(5) !B:A:C:C shift1=1 case(6) !B:C:C:A shift1=1 case(7) !C:B:C:A shift1=1 case(8) !C:C:B:A shift1=1 case(9) !C:C:A:B shift1=1 case(10) !C:A:C:B shift1=1 case(11) !A:C:C:B shift1=1 case(12) ! no more end select endif subl enddo 1000 continue return end subroutine fccint211 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine fccpe211 !\begin{verbatim} %- subroutine fccpe211(l1,elinks,nsl,lshift,iord) ! sets appropriate links to constituents for the 12 perumations of ! A:A:B:C (l1=1), A:B:B:C (l1=2) and A:B:C:C (l1=3) implicit none integer l1,nsl,lshift integer, dimension(nsl,*) :: elinks integer, dimension(*) :: iord !\end{verbatim} %+ integer odd,np,ll,ib ! l1=1; keep 1 and change 3o4 and 2o3 6 times; then change 1o2 and ! loop 2 times ! changing 3o4 and 2o3; then change 1o2 and loop 2 times changing 2o3 ! and 3o4 ! AABC; AACB; ACAB; ACBA; ABCA; ABAC; ! BAAC; BACA; BCAA; ! CBAA; ! CABA; CAAB; ! l1=2; keep 2 and change 3o4 and 1o3 6 times; then change 2o3 and ! loop 2 times ! changing 3o4 and 1o3; then change ! ABBC; ABCB; CBAB; CBBA; BBCA; BBAC; ! BABC; BACB; CABB; ! ACBB; ! BCAB; BCBA; ! l1=3; keep 4 and change 2o3 and 1o2 6 times; then change ! ABCC; ACBC; CABC; CBAC; BCAC; BACC; ! ! write(*,*)'3B fccpe211: ',l1 odd=0 loop12: do np=0,11 do ll=1,nsl if(iord(ll).lt.0) iord(ll)=-99 elinks(ll,np+1)=iord(ll) enddo ! note l1 and ll are different !!! if(l1.eq.1) then ! AABC. Keep constituent in sublattice 1 first 6 loops; then for 3 and 3 if(np.eq.5) then ib=iord(1)+lshift iord(1)=iord(2)-lshift iord(2)=ib odd=1-odd elseif(np.eq.8) then ib=iord(1)+lshift iord(1)=iord(2)-lshift iord(2)=ib odd=1-odd elseif(odd.eq.0) then ib=iord(3)+lshift iord(3)=iord(4)-lshift iord(4)=ib odd=1-odd else ib=iord(2)+lshift iord(2)=iord(3)-lshift iord(3)=ib odd=1-odd endif elseif(l1.eq.2) then ! ABBC. Keep constituent in sublattice 2 for first 6; then for 3 and 3 if(np.eq.5) then ib=iord(2)+lshift iord(2)=iord(3)-lshift iord(3)=ib odd=1-odd elseif(np.eq.8) then ib=iord(1)+lshift iord(1)=iord(2)-lshift iord(2)=ib odd=1-odd elseif(odd.eq.0) then ib=iord(3)+lshift iord(3)=iord(4)-lshift iord(4)=ib odd=1-odd else ib=iord(1)+2*lshift iord(1)=iord(3)-2*lshift iord(3)=ib odd=1-odd endif else ! ABCC. Keep constituent in sublattice 4 for first 6; then for 3 and 3 if(np.eq.5) then ib=iord(2)+2*lshift iord(2)=iord(4)-2*lshift iord(4)=ib elseif(np.eq.8) then ib=iord(3)+lshift iord(3)=iord(4)-lshift iord(4)=ib odd=1-odd elseif(odd.eq.0) then ib=iord(2)+lshift iord(2)=iord(3)-lshift iord(3)=ib odd=1-odd else ib=iord(1)+lshift iord(1)=iord(2)-lshift iord(2)=ib odd=1-odd endif endif enddo loop12 1000 continue return end subroutine fccpe211 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine fccpe1111 !\begin{verbatim} %- subroutine fccpe1111(elinks,nsl,lshift,iord) ! sets appropriate links to 24 permutations when all 4 constituents different ! A:B:C:D ! The do loop keeps the same constituent in first sublattice 6 times, changing ! the other 3 sublattice, then changes the constituent in the first sublattice ! and goes on changing in the other 3 until all configurations done implicit none integer nsl,lshift integer, dimension(nsl,*) :: elinks integer, dimension(*) :: iord !\end{verbatim} integer np,ll,odd,ib ! odd is either 0 or 1 odd=1 loop24: do np=0,23 do ll=1,nsl if(iord(ll).lt.0) iord(ll)=-99 elinks(ll,np+1)=iord(ll) enddo ! keep the same constituent in sublattice 1 for 6 endmembers, then shift if(np.eq.5) then ! shift 1 and 2, change odd ib=iord(2)-lshift iord(2)=iord(1)+lshift iord(1)=ib odd=1-odd elseif(np.eq.11) then ! shift 1 and 4, keep odd ib=iord(3)-2*lshift iord(3)=iord(1)+2*lshift iord(1)=ib elseif(np.eq.17) then ! shift 1 and 4, change odd ib=iord(4)-3*lshift iord(4)=iord(1)+3*lshift iord(1)=ib odd=1-odd elseif(odd.eq.0) then odd=1-odd ! shift 3 and 4 ib=iord(4)-lshift iord(4)=iord(3)+lshift iord(3)=ib else odd=1-odd ! shift 2 and 3 ib=iord(3)-lshift iord(3)=iord(2)+lshift iord(2)=ib endif enddo loop24 1000 continue return end subroutine fccpe1111 !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable logical function check_minimal_ford !\begin{verbatim} logical function check_minimal_ford(lokph) ! some tests if the fcc/bcc permutation model can be applied to this phase ! The function returns FALSE if the user may set the FORD or BORD bit of lokph implicit none integer lokph !\end{verbatim} integer nsl,nc,jl,ll,j2,loksp,lokcs logical notallowed integer, dimension(:), allocatable :: const double precision ss notallowed=.true. nsl=phlista(lokph)%noofsubl if(btest(phlista(lokph)%status1,PHHASP)) then ! The PHASP bit is set if a parameter has been entered (never cleared) write(kou,*)'Permutation must be set before parameters are entered' goto 1000 endif if(nsl.lt.4) then write(kou,*)'Phase with permutation must have 4 or more sublattices' goto 1000 else ! ordering assumed in first 4 sublattices, that is not really necessary ! ss=phlista(lokph)%sites(1) lokcs=phlista(lokph)%linktocs(1) ss=firsteq%phase_varres(lokcs)%sites(1) nc=phlista(lokph)%nooffr(1) allocate(const(nc)) do jl=1,nc loksp=phlista(lokph)%constitlist(jl) const(jl)=splista(loksp)%alphaindex enddo jl=nc do ll=2,4 ! if(abs(phlista(lokph)%sites(ll)-ss).gt.1.0D-12) then if(abs(firsteq%phase_varres(lokcs)%sites(ll)-ss).gt.1.0D-12) then write(kou,12) 12 format(' Permutation requires the same number of',& ' sites in first 4 sublattices') goto 1000 endif if(phlista(lokph)%nooffr(ll).ne.nc) then write(kou,13) 13 format(' Permutation requires that the number of constituents',& ' are equal'/' in all 4 sublattices for ordering') goto 1000 endif ! one must also check the constituents are identical do j2=1,nc loksp=phlista(lokph)%constitlist(jl+j2) if(splista(loksp)%alphaindex.ne.const(j2)) then write(kou,14) 14 format(' Permutation requires that the constituents in the',& ' 4 sublattices for'/' ordering are identical') goto 1000 endif enddo jl=jl+nc enddo endif notallowed=.false. 1000 continue check_minimal_ford=notallowed return end function check_minimal_ford !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine bccpermuts !\begin{verbatim} subroutine bccpermuts(lokph,nsl,iord,noperm,elinks,nint,jord,intperm,intlinks) ! finds all bcc permutations needed for this parameter implicit none integer lokph,nsl,noperm,nint ! iord are the endmember constituent indices ! intperm has dimension 24 and contain propagation of interactions ?? integer, dimension(*) :: iord,intperm ! jord(1,int) is the interaction subl. and jord(2,int) the constituent index integer, dimension(2,*) :: jord ! these must be allocated here and will be stored in the parameter records ! giving the constituent indices for permutations of endmembers and interactions integer, dimension(:,:), allocatable :: elinks integer, dimension(:,:), allocatable :: intlinks !\end{verbatim} %+ integer ls,l1,l2,l3,loksp,c1,c2,c3,mint,ip,nsame integer elal(9),unshift(9),orgem(4),esame(4) character pch*64 logical notdone ! I assume the ordering is in the first 4 sublattices, that could be changed if(nsl.lt.4) then write(*,*)'3B There must be at least 4 sublattices for bcc option' gx%bmperr=4267; goto 1000 endif ! unifinished ! write(*,*)'3B implementation of BCC permutations not finished' ! gx%bmperr=4277 ! In BCC the tetrahedron is unsymmetrical, I assume sublattice 1 and 2 ! are NEXT-nearest neighbours and also sublattice 3 and 4, i.e. ! G_A:B:C:D = u_AC + u_AD + u_BC + u_BD + v_AB + v_CD where ! u_ij is the nearest neighbour bond (nnb) energy and v_ij the nnnb energy ! NOTE that endmember permutations are different from FCC/HCP ! NOTE that reciprocal parameters have their permutation in its own record ! (not propagated from the first order interaction) ! ! we must rearrange constituents in alphabetcal order in the sublattices ! and change interactions also! Note we can exchange between sublattice 1&2 ! and 3&4 but not between 1&3 for example. if(nint.gt.2) then write(*,*)'3B Maximum 2nd level interaction with option F' gx%bmperr=4268; goto 1000 endif ! list elal and jord on entering ! write(*,10)'3B bccperm 1: ',(iord(l2),l2=1,4),(jord(1,l2),jord(2,l2),l2=1,2) 10 format(a,4i4,5x,2i3,3x,2i3) ! rearrange constituents in alphabetical order in the sublattices, ! change interactions also! ! iord is the lowest constituent index in each sublattice (incl interactions) ! rearrange to make have the lowest index in sublattice 1 ! NOTE: wildcards have index -99, they should come last! c1=10000 do ls=1,nsl if(iord(ls).gt.0) then loksp=phlista(lokph)%constitlist(iord(ls)) elal(ls)=splista(loksp)%alphaindex if(elal(ls).lt.c1) then c1=elal(ls) l1=ls endif else ! this branch if wildcard, iord(ls)=-99 elal(ls)=iord(ls) endif enddo ! save origional sublattice of endmember constituent in orgem ! in order to shift interactions!! orgem=0 unshift=elal ! c1 in sublattice l1 is lowest component index, if l1>1 shift c1 to subl. 1 if(l1.eq.1) then ! sublattice 1&2 OK but we may have to rearrange sublattice 3&4 c2=elal(3) c3=elal(4) if(c3.gt.0) then ! c3 negative means wildcard and do nothing if(c2.eq.c1 .and. c3.eq.c1) then if(elal(2).ne.c1) then ! elements in subl 1,3 and 4 same, move 2 last elal(4)=elal(2) elal(2)=c3 orgem(2)=4 orgem(4)=2 endif elseif(c2.eq.c1) then ! element in 1 and 3 same, if 4 lower than 2 shift! if(c3.lt.elal(2)) then elal(4)=elal(2) elal(2)=c3 orgem(4)=2 orgem(2)=4 endif elseif(c3.lt.c2) then elal(4)=c2 elal(3)=c3 orgem(3)=4 orgem(4)=3 endif endif elseif(l1.eq.2) then ! if l1=2 then just shift constituents in sublattice 1 and 2 c2=elal(1) elal(1)=c1 elal(l1)=c2 orgem(1)=2 orgem(2)=1 ! we may have to rearrange sublattice 3&4 c2=elal(3) c3=elal(4) if(c3.gt.0 .and. c3.lt.c2) then ! c3 negative means wildcard elal(4)=c2 elal(3)=c3 orgem(3)=4 orgem(4)=3 endif elseif(l1.gt.2) then ! if l1=3 or 4 we must move the constituent in position (7-l1) also ! note if l1=3 then 7-l1=4; l1=4 then 7-l1=3 c2=elal(1) elal(1)=elal(l1) c3=elal(2) elal(2)=elal(7-l1) orgem(1)=l1 orgem(2)=7-l1 if(c3.gt.0 .and. c3.lt.c2) then ! c3 negative means wildcard elal(3)=c3 elal(4)=c2 orgem(3)=2 orgem(4)=1 else elal(3)=c2 elal(4)=c3 orgem(3)=1 orgem(4)=2 endif endif ! write(*,9)'3B sorted 1: ',(unshift(ls),ls=1,4),(elal(ls),ls=1,4),l1 ! Now the alphabetically first constituent is in sublattice 1 ! If 3 elements are equal they should be ordered A:A:A:B or A:B:B:B ! in all other cases the alphabetical order is OK ?? ! ?? if 2 pairs are equal they should be ordered A:A:B:B or A:B:A:B ! ?? if 2 or less equal the alphabetical order is OK nsame=0 ! problem with NI:FE:NI:FE becomes FE:NI:NI:NI !! if(elal(2).eq.elal(1)) then if(elal(3).eq.elal(1)) then ! all is OK. We should have correct alphabetical order in sublattice 3&4 continue endif elseif(elal(3).eq.elal(1)) then ! elal(2) =/= elal(1), if elal(3)=elal(4)=elal(1) shift elal(2) to elal(4) if(elal(4).eq.elal(1)) then ! change A:B:A:A to A:A:A:B c2=elal(2) elal(2)=elal(4) elal(4)=c2 orgem(4)=2 nsame=1 elseif(elal(4).lt.elal(2)) then ! change A:C:A:B to A:B:A:C c2=elal(2) elal(2)=elal(4) elal(4)=c2 orgem(4)=2 nsame=2 endif endif ! shift interactions also!!! orgem(ls) is original sublattice of endmember ! interactions must not be wildcard ! write(*,9)'3B sorted 2: ',(unshift(ls),ls=1,4),(elal(ls),ls=1,4),nsame 9 format(a,4i4,5x,9i4) ! write(*,12)'3B orgem: ',orgem,(jord(1,mint),jord(2,mint),mint=1,nint) 12 format(a,4i4,5x,4i4) do mint=1,nint latloop2: do ls=1,4 if(jord(1,mint).eq.orgem(ls)) then ! interaction has changed to sublattice ls ! write(*,13)'3B noshift: ',mint,ls,jord(1,mint),jord(2,mint) jord(1,mint)=ls loksp=phlista(lokph)%constitlist(jord(2,mint)) jord(2,mint)=splista(loksp)%alphaindex ! write(*,13)'3B shifted: ',mint,ls,jord(1,mint),jord(2,mint) exit latloop2 endif ! we come here if interaction in same sublattice but we must change jord(2,mint) loksp=phlista(lokph)%constitlist(jord(2,mint)) jord(2,mint)=splista(loksp)%alphaindex ! write(*,13)'3B changed: ',mint,ls,jord(1,mint),jord(2,mint) enddo latloop2 enddo ! write(*,13)'3B interactions: ',(jord(1,mint),jord(2,mint),mint=1,nint) 13 format(a,2(2i5,5x)) ! make sure jord are in sublattice order if(nint.gt.1) then if(jord(1,1).gt.jord(1,2)) then l1=jord(1,1) jord(1,1)=jord(1,2) jord(1,2)=l1 c1=jord(2,1) jord(2,1)=jord(2,2) jord(2,2)=c1 endif endif if(nint.eq.2) then ! we have two interactions if(jord(1,1).ne.jord(1,2) .and. elal(jord(1,1)).eq.elal(jord(1,2))) then ! the interactions are not in the same sublattice but we have the same ! endmember component for the interactions! if(jord(2,2).lt.jord(2,1)) then ! The second interacting component is lower alphabetically, in some cases ! we should shift the alphabetical lowest interacting component first if(jord(1,1)+jord(1,2).eq.3 .or. jord(1,1)+jord(1,2).eq.7) then ! 1) if both interactions are in sublattice 1&2 or 3&4: A,C:A,B => A,B:A,C l1=jord(2,1) jord(2,1)=jord(2,2) jord(2,2)=l1 ! write(*,*)'3B shifting 1 interaction component to first' elseif(elal(3-jord(1,1)).eq.elal(7-jord(1,2))) then ! 2) if the endmember constituents in the other sublattices the same ! A,C:D:A,B:D => A,B:D:A,C:D l1=jord(2,1) jord(2,1)=jord(2,2) jord(2,2)=l1 ! write(*,*)'3B shifting 2 interaction component to first' endif endif endif endif ! write(*,10)'3B bccperm 4: ',(elal(l2),l2=1,4),(jord(1,l2),jord(2,l2),l2=1,2) !------------------------------------------------------------------------- ! now we can start generating permutations <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ! elal(1..4) are now species in alphabetical order (>4 not changed) ! jord(1,int) is sublattice and jord(2,int) is species of interaction int=0,1,2 ! wildcards always at the end ! Always generate the endmember permutations call bccendmem(lokph,nsl,elal,noperm,elinks) if(gx%bmperr.ne.0) goto 1000 if(nint.ge.1) then ! if first level interaction generate the necessary permutations call bccint1(lokph,nsl,elal,noperm,elinks,nint,jord,intperm,intlinks) if(gx%bmperr.ne.0) goto 1000 if(nint.ge.2) then ! if second level interaction generate the necessary permutations ! write(*,*)'3B calling bccint2',jord(1,2),jord(2,2) call bccint2(lokph,nsl,elal,noperm,elinks,nint,jord,intperm,intlinks) ! write(*,*)'3B back from bccint2',gx%bmperr if(gx%bmperr.ne.0) goto 1000 if(nint.gt.2) then write(*,*)'3B Max two level of interactions for BCC permutations' gx%bmperr=4275 endif endif endif ! if(gx%bmperr.ne.0) goto 1000 1000 continue ! unifinished return end subroutine bccpermuts !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine bccendmem !\begin{verbatim} %- subroutine bccendmem(lokph,nsl,elal,noperm,elinks) ! generate an bcc endmember with all permutations implicit none integer lokph,nsl,noperm ! elal are the endmember species indices integer, dimension(*) :: elal ! these must be allocated here and will be stored in the parameter records ! giving the sublattice and constituent indices for each permutation ! of an endmembers integer, dimension(:,:), allocatable :: elinks ! integer, dimension(:,:), allocatable :: intlinks !\end{verbatim} %+ ! endmember perm ! A:A:A:A 1 ! A:A:A:B 4 ! A:A:B:B B2 2 A:A:B:B B:B:A:A ! A:B:A:B B32 4 A:B:A:B A:B:B:A B:A:A:B B:A:B:A ! A:B:B:B 4 ! A:A:B:C 4 A:A:B:C A:A:C:B B:C:A:A C:B:A:A ! A:B:A:C 8 A:B:A:C A:B:C:A B:A:A:C B:A:C:A A:C:A:B A:C:B:A C:A:A:B C:A:B:A ! Note the parameter below requires 3 sets of permutations ! A:B:C:D B2 8 A:B:C:D A:B:D:C B:A:C:D B:A:D:C C:D:A:B C:D:B:A D:C:A:B D:C:B:A ! G(BCC,A:B:C:D) = u_AC+u_AD+u_BC+u_BD+v_AB+v_CD, u nn bond, v nnn bond ! A:C:B:D 8 ! G(BCC,A:C:B:D) = u_AB+u_AD+u_CB+u_CD+v_AC+v_BD ! A:D:B:C 8 ! G(BCC,A:D:B:C) = u_AB+u_AC+u_DB+u_DC+v_AD+v_BC integer ls,ip,mperm,cix integer, parameter, dimension(16) :: prm4=[1,2,3,4,4,3,1,2,2,1,4,3,3,4,2,1] integer, parameter, dimension(32) :: prm8=[1,2,3,4,1,2,4,3,2,1,3,4,2,1,4,3,& 3,4,1,2,3,4,2,1,4,3,1,2,4,3,2,1] character pch*64 ! ! nperm=0 ! elal(i) ordered c1<=c2 and c1<=c3 and c3<=c4 and c2<=c4 but maybe c3<=c2 ! if(elal(2).ne.elal(1)) then ! 2 different elements in sublattice 1&2: A:B ! if(elal(3).ne.elal(4)) then ! 2 different elements in sublattice 3&4: X:Y ! if(elal(3).ne.elal(1)) then ! if(elal(3).ne.elal(2)) then ! A:B:C:D = A:B:C:D A:B:D:C B:A:C:D B:A:C:D C:D:A:B C:D:B:A D:C:A:B D:C:B:A ! nperm=8 ! else ! A:B:B:C = A:B:B:C A:B:C:B B:A:B:C B:A:C:B B:C:A:B B:C:B:A C:B:A:B C:B:B:A ! nperm=8 ! endif ! elseif(elal(4).ne.elal(2)) then ! A:B:A:C = A:B:A:C A:B:C:A B:A:A:C B:A:C:A A:C:A:B A:C:B:A C:A:A:B C:A:B:A ! nperm=8 ! else ! A:B:A:B = A:B:A:B A:B:B:A B:A:A:B B:A:B:A ! nperm=4 ! endif ! elseif(elal(3).eq.elal(2)) then ! same constituents in sublattice 2 ! A:B:B:B = A:B:B:B B:A:B:B B:B:A:B B:B:B:A ! nperm=4 ! else ! A:B:C:C = A:B:C:C B:A:C:C C:C:A:B C:C:B:A ! nperm=4 ! endif ! elseif(elal(3).eq.elal(4)) then ! same elements in sublattice 1&2: A:A, and in sublattice 3&4: X:Y ! if(elal(3).eq.elal(1)) then ! A:A:A:A ! nperm=1 ! else ! A:A:B:B = A:A:B:B, B:B:A:A ! nperm=2 ! endif ! else ! A:A:B:C = A:A:B:C A:A:C:B B:C:A:A C:B:A:A ! nperm=4 ! endif !------------------------------- same in simpler way mperm=0 ! find the number of permutations if(elal(1).eq.elal(2)) then if(elal(3).eq.elal(4)) then if(elal(3).eq.elal(1)) then ! A:A:A:A mperm=1 else ! A:A:B:B mperm=2 endif else ! A:A:A:B = ... ! A:A:B:C = A:A:B:C A:A:C:B B:C:A:A C:B:A:A mperm=4 endif elseif(elal(3).eq.elal(4)) then ! if(elal(3).eq.elal(2)) then ! A:B:B:B = A:B:B:B B:A:B:B B:B:A:B B:B:B:A mperm=4 ! else ! A:B:C:C = A:B:C:C B:A:C:C C:C:A:B C:C:B:A ! mperm=4 ! endif elseif(elal(3).eq.elal(1) .and. elal(4).eq.elal(2)) then ! A:B:A:B = mperm=4 else ! A:B:A:C = ! A:B:B:C = ! A:B:C:D = mperm=8 endif ! Code below is just to check the constituents are correctly sorted pch='G(BORD,' ip=8 do ls=1,4 if(elal(ls).lt.0) then pch(ip:)='*:' else ! splista is ordered as the species are entered, thus splista(1) is VA ! species(i) is the index in splista of elements in alphabetcal order pch(ip:)=trim(splista(species(elal(ls)))%symbol)//':' endif ip=len_trim(pch)+1 ! when we are here there are no interactions ! if(mint.le.nint .and. jord(1,mint).eq.ls) then ! pch(ip-1:)=','//trim(splista(species(jord(2,mint)))%symbol)//':' ! ip=len_trim(pch)+1 ! mint=mint+1 ! endif enddo ! pch(ip-1:)=';0)' ! write(*,14)'3B sorted endmember: ',trim(pch),mperm 14 format(a,a,i6) ! now generate values in elinks noperm=mperm allocate(elinks(nsl,noperm)) ! elal is species index, it has to be converted to constituent index select case(noperm) case default write(*,*)'3B unknown permutation for bcc endmember: ',noperm gx%bmperr=4269 !------------ case(1) ! A:A:A:A do ls=1,4 ! findconst find the constituent index of species elal(ls) in sublattice ls ! for wildcards elal(ls)=-99 that is propagated call findconst(lokph,ls,elal(ls),cix) if(gx%bmperr.ne.0) goto 1000 elinks(ls,1)=cix enddo !--------------- case(2) ! A:A:B:B B:B:A:A do ls=1,4 call findconst(lokph,ls,elal(ls),cix) if(gx%bmperr.ne.0) goto 1000 elinks(ls,1)=cix enddo do ls=1,2 call findconst(lokph,ls,elal(ls+2),cix) if(gx%bmperr.ne.0) goto 1000 elinks(ls,2)=cix enddo do ls=3,4 call findconst(lokph,ls,elal(ls-2),cix) if(gx%bmperr.ne.0) goto 1000 elinks(ls,2)=cix enddo !-------------- case(4) ! several different cases but can be treated the same ??? ! A:B:A:B B:A:A:B B:A:B:A A:B:B:A 1234 4312 2143 3421 ! A:B:C:C C:C:A:B B:A:C:C C:C:B:A 1234 4312 2143 3421 ! A:B:B:B B:B:A:B B:A:B:B B:B:B:A 1234 4312 2143 3421 ! prm4=[1,2,3,4, 4,3,1,2, 2,1,4,3, 3,4,2,1] do mperm=0,noperm-1 do ls=1,4 call findconst(lokph,ls,elal(prm4(ls+4*mperm)),cix) if(gx%bmperr.ne.0) goto 1000 elinks(ls,mperm+1)=cix enddo ! write(*,66)mperm,(elinks(ls,mperm+1),ls=1,4) 66 format('3B bccperm: ',i2,5x,4i4) enddo !-------------- case(8) ! several cases all treated the same ! A:B:C:D A:B:D:C B:A:C:D B:A:C:D, C:D:A:B C:D:B:A D:C:A:B D:C:B:A ! 1234 1243 2134 2143 3412 ... ! A:B:B:C A:B:C:B B:A:B:C B:A:C:B, B:C:A:B B:C:B:A C:B:A:B C:B:B:A ! 1234 1243 2134 2134 ! A:B:A:C A:B:C:A B:A:A:C B:A:C:A, A:C:A:B A:C:B:A C:A:A:B C:A:B:A ! 1234 1243 2134 ! prm8=[1,2,3,4, 1,2,4,3, 2,1,3,4, 2,1,4,3,& ! 3,4,1,2, 3,4,2,1, 4,3,1,2, 4,3,2,1] do mperm=0,7 do ls=1,4 call findconst(lokph,ls,elal(prm8(4*mperm+ls)),cix) if(gx%bmperr.ne.0) goto 1000 elinks(ls,mperm+1)=cix enddo enddo end select !-------------------- ! constiuents in sublattice 5 to nsl are the same in all permutations ! write(*,77)((elinks(ls,mperm),ls=1,4),mperm=1,noperm) 77 format('3B perm:',4(4i4,2x)) ! write(*,*)'3B adding constituents: ',nsl,noperm do mperm=1,noperm do ls=5,nsl ! these constituents are the same for all permutations call findconst(lokph,ls,elal(ls),cix) if(gx%bmperr.ne.0) goto 1000 ! elinks(ls,mperm)=elal(ls) elinks(ls,mperm)=cix ! write(*,*)'3B notperm: ',elal(ls),cix enddo enddo !----------------------- 1000 continue return end subroutine bccendmem !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine bccint1 !\begin{verbatim} subroutine bccint1(lokph,nsl,elal,noperm,elinks,nint,jord,intperm,intlinks) ! generate all bcc permutations for a first order interaction implicit none ! on entry noperm is the number of permutation of the endmember ! on exit noperm is the number of permutation of the interaction integer lokph,nsl,noperm,nint ! elal are the endmember species indices integer, dimension(*) :: elal ! intperm has dimension 24 and contain propagation of interactions ?? integer, dimension(*) :: intperm ! jord(1,int) is the interaction subl. and jord(2,int) the constituent index integer, dimension(2,*) :: jord ! these contain the already allocated permutation of the endmember ! integer, dimension(:,:), allocatable :: elinks integer, dimension(nsl,*) :: elinks ! intlinks will be allocated here and will be stored in the parameter records ! giving the constituent indices for permutations of the interactions ! It may be reallocated if the interaction is second level integer, dimension(:,:), allocatable :: intlinks !\end{verbatim} %+ integer mint,ls,ip,nperm,mperm,cix,incperm,intem,lq,mq,subint(4) character pch*64 ! this is quite simple, the species jord(1,2) in sublattice jord(1,1) should ! be repeated for all permutations of the endmember in jord(1,1) ! noperm=1: 1,1,1,1 ! noperm=2: 1,1,2,2, 2,2,1,1 ! nopermg=4: prm4=[1,2,3,4, 4,3,1,2, 2,1,4,3, 3,4,2,1] ! noperm=8: prm8=[1,2,3,4, 1,2,4,3, 2,1,3,4, 2,1,4,3,& ! 3,4,1,2, 3,4,2,1, 4,3,1,2, 4,3,2,1] integer, parameter :: prm4(16)=[1,2,3,4, 4,3,1,2, 2,1,4,3, 3,4,2,1] integer, parameter :: prm8(32)=[1,2,3,4, 1,2,4,3, 2,1,3,4, 2,1,4,3,& 3,4,1,2, 3,4,2,1, 4,3,1,2, 4,3,2,1] ! This is related to the order in prm4 ! WOW, comment 2023: I have completely forgotten how shape/reshape works .... integer, parameter :: & prmint4(4,4)=reshape([1,3,2,4,2,4,1,3,3,2,4,1,4,1,3,2],shape(prmint4)) ! ! integer, parameter :: prmint4(4,4)=[[1,3,2,4],[2,4,1,3],[3,2,4,1],[4,1,3,2]] integer, parameter, dimension(8,4) :: & prmint8=reshape([1,1,2,2,3,4,3,4, 2,2,1,1,4,3,4,3,& 3,4,3,4,1,1,2,2, 4,3,4,3,2,2,1,1], shape(prmint8)) ! intperm(1)=number of interaction permutations on level 1 for each endmember ! on level 1 each endmember permutation has the same ! intperm(2)=total number of permutation links for level 1 ! intperm(3..) used for 2nd level ! intlinks(1,iperm) is sublattice with interaction for permutation iperm ! intlinks(2,iperm) is constituent index for permutation iperm ! ! noperm will be updated!! nperm=noperm ! write(*,*)'3B in bccint1: ',jord(1,1),jord(2,1) ! allocate sufficient number of sublattice/constituent pairs for permutations allocate(intlinks(2,100)) ! incperm is incremented for each permutation stored in intlinks incperm=0 ! select case(nperm) case default write(*,*)'illegal endmember permutation in bccint1',nperm gx%bmperr=4269 !------------------------- case(1) ! same component and interaction in all 4 sublattices ! this is the number of interaction permutation for each endmember intperm(1)=4 ! intperm(2) is intperm(1) multiplied with number of endmember permutation, 1 intperm(2)=4 do ls=1,4 call findconst(lokph,ls,jord(2,1),cix) if(gx%bmperr.ne.0) goto 1000 incperm=incperm+1 intlinks(1,incperm)=ls intlinks(2,incperm)=cix enddo if(incperm.ne.intperm(2)) stop 'internal error 3B:17' !------------------------- case(2) ! A:A:B:B and B:B:A:A, two endmembers ! intperm(1) is the number of permutations for each endmember intperm(1)=2 ! intperm(2) depends on the number of endmember permutations, here 2, thus 4 ?? intperm(2)=4 if(jord(1,1).eq.1) then ! for first endmember 2 permutations of interaction with A do ls=1,2 call findconst(lokph,ls,jord(2,1),cix) if(gx%bmperr.ne.0) goto 1000 incperm=incperm+1 intlinks(1,incperm)=ls intlinks(2,incperm)=cix enddo ! for second endmember 2 permutations of interaction with A do ls=3,4 call findconst(lokph,ls,jord(2,1),cix) if(gx%bmperr.ne.0) goto 1000 incperm=incperm+1 intlinks(1,incperm)=ls intlinks(2,incperm)=cix enddo elseif(jord(1,1).eq.3) then ! for first endmember 2 permutations of interaction with B do ls=3,4 call findconst(lokph,ls,jord(2,1),cix) if(gx%bmperr.ne.0) goto 1000 incperm=incperm+1 intlinks(1,incperm)=ls intlinks(2,incperm)=cix enddo ! for second endmember 2 permutations of interaction with B do ls=1,2 call findconst(lokph,ls,jord(2,1),cix) if(gx%bmperr.ne.0) goto 1000 incperm=incperm+1 intlinks(1,incperm)=ls intlinks(2,incperm)=cix enddo else write(*,*)'3B interaction on wrong sublattice in BCC',jord(1,1) gx%bmperr=4399; goto 1000 endif if(incperm.ne.intperm(2)) stop 'internal error 3B:18' !------------------------- case(4) ! many different permutations, ! there are at least 2 identical species ! A:B:A:B B:A:A:B B:A:B:A A:B:B:A 1234 4312 2143 3421 ! A:B:C:C C:C:A:B B:A:C:C C:C:B:A 1234 4312 2143 3421 ! A:B:B:B B:B:A:B B:A:B:B B:B:B:A 1234 4312 2143 3421 ! A:A:B:C C:B:A:A A:A:C:B B:C:A:A ! set intem to the endmember species index of the sublattice with interaction intem=elal(jord(1,1)) subint=0 ip=0 do ls=1,4 if(elal(ls).eq.intem) then subint(ls)=1; ip=ip+1 endif enddo ! ip can be 1, 2 or 3 select case(ip) case default write(*,*)'3B illegal case for interaction',ip gx%bmperr=4269; goto 1000 !.................. case(1) ! interaction with a component that appears only once: AX:B:B:B ! intperm(1) is the number of permutations for each endmember intperm(1)=1 ! intperm(2) depends on the number of endmember permutations, here 4, thus 4 ?? intperm(2)=4 incperm=0 ! find the sublattice with the endmember do ip=1,4 if(subint(ip).eq.1) lq=ip enddo ! if ls=1 the endmember varies 1, 3, 2, 4 ! 2 2, 4, 1, 3 ! 3 3, 2, 4, 1 ! 4 4, 1, 3, 2 ! probably one can permute the endmembers in a smarter way .... ! noperm=4: prm4=[1,2,3,4, 4,3,1,2, 2,1,4,3, 3,4,2,1] ! A:B:C:D D:C:A:B B:A:D:C C:D:B:A ! prmint4(1..4,1) = 1, 3, 2, 4 etc. do ls=1,4 call findconst(lokph,prmint4(ls,lq),jord(2,1),cix) if(gx%bmperr.ne.0) goto 1000 incperm=incperm+1 intlinks(1,incperm)=prmint4(ls,lq) intlinks(2,incperm)=cix enddo !.................. case(2) ! interaction with a component that appears twice: AX:B:A:B ! intperm(1) is the number of permutations for each endmember intperm(1)=2 ! intperm(2) depends on the number of endmember permutations, here 4, thus 8 ?? intperm(2)=8 ! noperm=4: prm4=[1,2,3,4, 4,3,1,2, 2,1,4,3, 3,4,2,1] ! A:B:A:B B:A:A:B B:A:B;A A;B;B;A ! find the sublattice with the endmember lq=0; mq=0 do ip=1,4 if(subint(ip).eq.1) then if(lq.eq.0) then lq=ip else mq=ip endif endif enddo ! create 2 links for each endmember permutation do ls=1,4 call findconst(lokph,prmint4(ls,lq),jord(2,1),cix) if(gx%bmperr.ne.0) goto 1000 incperm=incperm+1 intlinks(1,incperm)=prmint4(ls,lq) intlinks(2,incperm)=cix call findconst(lokph,prmint4(ls,mq),jord(2,1),cix) if(gx%bmperr.ne.0) goto 1000 incperm=incperm+1 intlinks(1,incperm)=prmint4(ls,mq) intlinks(2,incperm)=cix enddo !.................. case(3) ! interaction with a component that appears 3 times: A:BX:B:B ! intperm(1) is the number of permutations for each endmember intperm(1)=3 ! intperm(2) depends on the number of endmember permutations, here 4, thus 12?? intperm(2)=12 ! create 3 links for each endmember permutation do ls=1,4 do lq=1,4 ! subint(lq) is zero for the sublattice with endmember without interaction if(subint(lq).ne.0) then call findconst(lokph,prmint4(ls,lq),jord(2,1),cix) if(gx%bmperr.ne.0) goto 1000 incperm=incperm+1 intlinks(1,incperm)=prmint4(ls,lq) intlinks(2,incperm)=cix endif enddo enddo end select if(incperm.ne.intperm(2)) stop 'internal error 3B:20' !---------------------------------------- case(8) ! many different permutations ! A:B:C:D A:B:D:C B:A:C:D B:A:C:D, C:D:A:B C:D:B:A D:C:A:B D:C:B:A ! A:B:B:C A:B:C:B B:A:B:C B:A:C:B, B:C:A:B B:C:B:A C:B:A:B C:B:B:A ! A:B:A:C A:B:C:A B:A:A:C B:A:C:A, A:C:A:B A:C:B:A C:A:A:B C:A:B:A ! noperm=8: prm8=[1,2,3,4, 1,2,4,3, 2,1,3,4, 2,1,4,3,& ! 3,4,1,2, 3,4,2,1, 4,3,1,2, 4,3,2,1] ! integer, parameter, dimension(4,8) :: prmint8=[1,1,2,2,3,4,3,4,& ! 2,2,1,1,4,3,4,3,& ! 3,4,3,4,1,1,2,2,& ! 4,3,4,3,2,2,1,1] intem=elal(jord(1,1)) subint=0 ip=0 do ls=1,4 if(elal(ls).eq.intem) then subint(ls)=1; ip=ip+1 endif enddo ! ip can be 1 or 2 select case(ip) case default write(*,*)'3B illegal case for interaction',ip gx%bmperr=4269; goto 1000 !.................. case(1) ! intperm(1) is the number of permutations for each endmember intperm(1)=1 ! intperm(2) depends on the number of endmember permutations, here 8, thus 4 ?? intperm(2)=8 incperm=0 ! find the sublattice with the odd endmember (other 3 same) do ip=1,4 if(subint(ip).eq.0) lq=ip enddo ! create 1 link for each endmember permutation do ls=1,8 call findconst(lokph,prmint8(ls,lq),jord(2,1),cix) if(gx%bmperr.ne.0) goto 1000 incperm=incperm+1 intlinks(1,incperm)=prmint4(ls,lq) intlinks(2,incperm)=cix enddo !.................. case(2) ! intperm(1) is the number of permutations for each endmember intperm(1)=2 ! intperm(2) depends on the number of endmember permutations, here 8, thus 16?? intperm(2)=16 incperm=0 ! create 1 link for each endmember permutation do ls=1,8 do lq=1,4 if(subint(lq).ne.0) then call findconst(lokph,prmint4(ls,lq),jord(2,1),cix) if(gx%bmperr.ne.0) goto 1000 incperm=incperm+1 intlinks(1,incperm)=prmint4(ls,lq) intlinks(2,incperm)=cix endif enddo enddo end select if(incperm.ne.intperm(2)) stop 'internal error 3B:21' end select ! The interacting sublattice may have changed: correct jord(1,1) ! write(*,*)'3B correct interacting sublattice: ',jord(1,1),intlinks(1,1) if(jord(1,1).ne.intlinks(1,1)) then ! important!! if jord(1,2) same as jord(1,1) that must be changed too!! if(jord(1,2).eq.jord(1,1)) then jord(1,2)=intlinks(1,1) endif jord(1,1)=intlinks(1,1) endif !---------------------------------------- ! Just a check output mperm=1 mint=1 pch='G(BORD,' ip=8 do ls=1,4 if(elal(ls).lt.0) then pch(ip:)='*:' else ! splista is ordered as the species are entered, thus splista(1) is VA ! species(i) is the index in splista of elements in alphabetcal order pch(ip:)=trim(splista(species(elal(ls)))%symbol)//':' endif ip=len_trim(pch)+1 if(mint.le.1 .and. jord(1,mint).eq.ls) then pch(ip-1:)=','//trim(splista(species(jord(2,mint)))%symbol)//':' ip=len_trim(pch)+1 mint=mint+1 endif enddo pch(ip-1:)=';0)' ! write(*,14)'3B sorted interaction 1: ',trim(pch),& ! intperm(1),intperm(2),incperm 14 format(a,a,3i5) 1000 continue return end subroutine bccint1 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine bccint2 !\begin{verbatim} subroutine bccint2(lokph,nsl,elal,noperm,elinks,nint,jord,intperm,intlinks) ! generate all bcc permutations needed for a ternary or reciprocal parameter implicit none ! on entry noperm is the number of permutations of the first interaction ! on exit noperm is the number of permutations of the second interaction integer lokph,nsl,noperm,nint ! elal are the endmember species indices integer, dimension(*) :: elal ! intperm has dimension 24 and contain propagation of interactions ?? integer, dimension(*) :: intperm ! jord(1,int) is the interaction subl. and jord(2,int) the constituent index integer, dimension(2,*) :: jord ! elinks are the permutations of the endmember ! integer, dimension(:,:), allocatable :: elinks integer, dimension(nsl,*) :: elinks ! on entry intlinks are the permutations of the first interaction ! on exit intlinks are the permutations of the second interaction ! it must be deallocated and reallocated using int1links integer, dimension(:,:), allocatable :: int1links integer, dimension(:,:), allocatable :: intlinks !\end{verbatim} integer mint,ls,ip,nperm,mperm,cix,incperm,intem,lq,mq,subint(4) integer loksp,np,nz,isp,sub1,shift character pch*64 ! when we are here we have already generated endmember permutations ! and permutations for the first interaction. ! elal are the constituent indices for the first (ordered) endmember ! elinks are constituent indices for endmember permutations ! jord(1,*) are sublattices, jord(2,*) are species indices of interactions ! intperm(1) is the number of permutations for first interaction ! intperm(2) is total number of interaction links for first interaction ! intperm(3..) should be set here: ! intperm(3) to number of different sets of permutations of 2nd interaction ! this can be 1 if all equal, otherwise same as intperm(2) (??) ! intperm(3+i) to number of permutation for set i of second interaction ! intperm(4+intperm(2)) to total number of permutations ! intlinks are pairs of sublattice/constituent for permutations ! intlinks(1:2,1..intperm(2)) already set ! noperm should be set to the number of permutations of this interaction ?? ! write(*,7)'3B entering bccint2',jord(1,1),jord(1,2),jord(2,2),& nint,noperm,intperm(1),intperm(2),(elal(ls),ls=1,4) 7 format(a,3i4,2x,4i4,2x,4i4,2x,5i4) mperm=0 notternary: if(jord(1,1).ne.jord(1,2)) then ! reciprocal parameter, suck, complicated, noperm is endmember permuations ! elal(*) are species indices of endmembers ! jord(2,*) are species indices of interactions if(elal(jord(1,1)).eq.elal(jord(1,2)) .and. & jord(2,1).eq.jord(2,2)) then ! we have interaction between the same two elements in two subl A,B:A,B:C:D ! the endmember permutation determine what is C and D and sublattices !---------------------- select case(noperm) case default write(*,*)'3B illegal value of noperm in bccint2' gx%bmperr=4277; goto 1000 !---------------------- ! BCC permutations, case(1) ! A:A:A:A interaction AX:AX:A:A or AX:A:AX:A ! Trying to understand this in December 2023/BoS ! this is recipocal parameter for B32, it is binary and should be implemented!! ! There are 4 permutations AX:A:AX:A, A:AX:AX:A, AX:A:A:AX and A:AX:A:AX ! int1: AX:A:A:A A:AX:A:A A:A:AX:A ! int2: AX:AX:A:A A:AX:AX:A A:A:AX:AX ! AX:A:AX:A A:AX:A:AX - ! AX:A:A:AX - - maybe not important write(*,*)'3B BCC reciprocal AX:AX:A:A not implemented case1' gx%bmperr=4277; goto 1000 !---------------------- case(2) ! A:A:B:B interaction AX:AX:B:B or A:A:BX:BX ! This is reciprocal parameter in B2 ordering ! int1: AX:A:B:B A:AX:B:B B:B:AX:A B:B:A:AX ! int2: AX:AX:B:B none B:B:AX:AX none ! This can handle A,B:A,B:*:* intperm(3)=2 intperm(4)=1 intperm(5)=0 intperm(6)=2 nz=intperm(2) loksp=phlista(lokph)%constitlist(jord(2,2)) isp=splista(loksp)%alphaindex write(*,*)'3B reciprocal AB:AB:C:C',intperm(5),jord(1,2) if(jord(1,2).eq.2) then intlinks(1,nz+1)=2 call findconst(lokph,intlinks(1,nz+1),isp,intlinks(2,nz+1)) if(gx%bmperr.ne.0) goto 1000 intlinks(1,nz+2)=4 call findconst(lokph,intlinks(1,nz+2),isp,intlinks(2,nz+2)) if(gx%bmperr.ne.0) goto 1000 else intlinks(1,nz+1)=4 call findconst(lokph,intlinks(1,nz+1),isp,intlinks(2,nz+1)) if(gx%bmperr.ne.0) goto 1000 intlinks(1,nz+2)=2 call findconst(lokph,intlinks(1,nz+2),isp,intlinks(2,nz+2)) if(gx%bmperr.ne.0) goto 1000 endif !---------------------- case(4) ! A:B:A:B and a ternary interaction, B can be wildcard ! this is also the B32 binary reciprocal parameter such as A,B:*:A,B:* ! int1: AB:*:A:* *:AB:A:* ! int2: AB:*:AB:* *:AB:AB:* ! AB:*:*:AB *:AB:*:AB ! Trying to understand argument ... 2023/BoS write(*,11)'3B reciprocal AB:C:AB:C',noperm,(intperm(nz),nz=1,8) write(*,12)nint,(jord(1,nz),nz=1,nint),(jord(2,nz),nz=1,nint) 11 format(a,i7,7i3) 12 format(i3,5x,2i3,5x,2i3) write(*,*)'3B BCC B32 reciprocal interaction not implemented case4' gx%bmperr=4277 !---------------------- case(8) ! several other ternary excess parameters ignored write(*,*)'3B BCC reciprocal interaction not implemented case8' gx%bmperr=4277 end select !---------------------- elseif(elal(jord(1,1)).eq.elal(jord(1,2)) .or. & jord(2,1).eq.jord(2,2)) then ! in interacting sublattices the endmembers or interactions are the same ! common case 2: A,B:A,C:D:D (where D can be wildcard, A, B or C) ! common case 3: A,C:B,C:D:D (where D can be wildcard, A, B or C) ! 4 permutations: AB:AC:D:D AC:AB:D:D D:D:AB:AC D:D:AC:AB or ! 8 permutations: AB:D:AC:D D:AB:AC:D AB:D:D:AC D:AB:D:AC ! AC:D:AB:D D:AC:D:AB AC:D:D:AB D:AC:D:AB select case(noperm) case default write(*,*)'3B illegal value of noperm in bccint2' gx%bmperr=4277; goto 1000 !---------------------- case(1) ! A:A:A:A interaction AX:AY:A:A or AX:A:AY:A write(*,*)'3B BCC reciprocal AX:AY:A:A not implemented case1B' gx%bmperr=4277; goto 1000 !---------------------- case(2) ! A:A:B:B interaction AX:AY:B:B or A:A:BX:BY ! int1: AX:A:B:B A:AX:B:B B:B:AX:A B:B:A:AX ! int2: AX:AY:B:B AY:AX:B:B B:B:AX:AY B:B:AY:AX intperm(3)=1 intperm(4)=1 intperm(5)=4 nz=intperm(2) loksp=phlista(lokph)%constitlist(jord(2,2)) isp=splista(loksp)%alphaindex write(*,*)'3B reciprocal AB;AB:C:C',intperm(5),jord(1,2) if(jord(1,2).eq.2) then intlinks(1,nz+1)=2 call findconst(lokph,intlinks(1,nz+1),isp,intlinks(2,nz+1)) if(gx%bmperr.ne.0) goto 1000 intlinks(1,nz+2)=1 call findconst(lokph,intlinks(1,nz+2),isp,intlinks(2,nz+2)) if(gx%bmperr.ne.0) goto 1000 intlinks(1,nz+3)=4 call findconst(lokph,intlinks(1,nz+3),isp,intlinks(2,nz+3)) if(gx%bmperr.ne.0) goto 1000 intlinks(1,nz+4)=3 call findconst(lokph,intlinks(1,nz+4),isp,intlinks(2,nz+4)) if(gx%bmperr.ne.0) goto 1000 else intlinks(1,nz+1)=4 call findconst(lokph,intlinks(1,nz+1),isp,intlinks(2,nz+1)) if(gx%bmperr.ne.0) goto 1000 intlinks(1,nz+2)=3 call findconst(lokph,intlinks(1,nz+2),isp,intlinks(2,nz+2)) intlinks(1,nz+3)=2 if(gx%bmperr.ne.0) goto 1000 call findconst(lokph,intlinks(1,nz+3),isp,intlinks(2,nz+3)) if(gx%bmperr.ne.0) goto 1000 intlinks(1,nz+4)=1 call findconst(lokph,intlinks(1,nz+4),isp,intlinks(2,nz+4)) if(gx%bmperr.ne.0) goto 1000 endif !---------------------- case(4) ! A:B:A:B not much used ?? ! This is the B32 reciprocal AB:*:AB:* write(*,*)'3B BCC interaction not implemented case 4B' gx%bmperr=4277 !---------------------- case(8) ! several write(*,*)'3B BCC interaction not implemented case 8B' gx%bmperr=4277 end select !---------------------- else ! in subl with interactions neither interaction elements nor endmember sames ! like A,B:B,C:D:E write(*,*)'3B BCC reciprocal interaction not implemented 20' gx%bmperr=4277 endif !------------------------------------------------------------- else ! this is the ternary permutation ! if second interaction in same sublattice as first it is simple!! ! A,B,C:X:Y:Z has exactly the same permutations as A,B:X:Y:Z ! NOT STORED CORRECTLY, bug when listing, also for option F!!! (never tested) intperm(3)=1 intperm(4)=1 ! intperm(4+intperm(3)) should be total number of permutations!! ! intperm(2) is number of endmeber+first interaction permutations intperm(5)=2*intperm(2) nz=intperm(2) loksp=phlista(lokph)%constitlist(jord(2,2)) isp=splista(loksp)%alphaindex write(*,*)'3B ternary: ',trim(splista(species(jord(2,2)))%symbol),& nz,intlinks(1,1),isp do np=1,intperm(2) intlinks(1,nz+np)=intlinks(1,np) call findconst(lokph,intlinks(1,np),isp,intlinks(2,nz+np)) if(gx%bmperr.ne.0) goto 1000 enddo endif notternary ! Code below is just to check the constituents are correctly sorted 900 continue mint=1 pch='G(BORD,' ip=8 do ls=1,4 if(elal(ls).lt.0) then pch(ip:)='*:' else ! splista is ordered as the species are entered, thus splista(1) is VA ! species(i) is the index in splista of elements in alphabetcal order pch(ip:)=trim(splista(species(elal(ls)))%symbol)//':' endif ip=len_trim(pch)+1 910 continue if(mint.le.nint .and. jord(1,mint).eq.ls) then pch(ip-1:)=','//trim(splista(species(jord(2,mint)))%symbol)//':' ip=len_trim(pch)+1 mint=mint+1 goto 910 endif enddo pch(ip-1:)=';0)' write(*,14)'3B sorted interaction 2: ',trim(pch),intperm(4+intperm(3)) 14 format(a,a,4i5) 1000 continue return end subroutine bccint2 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine tdbrefs !\begin{verbatim} subroutine tdbrefs(refid,line,mode,iref) ! store a reference from a TDB file or given interactivly ! If refid already exist and mode=1 then amend the reference text implicit none character*(*) refid,line integer mode,iref !\end{verbatim} integer ip,ml,nr,mc,nc,jl ! make sure refid is left adjusted ip=0 10 ip=ip+1 if(ip.gt.len(refid)) then gx%bmperr=4154; goto 1000 endif if(refid(ip:ip).eq.' ') goto 10 if(ip.gt.1) refid=refid(ip:) ! make it upper case call capson(refid) ! look if refid already exist do iref=1,reffree-1 if(refid.eq.bibrefs(iref)%reference) then if(mode.eq.1) then ! write(*,70)i,refid,bibrefs(i)%refspec !70 format('3B tdbrefs: ',i4,a,a) ! deallocate(bibrefs(iref)%refspec) ! deallocate(bibrefs(iref)%nyrefspec) deallocate(bibrefs(iref)%wprefspec) goto 200 else ! reference already exist and no changes needed goto 1000 endif endif enddo ! if bibliographic reference does not exist do not create if(mode.eq.1) goto 1000 iref=reffree reffree=reffree+1 bibrefs(iref)%reference=refid 200 continue ml=len_trim(line) ! nr=(ml+63)/64 ! allocate(bibrefs(iref)%refspec(nr)) if(ml.gt.1024) then write(*,*)'Bibliographic references longer than 1024 will be truncated' mc=nwch(1024)+1 else mc=nwch(ml)+1 endif allocate(bibrefs(iref)%wprefspec(mc)) ! This requires Fortran 2003/2008 standard ! allocate(character(len=mc) :: bibrefs(iref)%nyrefspec) ! mc=1 ! nc=0 ! bibrefs(iref)%nyrefspec=line(1:mc) bibrefs(iref)%wprefspec(1)=ml call storc(2,bibrefs(iref)%wprefspec,line(1:ml)) ! write(*,202)'3B newref: ',iref,refid,nr,line(1:min(32,len_trim(line))) !202 format(a,i4,1x,a,i3,1x,a) ! do jl=1,nr ! 1-64 mc=1, nc=64 ! 65-122 ! bibrefs(iref)%refspec(jl)=' ' ! nc=nc+min(ml,64) ! bibrefs(iref)%refspec(jl)=line(mc:nc) ! mc=nc+1 ! ml=ml-64 ! enddo 1000 continue return end subroutine tdbrefs !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine enter_equilibrium !\begin{verbatim} subroutine enter_equilibrium(name,number) ! creates a new equilibrium. Allocates arrayes for conditions ! components, phase data and results etc. ! returns index to new equilibrium record ! THIS CAN PROBABLY BE SIMPLIFIED, especially phase_varres array can be ! copied as a whole, not each record structure separately ... ??? implicit none character name*(*) integer number !\end{verbatim} %+ ! allocate TYPE(gtp_phase_varres), pointer :: cpv,cp1 character name2*64 integer ieq,ipv,nc,jz,iz,jl,jk,novarres,lokdis,needcs,lokph if(.not.allowenter(3)) then write(*,*)'3B: not allowed enter equilibrium: ',name gx%bmperr=4153; goto 1000 endif ! if name is empty or has a non-alphabetical letter first generate a name ?? name2=name call capson(name2) ! write(*,3)'3B In enter equilibria: ',name,noofph,eqfree,csfree,highcs 3 format(a,1x,a,6i5) if(.not.proper_symbol_name(name2,0)) then ! the name must start with a letter A-Z and contain letters, numbers and _ gx%bmperr=4122 goto 1000 endif call findeq(name2,ieq) if(gx%bmperr.eq.0) then ! error as equilibrium with this name already exists gx%bmperr=4123 goto 1000 else ! Error code 4124 means no such equilibrium, OK as we are creating it! ! Any other error code will cause error return if(gx%bmperr.ne.4124) goto 1000 gx%bmperr=0 endif if(eqfree.le.maxeq) then ieq=eqfree eqfree=eqfree+1 endif number=ieq if(ocv()) write(*,*)'3B create eq',eqfree,maxeq,ieq ! allocate data arrayes in equilibrium record eqlista(ieq)%nexteq=0 eqlista(ieq)%eqname=name2 eqlista(ieq)%eqno=ieq eqlista(ieq)%weight=-one eqlista(ieq)%comment=' ' ! component list and matrix, if second or higher equilibrium copy content if(ocv()) write(*,*)'3B: entereq 1: ',maxel,ieq,noofel if(ieq.eq.1) then ! allocate large arrays as we do not know what system will be calculated allocate(eqlista(ieq)%complist(maxel)) allocate(eqlista(ieq)%compstoi(maxel,maxel)) allocate(eqlista(ieq)%invcompstoi(maxel,maxel)) allocate(eqlista(ieq)%cmuval(maxel)) eqlista(ieq)%cmuval=zero ! this is a bit meaningless but skipping it has given raise to strange errors eqlista(ieq)%compstoi=zero eqlista(ieq)%invcompstoi=zero do jl=1,maxel eqlista(ieq)%compstoi(jl,jl)=one eqlista(ieq)%invcompstoi(jl,jl)=one ! valgrind complained this was not set !! eqlista(ieq)%complist(jl)%chempot=zero enddo ! Maybe valgrind complained of this ... it can have to do with -finit-local-zero eqlista(ieq)%status=0 eqlista(ieq)%status=ibset(eqlista(ieq)%status,EQNOEQCAL) else eqlista(ieq)%status=0 ! we should set some status bits ... eqlista(ieq)%status=ibset(eqlista(ieq)%status,EQNOEQCAL) allocate(eqlista(ieq)%complist(noofel)) ! copy mass of components, maybe other components? do jl=1,noofel eqlista(ieq)%complist(jl)%mass=firsteq%complist(jl)%mass enddo allocate(eqlista(ieq)%compstoi(noofel,noofel)) allocate(eqlista(ieq)%invcompstoi(noofel,noofel)) allocate(eqlista(ieq)%cmuval(noofel)) ! this is a bit meaningless but skipping it has given raise to strange errors eqlista(ieq)%compstoi=zero eqlista(ieq)%invcompstoi=zero do jl=1,noofel eqlista(ieq)%compstoi(jl,jl)=one eqlista(ieq)%invcompstoi(jl,jl)=one enddo eqlista(ieq)%cmuval=zero if(ocv()) write(*,*)'3B: entereq 1B: ' do jl=1,noofel eqlista(ieq)%complist(jl)%splink=firsteq%complist(jl)%splink eqlista(ieq)%complist(jl)%phlink=firsteq%complist(jl)%phlink eqlista(ieq)%complist(jl)%status=firsteq%complist(jl)%status ! if(firsteq%complist(jl)%phlink.gt.0) then ! only if there is a defined reference state eqlista(ieq)%complist(jl)%refstate=firsteq%complist(jl)%refstate eqlista(ieq)%complist(jl)%tpref=firsteq%complist(jl)%tpref eqlista(ieq)%complist(jl)%chempot=zero do jk=1,noofel eqlista(ieq)%compstoi(jl,jk)=firsteq%compstoi(jl,jk) eqlista(ieq)%invcompstoi(jl,jk)=firsteq%invcompstoi(jl,jk) enddo if(allocated(firsteq%complist(jl)%endmember)) then iz=size(firsteq%complist(jl)%endmember) if(ocv()) write(*,*)'3B: entereq 1E: ',iz allocate(eqlista(ieq)%complist(jl)%endmember(iz)) eqlista(ieq)%complist(jl)%endmember=& firsteq%complist(jl)%endmember endif ! endif enddo endif ! write(*,*)'3B enter_eq 2, after this segmentation fault' ! these records keep calculated values of G and derivatives for each phase ! For phase lokph the index to phase_varres is in phlista(lokph)%cslink ! For phase lokph the index to phase_varres is in phlista(lokph)%linktocs(ics) if(ocv()) write(*,*)'3B: entereq 2: ',maxph alleq: if(ieq.eq.1) then needcs=2*maxph allocate(eqlista(ieq)%phase_varres(needcs)) firsteq=>eqlista(ieq) ! %multiuse is used for axis and direction of a start equilibrium firsteq%multiuse=0 ! we should also set phstate in all phase_varres to 0 to avoid uninitiated ! test of phase status in test_phase_status!! do ipv=1,needcs firsteq%phase_varres(ipv)%phstate=0 enddo ! endif is at label 900, no need for goto ! goto 900 else eqlista(ieq)%multiuse=0 ! UNFINISHED vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! this is not good, csfree is not the last used phase_varres ! there may be allocated records after and unallocated before !! ! if(highcs.ne.csfree-1) then ! write(*,*)'3B Beware, problems with varres records!',csfree,highcs ! endif novarres=highcs ! the next line should be removed when highcs correctly implemented novarres=csfree-1 iz=noofph !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! for ieq>1 allocate an estimated number of phase_varres records ! for extra composition sets added later ! allocate(eqlista(ieq)%phase_varres(iz+10)) ! I had a case with 4 components, 1 phase+disordered fraction set ! and with 4 compositon sets!! needcs=2*noofph+2*noofel+10 if(csfree.gt.needcs .or. highcs.gt.needcs) then write(*,*)'3B Error allocating phase_varres: ',needcs,csfree,highcs needcs=max(csfree,highcs)+10 endif ! the +10 should cater for compostion sets created due to miscibility gaps ! and also disordered fractions sets allocate(eqlista(ieq)%phase_varres(needcs)) ! write(*,*)'3B enter_eq 2B, after this segmentation fault' ! write(*,*)'3B varres: ',ieq,size(eqlista(ieq)%phase_varres),iz if(ocv()) write(*,*)'3B varres: ',ieq,size(eqlista(ieq)%phase_varres) ! now copy the current content of firsteq%phase_varres to this equilibrium ! note, the SELECT_ELEMENT_REFERENCE phase has phase number 0 ! and phase_varres index 1, the number of phase_varres records is not the ! same as number of phases .... novarres=needcs ! copy also unused varres records, we do not really how many is used ... copypv: do ipv=1,novarres ! note eqlista(1) is identical to firsteq if(.not.allocated(firsteq%phase_varres(ipv)%yfr)) then ! UNFINISHED this handels unallocated records below novarres ! write(*,*)'3B problem creating varres record',ipv ! BUT what about allocated after !!! no problem so far but ............. cycle copypv endif cp1=>eqlista(1)%phase_varres(ipv) cpv=>eqlista(ieq)%phase_varres(ipv) cpv%nextfree=cp1%nextfree cpv%phlink=cp1%phlink cpv%phstate=cp1%phstate cpv%status2=cp1%status2 cpv%abnorm=cp1%abnorm cpv%prefix=cp1%prefix cpv%suffix=cp1%suffix cpv%phtupx=cp1%phtupx ! Be careful, in first equilibrium these arrays are dimentioned very large ! allocate and copy arrays lokph=cp1%phlink if(lokph.le.0) then ! maybe problem here for SELECT_ELEMENT_REFERENCE ?? ! write(*,*)'No phase? ',ipv nc=noofel else nc=phlista(lokph)%tnooffr endif ! note SIZE gives rubbish unless array is allocated if(ocv()) write(*,*)'3B copy yfr 1: ',nc ! yfr may be allocated if this composition set is a disordered fraction set if(allocated(cpv%yfr)) then write(*,*)'3B fractions already allocated: ',ieq,ipv cycle copypv endif allocate(cpv%yfr(nc)) cpv%yfr=cp1%yfr ! problems with phase_varres in equilibrium 2 ... ! write(*,46)'3B 1: ',cp1%yfr ! write(*,46)'3B v: ',cpv%yfr 46 format('yfr ',a,10(F7.3)) allocate(cpv%constat(nc)) cpv%constat=cp1%constat ! write(*,*)'3B enter_eq 2C, after this segmentation fault' if(allocated(cp1%mmyfr)) then ! problem with mmyfr??? .... no ! if(ocv()) write(*,*)'3B mmyfr 1: ',ipv,cpv%phlink,nc allocate(cpv%mmyfr(nc)) cpv%mmyfr=cp1%mmyfr ! write(*,34)'3B mmyfr 2: ',(cpv%mmyfr(jz),jz=1,nc) 34 format(1x,a,10(F7.3)) ! else ! write(*,*)'3B mmyfr not allocated' endif jz=size(cp1%sites) allocate(cpv%sites(jz)) cpv%sites=cp1%sites ! these are currently not allocated (ionic liquid model) Maybe not needed?? if(allocated(cp1%dpqdy)) then jz=size(cp1%dpqdy) allocate(cpv%dpqdy(jz)) cpv%dpqdy=cp1%dpqdy jz=size(cp1%d2pqdvay) allocate(cpv%d2pqdvay(jz)) cpv%d2pqdvay=cp1%d2pqdvay endif ! the values in the following arrays are irrelevant, just allocate and zero ! write(*,*)'3B enter_eq 2D, after this segmentation fault',ipv,novarres cpv%nprop=cp1%nprop allocate(cpv%listprop(cp1%nprop)) allocate(cpv%gval(6,cp1%nprop)) allocate(cpv%dgval(3,nc,cp1%nprop)) allocate(cpv%d2gval(nc*(nc+1)/2,cp1%nprop)) cpv%listprop=0 cpv%amfu=zero cpv%dgm=zero cpv%phstate=PHENTERED cpv%netcharge=zero cpv%gval=zero cpv%dgval=zero cpv%d2gval=zero ! copy the disordered fraction record, that should take care of all ! array allocations inside the disfra record ??? cpv%disfra=cp1%disfra !------------------------------------------------------------------- ! attempt to correct segmentation fault 2017.12.09/BoS ! This is correct but the varres records for the disordered fraction sets ! will be copied in this loop anyway ! disordered: if(cpv%disfra%varreslink.gt.0) then ! if there is a disordered phase_varres record that must be taken care of ! lokdis=cpv%disfra%varreslink ! eqlista(ieq)%phase_varres(lokdis)%abnorm=& ! eqlista(1)%phase_varres(lokdis)%abnorm ! !!!! WOW it really seems to copy a whole phase_varres record just by = !!! ! eqlista(ieq)%phase_varres(lokdis)=eqlista(1)%phase_varres(lokdis) ! !!! NO!!! an assignment = will only copy local data in the record ! records accessed by pointers (such as conditions !!!) ! are not copied and point at at the same records as ! in the old phase_varres record ! endif disordered !------------------------------------------------------------------- enddo copypv ! write(*,*)'3B enter_eq 2E, after this segmentation fault' endif alleq ! From here also for first equilibria 900 continue ! write(*,*)'3B enter_eq 3' if(ocv()) write(*,*)'3B: entereq 3: ' ! nullify condition links, otherwise "if(associated(..)" does not work nullify(eqlista(ieq)%lastcondition) nullify(eqlista(ieq)%lastexperiment) if(ocv()) write(*,*)'3B set T and P',ieq ! also set default local values of T and P (not conditions) eqlista(ieq)%tpval(1)=1.0D3; eqlista(ieq)%tpval(2)=1.0D5 ! allocate and copy tpfun result array also for first equilibria ! jz=size(firsteq%eq_tpres) jz=maxtpf ! write(*,*)'3B enter_eq 4',jz,maxsvfun if(ocv()) write(*,*)'3B: entereq 4: ',jz,maxsvfun ! write(*,*)'3B create equil tpres size ',jz,notpf() ! Valgrind wants us to initiate eq_tpres%forcenewcalc !!! ! This is probably quite messy as eq_pres are pointers??? !! eq_tpres already allocated in gtp_init??? ! allocate(eqlista(ieq)%eq_tpres(jz)) if(.not.allocated(eqlista(ieq)%eq_tpres)) then ! if(ieq.ne.1) then ! write(*,*)'3B Allocating eq_tpres for equil: ',ieq,jz,freetpfun allocate(eqlista(ieq)%eq_tpres(jz)) ! endif endif ! this should be done in init_tpfun (gtp3Z.F90) ?? do iz=1,jz eqlista(ieq)%eq_tpres(iz)%forcenewcalc=0 enddo ! allocate result array for state variable functions (svfunres) if(ocv()) write(*,*)'3B maxsvfun: ',ieq,maxsvfun,jz ! write(*,*)'3B Allocating svfunres for equilibrium: ',name(1:len_trim(name)) allocate(eqlista(ieq)%svfunres(maxsvfun)) ! convergence criteria PHTUPX eqlista(ieq)%xconv=firsteq%xconv eqlista(ieq)%gdconv(1)=firsteq%gdconv(1) eqlista(ieq)%gdconv(2)=firsteq%gdconv(2) eqlista(ieq)%maxiter=firsteq%maxiter 1000 continue if(ocv()) write(*,*)'3B finished enter equilibrium',ieq return end subroutine enter_equilibrium !allocate !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine geneqname !\begin{verbatim} subroutine geneqname(text) ! creates a equilibrium name like EQ_x where x is the freeq in text implicit none character text*(*) !\end{verbatim} integer ip text='EQ_' ip=4 call wriint(text,ip,eqfree) ! write(*,*)'3B eqname: ',trim(text),len_trim(text),eqfree 1000 continue end subroutine geneqname !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine enter_many_equil !\begin{verbatim} subroutine enter_many_equil(cline,last,pun) ! executes an enter many_equilibria command ! and creates many similar equilibria from a table ! pun is file units for storing experimental dataset, pun(i)>0 if i is open implicit none character*(*) cline integer last,pun(9) !\end{verbatim} ! enter many_equilibria ! by default all phases suspended ! 1 entered phases ! 2 fixed phases ! 3 dormant phases ! 4 conditions .... ! 5 experiments .... ! 6 calculate symbols ! 7 list state_variables ! 8 table_start ! values in columns ... ! 9 table_end !10 referece state !11 plot_data !12 not used ! ! values required by @ will appear in table in column order ! EXAMPLE: ! enter many_equilibria ! fixed 1 liquid @1 ! condition T=1000 p=1e5 ! experiment x(liq,cr)=@2:@3 x(@1,cr)=@4:10% ! table_start ! bcc 0.15 0.02 0.20 ! ... ! table_end ! expanded experiment line: ! experiment x(liq,cr)=0.15:0.02 x(bcc,cr)=0.20:10% ! ! ncom is numbor of command, ncol is max number of columns in tables integer, parameter :: ncom=12,ncol=9 character (len=12), dimension(ncom), parameter :: commands=& ! 123456789.12...123456789.12...123456789.12...123456789.12 ['FIXED ','ENTERED ','DORMANT ','CONDITIONS ',& 'EXPERIMENTS ','CALCULATE ','LIST ','TABLE_START ',& 'COMMENT ','REFERENCE_S ','PLOT_DATA ',' '] character*128 rowtext(ncom),text*128,dummy*128,tval*24,savetitle*24 character*128 eqlin(ncom),eqname*24,plotdatafile*8,encoded*24 character*512 curdir integer dcom,kom,done(ncom),ip,jp,kp,ival,jval,neq,slen,shift,ieq,nystat integer iel,iph,ics,maxcol,jj type(gtp_equilibrium_data), pointer ::ceq double precision xxx,xxy,pxx,pyy,tpa(2),xarr(6) ! This is to know where to store column values from a row TYPE gtp_row integer column,position end type gtp_row type(gtp_row), dimension(ncom,ncol) :: colvar,coleq logical plotfile ! done=0 plotfile=.FALSE. do ip=1,ncom-1 colvar(ip,1)%column=0 rowtext(ip)=' ' enddo maxcol=0 dcom=0 100 continue call gparcdx('Table head line: ',cline,last,5,text,' ','?Enter many equil') kom=ncomp(text,commands,ncom,last) if(kom.le.0) then write(kou,110)text(1:len_trim(text)) 110 format('Error in subcommand to enter many: ',a) gx%bmperr=4278; goto 1000 endif ! the table_start command means end of head, generate one equilibria per row if(kom.eq.8) goto 299 ! ================================================================= ! the heading is stored in character array rowtext(1..12) ! Keep the whole line, the only thing we handle now are column references dcom=dcom+1 rowtext(dcom)=cline !===================================================================== ! seach for column indicators @digit (0< digit <=9) ip=1 200 continue ! write(*,*)'3B at 200: ',rowtext(kom)(ip:len_trim(rowtext(kom))),ip jp=index(rowtext(dcom)(ip:),'@') if(jp.gt.0) then ! only a single digit allowed!! ival=ichar(rowtext(dcom)(ip+jp:ip+jp))-ichar('0') if(ival.le.0 .or. ival.gt.9) then write(*,*)'3B Error in line: "',trim(rowtext(dcom)),'"' gx%bmperr=4399; goto 1000 endif ! maxcol is the maximal column referred to in the head if(ival.gt.maxcol) maxcol=ival if(ival.le.0 .or. ival.gt.9) then ! column 0 is name of equilibrium, not a value write(kou,*)ival,rowtext(dcom)(1:jp+1) 210 format('Illegal column for variable: ',i3,': ',a) gx%bmperr=4399; goto 1000 else do kp=1,ncol if(colvar(dcom,kp)%column.eq.0) then if(kp.lt.ncol) colvar(dcom,kp+1)%column=0 colvar(dcom,kp)%column=ival colvar(dcom,kp)%position=ip+jp-1 goto 250 endif enddo ! write(kou,240)ncol,dcom,rowtext(dcom)(1:len_trim(rowtext(dcom))) 240 format('More than ',i2,' column variables used in row ',i3/a) gx%bmperr=4279; goto 1000 ! no problem, continue 250 continue endif ip=ip+jp if(ip.lt.len_trim(rowtext(dcom))) then goto 200 endif endif ! force reading next command line from file or keyboard last=len(cline) goto 100 ! !------------------------------------------------------------ ! Now start generating one equilibrium per line in table 299 continue neq=0 300 continue ! we must not destroy the values in colvar and rowtext!! coleq=colvar eqlin=rowtext ! This is input of lines of the many-equilibria call gparcx('Table row: ',cline,last,5,text,' ','?Enter table row') ! allow empty lines if(len_trim(text).le.1) goto 300 ! remove TAB characters call untab(text) ! make all upper case call capson(text) ! write(*,*)'3B 300: ',cline(1:len_trim(cline)) if(text(1:5).eq.'TABLE') then ! finish if first word on line is "TABLE" meaning TABLE_END ! the beginning has already passed write(kou,310)neq 310 format('Created ',i5,' equilibria') goto 1000 endif ! values are in column order,the digit after @ ip=0 values: do ival=0,maxcol ! value in column ival should replace all @digit in all lines, allow "," in tval call getext(text,ip,2,tval,' ',slen) ! write(*,*)'3B tval: ',tval,slen,ival if(slen.le.0) then write(kou,*)'Table row missing value in column: ',ival gx%bmperr=4280; goto 1000 endif ! first value, in column 0, is equilibrium name if(ival.eq.0) then eqname=tval; cycle values endif ! the column value can be used in several places, also in the same row com2: do jp=1,ncom-1 shift=0 com3: do kp=1,ncol if(coleq(jp,kp)%column.gt.0) then ! write(*,330)'3B replace: ',jp,kp,coleq(jp,kp)%column,ival,& ! shift,tval 330 format(a,2i3,i14,2i4,': ',a) if(coleq(jp,kp)%column.eq.ival) then ! insert column value at coleq(jp,kp)%position dummy=eqlin(jp)(coleq(jp,kp)%position+2:) eqlin(jp)(coleq(jp,kp)%position:)=tval eqlin(jp)(coleq(jp,kp)%position+slen:)=dummy ! write(*,*)'3B eqlin: ',eqlin(jp)(1:len_trim(eqlin(jp))) shift=shift+slen-2 else ! we must update all following positions in coleq(jp,...) ! write(*,332)'3B shifting: ',jp,kp,coleq(jp,kp)%position,shift 332 format(a,2i3,2x,2i4) coleq(jp,kp)%position=coleq(jp,kp)%position+shift endif else cycle com2 endif enddo com3 enddo com2 enddo values ! check the final equilibrium description neq=neq+1 ! write(*,*)'3B New equilibrium: ',eqname,dcom ! do kom=1,dcom ! write(kou,340)neq,kom,eqlin(kom)(1:len_trim(eqlin(kom))) !340 format('3B cc',2i3,' :',a) ! enddo !======================================================================== ! create the equilibrium using the row values ! write(*,*)'3B enter equilibrium: ',eqname,ieq call enter_equilibrium(eqname,ieq) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'3B entered equilibrium: ',eqname call selecteq(ieq,ceq) ! write(kou,515)eqname,ieq !515 format('3B Entered equilibrium: ',a,' with number ',i4) ! by default set all phases suspended ip=-1; jp=1; nystat=PHSUS; xxx=zero ! write(*,*)'3B suspending all phases' call change_phase_status(ip,jp,nystat,xxx,ceq) ! call change_many_phase_status(tval,nystat,xxx,ceq) if(gx%bmperr.ne.0) goto 1000 !======================================================================== ! now set values for the equilibrium description with dcom lines ! THESE COMMANDS IS NOT INTERACTIVE, they should be read from a file do jval=1,dcom kom=ncomp(eqlin(jval),commands,ncom,last) ! write(*,12)'3B eqlin: ',jval,trim(eqlin(jval)),last,kom 12 format(a,i3,' "',a,'" ',2i3) SELECT CASE(kom) !--------------------------- CASE DEFAULT write(*,*)'Error generating equilibrium: ',trim(eqlin(jval)) !--------------------------- CASE(1,2)! fixed and entered phases ! pick up the number of moles of the phases as first argument after command call getext(eqlin(jval),last,1,tval,'1.0',slen) ip=1 call getrel(tval,ip,xxx) if(buperr.ne.0) then write(*,11)'3B Line causing error: ',trim(eqlin(jval)) 11 format(/a,' "',a,'"'/) gx%bmperr=4281; goto 1000 endif nystat=PHFIXED if(kom.eq.2) nystat=PHENTERED if(eolch(eqlin(jval),last)) then write(*,*)'3B no phase name after status command' gx%bmperr=4282; goto 1000 endif call change_many_phase_status(eqlin(jval)(last:),nystat,xxx,ceq) if(gx%bmperr.ne.0) goto 1000 !--------------------------- CASE(3)! domant phases nystat=PHSUS xxx=zero call change_many_phase_status(eqlin(jval)(last:),nystat,xxx,ceq) if(gx%bmperr.ne.0) goto 1000 !--------------------------- CASE(4)! conditions ip=0 call set_condition(eqlin(jval)(last:),ip,ceq) if(gx%bmperr.ne.0) goto 1000 !--------------------------- CASE(5)! experiments ip=0 ! write(*,*)'3B exp: "',trim(eqlin(jval)(last:)),'"',jp call enter_experiment(eqlin(jval)(last:),ip,ceq) if(gx%bmperr.ne.0) goto 1000 !--------------------------- CASE(6)! calculate symbol if(.not.allocated(ceq%eqextra)) then allocate(ceq%eqextra(3)) ceq%eqextra(2)=' ' ceq%eqextra(3)=' ' endif ceq%eqextra(1)=eqlin(jval)(last:) !--------------------------- CASE(7)! list state variables and modelled properties if(.not.allocated(ceq%eqextra)) then allocate(ceq%eqextra(3)) ceq%eqextra(1)=' ' ceq%eqextra(3)=' ' endif ceq%eqextra(2)=eqlin(jval)(last:) !--------------------------- ! CASE(8)! table start should never occur !--------------------------- CASE(9)! comment ceq%comment=eqlin(jval)(last:) !--------------------------- CASE(10)! reference state call gparcx('Component name: ',eqlin(jval),last,1,tval,' ',& '?Enter many equil') call find_component_by_name(tval,iel,ceq) if(gx%bmperr.ne.0) goto 1000 call gparcx('Reference phase: ',eqlin(jval),last,1,tval,'SER ',& '?Enter many equil') if(tval(1:4).eq.'SER ') then ! write(kou,*)'Reference state is stable phase at 298.15 K and 1 bar' ! this means no reference phase, SER is at 298.15K and 1 bar iph=-1 else call find_phase_by_name(tval,iph,ics) if(gx%bmperr.ne.0) goto 1000 ! temperature * means always to use current temperature xxy=-one call gparrx('Temperature: /*/: ',eqlin(jval),last,xxx,xxy,& '?Enter many equil') if(buperr.ne.0) then ! write(*,*)'3B buperr: ',buperr buperr=0 tpa(1)=-one elseif(xxx.le.zero) then tpa(1)=-one else tpa(1)=xxx endif xxy=1.0D5 call gparrdx('Pressure: ',eqlin(jval),last,xxx,xxy,& '?Enter many equil') if(xxx.le.zero) then tpa(2)=xxy else tpa(2)=xxx endif endif ! write(*,*)'3B Reference T and P: ',tpa call set_reference_state(iel,iph,tpa,ceq) !--------------------------- CASE(11)! PLOT_DATA call getint(eqlin(jval),last,ip) if(buperr.ne.0) then write(kou,*)'Dataset number must be 1 to 9',buperr elseif(ip.eq.0) then ! this is a special plotdata file for calculated values, store in eqextra(3) if(.not.allocated(ceq%eqextra)) then allocate(ceq%eqextra(3)) ceq%eqextra(1)=' ' ceq%eqextra(2)=' ' endif ceq%eqextra(3)=' 0 '//eqlin(jval)(last:) ! write(*,*)'3B eqextra(3): ',trim(ceq%eqextra(3)) else if(ip.le.0 .or. ip.gt.9) then write(*,*)'3B plot_data dataset must be from 1 to 9' goto 1000 endif ! this is for plot datafile 1 to 9 if(pun(ip).eq.0) then ! open file pun(ip)=30+ip plotdatafile='oc_many0' plotdatafile(8:8)=char(ichar('0')+ip) ! call getcwd(curdir) ! write(*,*)'3B current dir: ',trim(curdir) ! write(*,*)'3B working dir: ',trim(workingdir) write(*,77)plotdatafile//'.plt',trim(workingdir) 77 format('3B Plot data written on ',a/3x,'in directory: ',a) open(pun(ip),file=trim(workingdir)//'/'//plotdatafile//'.plt',& access='sequential',status='unknown') call getrel(eqlin(jval),last,pxx) call getrel(eqlin(jval),last,pyy) call getint(eqlin(jval),last,iel) if(buperr.ne.0) then write(*,*)'3B Incorrect values in plot_data: ',& trim(eqlin(jval)) buperr=0 endif if(eolch(eqlin(jval),last)) then savetitle='Unknown' else savetitle=trim(eqlin(jval)(last:)) endif ! write(pun(ip),600)iel,trim(eqlin(jval)(last:)) write(pun(ip),600) 600 format('# GUNPLOT file generated by enter many_equilibria '/& 'set title "Open Calphad 5 : with GNUPLOT"'/& 'set xlabel "whatever"'/& 'set ylabel "whatever"'/& 'set key bottom right'/& '#'/'# You can use expressions to convert values:'/& '# using (1-$3):2 means x-value is "1-value in column 3",',& ' y-value is column 2'/'#'/& '# pt pointtype 1 +, 2 x, 3 star, 4 square, 5 filled square, 6 circle',/& '#',14x,'7 filled circle, 8 triangle up, 9 filled triangle up'/& '#',14x,'10 triangle down, 11 filled triangle down, 12 romb'/& '#',14x,'13 filled romb, 14 pentad, 15 filled pentad, 16 same as 1 etc'/& '# ps pointsize'/'#'/& '# To make a nice plot with different symbols for each experimentalist'/& '# add a plot command for each pointtype with a separate title like:'/& '# plot "-" using 2:3 with points pt 3 ps 1 title "Author A",\ '/& '# "" using 2:3 with points pt 4 ps 1 title "Author B",\ '/& '# etc (see GNUPLOT documentation)',/& '# and add a single "e" after the last line for each pointtype '/'#'/& 'plot "-" using 2:3:4 with points pt variable ps 1 title "please add id"') ! finished opening file else ! This is for reading plot_data values when the file is open call getrel(eqlin(jval),last,pxx) call getrel(eqlin(jval),last,pyy) call getint(eqlin(jval),last,iel) if(buperr.ne.0) then write(*,*)'3B Incorrect values in plot_data',& trim(eqlin(jval)) buperr=0 endif if(eolch(eqlin(jval),last)) then savetitle='Unknown' endif endif ! write the plot_data values on the file write(pun(ip),610)' ',ip,pxx,pyy,iel 610 format(a,i2,2x,2(1pe14.6),i3,5x,a) ! endif data_plot type endif ! endif buperr !--------------------------- ! CASE(12)! unused ! continue end SELECT enddo ! ! force reading next row with values for another equilibrium last=len(cline) goto 300 ! 1000 continue if(gx%bmperr.ne.0) write(*,*)'Error return from enter_many_equil',gx%bmperr ! we can have many enter many with plot data, do not close here! ! The file(s) will be closed when the command enter range ! if(plotfile) then ! write(pun,1010) !1010 format('e'/'pause mouse'/) ! close(pun) ! endif return end subroutine enter_many_equil !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine mqmqa_species !\begin{verbatim} subroutine mqmqa_species(name1,inline,nend) ! almost identical to subroutine mqmqa_species(inline,const,nend,... ! called from readtdb in gtp3E.F90. If nend<0 initiate to 1 ! called also from gtp3EY, OCenterspecies ! the species is created at the end if all is OK ! can take input from database file or terminal ! name1 is OC species name. Must contain / followd by letter ! inline is A/B or A,C/B or A/B,D or A,C/B,D with , and / ! where A, B, C etc must be entered species ! possible inline: "Fe,Al/Si1/4O,Al2/3O" ??? ! it has to decode the list of species A, B, C or D implicit none integer nend ! nend inncremented for each endmember constituent, set -1 at first call ! name2 is the stoichiometry,dimension maxconst! check for overflow character*(*) name1, inline ! type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} ! to enter a whole database, max set by seqnum='01' to '99' ! integer, parameter :: f1=maxconst ! integer, parameter :: f1=200 ! const is array of all quadruplet names, ! mqxquads is maxium number of quads, mqq is max number of species in quads integer, parameter :: maxquads=99,mqq=30 ! it will be all quads character const(maxquads)*24 integer ip,lenc,jp,kp,ncat,ntot,isp(4),loksp,loksparr(4),nspel,thiscon,s1 integer jelno(9),ielno(9),nextra,ee,nel,order1,order2,lat,nquad,ij,ik logical endmember,sametwice1,sametwice2,nomqmqava character*24 cation1,species(4),quaderr character quadname*64,ch1*1,elnames(9)*2 character*2 :: seqnum='00' ! beginning of text to save in species record integer sinsp double precision val,qstoi(mqq),smass,qsp,extra(5),stoi(20),double(4) double precision vazero,totstoi ! Example of input line with "constituents": ! LI/CL 6 6 2.4 LI/O 6 3 2.4 U/CL 6 2 2.4 U/O 6 3 2.4 LI,U/CL 2 6 6 ! LI,U/O 2 6 3 LI/CL,O 6 6 3 U/CL,O 2 6 3 LI,U/CL,O 6 2 6 2 ! The 2.4 for the pairs is the default FNN/SNN ratio ! Added to have correct reference state for SNN quadruplets when elements with ! multiple valencies are used such as U+3 and U+4 ! Species representing different valencies of an element have names as UQ4 ! fnnquads store names of FNN quadruplets integer nfnnq,nsnnq,pair,qorder(maxconst),haha integer, parameter :: mfnnq=40 character (len=24) :: fnnquads(mfnnq),snnrefs(4,maxconst-mfnnq) ! this save is probably redundant save seqnum,nfnnq,nsnnq,fnnquads,snnrefs ! if(nend.lt.0) then ! nend should be a global variable which can be reinitiated with NEW nend=0 mqmqanend=0 endif ! write(*,575)trim(name1),trim(inline),nend 575 format('3B In mqmqa_species: "',a,'" "',a,'" ',i5) ! write(*,2)trim(inline),name1,nend 2 format('3B in mqmqa_species: "',a,'" "',a,'" ',i3) ! This toutine will be called for each mqmqa species entered ! increased %contyp with 4 integers to indices of sublattice species if(.not.allocated(mqmqa_data%contyp)) then ! these should not be already allocated but ... who knows ! sometimes there can be two liquids in the TDB file .... ! write(*,*)'3B Allocating mqmqa_data, max constituents: ',maxquads allocate(mqmqa_data%contyp(14,maxquads)) allocate(mqmqa_data%constoi(4,maxquads)) allocate(mqmqa_data%totstoi(maxquads)) ! how much each pair is part of a quadruplet, needed for pair fractions if(allocated(mqmqa_data%pp)) deallocate(mqmqa_data%pp) allocate(mqmqa_data%pp(4,maxquads)) allocate(mqmqa_data%pinq(12)) mqmqa_data%contyp=0 mqmqa_data%nconst=0 mqmqa_data%constoi=zero mqmqa_data%pp=zero ! these values should maybe be saved between calls .... seqnum='00' nfnnq=0 nsnnq=0 endif ip=0 call capson(inline) ! number of quads nquad=0 mqmqa_data%totstoi=zero ! this set TRUE means VA not allowed in MQMQA phase nomqmqava=.TRUE. 100 continue if(eolch(inline,ip)) goto 900 haha=0 ! set TRUE below if two species represent the same element, such as Fe2Q, Fe3Q sametwice1=.FALSE.; sametwice2=.FALSE. ! here a new quadrupole. Third argumment 2 means terminated by space ! getext increment ip by 1 before extracting so decrement first ip=ip-1 sinsp=ip ! trying to extract quad information ! write(*,*)'3B inline: "',trim(inline),'"',ip call getext(inline,ip,2,quadname,' ',lenc) if(buperr.ne.0) then write(*,*)'3B error reading name of quadrupole' buperr=0; goto 1000 endif ! write(*,*)'3B quadname 3: ',trim(quadname),ip ! a ":" terminates list of quadrupoles if(quadname(1:1).eq.':') goto 900 ! a slash / separate species in different sublattices ! if a species does not exist skip this quadrupole (not an error) jp=index(quadname,'/') if(jp.le.0) then write(*,*)'3B missing / in quadrupole "',trim(quadname),'"' gx%bmperr=4399; goto 1000 endif isp=0 double=one kp=index(quadname,',') ! write(*,*)'3B quadrupole: ',trim(quadname),kp,jp order1=0 if(kp.gt.0 .and. kp.lt.jp) then ! there are two cation species in an SNN species(1)=quadname(1:kp-1) species(2)=quadname(kp+1:jp-1) call find_species_by_name_exact(species(1),isp(1)) call find_species_by_name_exact(species(2),isp(2)) if(gx%bmperr.ne.0) then ! This normal if species not selected ! write(*,*)'3B cannot find cations in: ',trim(quadname(1:jp-1)),& ! ' maybe not selected' goto 810 endif ncat=2 else ! There is a single cation, maybe FNN or quad with two anions species(1)=quadname(1:jp-1) call find_species_by_name_exact(species(1),isp(1)) if(gx%bmperr.ne.0) then ! This normal if species not selected ! write(*,*)'3B cannot find cation: ',trim(species(1)),& ! ' maybe not selected' goto 810 endif isp(2)=0 ncat=1 ! this is because a single cation should have stoichimetry 2.0/bonds double(1)=2.0D0 endif !------------------- ! the cation(s) exist, now check anions, jp is position of / kp=index(quadname(jp:),',') order2=0 if(kp.gt.0) then ! there are two anions ntot=ncat+1 species(ntot)=quadname(jp+1:jp+kp-2) ! write(*,*)'3B anion1: ',species(ntot) call find_species_by_name_exact(species(ntot),isp(ntot)) ! call find_species_record(species(ntot),isp(ntot)) if(gx%bmperr.ne.0) then ! This normal if species not selected ! write(*,*)'3B cannot find anion: ',trim(species(ntot)),& ! ' maybe not selected' goto 810 endif ntot=ntot+1 species(ntot)=quadname(jp+kp:) ! this is second anion ! write(*,*)'3B anion2: ',species(ntot) call find_species_by_name_exact(species(ntot),isp(ntot)) ! call find_species_record(species(ntot),isp(ntot)) if(gx%bmperr.ne.0) then ! This normal if species not selected ! write(*,*)'3B cannot find anion: ',trim(species(ntot)),& ! ' maybe not selected' goto 810 if(isp(ntot-1).eq.isp(ntot)) then write(*,*)'3B two anions represent the same species' sametwice2=.TRUE. endif endif else ! a single anion ntot=ncat+1 species(ntot)=quadname(jp+1:) ! write(*,*)'3B anion: ',species(ntot) call find_species_by_name_exact(species(ntot),isp(ntot)) ! call find_species_record(species(ntot),isp(ntot)) if(gx%bmperr.ne.0) then ! This normal if species not selected ! write(*,*)'3B cannot find anion: ',trim(species(ntot)),& ! ' maybe not selected: ',trim(quadname) goto 810 endif ! this is because a single cation should have stoichimetry 2.0/bonds double(ntot)=2.0D0 endif ! New code 22.12.14/BoS to handle element with multiple valences ! we have to save the SNNs reference to its FNN quads ! FNN are First NearestNeighbours with 2 constituents ! Note the SNN may be entered before the FNN if(ntot.eq.2) then nfnnq=nfnnq+1 ! qorder is used when rearranging the quads in alphabetical order qorder(mqmqa_data%nconst+1)=nfnnq if(nfnnq.gt.size(fnnquads)) then write(*,61)nfnnq,size(fnnquads) 61 format('3B Too many quads in MQMQA liquid ',2i3) gx%bmperr=4399 goto 1000 endif fnnquads(nfnnq)=quadname else nsnnq=nsnnq+1 qorder(mqmqa_data%nconst+1)=-nsnnq do ij=1,4 snnrefs(ij,nsnnq)=' ' enddo ! we have to generate the FNN constituents of this SNN, very clumsy ik=0 do ij=1,ncat do kp=ncat+1,ntot ik=ik+1 snnrefs(ik,nsnnq)=trim(species(ij))//'/'//species(kp) enddo enddo ! write(*,62)'3B found SNN constituent ',nsnnq,trim(quadname),ntot,& ! (trim(snnrefs(ij,nsnnq)),ij=1,ik) 62 format(a,i3,1x,a,1x,i3,': ',(a,1x,a,1x,a,1x,a)) endif ! end new code............... ! double(1..4) should be 2.0 for species 1..4 single in the sublattice ! if the species has been rearranged we must rearrange the stoichiometry also ! write(*,77)'3B species: ',(trim(species(kp)),isp(kp),kp=1,ntot) 77 format(a,4(a,i5,2x)) !---------------------------------------------------------- ! we have found all species, we have a new quadrupol mqmqa_data%nconst=mqmqa_data%nconst+1 if(mqmqa_data%nconst.gt.maxquads) then write(*,777)maxquads 777 format('3XQ Too many quadrupoles, max ',i3) gx%bmperr=4399; goto 1000 endif thiscon=mqmqa_data%nconst ! write(*,*)'3B thiscon: ',thiscon if(thiscon.ge.maxconst) then write(*,*)'3B Too many constituents in MQMQA phase: ',maxconst gx%bmperr=4399; goto 1000 endif ! save sublattice species record for the bonds ! mqmqa_data%contyp(11,thiscon)=isp(1) ! mqmqa_data%contyp(12,thiscon)=isp(2) ! mqmqa_data%contyp(13,thiscon)=isp(3) ! mqmqa_data%contyp(14,thiscon)=isp(4) ! now read the coordination values, 2, 3 or 4, Z^A_{AB:XY) kp=ip if(.not.allocated(mqmqa_data%constoi)) then ! I had a segmentation fault here when calling this routine twice write(*,*)'3B error mqmqa_data%constoi not allocated' gx%bmperr=4399; goto 1000 endif ! There are always 2 stoichiometries .... call getrel(inline,ip,mqmqa_data%constoi(1,thiscon)) call getrel(inline,ip,mqmqa_data%constoi(2,thiscon)) if(buperr.ne.0) then write(*,*)'3B error reading stoichiometry 2',inline(kp:ip) goto 1000 endif ! if(ntot.eq.2) then ! this is the \zeta value needed to calculate the entropy of pairs call getrel(inline,ip,mqmqa_data%constoi(3,thiscon)) elseif(ntot.gt.2) then call getrel(inline,ip,mqmqa_data%constoi(3,thiscon)) endif if(ntot.gt.3) call getrel(inline,ip,mqmqa_data%constoi(4,thiscon)) if(buperr.ne.0) then write(*,*)'3B error in stoichiometry: "',inline(kp:ip),'"' goto 1000 endif ! this is needed if a quadrupole species is not an element ... ! ncat is number in species in first sublattice, ntot is total number (max 4) ! %spstoi not used ?? ! if(ntot.eq.2) then ! mqmqa_data%spstoi(1,1,thiscon)=2.0d0/mqmqa_data%constoi(1,thiscon) ! mqmqa_data%spstoi(2,1,thiscon)=2.0d0/mqmqa_data%constoi(2,thiscon) ! elseif(ncat.eq.1) then ! mqmqa_data%spstoi(1,1,thiscon)=2.0d0/mqmqa_data%constoi(1,thiscon) ! mqmqa_data%spstoi(2,1,thiscon)=one/mqmqa_data%constoi(2,thiscon) ! mqmqa_data%spstoi(2,2,thiscon)=one/mqmqa_data%constoi(3,thiscon) ! else ! mqmqa_data%spstoi(1,1,thiscon)=one/mqmqa_data%constoi(1,thiscon) ! mqmqa_data%spstoi(1,2,thiscon)=one/mqmqa_data%constoi(2,thiscon) ! if(ntot.eq.3) then ! mqmqa_data%spstoi(1,2,thiscon)=2.0d0/mqmqa_data%constoi(3,thiscon) ! else ! mqmqa_data%spstoi(1,2,thiscon)=one/mqmqa_data%constoi(3,thiscon) ! mqmqa_data%spstoi(2,2,thiscon)=one/mqmqa_data%constoi(4,thiscon) ! endif ! endif !******************************************************************** ! IF ALL INPUT IS IN ALPHABETICAL ORDER (incl elements!) IT WORKS ! For non-alphabetical input a very strong link between the ! order of species order and stoichiometry also connected to endmember ! order when species replaced by species .... SUCK !******************************************************************** ! if(order2.gt.0) then ! val=mqmqa_data%constoi(ntot-1,thiscon) ! mqmqa_data%constoi(ntot-1,thiscon)=mqmqa_data%constoi(ntot,thiscon) ! mqmqa_data%constoi(ntot,thiscon)=val ! endif ! write(*,33)(mqmqa_data%constoi(jp,thiscon),jp=1,4) 33 format('3B mqmqstoi: ',4F10.4) ! Now we have a quadrupole, create the species and enter contyp and constoi ! sum up the elements in the quadrupole ! VA must have stoichiometry zero otherwise minimizer is confused qstoi=zero nel=0 jelno=0 loksparr=0 ielno=0 vazero=zero totstoi=zero ! add stoichiometry from all species in the quadrupole ! NOTE multiply stoichiometry with double for either or both sublattices ! NOTE ALSO some elements may appear twice representing different charge!! sumstoi: do kp=1,ntot call get_species_location(isp(kp),loksp,cation1) ! how is the Va stored in a species?? it has loksp=1 ! write(*,34)trim(cation1),kp,ntot,isp(kp),loksp 34 format('3B stoik: ',a,4i5) ! extract data directly from the local arrays nspel=splista(loksp)%noofel do ee=1,nspel ielno(ee)=splista(loksp)%ellinks(ee) if(ielno(ee).eq.0) then ! TEMPORARY SKIP MQMQA species with vacancies write(*,*)'3B Warning quad with vacancies ingnored: ',trim(quadname) mqmqa_data%nconst=mqmqa_data%nconst-1 goto 100 ! TEMPORARY TREATMENT OF VA ALONE IN A SUBLATTICE ! ielno(ee)=0 indicate Va, try setting its stoichiometry to zero !!! ! write(*,'(a,4i3)')'3B Vacancy removed from totstoi:',kp,ee,ielno(ee) vazero=vazero-splista(loksp)%stoichiometry(ee) stoi(ee)=zero ! must be tested write(*,*)'3B Warning quad with vacancies ',& 'in a sublattice may not work: ',trim(splista(loksp)%symbol) ! maybe here use mqmqa_data%quadsp to indicate vacancy?? ! NOTE species indices changes as we add new species ! This does not work if there are real species on same sublattice as Va ! maybe just ignore Va in sum of stoichiometries? else stoi(ee)=splista(loksp)%stoichiometry(ee) endif enddo ! write(*,*)'3B ielno: ',(ielno(jp),jp=1,nspel) if(gx%bmperr.ne.0) goto 1000 loksparr(kp)=loksp ! loop for all elements in species if(nspel.gt.1) then write(*,'(a,a,a)')'3B *** Warning, quad species "',& trim(cation1),'" has two elements, calculations may fail' endif elstoi: do jp=1,nspel notnew: do ee=1,nel if(ielno(jp).eq.jelno(ee)) then ! debug info ! Problems here if species has more than 2 cations ............ write(kou,3001)trim(quadname),jp,nspel,ee,nel 3001 format('3B same element twice as cation or anion in: ',& a,2x,2i3,2x,2i3) write(*,3005)thiscon 3005 format('3B constituent index: ',i3) ! write(kou,3002)(mqmqa_data%constoi(pair,s1),pair=1,4) ! same cation twice in a quad should not be a problem, it will should a ! different stoichiometry relative to the element by itself and should ! be treated as a quadruplet by itself and form separate mixed quadruplets ! so it must have some kind of unique identifier. ! Example Fe+2 and Fe+3: FeCl2 and FeCl3 write(kou,3010)(mqmqa_data%constoi(pair,thiscon),pair=1,4) 3010 format('3B factors: ',4(1pe15.6)) ! Or if the same element occur in two anion/cation species, such as Fe+2/Fe+3 ! we must treat all elements as new?? ! exit notnew endif enddo notnew if(ee.gt.nel) then ! a new element in this quad nel=nel+1 jelno(nel)=ielno(jp) ee=nel else ee=ielno(jp) endif ! ee is element index in species elnames(ee)=ellista(ielno(jp))%symbol ! qstoi is the sum of species/element mm in all species of the quadrupole ! element alone in a sublattice should have the stoichiometry doubled ! The stoichiometry should be divided by the coordination number qstoi(ee)=qstoi(ee)+& double(kp)*stoi(jp)/mqmqa_data%constoi(kp,thiscon) ! write(*,35)thiscon,kp,ee,nel,jp,& ! double(kp),qstoi(ee),stoi(jp),mqmqa_data%constoi(kp,thiscon) 35 format('3B qstoi: ',5i5,6F7.4) totstoi=totstoi+qstoi(ee) enddo elstoi enddo sumstoi mqmqa_data%totstoi(thiscon)=totstoi ! %totstoi is probably useless, the important part above is removing Va ! write(*,'(a,i3,F10.4)')'3B totstoi: ',thiscon,mqmqa_data%totstoi(thiscon) ! enter some data in mqmqa_data%contyp; we cannot enter endmember links ! because we need to sort the mqmqa_data%contyp endmember=.FALSE. ! do kp=1,9 do kp=1,14 mqmqa_data%contyp(kp,thiscon)=0 enddo ! DEBUG contyp ! write(*,3434)'A',thiscon,(mqmqa_data%contyp(kp,thiscon),kp=1,14) ! I am not sure if %contyp(10,thiscon) is already set to species index? ! do kp=11,14 ! mqmqa_data%contyp(kp,thiscon)=0 ! enddo if(ncat.eq.1) then mqmqa_data%contyp(1,thiscon)=2 if(ntot.eq.ncat+1) then ! this is an endmember mqmqa_data%contyp(2,thiscon)=-2 nend=nend+1 mqmqa_data%contyp(5,thiscon)=nend endmember=.TRUE. else mqmqa_data%contyp(2,thiscon)=-1 mqmqa_data%contyp(3,thiscon)=-1 endif else mqmqa_data%contyp(1,thiscon)=1 mqmqa_data%contyp(2,thiscon)=1 if(ntot.eq.ncat+1) then mqmqa_data%contyp(3,thiscon)=-2 else mqmqa_data%contyp(3,thiscon)=-1 mqmqa_data%contyp(4,thiscon)=-1 endif endif ! temporarily add species location in position 6..9 for all quadrupoles ! For non-endmembers they will be replaced by the endmembers indices mqmqa_data%contyp(6,thiscon)=loksparr(1) mqmqa_data%contyp(7,thiscon)=loksparr(2) mqmqa_data%contyp(8,thiscon)=loksparr(3) mqmqa_data%contyp(9,thiscon)=loksparr(4) ! make a copy of this in 11..14 mqmqa_data%contyp(11,thiscon)=loksparr(1) mqmqa_data%contyp(12,thiscon)=loksparr(2) mqmqa_data%contyp(13,thiscon)=loksparr(3) mqmqa_data%contyp(14,thiscon)=loksparr(4) haha=thiscon nspel=0 ! loop from 0 to include the vacancy, it will be the first element? ! why loop to 20? Well, I assume there is less than 20 different species do kp=1,mqq if(qstoi(kp).gt.zero) then nspel=nspel+1 ielno(nspel)=kp ! stoichiometry should be divided by coordination number stoi(nspel)=qstoi(kp) endif enddo ! DEBUG contyp ! write(*,3434)'B',thiscon,(mqmqa_data%contyp(kp,thiscon),kp=1,14) 3434 format('3B contyp',a,': ',i3,': ',4i3,1x,i4,1x,4i3,1x,i3,1x,4i3) ! create the quadname from the species names if(mqmqa_data%contyp(1,thiscon).eq.2) then quadname=trim(species(1))//'/' ntot=2 else quadname=trim(species(1))//trim(species(2))//'/' ntot=3 endif kp=len_trim(quadname) if(mqmqa_data%contyp(3,thiscon).eq.-1) then ! possibilies: 2 -2 0 0 ; 2 -1 -1 0; 1 1 -2 0; 1 1 -1 -1 quadname(kp+1:)=trim(species(ntot))//species(ntot+1) else quadname(kp+1:)=species(ntot) endif if(sametwice1 .or. sametwice2) then write(*,*)'3B same twice: ',sametwice1,sametwice2 write(*,'(a,a,2i3,5i5)')'3B ielno1: ',trim(quadname),thiscon,nspel,& (mqmqa_data%contyp(kp,thiscon),kp=6,9) write(*,'(a,i3,10(F10.7))')'3B stoi: ',nspel,(stoi(kp),kp=1,nspel) endif ! write(*,*)'3B quadname 4: ',quadname ! remove , from quadname, keep / ! kp=index(quadname,',') ! do while(kp.gt.0) ! quadname(kp:)=quadname(kp+1:) ! kp=index(quadname,',') ! enddo ! the quadname can be ambiguous, for example NASI/FO if there is a NASI/F kp=len_trim(quadname) ! check if quad already entered (ignoring the -Qij) ! all constituent names are in const(1..kend) do s1=1,thiscon if(quadname(1:kp).eq.const(s1)(1:kp)) then write(*,567)'3B Same quadruplet twice: "',trim(quadname)//'"',& kp,s1,thiscon,'"'//trim(const(s1))//'"' 567 format(a,a,3i3,a) write(*,'(a,2i3,a)')'3B ip,inline:',ip,s1,': "'//trim(inline)//'"' gx%bmperr=4399; goto 1000 endif enddo ! check we have not too many quads nquad=nquad+1 if(nquad.gt.maxquads) then write(*,*)'3B Error, too many quadruplets, max: ',maxquads,nquad gx%bmperr=4399 goto 1000 endif ! add a suffix _Q !! ! write(*,*)'3B test seqnum 2: ',seqnum call incnum(seqnum) ! write(*,*)'3B test seqnum 2: ',seqnum quadname(kp+1:)='-Q'//seqnum ! we must return this to enter it also in selsp!!! BUT WITH THE DIGITS! ! kp=len_trim(quadname) name1=quadname(1:kp+2) ! write(*,600)trim(quadname),nspel,(trim(elnames(kp)),qstoi(kp),kp=1,nspel) 600 format('3B enter quad: ',a,i3,4(1x,a,F6.3)) call enter_species(quadname,nspel,elnames,qstoi) if(gx%bmperr.ne.0) then write(*,'(a,a,2l2,i5,10i5)')'3B failed to enter quad: ',trim(quadname),& sametwice1,sametwice2,& gx%bmperr,(mqmqa_data%contyp(kp,thiscon),kp=6,9) write(*,'(a,i3,4(F10.6))')trim(quadname),nspel,(qstoi(kp),kp=1,4) goto 1000 ! else ! write(*,*)'3B found MQMQA quad: ',trim(quadname) endif ! write(*,*)'3B returning the quadrupole name' const(thiscon)=quadname ! we must use the location of the endmember species?? YES call find_species_by_name_exact(quadname,kp) if(gx%bmperr.ne.0) then write(*,*)'3B quad link from species failed',trim(quadname) goto 1000 endif call get_species_location(kp,loksp,cation1) ! save quad index in species record ! write(*,611)nspel,loksp,kp,thiscon 611 format('3B set link from species to quad',4i5) ! splista(loksp)%quadindex=thiscon splista(loksp)%quadindex=haha ! finally store the input information splista(loksp)%mqmqa1=trim(inline) ! write(*,*)'3B saved quad info: "',splista(loksp)%mqmqa1,'"' ! ! write(*,612)trim(quadname),kp,loksp,thiscon,haha,splista(loksp)%quadindex 612 format('3B found quad: ',a,6i5) if(gx%bmperr.ne.0) goto 1000 ! in this place we must store the final constituent index of this species ! the constituents are arranged alphabetical in the call to enter_phase mqmqa_data%contyp(10,thiscon)=-loksp ! write(*,602)thiscon,(mqmqa_data%contyp(kp,thiscon),kp=1,14),& ! qorder(thiscon),(mqmqa_data%constoi(kp,thiscon),kp=1,4) ! if(qorder(thiscon).gt.0) then ! write(*,603)'3B FNN: ',trim(fnnquads(thiscon)) ! else ! write(*,603)'3B SNN: ',(trim(snnrefs(ij,thiscon)),ij=1,4) ! endif ! loop back to read next quadrupole goto 100 !----------------------------------------------------------------------- ! illegal quadrupole, skip this quadruple there can be 2-4 reals trailing 800 continue write(*,*)'3B quadrupole not selected: ',trim(quadname) ! species not entered, maybe not selected 810 continue gx%bmperr=0 call getrel(inline,ip,val) call getrel(inline,ip,val) if(buperr.ne.0) goto 1000 ! there can be up to 4 reals, this is the third or a new quad or : call getrel(inline,ip,val) if(buperr.ne.0) then ch1=inline(ip:ip) call capson(ch1) if((ch1.ge.'A' .and. ch1.le.'Z') .or. ch1.eq.':') then ! this is the name of another quadrupole ! write(*,*)'3B Error reset, continuing' buperr=0; goto 100 endif endif ! this is the last real or a new quadrupole call getrel(inline,ip,val) if(buperr.ne.0) then ch1=inline(ip:ip) call capson(ch1) if((ch1.ge.'A' .and. ch1.le.'Z') .or. ch1.eq.':') then ! this is the name of another quadrupole ! write(*,*)'3B Error reset, continuing' buperr=0; goto 100 endif endif ! write(*,*)'3B trying next one' goto 100 !------------------------------------------ ! jump here when EOL or : detected ! routine may be called again with more quadrupoles if interactive input ! and with loop different from 0 900 continue ! we come here when all constituents read, maybe there are none?? ! if(nend.eq.0) then ! write(*,*)'3B MQMQA phase has no constituents!' ! gx%bmperr=4399 ! endif ! With the MQMQA ohase one cannot have composition sets (only one mqmqa_data%) ! indicate that one cannot make gridtests after an equilibrium calculation ! globaldata%status=ibset(globaldata%status,GSNOAFTEREQ) goto 1000 ! this is just debug output ik=1; ij=1 do thiscon=1,mqmqa_data%nconst if(qorder(thiscon).gt.0) then write(*,603)'3B FNN: ',trim(fnnquads(ik)) ik=ik+1 else write(*,603)'3B SNN: ',(trim(snnrefs(s1,ij)),s1=1,4) ij=ij+1 endif 603 format(a,4(1x,a)) write(*,602)thiscon,(mqmqa_data%contyp(kp,thiscon),kp=1,14),& qorder(thiscon),(mqmqa_data%constoi(kp,thiscon),kp=1,4) 602 format('3B contyp: ',i2,1x,4i3,1x,i3,1x,4i2,1x,i3,1x,4i2,1x,i4/30x,4F10.6) enddo ! 1000 continue ! write(*,*)'3B leaving mqmqa_species',thiscon ! write(*,910)nend 910 format('3B found ',i3,' FNN constituents in MQMQA') return end subroutine mqmqa_species !loop !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine mqmqa_rearrange !\begin{verbatim} subroutine mqmqa_rearrange(const) ! This routine will scan the mqmqa_data datastructure ! The phase record does not yet exist ... ! and for all non-endmembers replace links to species by links to endmembers ! and calculate and store several useful things ! NOTE the phase is not yet entered!! we only have arrays with data implicit none ! array with names of quadrupole constituents, needed by enter phase!! character const(*)*24 !\end{verbatim} ! mqmqa_data contain information needed for the liquid modeled with MQMQA integer, parameter :: f1=maxconst ! integer endmem(2,f1),s1,s2,s3,s4,s5,s6,nend,new(4),need,found,pair integer s1,s2,s3,s4,s5,s6,nend,new(4),need,found,pair integer subcon1(f1),subcon2(f1),ncon1,ncon2,ix1,ix2,lattice,indx(f1) integer top,stack(0:f1),last,mqm1(f1),mqm2(f1),jk,kkk,ll,loksp,nyfas integer ee,gg,pix,plink(4),pinq(f1),krux,ccontyp(14,f1) character spname1*24,spname2*24 double precision cconstoi(4,f1),ctotstoi(f1) ! ! write(*,2) 2 format('3B in mqmqa_rearrange fixing mqmqa_data%contyp and more') ! attempt to fix problem with stoichiometries and order, sort const need=mqmqa_data%nconst ! save element index of quad if(need.gt.f1) then write(*,*)'3B too many constituents, ',need,', max: ',f1 gx%bmperr=4399; goto 1000 endif ! do s1=1,mqmqa_data%nconst ! write(*,820)'3B Phase constituent: ',s1,trim(const(s1)) ! enddo ! write(*,8)(trim(const(s1)),s1=1,need) 8 format(/'3B orig: ',20(a,1x)) ! write(*,*)'3B calling MQSORT' if(need.gt.1) then call mqsort(const,need,indx) if(buperr.ne.0) then gx%bmperr=4399; goto 1000 endif ! write(*,'(a,20i3)')'3B order: ',(indx(s1),s1=1,need) else indx(1)=1 endif ! indx(i) gives the alphabetical order of const(1) ! write(*,9)(trim(const(indx(s1))),s1=1,need) 9 format('3B sort: ',20(a,2x)) ! set inorder in alphabetical order ! do s1=1,need ! inorder(s1)=const(indx(s1)) ! enddo ! write(*,'(a,10(1x,a))')'3B quads: ',(trim(inorder(s1)),s1=1,need) ! write(*,*)'3B original order:' ! do s1=1,need ! NOTE here -%contyp(10,s1) is the order the species were created ! write(*,7)'3B orig: ',s1,(mqmqa_data%contyp(s2,s1),s2=1,14),& ! (mqmqa_data%constoi(s2,s1),s2=1,4),& ! trim(splista(-mqmqa_data%contyp(10,s1))%symbol) ! enddo !7 format(a,i2,14i3,i4,4F6.2,1x,a) ! rearrange contyp and constoi according to indx... example: ! original order: 1 2 3 4 5 6 7 8 9 ! alphabet order: 7 3 2 5 1 6 8 9 4 ! stack: push 1; push 7; push 8; push 9; 9 push 4; push 5: find 5=1 ! stack from top: 5, 4, 9, 8, 7, 1 ! save(5); copy 4 to (5); copy 9 to (4); copy 8 to (9); copy 7 to (8); ! this is the position to store inintial record index stack(0)=f1 ! write(*,'(a,20i3)')'3B index: ',(s3,s3=1,need) ! write(*,'(a,20i3)')'3B sort1: ',(indx(s3),s3=1,need) ! stop 2 ! ! Now the constituents are in alphabetical order, rearrange mqmqa_data%contyp ! %constoi and totat, don't be smart or fast, just copy do s1=1,need do s2=1,14 ccontyp(s2,s1)=mqmqa_data%contyp(s2,s1) enddo do s2=1,4 cconstoi(s2,s1)=mqmqa_data%constoi(s2,s1) enddo ctotstoi(s1)=mqmqa_data%totstoi(s1) enddo ! now write them back in their correct order do s1=1,need s3=indx(s1) do s2=1,14 mqmqa_data%contyp(s2,s1)=ccontyp(s2,s3) enddo do s2=1,4 mqmqa_data%constoi(s2,s1)=cconstoi(s2,s3) enddo mqmqa_data%totstoi(s1)=ctotstoi(s3) ! also set correct name in const if(-mqmqa_data%contyp(10,s1).le.0) then write(*,*)'3B negative index to mqmqa symbol:',s1,& -mqmqa_data%contyp(10,s1) stop else const(s1)=splista(-mqmqa_data%contyp(10,s1))%symbol endif enddo ! We must correct the order of pairs, they must be from 1 and up !!! ! Later we will change 6..9 in SNN quads to pair indices s2=1 do s1=1,need if(mqmqa_data%contyp(5,s1).gt.0) then mqmqa_data%contyp(5,s1)=s2 s2=s2+1 endif enddo ! write(*,*)'3B in alphabetical order?' ! do s1=1,need ! NOTE here -%contyp(10,s1) is the order the species were created ! write(*,7)'3B orig: ',s1,(mqmqa_data%contyp(s2,s1),s2=1,14),& ! (mqmqa_data%constoi(s2,s1),s2=1,4),trim(const(s1)) ! enddo ! goto 300 300 continue pair=0 ! endmem never used !!! skip it ! endmem=0 ! write(*,*)'3B Loop to set SNN endmembers links to FNN and factor' try1: do s1=1,mqmqa_data%nconst if(mqmqa_data%contyp(5,s1).gt.0) then ! this is a mixed SNN endmember, only one anion allowed! if(mqmqa_data%contyp(8,s1).gt.0) then write(*,*)'3B reciprocal quads not implemented' gx%bmperr=4399; goto 1000 endif pair=pair+1 pinq(pair)=s1 ! endmem(1,pair)=mqmqa_data%contyp(6,s1) ! endmem(2,pair)=mqmqa_data%contyp(7,s1) ! save stoichiometry of each constituent in pp(1..2,s1) mqmqa_data%pp(1,s1)=2.0D0/mqmqa_data%constoi(1,s1) ! mqmqa_data%pp(2,s1)=2.0D0/mqmqa_data%constoi(1,s1) mqmqa_data%pp(2,s1)=2.0D0/mqmqa_data%constoi(2,s1) ! write(*,'(a,2i3,1x,4i3,4(1pe12.4)/27x,4(1pe12.4))')'3B SNN: ',pair,s1,& ! (mqmqa_data%contyp(s2,s1),s2=6,9),& ! (mqmqa_data%constoi(s2,s1),s2=1,4),(mqmqa_data%pp(s2,s1),s2=1,4) ! else ! write(*,'(a,2i3,1x,4i3,4(1pe12.4))')'3B FNN: ',0,s1,& ! (mqmqa_data%contyp(s2,s1),s2=6,9),& ! (mqmqa_data%constoi(s2,s1),s2=1,4) endif ! note code above is skipped due to cycle try1 enddo try1 ! ! write(*,*)'3B allocating pairs: ',pair mqmqa_data%npair=pair ! if(.not.allocated(mqmqa_data%pinq)) then ! the problem with an already allocated mqmqa_data ! was that a TDB file had 2 MQMQA phases .... SUCK ! mqmqa1 data character ... problem reading MQMQA as TDB or XTDB ! where is pinq set?? ! write(*,*)'3B pinq:',pair,pinq(1),pinq(2),pinq(3) do s1=1,pair ! mqmqa_data%pinq destroyed here, where is it set? mqmqa_data%pinq(s1)=pinq(s1) enddo ! write(*,*)'3B pinq1: ',(mqmqa_data%pinq(s2),s2=1,mqmqa_data%npair) if(pair.le.0) then write(*,*)'3B No pairs among mqmqa constituents!',mqmqa_data%nconst gx%bmperr=4399; goto 1000 endif ! ! write(*,*)'3B replace SNN species by pairs: ',mqmqa_data%nconst,pair ! do s1=1,mqmqa_data%nconst ! write(*,12)'3B quad1: ',s1,(mqmqa_data%contyp(s2,s1),s2=1,14),& ! (mqmqa_data%constoi(s2,s1),s2=1,4) ! enddo 12 format(a,i3,1x,4i2,1x,i3,1x,4i3,1x,i3,1x,4i3,4F5.2,1x,a) ! subcon1=0; subcon2=0; ncon1=0; ncon2=0 ! write(*,*)'3B replace species with pairs' ! new=0 loop: do s1=1,mqmqa_data%nconst if(mqmqa_data%contyp(5,s1).gt.0) then ! calculate the number of constituents on each sublattice lat1: do s2=1,ncon1 if(mqmqa_data%contyp(6,s1).eq.subcon1(s2)) exit lat1 enddo lat1 if(s2.gt.ncon1) then ncon1=ncon1+1 subcon1(ncon1)=mqmqa_data%contyp(6,s1) endif lat2: do s2=1,ncon2 if(mqmqa_data%contyp(7,s1).eq.subcon2(s2)) exit lat2 enddo lat2 if(s2.gt.ncon2) then ncon2=ncon2+1 subcon2(ncon2)=mqmqa_data%contyp(7,s1) endif ! write(*,'(a,2i3,2x,2i3,2x,a)')'3B FNN: ',ncon1,ncon2,& ! subcon1(ncon1),subcon2(ncon2),trim(const(s1)) cycle loop endif ! write(*,'(a,20i3)')'3B pinq2:',(mqmqa_data%pinq(s2),s2=1,mqmqa_data%npair) ! write(*,'(a,20i3)')'3B pinq3:',(pinq(s2),s2=1,mqmqa_data%npair) found=0; need=2 ! THIS IS A QUAD WITH 3 OR MORE SPECIES ! Replace CAREFULLY the species with pair pointers ! The order of the pairs MUST reflect the order of %constoi factors ! because when normalizing the pair fractions we need these factors ! AB/XX should have first pair A/X then B/X b_A b_B b_X ! AA/XY should have first A/X, then A/Y b_A b_X b_Y ! AB/XY should have pairs in order A/X, A/Y, B/X, BY b_A b_B b_X b_Y ! BUG: when 2 constituents in 2nd sublattice if(mqmqa_data%contyp(9,s1).gt.0) need=4 ! write(*,87)'3B set pair links in quad ',s1,& ! (mqmqa_data%contyp(s2,s1),s2=6,9) 87 format(a,i3,5x,4i4) pix=0 plink=0 ! mqmqa_data%contyp(1,s1) is 1 if two species in first subl., otherwise 2 krux=3-mqmqa_data%contyp(1,s1) do s2=1,krux ee=mqmqa_data%contyp(5+s2,s1) ! %contyp(krux+1,s1) indicates (as negative) if one or 2 in second sublattice do s3=1,3+mqmqa_data%contyp(krux+1,s1) ! specis is in 5+krux+s3 gg=mqmqa_data%contyp(5+krux+s3,s1) ! write(*,'(a,6i3,2x,4i3,2x,2i3)')'3B SNN and pair: ',s1,s2,s3,krux,& ! 3-mqmqa_data%contyp(krux+1,s1),& ! 5+krux+s3,(mqmqa_data%contyp(s4,s1),s4=6,9),ee,gg fpair: do s4=1,mqmqa_data%npair s5=mqmqa_data%pinq(s4) ! s5 is %contyp index of pair s2 ! write(*,*)'3B pair: ',ee,gg,mqmqa_data%contyp(11,s4),& ! mqmqa_data%contyp(12,s4) if(mqmqa_data%contyp(11,s5).eq.ee .and. & mqmqa_data%contyp(12,s5).eq.gg) then ! pix=pix+1; plink(pix)=s5 ! not by s5 which is index in %contyp but pair index pix=pix+1; plink(pix)=mqmqa_data%contyp(5,s5) ! write(*,*)'3B found pair in %contyp ',s5,pix exit fpair endif enddo fpair ! if s4 is greater than mqmqa_data%npair we have not found any pair if(s4.gt.mqmqa_data%npair) then write(*,'(a,2i3,a,i3)')'3B failed search for pair: ',ee,gg,& ' in quadruplet ',s1 ! species name should be in splista, or is ee, gg not loksp? write(*,838)trim(splista(ee)%symbol),trim(splista(gg)%symbol) 838 format('3B specie in first sublattice "',a,'" or second "',& a,'" not found.') write(*,*)'All quad names: ' do s5=1,mqmqa_data%nconst write(*,839)s5,mqmqa_data%contyp(5,s5),& (mqmqa_data%contyp(s6,s5),s6=10,14) 839 format('3B Quads: ',i3,2x,i3,2x,i3,2x,4i3) enddo gx%bmperr=4399; goto 1000 endif enddo enddo !---------------------------------------------------- ! replace species in 6..9 by plink ! write(*,887)(mqmqa_data%contyp(s3,s1),s3=6,9),plink 887 format('3B replacing: ',4i4,' by ',4i4) do s3=1,4 mqmqa_data%contyp(5+s3,s1)=plink(s3) enddo enddo loop !---------------------- ! write(*,*)'3B replaced all species by pairs' ! do s1=1,mqmqa_data%nconst ! write(*,12)'3B quad2: ',s1,(mqmqa_data%contyp(s2,s1),s2=1,14),& ! (mqmqa_data%constoi(s2,s1),s2=1,4) ! enddo ! cations and anions write(*,*)'3B Number of cations and anions ',ncon1,ncon2 mqmqa_data%ncon1=ncon1 mqmqa_data%ncon2=ncon2 ! copy the value in constoi(3,s1) for all pairs to qfnnsnn if(.not.allocated(mqmqa_data%qfnnsnn)) then allocate(mqmqa_data%qfnnsnn(50)) endif mqmqa_data%qfnnsnn=zero do s1=1,mqmqa_data%nconst s2=mqmqa_data%contyp(5,s1) if(s2.gt.0) then mqmqa_data%qfnnsnn(s2)=mqmqa_data%constoi(3,s1) mqmqa_data%constoi(3,s1)=zero endif enddo ! do s1=1,mqmqa_data%nconst ! write(*,34)'3B fixed: ',(mqmqa_data%contyp(s2,s1),s2=1,14) ! enddo !----------------------------------------- ! check we have all necessary quadrupoles, the DAT file may not provide all!! ! pairs: s1=ncon1*ncon2 ! write(*,*)'3B ncon1,ncon2: ',ncon1,ncon2,s1 if(s1-pair.ne.0) write(*,*)'3B wrong number of endmembers: ',s1,pair ! binara SNN: ncon1*(ncon1-1)/2*ncon2 (in both sublattices): ! (3)(2) means (3*2/2)*(2) + (3)*(2*1/2) = 6+3 = 9 ! (4)(2) means (4*3/2)*(2) + (4)*(2*1/2) = 12+4 = 16 ! (4)(3) means (4*3/2)*(3) + (4)*(3*2/2) = 18+12 = 30 s2=ncon1*(ncon1-1)/2*ncon2 + ncon1*ncon2*(ncon2-1)/2 ! reciprocal SNN: ncon1*(ncon1-1)/2*ncon2*(ncon2-1)/2 ! (3)(2) means 3*2*1/2 = 3 s3=ncon1*(ncon1-1)*ncon2*(ncon2-1)/4 ! ! write(*,'(a,5i4)')'3B MQMQA: quads, FNN pairs, binary and reciprocal SNNs:',& ! mqmqa_data%nconst,s1,s2,s3 ! write(*,760)mqmqa_data%nconst,s1,s2,s3 760 format('3B MQMQA quads: ',i3,', with ',i3,' FNN pairs, ',i3,& ' binary SNNs and ',i3,' reciprocal SNNs') if(s1+s2+s3-mqmqa_data%nconst.ne.0) then write(*,'(a,i5,a,i5)')'3B total number of quadrupoles is wrong, is ',& s1+s2+s3,' should be: ',mqmqa_data%nconst ! IN THE FURURE ... we should automatically create the additional quadrupoles ! call mqmqa_addquads ! if(gx%bmperr.ne.0) goto 1000 gx%bmperr=4399; goto 1000 endif ! They all have zero Gibbs energy of formation. ! write(*,'(a,i3,2x,2i3,3i5)')'3B some numbers:',mqmqa_data%nconst,& ! ncon1,ncon2,pair,s1,s2 ! according to original MQMQA model we MUST have all quadrupoles ! debug output ! do s1=1,mqmqa_data%nconst ! write(*,763)'3B quad3:',s1,(mqmqa_data%contyp(s2,s1),s2=1,14),& ! (mqmqa_data%constoi(s2,s1),s2=1,4) ! enddo 763 format(a,i2,i3,3i2,2i4,3i3,2i4,3i3,4F6.2) ! we have to set values in nonpairs for pairpart, pp, it should be stoich of ! the sublattice element ! write(*,*)'3B attempt to associate the pair with pairpart' pp: do s1=1,mqmqa_data%nconst if(mqmqa_data%contyp(5,s1).gt.0) cycle pp ! an SNN quadruplet ! write(*,'(a,i3,4i2,i3,1x,4i3,1x,i3,1x,4i3)')'3B %contyp: ',s1,& ! (mqmqa_data%contyp(s3,s1),s3=1,14) do s2=1,4 ! s3 is index of a pair in the SNN s3=mqmqa_data%contyp(5+s2,s1) if(s3.gt.0) then ! if there is a pair link, use s3 to associate %constoi with pair ???? mqmqa_data%pp(s2,s1)=one/mqmqa_data%constoi(s2,s1) ! write(*,'(a,3i3,2F12.8,1x,a)')'3B SNN%pp: ',s1,s2,s3,& ! mqmqa_data%constoi(s2,s1),mqmqa_data%pp(s2,s1),const(s1) endif enddo enddo pp ! ! DO NOT CHANGE ABOVE, probably necessay for the configurational entropy ! just add what is needed for the asymmetrical excess below ! check what is available in mqmqa_data record ! write(*,800)mqmqa_data%nconst !800 format('3B line 8010 we have finished subroutine mqmqa_rearrange: ',i3) ! do s1=1,mqmqa_data%nconst ! I do not understand many of the indices in this array and I miss some ! for example the element indices of the cations and anions ! I have added 4 arrays: quadel_i, quadel_j, _k _l for element indices in xquad ! write(*,810)s1,(mqmqa_data%contyp(s2,s1),s2=1,14) !810 format('3B contyp ',i3,2x,2i3,2x,2i3,i4,2i3,2x,2i3,i5,4i3) ! enddo ! do s1=1,mqmqa_data%nconst ! write(*,820)'Phase constituent: ',s1,trim(const(s1)) !820 format(a,i3,' name: ',a) ! enddo ! do s1=1,noofsp ! write(*,820)'Species: ',s1,trim(splista(species(s1))%symbol) ! enddo ! ! write(*,*)'3B We need to add cross references between xquad and fractions' ! ! ! do s1=1,mqmqa_data%nconst ! an AB/XY has 4 FNN paris ! write(*,'(a,i2,4F10.7,1x,a)')'3B all pairparts: ',s1,& ! (mqmqa_data%pp(s2,s1),s2=1,4),trim(const(s1)) ! enddo 1000 continue write(*,1010) 1010 format('3B mqmqa_rearrange has verified the data structure') ! maybe also call create_asymmetry in gtp3XQ.F90 ? return end subroutine mqmqa_rearrange !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine mqmqa_quadbonds !\begin{verbatim} subroutine mqmqa_quadbonds(index,values) ! This routine will return quad specifics implicit none integer index double precision values(*) !\end{verbatim} integer i ! (mqmqa_data%constoi(s2,s1),s2=1,4),trim(const(s1)) do i=1,4 values(i)=mqmqa_data%constoi(i,index) enddo if(values(3).eq.zero) then ! this is an A/X quadruplet, return FNNSNN factor i=mqmqa_data%contyp(5,index) if(i.le.0) then write(*,*)'3B error, no FNNSNN factor for quadruplet: ',index,i else values(3)=mqmqa_data%qfnnsnn(i) endif endif return end subroutine mqmqa_quadbonds !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine mqmqa_addquads !\begin{verbatim} subroutine mqmqa_addquads ! This routine will add missing quads using the pairs implicit none !\end{verbatim} ! mqmqa_data contain information needed for the liquid modeled with MQMQA write(*,*)'3B not implemented yet: mqmqa_addquads' gx%bmperr=4399 1000 continue return end subroutine mqmqa_addquads !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine enter_species_property !\begin{verbatim} subroutine enter_species_property(loksp,nspx,value) ! enter an extra species property for species loksp implicit none integer loksp,nspx double precision value !\end{verbatim} %+ ! this is illegal for species that are elements ... if(btest(splista(loksp)%status,SPEL) .or. & btest(splista(loksp)%status,SPVA)) then ! write(*,*)'Illegal to set this for element species' gx%bmperr=4298 elseif(.not.allocated(splista(loksp)%spextra)) then write(*,*)'3B this species has no allocated extra data' gx%bmperr=4399; goto 1000 elseif(nspx.gt.size(splista(loksp)%spextra)) then write(*,*)'3B species has not sufficient extra data allocated ',nspx gx%bmperr=4399; goto 1000 else splista(loksp)%spextra(nspx)=value endif 1000 continue return end subroutine enter_species_property !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine set_uniquac_species !\begin{verbatim} subroutine set_uniquac_species(loksp) ! set the status bit and allocates spexttra array implicit none integer loksp !\end{verbatim} ! this is illegal for species that are elements ... if(btest(splista(loksp)%status,SPEL) .or. & btest(splista(loksp)%status,SPVA)) then gx%bmperr=4298 else splista(loksp)%status=ibset(splista(loksp)%status,SPUQC) if(.not.allocated(splista(loksp)%spextra)) then allocate(splista(loksp)%spextra(2)) splista(loksp)%spextra=one endif endif 1000 continue return end subroutine set_uniquac_species !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine enter_material !\begin{verbatim} subroutine enter_material(cline,last,nv,xknown,ceq) ! enter a material from a database ! called from user i/f implicit none integer last,nv character cline*(*) double precision xknown(*) type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer nel,j1,j2,j3 character material*72,database*72,selel(20)*2,ext*4,alloy(20)*2 character majorel*2,ftype*1,bline*128,elnam*2 double precision xalloy(20),rest,xxx,xxy logical byte ! these are saved for use in a subsequent call save selel,majorel,ftype,xalloy ! if(.not.btest(globaldata%status,GSNOPHASE)) then ! Ask for new alloy composition: if(ftype.eq.'Y') then rest=1.0D2 bline='Mass % of ' else rest=one bline='Mole fraction of ' endif j2=len_trim(bline)+2 do j1=1,noofel if(ellista(j1)%symbol.eq.majorel) cycle bline(j2:)=ellista(j1)%symbol xxy=xalloy(j1) 60 continue call gparrdx(bline,cline,last,xxx,xxy,'?Enter Material') if(buperr.ne.0 .or. xxx.le.zero) then write(*,*)'3B Illegal value for composition' goto 60 endif xalloy(j1)=xxx rest=rest-xxx enddo else ext='.TDB' call gparcx('Database: ',cline,last,1,database,' ','?Enter matrial') ! this extracts all element symbols from database call checkdb2(database,ext,nel,selel) if(gx%bmperr.ne.0) goto 1000 write(kou,70)(selel(nv),nv=1,nel) 70 format('Elements: ',15(a2,', ')) ! ask for major component call gparcx('Major element or material: ',cline,last,1,majorel,' ',& '?Enter material') call capson(majorel) do nv=1,nel if(majorel.eq.selel(nv)) goto 100 enddo write(*,*)'3B No such element in the database' gx%bmperr=4399 goto 1000 100 continue call gparcdx('Input in mass percent? ',cline,last,1,ftype,'Y',& '?Enter material') if(ftype.eq.'Y') then rest=1.0D2 write(*,102)'mass percent' else rest=one write(*,102)'mole fractions' endif 102 format('Input expected in ',a/) 110 continue call gparcx('First alloying element:',cline,last,1,alloy(1),' ',& '?Enter matrial') nv=0 call capson(alloy(1)) do j1=1,nel if(alloy(1).eq.selel(j1)) goto 200 enddo write(*,*)'3B No such element in database' goto 110 !----- 200 continue do j1=1,nv if(alloy(nv+1).eq.alloy(j1)) then write(*,*)'3B Alloying element already entered' goto 250 endif enddo nv=nv+1 220 continue if(ftype.eq.'Y') then call gparrdx('Mass percent: ',cline,last,xalloy(nv),one,& '?Enter material') if(buperr.ne.0) then write(*,*)'Give a numeric value'; buperr=0 goto 220 endif else call gparrdx('Mole fraction: ',cline,last,xalloy(nv),1.0D-2,& '?Enter material') if(buperr.ne.0) then write(*,*)'Give a numeric value'; buperr=0 goto 220 endif endif if(xalloy(nv).le.zero) then write(*,*)'Composition must be positive!' goto 220 endif rest=rest-xalloy(nv) if(rest.le.zero) then write(*,240)'zero!!' 240 format('Your major component composition is less than ') gx%bmperr=4399; goto 1000 elseif(rest.le.5.0D-1) then write(*,240)'half the system!!' endif 250 continue if(nv.eq.1) then call gparcx('Second alloying element:',cline,last,1,alloy(2),' ',& '?Enter material') if(alloy(2).eq.' ') goto 500 elseif(nv.eq.2) then call gparcx('Third alloying element:',cline,last,1,alloy(3),' ',& '?Enter material') if(alloy(3).eq.' ') goto 500 else call gparcx('Next alloying element:',cline,last,1,& alloy(nv+1),' ','?Enter material') if(alloy(nv+1).eq.' ') goto 500 endif call capson(alloy(nv+1)) do j1=1,nel if(alloy(nv+1).eq.selel(j1)) goto 200 enddo write(*,*)'3B No such element in database' goto 250 !---------------------- ! read the database including the major element 500 continue ! write(*,505)'Comp: ',nv,(alloy(j1),xalloy(j1),j1=1,nv) 505 format(a,i2,2x,8(a2,F8.4,', ')) nv=nv+1 alloy(nv)=majorel xalloy(nv)=rest ! write(*,505)'3B m1: ',nv,(alloy(j1),xalloy(j1),j1=1,nv) call readtdb(database,nv,alloy) if(gx%bmperr.ne.0) goto 1000 ! order the amounts in xalloy in alphabetical order byte=.true. order: do while(byte) byte=.false. do j1=1,nv do j2=j1+1,nv if(alloy(j1).gt.alloy(j2)) then byte=.true. elnam=alloy(j1) alloy(j1)=alloy(j2) alloy(j2)=elnam xxx=xalloy(j1) xalloy(j1)=xalloy(j2) xalloy(j2)=xxx ! write(*,505)'3B m1: ',nv,(alloy(j3),xalloy(j3),j3=1,nv) cycle order endif enddo enddo enddo order ! these are saved until another enter material command do j1=1,nv xknown(j1)=xalloy(j1) enddo ! write(*,505)'3B m2: ',nv,(alloy(j1),xknown(j1),j1=1,nv) 510 format('3B em: ',10(a2,F6.3,1x)) endif !---------------------------------- ! set conditions for composition (replace major by N=1) bline=' ' j2=len_trim(bline)+2 do j1=1,nv if(alloy(j1).eq.majorel) cycle if(ftype.eq.'Y') then bline(j2:)='W%('//trim(alloy(j1))//')=' else bline(j2:)='X('//trim(alloy(j1))//')=' endif j2=len_trim(bline)+1 call wrinum(bline,j2,10,0,xalloy(j1)) j2=j2+2 enddo bline(j2:)=' N=1 ' j2=len_trim(bline)+2 write(*,*)'3B em: ',trim(bline) ! set_condition will increment j1 j1=1 call set_condition(bline,j1,ceq) 1000 continue return end subroutine enter_material !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine delete_all_conditions !\begin{verbatim} subroutine delete_all_conditions(mode,ceq) ! deletes the (circular) list of conditions in an equilibrium ! it also deletes any experiments ! if mode=1 the whole equilibrium is removed, do not change phase status ! because the phase_varres records have been deallocated !!! ! I am not sure it releases any memory though ... implicit none integer mode type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} type(gtp_condition), pointer :: last,current,next integer iph,ics,lokcs ! ! write(*,*)'3B deleting conditions and experiments',trim(ceq%eqname) last=>ceq%lastcondition do while(associated(last)) next=>last%next do while(.not.associated(next,last)) current=>next next=>current%next ! if mode=0 then the equilibrium is not deleted, just the conditions if(mode.eq.0 .and. current%active.eq.0) then ! if condition is active and that a phase is fix change the phase status!! ! A fix phase has a negative statevariable-id iph=-current%statvar(1)%statevarid ! write(*,*)'3B Active condition: ',iph if(iph.gt.0) then ! write(*,*)'3B rest status for phase: ',iph ics=current%statvar(1)%compset 110 continue if(phasetuple(iph)%compset.ne.ics) then iph=phasetuple(iph)%nextcs if(iph.gt.0) goto 110 ! this composition set does not exist gx%bmperr=4399; goto 1000 else lokcs=phasetuple(iph)%lokvares ! set the phase status to entered and unknown ! write(*,*)'3B remove phase condition: ',iph,ics,lokcs ceq%phase_varres(lokcs)%phstate=0 endif endif ! else ! write(*,*)'3B inactive condition: ',current%statvar(1)%statevarid endif deallocate(current) enddo ! write(*,*)'3B last condition' if(mode.eq.0 .and. last%active.eq.0) then ! if condition is active and that a phase is fix change the phase status!! ! A fix phase has a negative statevariable-id iph=-last%statvar(1)%statevarid ! write(*,*)'3B Active condition: ',iph if(iph.gt.0) then ! write(*,*)'3B restore status for phase: ',iph ics=last%statvar(1)%compset 120 continue if(phasetuple(iph)%compset.ne.ics) then iph=phasetuple(iph)%nextcs if(iph.gt.0) goto 120 ! this composition set does not exist gx%bmperr=4399; goto 1000 else lokcs=phasetuple(iph)%lokvares ! set the phase status to entered and stable (not fix) ! write(*,*)'3B change phase status: ',iph,ics,lokcs ceq%phase_varres(lokcs)%phstate=phentstab ! write(*,*)'3B new phase status: ',& ! ceq%phase_varres(lokcs)%phstate endif endif endif ! write(*,*)'3B deallocate last condition' deallocate(last) ! write(*,*)'3B last condition deallocated' enddo nullify(ceq%lastcondition) !------------------------------ ! same for experiments (no fix phases) last=>ceq%lastexperiment do while(associated(last)) next=>last%next do while(.not.associated(next,last)) current=>next next=>current%next deallocate(current) enddo deallocate(last) enddo nullify(ceq%lastexperiment) ! same for experiments ... 1000 continue ! mark conditions and current result may not be compatible ceq%status=ibset(ceq%status,EQINCON) return end subroutine delete_all_conditions !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine delete_equilibria !\begin{verbatim} subroutine delete_equilibria(name,ceq) ! deletes equilibria (needed when repeated step/map) ! name can be an abbreviation line "_MAP*" ! deallocates all data. Minimal checks ... one cannot delete "ceq" implicit none character name*(*) type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: curceq type(gtp_condition), pointer :: lastcond,pcond,qcond integer cureq,ieq,ik,novarres,ipv,ndel ! cureq=ceq%eqno ! write(*,*)'In delete_equilibria ',cureq,trim(name) ik=index(name,'*')-1 if(ik.lt.0) ik=min(24,len(name)) novarres=highcs ndel=0 ! write(*,*)'3B delete equilibria: ',eqfree-1,highcs,csfree eqloop: do ieq=eqfree-1,2,-1 ! we cannot have "holes" in the free list?? NO! Delete from the end... if(ieq.eq.cureq) exit eqloop if(eqlista(ieq)%eqname(1:ik).ne.name(1:ik)) exit eqloop ! write(*,*)'3B Deleting equil: ',trim(eqlista(ieq)%eqname),ieq eqlista(ieq)%eqname=' ' deallocate(eqlista(ieq)%complist) deallocate(eqlista(ieq)%compstoi) deallocate(eqlista(ieq)%invcompstoi) deallocate(eqlista(ieq)%cmuval) ! ! the next line should be removed when highcs implemented ! novarres=csfree-1 ! write(*,*)'3B deallocationg phase_varres' do ipv=1,novarres ! it can happen a phase_varres record is not allocated when previous errors ! if(.not.allocated(eqlista(ieq)%phase_varres(ipv)%yfr)) cycle deallocate(eqlista(ieq)%phase_varres(ipv)%yfr) ! with map 17 error here because not allocated, skip if not allocated if(.not.allocated(eqlista(ieq)%phase_varres(ipv)%constat)) cycle deallocate(eqlista(ieq)%phase_varres(ipv)%constat) ! skip also if this is not allocated if(.not.allocated(eqlista(ieq)%phase_varres(ipv)%mmyfr)) cycle ! If all prevous allocated I hope these will not cause errors .... deallocate(eqlista(ieq)%phase_varres(ipv)%mmyfr) eqlista(ieq)%phase_varres(ipv)%status2=& ibclr(eqlista(ieq)%phase_varres(ipv)%status2,CSDEFCON) deallocate(eqlista(ieq)%phase_varres(ipv)%sites) deallocate(eqlista(ieq)%phase_varres(ipv)%listprop) deallocate(eqlista(ieq)%phase_varres(ipv)%gval) deallocate(eqlista(ieq)%phase_varres(ipv)%dgval) deallocate(eqlista(ieq)%phase_varres(ipv)%d2gval) ! do not deallocate explicitly disfra as it is another phase_varres record ... enddo deallocate(eqlista(ieq)%phase_varres) deallocate(eqlista(ieq)%eq_tpres) ! write(*,*)'3B Deallocating svfunres for equilibrium:',trim(name) deallocate(eqlista(ieq)%svfunres) ! this deletes the conditions and experiments (if any) curceq=>eqlista(ieq) call delete_all_conditions(1,curceq) if(gx%bmperr.ne.0) then write(kou,800)gx%bmperr,ieq 800 format(' *** Error ',i6,' deleting equilibrium ',i5) gx%bmperr=0 endif ndel=ndel+1 eqfree=eqfree-1 enddo eqloop ! we have deleted all equilibria until ieq+1 if(ocv()) write(*,900)ieq+1,eqfree if(ndel.gt.0) write(*,900)ndel,eqfree-1 900 format('3B Deleted ',i3,' equilibria. First free ',i3) eqfree=ieq+1 1000 continue return end subroutine delete_equilibria !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine copy_equilibrium !\begin{verbatim} subroutine copy_equilibrium(neweq,name,ceq) ! creates a new equilibrium which is a copy of ceq. implicit none character name*(*) type(gtp_equilibrium_data), pointer ::neweq,ceq !\end{verbatim} %+ integer number call copy_equilibrium2(neweq,number,name,ceq) 1000 continue return end subroutine copy_equilibrium !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine copy_equilibrium2 !\begin{verbatim} %- subroutine copy_equilibrium2(neweq,number,name,ceq) ! creates a new equilibrium which is a copy of ceq. THIS IS STILL USED !! ?? ! Allocates arrayes for conditions, ! components, phase data and results etc. from equilibrium ceq ! returns a pointer to the new equilibrium record ! THIS CAN PROBABLY BE SIMPLIFIED, especially phase_varres array can be ! copied as a whole, not each record structure separately ... ??? implicit none character name*(*) integer number type(gtp_equilibrium_data), pointer ::neweq,ceq !\end{verbatim} type(gtp_condition), pointer :: oldcond,lastcond type(gtp_condition), pointer :: newcond1,newcond2 type(gtp_condition), pointer :: bugcond character name2*64 integer ieq,ipv,jz,iz,jl,jk,novarres,oldeq logical okname ! ! write(*,*)'In copy_equilibrium2',trim(name),eqfree nullify(neweq) if(.not.allowenter(3)) then ! write(*,*)'3B Not allowed to copy or enter equilibria' gx%bmperr=4153; goto 1000 endif ! write(*,*)'3B allow enter OK' ! not allowed to enter equilibria if there are no phases ! if(btest(globaldata%status,GSNOPHASE)) then ! write(*,*)'3B Meaningless to copy equilibria with no phase data' ! gx%bmperr=7777; goto 1000 ! endif ! equilibrium names starting with _ are automatically created by mapping ! and in some other cases. if(name(1:1).eq.'_') then name2=name(2:) jk=1 elseif(name(1:1).eq.' ') then write(*,*)'A name must start with a letter' gx%bmperr=4284; goto 1000 else name2=name jk=0 endif call capson(name2) ! write(*,*)'3B Entering copy equilibria: ',name2,jk ! program crashed with this construction ! if(.not.proper_symbol_name(name2,0)) then okname=proper_symbol_name(name2,0) if(.not.okname) then ! the name must start with a letter A-Z and contain letters, numbers and _ gx%bmperr=4122 goto 1000 endif ! write(*,*)'3B name check ok: ',jk ! remove initial "_" used for automatically created equilibria if(jk.eq.1) then ! changing this cause a lot of trouble ... but I do not understand name2='_'//name2 ! name2=name2(2:) endif ! check if name already used ! write(*,*)'3B check if name unique: ',name2 call findeq(name2,ieq) if(gx%bmperr.eq.0) then gx%bmperr=4123 goto 1000 else ! reset error code gx%bmperr=0 endif ! write(*,*)'3B check if name unique: ',eqfree if(eqfree.le.maxeq) then ieq=eqfree eqfree=eqfree+1 else ! write(*,*)'Too many equilibrium required, increase dimension',eqfree gx%bmperr=4283; goto 1000 endif number=ieq if(ieq.eq.1) then ! write(*,*)'Cannot copy to default equilibria' gx%bmperr=4285; goto 1000 endif ! write(*,*)'3B copy eq',eqfree,maxeq,ieq ! allocate data arrayes in equilibrium record eqlista(ieq)%nexteq=0 eqlista(ieq)%eqname=name2 eqlista(ieq)%eqno=ieq ! do not copy comment but set it to blanks eqlista(ieq)%comment=' ' ! component list and matrix, if second or higher equilibrium copy content ! write(*,*)'3B: copyeq 1A: ',maxel,noofel allocate(eqlista(ieq)%complist(noofel)) allocate(eqlista(ieq)%compstoi(noofel,noofel)) allocate(eqlista(ieq)%invcompstoi(noofel,noofel)) allocate(eqlista(ieq)%cmuval(noofel)) ! write(*,*)'3B: copyeq 1B: ',noofel ! careful here because FIRSTEQ has other dimensions than the other do jl=1,noofel eqlista(ieq)%complist(jl)=ceq%complist(jl) eqlista(ieq)%cmuval(jl)=ceq%cmuval(jl) do jk=1,noofel eqlista(ieq)%compstoi(jk,jl)=ceq%compstoi(jk,jl) eqlista(ieq)%invcompstoi(jk,jl)=ceq%invcompstoi(jk,jl) enddo enddo oldeq=ceq%eqno ! what about the weight? eqlista(ieq)%weight=ceq%weight ! write(*,*)'3B copyeq 1: ',ceq%weight,eqlista(ieq)%weight do jl=1,noofel eqlista(ieq)%complist(jl)%splink=eqlista(oldeq)%complist(jl)%splink eqlista(ieq)%complist(jl)%phlink=firsteq%complist(jl)%phlink eqlista(ieq)%complist(jl)%status=firsteq%complist(jl)%status if(firsteq%complist(jl)%phlink.gt.0) then ! only if there is a defined reference state eqlista(ieq)%complist(jl)%refstate=firsteq%complist(jl)%refstate eqlista(ieq)%complist(jl)%tpref=firsteq%complist(jl)%tpref eqlista(ieq)%complist(jl)%chempot=zero do jk=1,noofel eqlista(ieq)%compstoi(jl,jk)=firsteq%compstoi(jl,jk) eqlista(ieq)%invcompstoi(jl,jk)=firsteq%invcompstoi(jl,jk) enddo if(.not.allocated(eqlista(ieq)%complist(jl)%endmember)) then iz=size(firsteq%complist(jl)%endmember) allocate(eqlista(ieq)%complist(jl)%endmember(iz)) eqlista(ieq)%complist(jl)%endmember=firsteq%complist(jl)%endmember endif else eqlista(ieq)%complist(jl)%refstate=firsteq%complist(jl)%refstate endif enddo ! these records keep calculated values of G and derivatives for each phase ! For phase lokph the index to phase_varres is in phlista(lokph)%cslink ! For phase lokph the index to phase_varres is in phlista(lokph)%linktocs(ics) ! for ieq>1 allocate the current number of phase_varres records plus 10 ! for extra composition sets added later ! 170524: It seems that phase_varres for disordered fraction sets are not ! included in novarres in novarres or highcs!! ! BEWARE: allocation: calculating with one phase with 8 composition sets ! and disordered fractions sets !!! if(oldeq.eq.1) then ! the first equilibria has many phase_varres record as we do not what system ! we will have. If we copy that we create as many varres as in the enter_equil iz=2*noofph+2*noofel+10 else ! When we copy other equilibria we copy the same number as in the origin iz=size(ceq%phase_varres) endif allocate(eqlista(ieq)%phase_varres(iz)) ! write(*,*)'3B copy_equil allocates: ',oldeq,ieq,iz,highcs,csfree ! now copy the current content of ceq%phase_varres to this equilibrium ! note, the SELECT_ELEMENT_REFERENCE phase has phase number 0 ! and phase_varres index 1, the number of phase_varres records is not the ! same as number of phases .... ! ! strange error here running STEP on bigfcc4: crash with message: ! Index "3" of dimension 1 of array "eqlista" above upper bound of 2 ! write(*,*)'3B 3737:',novarres,ieq,oldeq,size(eqlista(oldeq)%phase_varres) ! Ahhhh, there are 2 phase_varres records for each phase because of ! disordered fraction set, one for the ordered with 33 y-fractions, one for ! the disordered with 8 y-fractions. ! A simple dimensioning problem: 1 phase, 8 compsets, disordered fracset ! requires 17 phase_varres. Before the "max" above I had dimensioned for 2 ! BEWARE: I am not sure novarres is correct ... ! copypv: do ipv=1,min(novarres+3,size(ceq%phase_varres)) ! copypv: do ipv=1,novarres ! THIS CREATED ALL TROUBLE ... I did not copy all varres records used!! copypv: do ipv=1,iz eqlista(ieq)%phase_varres(ipv)=eqlista(oldeq)%phase_varres(ipv) ! in matsmin nprop seemed suddenly to be zero in copied equilibria .... ! write(*,*)'3B copyeq 2: ',ieq,ipv,eqlista(ieq)%phase_varres(ipv)%nprop ! Bug 170524 ... disordered phase_varres had no ! write(*,833)'3B copyeq: ',oldeq,ipv,novarres,& ! eqlista(oldeq)%phase_varres(ipv)%disfra%varreslink,& ! eqlista(ieq)%phase_varres(ipv)%disfra%varreslink 833 format(a,2i3,i5,2i3,10i5) enddo copypv 900 continue ! write(*,*)'3B To copy conditions:' ! copy conditions (and experiments) !!! lastcond=>eqlista(oldeq)%lastcondition if(associated(lastcond)) then jz=1 call copy_condition(eqlista(ieq)%lastcondition,lastcond) ! write(*,770)'3B cc1: ',jz,lastcond%prescribed,& ! eqlista(ieq)%lastcondition%prescribed newcond1=>eqlista(ieq)%lastcondition bugcond=>newcond1 oldcond=>lastcond%next do while(.not.associated(oldcond,lastcond)) jz=jz+1 newcond2=>newcond1 call copy_condition(newcond1%next,oldcond) newcond1=>newcond1%next ! write(*,770)'3B cc2: ',jz,oldcond%prescribed,newcond1%prescribed 770 format(a,i2,6(1pe12.4)) newcond1%previous=>newcond2 oldcond=>oldcond%next enddo newcond1%next=>bugcond ! write(*,*)'3B Copied all condition',jz else nullify(eqlista(ieq)%lastcondition) endif ! copy experiments) ... later ! nullify(eqlista(ieq)%lastexperiment) ! ! copy TPfuns and symbols and current values ! write(*,*)'3B Copy tpval arrays' eqlista(ieq)%tpval=ceq%tpval allocate(eqlista(ieq)%eq_tpres(maxtpf)) ! write(*,*)'3B allocated tpres arrays' eqlista(ieq)%eq_tpres=ceq%eq_tpres allocate(eqlista(ieq)%svfunres(maxsvfun)) ! write(*,*)'3B allocated svfunres arrays' eqlista(ieq)%svfunres=ceq%svfunres ! copy convergence criteria eqlista(ieq)%xconv=ceq%xconv eqlista(ieq)%gdconv(1)=ceq%gdconv(1) eqlista(ieq)%gdconv(2)=ceq%gdconv(2) ! woops ... this is still used ! stop 'old copy_equilibrium ... we should never be here' eqlista(ieq)%maxiter=ceq%maxiter ! write(*,*)'3B finished copy equilibrium',ieq eqlista(ieq)%eqno=ieq neweq=>eqlista(ieq) ! status word is initiated to zero, no need to copy?? Maybe EQMIXED? ! write(*,*)'3B copy_eq: ',neweq%status,ceq%status ! write(*,*)'3B Assigned pointer to new equilibrium',neweq%eqno 1000 continue ! write(*,*)'3B exit copy_equilibrium' return end subroutine copy_equilibrium2 !csfree !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine copy_condition !\begin{verbatim} subroutine copy_condition(newrec,oldrec) ! Creates a copy of the condition record "oldrec" and returns a link ! to the copy in newrec. The links to "next/previous" are nullified implicit none type(gtp_condition), pointer :: oldrec type(gtp_condition), pointer :: newrec !\end{verbatim} ! write(*,*)' *** In copy_condition: ',oldrec%prescribed allocate(newrec) ! write(*,*)' *** Allocated' newrec=oldrec ! write(*,*)' *** Copied old condition to new',newrec%prescribed 1000 continue return end subroutine copy_condition !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable integer function newhighcs !\begin{verbatim} integer function newhighcs(reserved) ! updates highcs and arranges csfree to be in sequential order ! highcs is the higest used varres record before the last reservation ! or release of a record. release is TRUE if a record has been released ! csfree is the beginning of the free list of varres records. implicit none logical reserved !\end{verbatim} integer high,lok,free,prev ! Do not be smart, go through the whole array ! in all used varres record the %nextfree is zero high=0 free=0 do lok=1,size(firsteq%phase_varres) if(firsteq%phase_varres(lok)%nextfree.eq.0) then high=lok elseif(free.eq.0) then ! we have the first record belonging to the free list free=lok prev=lok else firsteq%phase_varres(prev)%nextfree=lok prev=lok endif enddo ! verification ?? prev=2*noofph+2 ! write(*,*)'3B high and free: ',high,free,reserved,highcs,csfree ! write(*,110)(firsteq%phase_varres(lok)%nextfree,lok=free,prev) 110 format(12(i6)) ! write(*,120)free,csfree,high,& ! (firsteq%phase_varres(lok)%nextfree,lok=free,high) 120 format('3B cs: ',3i5,(14i4)) newhighcs=high csfree=free ! write(*,*)'3B in newhighcs: ',csfree,highcs 1000 continue end function newhighcs !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable init_phlista !\begin{verbatim} subroutine init_phlista(nyfas) ! inititates all data in a new phase, attempt to make make NEW work better ! It has not helped with the convergence problems repeating calculating step1 integer nyfas !\end{verbatim} ! write(*,*)'Initate phase data ',nyfas phlista(nyfas)%models=' ' phlista(nyfas)%phletter=' ' phlista(nyfas)%status1=0 phlista(nyfas)%alphaindex=0 phlista(nyfas)%noofcs=0 phlista(nyfas)%nooffs=0 nullify(phlista(nyfas)%additions) nullify(phlista(nyfas)%ordered) nullify(phlista(nyfas)%disordered) phlista(nyfas)%noemr=0 phlista(nyfas)%ndemr=0 ! these are allocatable arrays ! nullify(phlista(nyfas)%oendmemarr) ! nullify(phlista(nyfas)%dendmemarr) phlista(nyfas)%noofsubl=0 phlista(nyfas)%tnooffr=0 ! this is an array with 9 elements phlista(nyfas)%linktocs=0 ! ignore nooffr and constitlist as allocateble arrays phlista(nyfas)%i2slx=0 nullify(phlista(nyfas)%tooplast) nullify(phlista(nyfas)%toopfirst) phlista(nyfas)%lasttoopid=0 ! That are all data in a phlista record 1000 continue return end subroutine init_phlista !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ ================================================ FILE: src/models/gtp3C.F90 ================================================ ! ! gtp3C included in gtp3.F90 ! !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !> 7. Section: list data !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_all_elements !\begin{verbatim} subroutine list_all_elements(unit) ! lists elements implicit none integer unit !\end{verbatim} %+ integer jl,ipos character line*80 line=' ' write(unit,10)noofel 10 format(/'List of ',i2,' elements'/ & ' No Sym Name',10X,'Reference state',12X,& 'Mass H298-H0 S298 Status') loop1: do jl=-1,noofel ipos=1 call list_element_data(line,ipos,elements(jl)) if(gx%bmperr.ne.0) goto 1000 write(unit,100)jl,line(1:ipos) enddo loop1 100 format(i3,2x,A) 1000 continue return end subroutine list_all_elements !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_all_elements2(unit) !\begin{verbatim} %- subroutine list_all_elements2(unit) ! lists elements implicit none integer unit !\end{verbatim} integer jl character line*80 line=' ' loop1: do jl=-1,noofel write(unit,100) ellista(jl)%symbol,ellista(jl)%ref_state,& ellista(jl)%mass,ellista(jl)%h298_h0,ellista(jl)%s298 enddo loop1 100 format('ELEMENT ',A,' ',A,3(1pe12.4),' !') 1000 continue return END subroutine list_all_elements2 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_all_components !\begin{verbatim} subroutine list_all_components(unit,ceq) ! lists the components for an equilibrium implicit none integer unit TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer jl,loksp character symbol*24 double precision moles,masspercent,chempot moles=zero masspercent=zero chempot=zero write(unit,10) 10 format('List of components'/ & 'No Symbol',19X,'Moles',6x,'Mass %',5x,'Chem pot',3x,'Ref. state') loop1: do jl=1,noofel loksp=ceq%complist(jl)%splink symbol=splista(loksp)%symbol write(unit,100)jl,symbol,moles,masspercent,chempot,& ceq%complist(jl)%refstate enddo loop1 100 format(i2,1x,A,3(1PE11.3),1X,A) 1000 continue return end subroutine list_all_components !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_element_data !\begin{verbatim} subroutine list_element_data(text,ipos,elno) implicit none character text*(*) integer ipos,elno !\end{verbatim} if(elno.lt.-1 .or. elno.gt.noofel) then gx%bmperr=4042 goto 1000 endif if(ipos.lt.1 .or. ipos.ge.len(text)) then gx%bmperr=4043 goto 1000 endif text(ipos:ipos+2)=ellista(elno)%symbol text(ipos+3:ipos+16)=ellista(elno)%name text(ipos+17:ipos+40)=ellista(elno)%ref_state write(text(ipos+41:ipos+73),100)ellista(elno)%mass,& ellista(elno)%h298_h0,ellista(elno)%s298,ellista(elno)%status 100 format(1x,f7.3,1x,f7.2,1x,f7.3,1x,z8) ipos=len_trim(text) ! write(*,*)'3C x:',text(1:79) 1000 continue return END subroutine list_element_data !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_species_data !\begin{verbatim} subroutine list_species_data(text,ipos,spno) implicit none character text*(*) integer ipos,spno !\end{verbatim} %+ character dummy*48 integer jpos if(spno.lt.1 .or. spno.gt.noofsp) then ! write(*,*)'3C in list_species_data' gx%bmperr=4051 goto 1000 endif if(ipos.lt.1 .or. ipos.ge.len(text)) then gx%bmperr=4043 goto 1000 endif text(ipos:ipos+24)=splista(spno)%symbol text(ipos+25:ipos+25)=' ' dummy=' ' call encode_stoik(dummy,jpos,5,spno) text(ipos+26:ipos+48)=dummy(1:min(23,jpos)) if(jpos.gt.23) text(ipos+46:ipos+48)='<.>' text(ipos+49:ipos+49)=' ' write(text(ipos+50:ipos+56),100)splista(spno)%mass write(text(ipos+57:ipos+62),105)splista(spno)%charge !100 format(F7.3) ! some MQMQA species are more than 1000 g 100 format(F7.2) 105 format(F6.2) text(ipos+66:)=' ' ! write(*,120)splista(spno)%status write(text(ipos+63:ipos+70),120)splista(spno)%status write(text(ipos+71:ipos+73),125)splista(spno)%quadindex 120 format(Z8) 125 format(i3) ipos=ipos+73 1000 continue return END subroutine list_species_data !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_species_data2 !\begin{verbatim} %- subroutine list_species_data2(text,ipos,loksp) ! loksp is species record ... implicit none character text*(*) integer ipos,loksp,tdb !\end{verbatim} character dummy*24 integer jpos if(loksp.lt.1 .or. loksp.gt.noofsp) then ! write(*,*)'3C in list_species_data2' gx%bmperr=4051 goto 1000 endif if(ipos.lt.1 .or. ipos.ge.len(text)) then gx%bmperr=4043 goto 1000 endif text(ipos:ipos+24)=splista(loksp)%symbol text(ipos+25:ipos+25)=' ' dummy=' ' if(splista(loksp)%quadindex.gt.0) then write(*,*)'3C quads listed in another way' goto 1000 endif ! if(tdb.ne.1) then ! text(ipos:)=splista(loksp)%mqmqa1 ! write(*,*)'3C list_species_data2: ',trim(text) ! else ! quads never arrive here call encode_stoik(dummy,jpos,5,loksp) text(ipos+26:ipos+48)=dummy(1:jpos) ! endif ! mqmqa SPECIES KLA/CL-Q K,LA/CL 3.5 6 2.5454546 ! ! mqmqa SPECIES MG/CL-Q MG/CL 6 3 4 ! ! write(text(ipos+50:ipos+59),100)splista(loksp)%mass ! write(text(ipos+60:ipos+65),105)splista(loksp)%charge !100 format(F10.3) ! Some MQMQA species are more than 1000 g 100 format(F10.2) 105 format(F6.1) ! text(ipos+66:)=' ' ! write(*,120)splista(loksp)%status ! write(text(ipos+66:ipos+73),120)splista(loksp)%status 120 format(Z8) ! ipos=ipos+73 1000 continue return END subroutine list_species_data2 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_all_species !\begin{verbatim} subroutine list_all_species(unit) implicit none integer unit !\end{verbatim} integer jl,ipos,loksp character line*100 write(unit,10)noofsp 10 format(/'List of ',i3,' species'/ & ' No Symbol',20X,'Stoichiometry',9X,'Mass',5x,'Charge Status Qua') loop1: do jl=1,noofsp ipos=1 call list_species_data(line,ipos,species(jl)) if(gx%bmperr.ne.0) goto 1000 write(unit,100)jl,line(1:ipos) ! uniquac values loksp=species(jl) if(btest(splista(loksp)%status,SPUQC)) then write(unit,110)splista(loksp)%spextra endif enddo loop1 100 format(i4,1x,A) 110 format(5x,'UNIQUAC area (q): ',F10.4,', segments (r): ',F10.4) 1000 continue return END subroutine list_all_species !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_sorted_phases !\begin{verbatim} subroutine list_sorted_phases(unit,mode,ceq) ! short list with one line for each phase ! suspended phases merged into one line ! stable first, then entered ordered in driving force order, then dormant ! also in driving force order. Only 10 of each, the others lumped together ! if mode not zero include status bits implicit none integer unit, mode TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer jl,jk,ics,lokph,lokcs,kp,ndorm,nsusp,nent,nstab,iph,jph,shbest character line*80,phname*24,trailer*28,chs*1,csname*36,susph*4096,ch1*1 integer, dimension(:), allocatable :: entph,dorph TYPE(gtp_phase_varres), pointer :: csrec double precision am1,am2 ! ! write(*,*)'3C list_sorted_phases' allocate(entph(nooftuples)) allocate(dorph(nooftuples)) nstab=0; nent=0; ndorm=0; nsusp=1 susph=' ' ch1=' ' shbest=0 phloop: do jk=1,noofph lokph=phases(jk) csloop: do ics=1,phlista(lokph)%noofcs ! write(*,17)'3C sort1: ',nent,(entph(iph),iph=1,nent) 17 format(a,i3,2x,16(i4)) lokcs=phlista(lokph)%linktocs(ics) csrec=>ceq%phase_varres(lokcs) ! write(*,*)'3C sorting: ',trim(phlista(lokph)%name),' ',csrec%phstate if(csrec%phstate.ge.PHENTSTAB) then if(nent.eq.0) then nent=1; entph(nent)=lokcs ! write(*,*)'3C first phase stable: ',nent,nent,lokcs else ! FIX and STABLE phases first in order of amount do iph=1,nent am1=csrec%amfu*csrec%abnorm(1) am2=ceq%phase_varres(entph(iph))%amfu*& ceq%phase_varres(entph(iph))%abnorm(1) if(am1.lt.am2) cycle ! if(csrec%amfu.lt.ceq%phase_varres(entph(iph))%amfu) cycle ! this is the place for this phase, shift later down do jph=nent,iph,-1 entph(jph+1)=entph(jph) enddo exit enddo ! according to new fortran standard loop variable at exit is high limit+1 ! write(*,18)'3C inserted stable phase ',iph,lokcs,csrec%amfu 18 format(a,2i4,1pe12.4) entph(iph)=lokcs nent=nent+1 ! write(*,*)'3C stable phase: ',nent,iph,lokcs endif elseif(csrec%phstate.eq.PHENTERED .or. & csrec%phstate.eq.PHENTUNST) then ! if dgm>0 this phase should be stable !!! add warning at the end if(csrec%dgm.gt.zero) shbest=csrec%phtupx if(nent.eq.0) then nent=1 entph(nent)=lokcs ! write(*,69)'3C first phase unstable: ',nent,nent,lokcs,csrec%dgm else ! ENTERED, not stable, sort after all stable phase and with smallest DGM first do iph=1,nent ! bypass all stable phases if(ceq%phase_varres(entph(iph))%amfu.gt.zero) cycle if(csrec%dgm/csrec%abnorm(1).lt.& ceq%phase_varres(entph(iph))%dgm/ceq%phase_varres(entph(iph))%abnorm(1)) cycle ! this is the place for this phase, shift later phases down do jph=nent,iph,-1 entph(jph+1)=entph(jph) enddo exit enddo ! according to new fortran standard loop variable at exit is high limit+1 ! write(*,18)'3C inserted ustable phase ',iph,lokcs,csrec%dgm entph(iph)=lokcs nent=nent+1 ! write(*,69)'3C unstable phase: ',iph,nent,lokcs,csrec%dgm 69 format(a,3i4,1pe12.4) endif elseif(csrec%phstate.eq.PHDORM) then if(ndorm.eq.0) then ndorm=ndorm+1 dorph(ndorm)=lokcs ! write(*,*)'3C first dormant phase: ',ndorm,ndorm,lokcs else ! DORMANT sort after with smallest (least nagative) DGM first do iph=1,ndorm if(csrec%dgm.lt.& ceq%phase_varres(dorph(iph))%dgm/ceq%phase_varres(dorph(iph))%abnorm(1)) cycle ! this is the place for this phase, shift later down do jph=ndorm,iph,-1 dorph(jph+1)=dorph(jph) enddo exit enddo ! according to new fortran standard loop variable at exit is high limit+1 dorph(iph)=lokcs ndorm=ndorm+1 ! write(*,*)'3C dormant phase: ',iph,ndorm,lokcs endif elseif(csrec%phstate.eq.PHSUS) then ! skip composition set number and pre/suffixes at present .... susph(nsusp:)=trim(phlista(lokph)%name)//', ' nsusp=len_trim(susph)+2 if(ics.gt.1) then susph(nsusp-2:)='#'//char(ichar('0')+ics)//',' nsusp=nsusp+2 endif endif enddo csloop enddo phloop ! we have now sorted stable, entered and dormant phases selmode: if(mode.eq.0) then ! This listing does not include the status bits, maybe add some information? write(unit,10) 10 format(/'List of stable and entered phases'/ & ' No tup Name',22x,'Mol.comp. Comp/FU dGm/RT') ! ' No tup Name',22x,'Mol.comp. At/F.U. dGm/RT Status1 Status2') ! come back here for dormant phases ?? jph=0 entlist: do iph=1,nent trailer=' ' lokcs=entph(iph) csrec=>ceq%phase_varres(lokcs) lokph=csrec%phlink phname=phlista(lokph)%name ! how do I to know composition set number??? ! Aha!! in phasetuple(phase_varres(lokcs)%phtupx)%compset if(phlista(lokph)%noofcs.gt.1) then ics=phasetuple(ceq%phase_varres(lokcs)%phtupx)%compset chs=char(ichar('0')+ics) kp=len_trim(csrec%prefix) if(kp.gt.0) then csname=csrec%prefix(1:kp)//'_'//phname else csname=phname endif kp=len_trim(csrec%suffix) if(kp.gt.0) csname=& csname(1:len_trim(csname))//'_'//csrec%suffix(1:kp) csname=csname(1:len_trim(csname))//'#'//chs//trailer else csname=phname endif ! phase names for composition sets can be larger than 24, remove middle part jl=len_trim(csname) if(jl.gt.24) then csname=csname(1:12)//'..'//csname(jl-9:jl) endif ch1='X' write(unit,112)phlista(lokph)%alphaindex,csrec%phtupx,csname, & csrec%amfu*csrec%abnorm(1),& csrec%abnorm(1),csrec%dgm/csrec%abnorm(1) 112 format(2i4,1x,a24,1PE10.2,1x,0PF8.2,1PE10.2) if(csrec%dgm.lt.zero) then jph=jph+1 if(jph.gt.10) then write(unit,*)' ... remaining phases further from stability' exit entlist endif endif enddo entlist if(shbest.gt.0) then call get_phasetup_name(shbest,phname) write(*,117)trim(phname) 117 format(' *** WARNING: unstable phase with positive driving force: ',a) endif if(ndorm.eq.0) goto 400 write(unit,210) 210 format(/'List of dormant phases'/ & ' No tup Name',22x,'Mol.comp. Comp/FU dGm/RT') jph=0 dorlist1: do iph=1,ndorm trailer=' ' lokcs=dorph(iph) csrec=>ceq%phase_varres(lokcs) lokph=csrec%phlink phname=phlista(lokph)%name ! how do I to know composition set number??? ! Aha!! in phasetuple(phase_varres(lokcs)%phtupx)%compset if(phlista(lokph)%noofcs.gt.1) then ics=phasetuple(ceq%phase_varres(lokcs)%phtupx)%compset chs=char(ichar('0')+ics) kp=len_trim(csrec%prefix) if(kp.gt.0) then csname=csrec%prefix(1:kp)//'_'//phname else csname=phname endif kp=len_trim(csrec%suffix) if(kp.gt.0) csname=& csname(1:len_trim(csname))//'_'//csrec%suffix(1:kp) csname=csname(1:len_trim(csname))//'#'//chs//trailer else csname=phname endif ! phase names for composition sets can be larger than 24, remove middle part jl=len_trim(csname) if(jl.gt.24) then csname=csname(1:12)//'..'//csname(jl-9:jl) endif ch1='D' write(unit,112)phlista(lokph)%alphaindex,csrec%phtupx,csname, & csrec%amfu*csrec%abnorm(1),& csrec%abnorm(1),csrec%dgm/csrec%abnorm(1) jph=jph+1 if(jph.gt.10) then write(unit,*)' ... other phases further from stability' exit dorlist1 endif enddo dorlist1 else ! This is the old listing including status bits write(unit,30) 30 format(/'List of stable and entered phases'/ & ' No tup Name',22x,'Mol.comp. Comp/FU dGm/RT Status1 Status2') ! ' No tup Name',22x,'Mol.comp. At/F.U. dGm/RT Status1 Status2') ! come back here for dormant phases jph=0 entlist2: do iph=1,nent trailer=' ' lokcs=entph(iph) csrec=>ceq%phase_varres(lokcs) lokph=csrec%phlink phname=phlista(lokph)%name ! how do I to know composition set number??? ! Aha!! in phasetuple(phase_varres(lokcs)%phtupx)%compset if(phlista(lokph)%noofcs.gt.1) then ics=phasetuple(ceq%phase_varres(lokcs)%phtupx)%compset chs=char(ichar('0')+ics) kp=len_trim(csrec%prefix) if(kp.gt.0) then csname=csrec%prefix(1:kp)//'_'//phname else csname=phname endif kp=len_trim(csrec%suffix) if(kp.gt.0) csname=& csname(1:len_trim(csname))//'_'//csrec%suffix(1:kp) csname=csname(1:len_trim(csname))//'#'//chs//trailer else csname=phname endif ! phase names for composition sets can be larger than 24, remove middle part jl=len_trim(csname) if(jl.gt.24) then csname=csname(1:12)//'..'//csname(jl-9:jl) endif ch1='X' write(unit,412)phlista(lokph)%alphaindex,csrec%phtupx,csname, & csrec%amfu*csrec%abnorm(1),csrec%abnorm(1),& csrec%dgm/csrec%abnorm(1),phlista(lokph)%status1,& ceq%phase_varres(lokcs)%status2,ch1 412 format(2i4,1x,a24,1PE10.2,1x,0PF8.2,1PE10.2,2(0p,z8),a1) if(csrec%dgm.lt.zero) then jph=jph+1 if(jph.gt.10) then write(unit,*)' ... remaining phases further from stability' exit entlist2 endif endif enddo entlist2 if(shbest.gt.0) then call get_phasetup_name(shbest,phname) write(*,117)trim(phname) endif ! if(ndorm.eq.0) goto 400 write(unit,211) 211 format(/'List of dormant phases'/ & ' No tup Name',22x,'Mol.comp. Comp/FU dGm/RT Status1 Status2') jph=0 dorlist: do iph=1,ndorm trailer=' ' lokcs=dorph(iph) csrec=>ceq%phase_varres(lokcs) lokph=csrec%phlink phname=phlista(lokph)%name ! how do I to know composition set number??? ! Aha!! in phasetuple(phase_varres(lokcs)%phtupx)%compset if(phlista(lokph)%noofcs.gt.1) then ics=phasetuple(ceq%phase_varres(lokcs)%phtupx)%compset chs=char(ichar('0')+ics) kp=len_trim(csrec%prefix) if(kp.gt.0) then csname=csrec%prefix(1:kp)//'_'//phname else csname=phname endif kp=len_trim(csrec%suffix) if(kp.gt.0) csname=& csname(1:len_trim(csname))//'_'//csrec%suffix(1:kp) csname=csname(1:len_trim(csname))//'#'//chs//trailer else csname=phname endif ! phase names for composition sets can be larger than 24, remove middle part jl=len_trim(csname) if(jl.gt.24) then csname=csname(1:12)//'..'//csname(jl-9:jl) endif ch1='D' write(unit,113)phlista(lokph)%alphaindex,csrec%phtupx,csname, & csrec%amfu*csrec%abnorm(1),& csrec%abnorm(1),csrec%dgm/csrec%abnorm(1),phlista(lokph)%status1,& ceq%phase_varres(lokcs)%status2,ch1 113 format(2i4,1x,a24,1PE10.2,1x,0PF8.2,1PE10.2,2(0p,z8),a1) jph=jph+1 if(jph.gt.10) then write(unit,*)' ... other phases further from stability' exit dorlist endif enddo dorlist endif selmode ! list suspended phases without composition set numbers 400 continue if(nsusp.gt.1) then write(unit,300) 300 format(/'List of suspended phases:') ! First indentation 4, for 2nd and later lines 4 also call wrice2(unit,2,4,78,1,susph(1:nsusp-3)) endif 1000 continue return end subroutine list_sorted_phases !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_all_phases !\begin{verbatim} subroutine list_all_phases(unit,ceq) ! short list with one line for each phase ! suspended phases merged into one line implicit none integer unit TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} ! separate entered/fixed form suspended/dormant integer jl,jk,ics,lokph,lokcs,kp,ndorm,nsusp character line*80,phname*24,trailer*28,chs*1,csname*36,susph*4096,ch1*1 ! type(gtp_phasetuple), allocatable :: dormant TYPE(gtp_phase_varres), pointer :: csrec susph=' ' nsusp=1 write(unit,10)nooftuples 10 format(/'List of ',i3,' phases'/ & ' No tup Name',22x,'Mol.comp. Comp/FU dGm/RT Status1 Status2') ! 230709 ' No tup Name',22x,'Mol.comp. Comp/FU dGm/RT Status1 Status2') ! ' No tup Name',22x,'Mol.comp. At/F.U. dGm/RT Status1 Status2') jl=0 trailer=' ' ! write(*,*)'3C In list_all_phases',noofph ! allocate(dormant(noofph)) ! dormant=0 ndorm=0 ! come back here for listing dormant phases 20 continue ! phloop: do jk=1,noofph line=' ' ! list in alphabetical order except gas and liquid(s) first lokph=phases(jk) csloop: do ics=1,phlista(lokph)%noofcs lokcs=phlista(lokph)%linktocs(ics) csrec=>ceq%phase_varres(lokcs) ! write(*,*)'3C lpd: 69: ',jk,ics,lokph,lokcs if(ndorm.ge.0) then if(csrec%phstate.eq.PHDORM) then ndorm=ndorm+1 cycle elseif(csrec%phstate.eq.PHSUS) then ! skip composition set number and pre/suffixes at present .... susph(nsusp:)=phlista(lokph)%name(1:& len_trim(phlista(lokph)%name))//', ' nsusp=len_trim(susph)+2 if(ics.gt.1) then susph(nsusp-2:)='#'//char(ichar('0')+ics)//',' nsusp=nsusp+2 endif cycle endif elseif(csrec%phstate.ne.PHDORM) then ! when ndorm<0 skip all ohases that are suspended, entered or fix cycle endif phname=phlista(lokph)%name jl=jl+1 ! write(*,70)'3C lpd: 70:',phname,phlista(lokph)%noofcs !70 format(a,a24,5i6) if(phlista(lokph)%noofcs.gt.1) then chs=char(ichar('0')+ics) kp=len_trim(csrec%prefix) if(kp.gt.0) then csname=csrec%prefix(1:kp)//'_'//phname else csname=phname endif kp=len_trim(csrec%suffix) if(kp.gt.0) & csname=csname(1:len_trim(csname))//'_'//csrec%suffix(1:kp) csname=csname(1:len_trim(csname))//'#'//chs//trailer else csname=phname endif ! phase names for composition sets can be larger than 24, remove middle part jl=len_trim(csname) if(jl.gt.24) then csname=csname(1:12)//'..'//csname(jl-9:jl) endif if(ceq%phase_varres(lokcs)%phstate.eq.phfixed) then ch1='F' elseif(ceq%phase_varres(lokcs)%phstate.eq.phentstab) then ch1='S' elseif(ceq%phase_varres(lokcs)%phstate.eq.phentered) then ch1='E' elseif(ceq%phase_varres(lokcs)%phstate.eq.phentunst) then ch1='U' elseif(ceq%phase_varres(lokcs)%phstate.eq.phdorm) then ch1='D' elseif(ceq%phase_varres(lokcs)%phstate.eq.phsus) then ch1='X' else write(*,*)'3C unknown state: ',ceq%phase_varres(lokcs)%phstate endif ! if(csrec%amfu.ne.zero) then if(csrec%dgm.eq.zero) then ! write(unit,110)jk,ics,csname, & write(unit,110)jk,csrec%phtupx,csname, & csrec%amfu*csrec%abnorm(1),& csrec%abnorm(1),phlista(lokph)%status1,& ceq%phase_varres(lokcs)%status2,ch1 ! 230709 shorter 110 format(i3,i4,1x,a24,1PE10.2,1x,0PF8.2,' 0.0 ',2(0p,z8),a1) !110 format(2i4,1x,a24,1PE10.2,1x,0PF8.2,' 0.0',2(0p,z8),a1) !110 format(2i4,1x,a24,1PE10.2,1x,0PF9.2,' 0.0',2(0p,z8)) else ! write(unit,112)jk,ics,csname, & write(unit,112)jk,csrec%phtupx,csname, & csrec%amfu*csrec%abnorm(1),& csrec%abnorm(1),csrec%dgm/csrec%abnorm(1),& phlista(lokph)%status1,ceq%phase_varres(lokcs)%status2,ch1 ! 230709 shorter 112 format(i3,i4,1x,a24,1PE10.2,1x,0PF8.2,1PE10.2,1x,2(0p,z8),a1) !112 format(2i4,1x,a24,1PE10.2,1x,0PF8.2,1PE10.2,2(0p,z8),a1) !112 format(2i4,1x,a24,1PE10.2,1x,0PF9.2,1PE10.2,2(0p,z8)) endif else ! write(unit,111)jk,ics,csname, & write(unit,111)jk,csrec%phtupx,csname, & csrec%abnorm(1),csrec%dgm/csrec%abnorm(1),& phlista(lokph)%status1,ceq%phase_varres(lokcs)%status2,ch1 ! 230709 shorter 111 format(i3,i4,1x,a24,' 0.0',1x,0PF8.2,1PE10.2,1x,2(0p,z8),a1) !111 format(2i4,1x,a24,' 0.0',1x0PF8.2,1PE10.2,2(0p,z8),a1) !111 format(2i4,1x,a24,' 0.0',1x0PF9.2,1PE10.2,2(0p,z8)) endif enddo csloop enddo phloop if(ndorm.gt.0) then write(unit,200) ! 230709 shorter 200 format(/'List of dormant phases'/ & ' No tup Name',22x,'Mol.comp. Comp/FU dGm/RT Status1 Status2') ! ' No tup Name',22x,'Mol.comp. At/F.U. dGm/RT Status1 Status2') ndorm=-1 goto 20 endif ! list suspended phases without composition set numbers if(nsusp.gt.1) then write(unit,300) 300 format(/'List of phases that are suspended:') ! First indentation 4, for 2nd and later lines 4 also call wrice2(unit,2,4,78,1,susph(1:nsusp-3)) endif 1000 continue ! temporary list all phase tuples ! do jl=1,nooftuples ! lokph=phases(phasetuple(jl)%phase) ! lokcs=phlista(lokph)%linktocs(phasetuple(jl)%compset) ! write(*,600)jl,phasetuple(jl)%phase,phasetuple(jl)%compset,lokcs,& ! firsteq%phase_varres(lokcs)%phtupx !600 format('Phase tuple: ',3i4,' backlink: ',5i4) ! enddo return END subroutine list_all_phases !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_global_results !\begin{verbatim} subroutine list_global_results(lut,ceq) ! list G, T, P, V and some other things implicit none integer lut TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} character encoded*64 double precision x1,x2,x3,xn,rtn ! ! write(kou,*)'gtp3C: output unit: ',lut encoded=' ' call get_state_var_value('T ',x1,encoded,ceq) call get_state_var_value('P ',x2,encoded,ceq) ! We must use VS to get SER reference call get_state_var_value('VS ',x3,encoded,ceq) ! this will write error message if any and reset the code if(.not.gtp_error_message(0)) then ! no error, list the data write(lut,10)x1,x1-273.15,x2,x3 10 format('T= ',F9.2,' K (',F9.2,' C), P= ',1pe11.4,& ' Pa, V= ',1pe11.4,' m3') rtn=globaldata%rgas*x1 else rtn=one endif ! problem with N, should not take into account the atoms/formula units? call get_state_var_value('N ',xn,encoded,ceq) call get_state_var_value('B ',x2,encoded,ceq) if(.not.gtp_error_message(0)) then write(lut,11)xn,x2,rtn 11 format('N= ',1pe12.4,' moles, B= ',1pe12.4,' g, RT= ',1pe12.4,' J/mol') endif ! we must use suffix S to have values referred to SER call get_state_var_value('GS ',x1,encoded,ceq) call get_state_var_value('HS ',x2,encoded,ceq) ! CCI changed format of S ! call get_state_var_value('S ',x3,encoded,ceq) call get_state_var_value('SS ',x3,encoded,ceq) if(.not.gtp_error_message(0)) then ! just use G, H and S here as the heading state the SER refernce state is used write(lut,12)x1,x1/xn,x2,x3 12 format('G= ',1pe12.5,' J, G/N=',1pe11.4,' J/mol, H=',1pe11.4,& ' J, S=',1pe10.3,' J/K') !CCI end endif 1000 continue return end subroutine list_global_results !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_components_result !\begin{verbatim} subroutine list_components_result(lut,mode,ceq) ! list one line per component (name, moles, x/w-frac, chem.pot. reference state ! mode 1=mole fractions, 2=mass fractions implicit none integer lut,mode TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} character svtext*64,encoded*64,name*24 integer ie,kl double precision x1,x2,x3,x4,rtn encoded=' ' if(mode.eq.1) then write(lut,7) !7 format('Component name',11x,'Moles',7x,'Mole-fracs Chem.potent. ',& 7 format('Component name',4x,'Moles',6x,'Mole-fr Chem.pot/RT ',& 'Activities Ref.state') elseif(mode.eq.2) then write(lut,9) 9 format('Component name',4x,'Moles',6x,'Mass-fr Chem.pot/RT ',& 'Activities Ref.state') endif call get_state_var_value('T ',x1,encoded,ceq) rtn=globaldata%rgas*x1 do ie=1,noofel call get_component_name(ie,name,ceq) kl=len_trim(name) svtext='N('//name(1:kl)//') ' ! write(*,*)'3C state variable :',svtext call get_state_var_value(svtext,x1,encoded,ceq) if(gx%bmperr.ne.0) goto 1000 ! if(mode.eq.1) then svtext='X('//name(1:kl)//') ' elseif(mode.eq.2) then svtext='W('//name(1:kl)//') ' endif call get_state_var_value(svtext,x2,encoded,ceq) if(gx%bmperr.ne.0) goto 1000 ! This should be read from component record .... ???? YES svtext='MU('//name(1:kl)//') ' ! write(*,*)'3C state variable :',svtext call get_state_var_value(svtext,x3,encoded,ceq) if(gx%bmperr.ne.0) then write(*,*)'3C Error line 659: ',trim(svtext),gx%bmperr gx%bmperr=0; x3=1.0D2*rtn endif ! divide mu with RT, lnac if(abs(x3).gt.1.0D-30) then x3=x3/rtn else x3=zero endif x4=exp(x3) ! reference state, by default "SER (default)" take from component record ! if(ceq%complist(ie)%phlink.gt.0) then encoded=ceq%complist(ie)%refstate ! else ! default name of reference state ! encoded='SER (default)' ! endif write(lut,10)name(1:16),x1,x2,x3,x4,encoded(1:16) !10 format(a,3(1pe12.4),2x,a) 10 format(a,1pe12.4,0pf9.5,2(1pe12.4),2x,a) enddo 1000 continue return end subroutine list_components_result !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_phases_with_positive_dgm !\begin{verbatim} subroutine list_phases_with_positive_dgm(mode,lut,ceq) ! list one line for each phase+comp.set with positive dgm on device lut ! The phases must be dormant or the result is in error. mode is not used implicit none integer mode,lut TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} character name*24 ! character*10, dimension(-3:2) :: status=& ! ['SuspendedEntered ','Fix ','Dormant ','Suspended '] integer once,iph,lokph,ics,lokcs,kkz,jd integer, dimension(:), allocatable :: phtupx integer, dimension(:), allocatable :: isort double precision xxx ! write(*,*)'3C In list_phases_with_positive_dgm' once=0 do iph=1,noofph lokph=phases(iph) csloop: do ics=1,phlista(lokph)%noofcs lokcs=phlista(lokph)%linktocs(ics) if(ceq%phase_varres(lokcs)%phstate.lt.PHDORM) cycle csloop ! if(abs(ceq%phase_varres(lokcs)%netcharge).gt.1.0d-6) then ! write(*,*)'3C ignoring phase with net charge: ',iph,ics ! cycle csloop ! endif if(ceq%phase_varres(lokcs)%dgm/& ceq%phase_varres(lokcs)%abnorm(1).gt.1.0D-4) then if(once.eq.0) then allocate(phtupx(nooftuples)) endif once=once+1 if(once.eq.1) write(lut,109) 109 format(/' *** There are phase(s) which would like to be stable:') phtupx(once)=ceq%phase_varres(lokcs)%phtupx write(lut,78, advance='no')trim(phlista(lokph)%name),& ceq%phase_varres(lokcs)%dgm/ceq%phase_varres(lokcs)%abnorm(1) 78 format(3x,a,1pe12.4) ! write(*,98)once,phtupx(once),phasetuple(phtupx(once))%phase,iph,& ! lokcs,ceq%phase_varres(lokcs)%dgm,& ! ceq%phase_varres(lokcs)%netcharge 98 format('3C dgm: ',5i4,2(1pe12.4),'; ') endif enddo csloop enddo if(once.gt.0) write(*,*) ! skip the listing below goto 1000 if(once.gt.0) then write(lut,110)once 110 format(/' *** ',i3,' Phases which would like to be stable in order') allocate(isort(once)) ! call sortrdd(pdgm,once,isort) ! if(buperr.ne.0) then ! write(*,*)'Error sorting fractions',buperr ! goto 1000 ! endif do jd=1,once ! add next line when we have sorted ! isort(jd)=jd isort(jd)=phtupx(jd) ! This is getting messy again, the phase tuple index is at present ! the index to phase_varres +1 (as index 1 is the stable reference phase) ! iph=phasetuple(phtupx(isort(jd)))%phaseix ! removing redundant call to get_phase_compset ! iph=phasetuple(phtupx(isort(jd)))%ixphase ! ics=phasetuple(phtupx(isort(jd)))%compset ! call get_phase_compset(iph,ics,lokph,lokcs) ! if(gx%bmperr.ne.0) goto 1000 lokph=phasetuple(phtupx(isort(jd)))%lokph lokcs=phasetuple(phtupx(isort(jd)))%lokvares ! write(*,117)jd,isort(jd),iph,ics,lokcs,phtupx(isort(jd)),& ! ceq%phase_varres(lokcs)%dgm 117 format('3C Phase: ',2i3,2i5,2i7,1pe10.2) ! call get_phasetup_name(phasetuple(isort(jd)),name) ! kkz=test_phase_status(iph,ics,xxx,ceq) ! write(*,*)'3C: error: ',name,lokcs,kkz ! old kkz.le.2 means entered or fixed ! if(kkz.le.3) then ! now: kkz= -3, -2, -1, 0, 1, 2 ! means SUSPEND, DORMANT, ENTENTED/UNST, ENTERED, ENTERD/STABLE, FIXED kkz=ceq%phase_varres(lokcs+1)%phstate if(kkz.ge.PHDORM) then write(lut,120)name,phstate(kkz),& ceq%phase_varres(lokcs+1)%dgm/ceq%phase_varres(lokcs+1)%abnorm(1) 120 format('Phase: ',a,' Status: ',a,' Driving force:',1pe12.4) endif enddo endif 1000 continue return end subroutine list_phases_with_positive_dgm !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_phase_results !\begin{verbatim} subroutine list_phase_results(iph,jcs,mode,lut,once,ceq) ! list results for a phase+comp.set on lut ! mode specifies the type and amount of results, ! unit digit: 0=mole fraction, othewise mass fractions ! 10th digit: 0=only composition, 10=also constitution ! 100th digit: 0=value order, 100=alphabetical order ! 1000th digit: 0=all phases, 1000=only stable phases ! 10000th digit: 1= constituent fractions times formula unit of phase (Solgas) ! ? digit, just one line per phase implicit none integer iph,jcs,mode,lut logical once TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ character text*256,phname*24,status*10 character (len=24), dimension(:), allocatable :: consts ! character*24, allocatable (:) :: consts double precision xmol(maxel),wmass(maxel),totmol,totmass,amount,abv,mindgm !CCI moles per Formula Unit double precision totmolperFU !CCI double precision, dimension(:), allocatable :: ymol integer lokph,lokcs,kode,nz,jl,nk,ll,ip,kstat mindgm=1.0D-10 if(ocv()) write(*,*)'3C mode: ',mode if(iph.lt.1 .or. iph.gt.noofph) then ! write(*,*)'3C lpr ',iph,jcs,mode gx%bmperr=4050; goto 1000 endif lokph=phases(iph) if(btest(phlista(lokph)%status1,phhid)) then ! phase is hidden gx%bmperr=4119; goto 1000 endif ! ! .gt.9 ! if(jcs.lt.0 .or. jcs.gt.phlista(lokph)%noofcs) then gx%bmperr=4072; goto 1000 elseif(jcs.eq.0) then jcs=1 endif lokcs=phlista(lokph)%linktocs(jcs) ! write(*,*)'3C lpr 2: ',jcs,phlista(lokph)%noofcs,lokcs ! get name with pre- and suffix call get_phase_name(iph,jcs,phname) if(gx%bmperr.ne.0) goto 1000 ! write(*,11)'3C Phase name: ',iph,jcs,phname !11 format(a,2i3,'"',a,'"') if(mode.ge.1000) then ! if mode>=1000 list stable phases only (dgm<0 ) ! if(ceq%phase_varres(lokcs)%amount(1).eq.zero) then if(abs(ceq%phase_varres(lokcs)%netcharge).gt.1.0d-6) then if(ceq%phase_varres(lokcs)%phstate.gt.phentered) then write(lut,18)phname(1:len_trim(phname)),& ceq%phase_varres(lokcs)%netcharge 18 format('Phase: ',a,' has stable status with net charge: ',F6.3) goto 1000 endif endif if(ceq%phase_varres(lokcs)%amfu.eq.zero) then ! skip phases with zero amount unless expcitly stable or positive dgm if(ceq%phase_varres(lokcs)%dgm.eq.zero) then ! if(ceq%phase_varres(lokcs)%phstate.ne.PHFIXED) goto 1000 if(ceq%phase_varres(lokcs)%phstate.lt.PHENTSTAB) goto 1000 elseif(ceq%phase_varres(lokcs)%dgm.lt.mindgm) then goto 1000 endif endif endif ! phase status (except hidden) .... use get_phase_status instead ??? ! if(btest(ceq%phase_varres(lokcs)%status2,cssus)) then ! if(btest(ceq%phase_varres(lokcs)%status2,csfixdorm)) then if(ceq%phase_varres(lokcs)%phstate.eq.PHDORM) then status='Dormant' kstat=4 ! skip dormant phases unless once TRUE (positive driving force) ! if(ceq%phase_varres(lokcs)%dgm.le.mindgm) goto 1000 if(.not.once) goto 1000 elseif(ceq%phase_varres(lokcs)%phstate.eq.PHSUS) then ! skip suspended phases status='Suspended' goto 1000 ! if(btest(ceq%phase_varres(lokcs)%status2,csfixdorm)) then elseif(ceq%phase_varres(lokcs)%phstate.eq.PHFIXED) then status='Fixed' kstat=2 else status='Entered' kstat=1 ! skip phase with net charge ! if(abs(ceq%phase_varres(lokcs)%netcharge).gt.1.0D-6) goto 1000 ! skip entered phases that have positive driving force, why?? ! if(ceq%phase_varres(lokcs)%dgm.gt.zero) goto 1000 endif if(phname(1:1).lt.'A' .or. phname(1:1).gt.'Z') then ! in some cases unprintable phase names appears!! write(lut,19)iph,jcs,lokph,lokcs 19 format(' *** Warning: illegal phase name: ',10i5) endif !X write(lut,20)phname,status,ceq%phase_varres(lokcs)%dgm 20 format(/'Phase: ',A,' Status: ',A,' Driving force: ',1PE12.4) !------------------------ ! xmol=zero ! wmass=zero call calc_phase_molmass(iph,jcs,xmol,wmass,totmol,totmass,amount,ceq) if(gx%bmperr.ne.0) then write(*,*)'3C Error: ',gx%bmperr; goto 1000 endif !CCI totmolperFU=ceq%phase_varres(lokcs)%amfu !CCI ! write(*,99)'3C xmol: ',xmol !99 format(a,6(1pe12.4)) kode=mod(mode,10) ! write(*,*)'3C lpr 3: ',mode,kode abv=ceq%phase_varres(lokcs)%abnorm(1) ! a shorter output ! write(lut,700)phname,status(1:1),totmol,totmass*0.001, & ! amount*ceq%rtn*ceq%phase_varres(lokcs)%gval(3,1),& ! ceq%phase_varres(lokcs)%amfu,abv,ceq%phase_varres(lokcs)%dgm ! try to fill upp the phase name with '.' nz=len_trim(phname) phname(nz+1:)='.........................' if(kode.eq.0) then ! The volume value here is WRONG: ceq%phase_varres(lokcs)%gval(3,1) !!! ??? if(once) write(lut,699)'Moles ' once=.FALSE. 699 format(/'Name Status ',a,' Volume',& ' Form.Units Cmp/FU dGm/RT Comp:') ! ' Form.U At/FU DGM Fracs:') write(lut,700)phname,status(1:1),totmol,& amount*ceq%rtn*ceq%phase_varres(lokcs)%gval(3,1),& ceq%phase_varres(lokcs)%amfu,abv,ceq%phase_varres(lokcs)%dgm/abv,'X:' ! phase status moles/mass (volume FU) Atomes/FU DGM Content 700 format(a,1x,a, 1pe11.3, 2(1pe10.2),1x,0pF7.2,1pe10.2,2x,a) !X if(abs(ceq%phase_varres(lokcs)%netcharge).gt.1.0D-6) then !X write(lut,28)totmol,totmass*0.001, & !X amount*ceq%rtn*ceq%phase_varres(lokcs)%gval(3,1),& !X ceq%phase_varres(lokcs)%netcharge !X else !X write(lut,25)totmol,totmass*0.001, & !X amount*ceq%rtn*ceq%phase_varres(lokcs)%gval(3,1) !X endif !X write(lut,21)ceq%phase_varres(lokcs)%amfu,abv 21 format('Formula Units: ',1pe12.4,', Moles of atoms/FU: ',1pe12.4,& ', Molar content:') else if(once) write(lut,699)'Mass ' once=.FALSE. write(lut,700)phname,status(1:1),totmass*0.001, & amount*ceq%rtn*ceq%phase_varres(lokcs)%gval(3,1),& ceq%phase_varres(lokcs)%amfu,abv,ceq%phase_varres(lokcs)%dgm/abv,'W:' !X write(lut,25)totmol,totmass*0.001,& !X amount*ceq%rtn*ceq%phase_varres(lokcs)%gval(3,1) !X write(lut,22)ceq%phase_varres(lokcs)%amfu,abv 22 format('Formula Units: ',1pe12.4,', Moles of atoms/FU: ',1pe12.4,& ', Mass fractions:') endif 25 format('Moles',1PE12.4,', Mass',1PE12.4,' kg, Volume',1PE12.4,' m3') 28 format('Moles',1PE11.3,' Mass',1PE11.3,' kg, Volume',1PE11.3,' m3,',& ' Charge: ',1pe11.3) ! skip composition if(mode.eq.10020) goto 1000 ! composition nz=noofel allocate(consts(nz)) consts=' ' do jl=1,nz consts(jl)=splista(ceq%complist(jl)%splink)%symbol enddo ! write(*,187)'3C lpr: ',consts !187 format(a,20(1x,a2)) if(kode.eq.0) then call format_phase_composition(mode,nz,consts,xmol,lut) else call format_phase_composition(mode,nz,consts,wmass,lut) endif deallocate(consts) if(gx%bmperr.ne.0) goto 1000 !------------------------------------- ! constitution only if nonzero tenth-digit of mode or if GAS 300 continue if(.not.btest(phlista(lokph)%status1,PHGAS)) then if(mod(mode/10,10).le.0) goto 900 endif if(mode.ge.10000) then ! CCI modification warning! write(lut,309) 309 format(' *** NOTE: values below are constituent fractions',& ' times formula unit of phase!') endif write(lut,310,advance='no') 310 format('Constitution: ') !--------------- nk=0 sublatloop: do ll=1,phlista(lokph)%noofsubl nz=phlista(lokph)%nooffr(ll) ! if(phlista(lokph)%noofsubl.gt.1) then if(size(ceq%phase_varres(lokcs)%sites).gt.1) then ! write(lut,320)ll,nz,phlista(lokph)%sites(ll) if(ll.gt.1) then write(lut,319)ll,nz,ceq%phase_varres(lokcs)%sites(ll) else write(lut,320)ll,nz,ceq%phase_varres(lokcs)%sites(ll) endif 319 format(14x,'Sublattice ',i2,' with ',i5,' constituents and ',& F12.6,' sites') 320 format('Sublattice ',i2,' with ',i5,' constituents and ',& F12.6,' sites') ! elseif(phlista(lokph)%sites(ll).eq.one) then elseif(ceq%phase_varres(lokcs)%sites(ll).eq.one) then write(lut,321)nz 321 format('There are ',i5,' constituents:') else ! write(lut,322)nz,phlista(lokph)%sites(ll) write(lut,322)nz,ceq%phase_varres(lokcs)%sites(ll) 322 format('Single lattice with ',i5,' constituents and ',& F12.6,' sites') endif text=' '; ip=1 allocate(consts(nz)) allocate(ymol(nz)) consts=' ' do jl=1,nz ! jcons=splista(phlista(lokph)%constitlist(nk+jl))%alphaindex consts(jl)=' ' if(phlista(lokph)%constitlist(nk+jl).gt.0) then consts(jl)=splista(phlista(lokph)%constitlist(nk+jl))%symbol else consts(jl)='*' endif ymol(jl)=ceq%phase_varres(lokcs)%yfr(nk+jl) enddo !CCI for mode >= 10000 if(mode.ge.10000) then ymol=ymol*totmolperFU endif !CCI end call format_phase_composition(mode,nz,consts,ymol,lut) deallocate(consts) deallocate(ymol) if(gx%bmperr.ne.0) goto 1000 nk=nk+nz enddo sublatloop 900 continue ! write an empty line after each phase ... write(lut,*) 1000 continue return end subroutine list_phase_results !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_short_results !\begin{verbatim} subroutine list_short_results(lut,ceq) ! list short results for all stable phases (for debugging) lut implicit none integer lut TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer iph,ics,lokph,lokcs,i1,i2 phaseloop: do iph=1,noofph lokph=phases(ics) compsets: do ics=1,phlista(lokph)%noofcs lokcs=phlista(lokph)%linktocs(ics) if(ceq%phase_varres(lokcs)%phstate.ge.PHENTSTAB) then write(lut,110)phlista(lokph)%name,ics,ceq%phase_varres(lokcs)%amfu 110 format(a,i2,4(1pe12.4)) endif enddo compsets enddo phaseloop 1000 continue return end subroutine list_short_results !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine format_phase_composition !\begin{verbatim} subroutine format_phase_composition(mode,nv,consts,vals,lut) ! list composition/constitution in alphabetical or value order ! entalsiffra 0 mole fraction, 1 mass fraction, 3 mole percent, 4 mass percent ! tiotalsiffra alphabetical order ... ?? ! mode >100 else alphabetical order ! nv is number of components/constitunents (in alphabetical order in consts) ! components/constituents in consts, fractions in vals implicit none integer nv,mode,lut character consts(nv)*(*) double precision vals(nv) !\end{verbatim} integer maxl,jl,kp,ncol,nrow2,nvrest,n1,nempty,n3r,n4r character names(4)*12 integer, dimension(:), allocatable :: isort ! 3-13 position name, 12 positions value (1pe12.5), 2 positions separator ! NOTE components can have negative fractions but not constituents ! so leave one blank after component names ! Constituents with names longer than 13 will be written A23456..12345 ! with 6 initial characters, two dots and then the 5 last characters ! Max 4 columns with 18 positions(=72) plus 3*2=6 position separator, ! min 3 columns with 24 positions(=72) plus 2*2=4 position separator ! ! max length of names and number of columns maxl=0 do jl=1,nv kp=len_trim(consts(jl)) if(kp.gt.maxl) then maxl=kp endif enddo if(maxl.le.4) then ! use 4 columns if names are short ncol=4 else ncol=3 endif ! number of rows is needed to have valuses in columns decending like: ! FE 0.75 SI 0.05 Ti 0.02 C 0.01 ! CR 0.20 Mn 0.04 V 0.01 !----------------------------------- nrow2=(nv+ncol-1)/ncol ! always use isort for the order, if alphabetical isort(i)=i allocate(isort(nv+4)) isort=0 ! if(mode.ge.100) then ! write(*,*)'3C mode: ',mode,mod(mode,100),mode-100*mod(mode,100) ! if(mod(mode,10).eq.0) then if(mod(mode/100,10).eq.0) then ! value order call sortrdd(vals,nv,isort) if(buperr.ne.0) then write(*,*)'Error sorting fractions',buperr gx%bmperr=buperr; goto 1000 endif ! write(*,'(a,10i3)')'3C value order',nv,ncol,nrow2 else ! if alphabetical order just set isort(i)=i, same index as for vals ! write(*,'(a,10i3)')'3C alphabetical order',nv,ncol,nrow2 do jl=1,nv isort(jl)=jl enddo endif ! write(*,'(a,i3,2x,15i3)')'3C isort: ',nv,isort ! list constituents in the order of isort if(ncol.eq.4) then ! All names max 4 characters, 4 columns: 1 + 4+1+13+2 +20 +20 +18 = 79 nvrest=nv n1=1 ! number of empty colums in last row is 4*nrow2-nv nempty=4*nrow2-nv ! 3rd and 4th column may start from one or two indices less n3r=2*nrow2 n4r=3*nrow2 if(nempty.eq.3) then n3r=n3r-1 n4r=n4r-2 elseif(nempty.eq.2) then n4r=n4r-1 endif 100 continue ! this can be quite complicated as last row may be partially empty as if(nvrest.ge.4) then names(1)=consts(isort(n1)) names(2)=consts(isort(n1+nrow2)) names(3)=consts(isort(n1+n3r)) ! 4th column may be empty after first row if(n1+n4r.le.nv) then names(4)=consts(isort(n1+n4r)) write(lut,110)names(1)(1:4),vals(n1),& names(2)(1:4),vals(n1+nrow2),names(3)(1:4),vals(n1+n3r),& names(4)(1:4),vals(n1+n4r) 110 format(1x,a,1x,1pe13.5,3(2x,a,1x,1pe13.5)) nvrest=nvrest-4 else write(lut,110)names(1)(1:4),vals(n1),& names(2)(1:4),vals(n1+nrow2),names(3)(1:4),vals(n1+n3r) nvrest=nvrest-3 endif n1=n1+1 else ! List in 4 columns, last row less than 4 columns names(1)=consts(isort(n1)) if(nvrest.gt.1) then names(2)=consts(isort(n1+nrow2)) if(nvrest.gt.2) then names(3)=consts(isort(n1+n3r)) write(lut,110)names(1)(1:4),vals(n1),& names(2)(1:4),vals(n1+nrow2),names(3)(1:4),vals(n1+n3r) else write(lut,110)names(1)(1:4),vals(n1),& names(2)(1:4),vals(n1+nrow2) endif else write(lut,110)names(1)(1:4),vals(n1) endif nvrest=0 endif if(nvrest.gt.0) goto 100 else ! List in 3 columns as constituent names are long ! All listed names have max 13 characters, longer names are truncated nvrest=nv n1=1 ! number of empty columns in last row nempty=3*nrow2-nv ! 3rd column may start from an indices less n3r=2*nrow2 ! if(nempty.eq.2) then ! BoS modified 19.11.19 at CEA ... wrong?? ! if(nempty.eq.1) then ! n3r=n3r-1 ! endif 200 continue ! write(*,'(a,4i4,2x,3i4)')'3C last species wrong: ',n1,nrow2,nempty,n3r,& ! isort(n1),isort(n1+nrow2),isort(n1+n3r) if(nvrest.ge.3) then names(1)=consts(isort(n1)) names(2)=consts(isort(n1+nrow2)) 203 format(a,i3,2x,10i3) if(n1+2*nrow2.le.nv) then ! write(*,203)'3C Row1 ',n1,nrow2,n3r,nempty,isort(n1),& ! isort(n1+nrow2),isort(n1+n3r) names(3)=consts(isort(n1+n3r)) write(lut,210)names(1),vals(n1),names(2),vals(n1+nrow2),& names(3),vals(n1+n3r) 210 format(1x,a,1pe12.5,2(2x,a,1pe12.5)) nvrest=nvrest-3 else ! write(*,203)'Row2 ',n1,nrow2,n3r,nempty,isort(n1),isort(n1+nrow2) write(lut,210)names(1),vals(n1),names(2),vals(n1+nrow2) nvrest=nvrest-2 endif n1=n1+1 else ! last row can be 1 or 2 columns names(1)=consts(isort(n1)) if(nvrest.gt.1) then ! write(*,203)'Row3 ',n1,nrow2,n3r,nempty,isort(n1),isort(n1+nrow2) names(2)=consts(isort(n1+nrow2)) write(lut,210)names(1),vals(n1),names(2),vals(n1+nrow2) else ! write(*,203)'3C Row4 ',n1 write(lut,210)names(1),vals(n1) endif nvrest=0 endif if(nvrest.gt.0) goto 200 endif ! 1000 continue return end subroutine format_phase_composition !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_many_formats !\begin{verbatim} subroutine list_many_formats(cline,last,ftyp,unit1) ! lists all data in different formats: SCREEN/TDB/MACRO/LaTeX/ODB ! ftyp: 1 2 3 ??? ! unfinished implicit none character cline*(*) integer last,unit1,ftyp !\end{verbatim} integer iph,ipos,kousave,unit,isp ! the retured file name can be very long character text*512, text2*2000,fil*128,zext*5 character date*8,CHTD*1 ! if not screen then ask for file name ! for screen output of file use /option= ... ! write(*,*)'3C In list_many_formats',ftyp ! problem with program jus dies after gparfilex trying to write a TDB file ! gparfilex called in PMON6 if(ftyp.ne.1) then ! call gparcdx('Output file: ',cline,last,1,fil,'database','?Output format') ! default extension (1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT, 6=XTDB, 7=DAT, -8=LOG ! NEGATIVE is for write, 0 read without filter, -100 write without filter ! gparfilex may call TINYFILESDIALOG text=' ' call gparfilex('Output file: ',cline,last,1,fil,text,& -ftyp,'?Output format') ! Sometimes segmentation fault between the exit of GPARFILEX and this write write(*,*)'3C back from gparfilex',ftyp,' "',trim(fil),'"' ipos=len_trim(fil) if(ipos.le.0) then write(*,*)'No file name, quit' gx%bmperr=4399 goto 1000 endif ! if there is a segmentation fault it is inside gparfilex SUCK write(*,*)'3C file name: ',trim(fil) ! it is impossible to have a blank name here, check if there is an extension iph=index(fil,'.') if(iph.gt.0) then ! There must be a letter after the period if(iph.eq.ipos) iph=0 endif if(iph.eq.0) then if(ftyp.eq.2) then ! TDB file a la TC fil(ipos+1:)='.TDB' elseif(ftyp.eq.3) then fil(ipos:)='.OCM' elseif(ftyp.eq.4) then fil(ipos:)='.tex' elseif(ftyp.eq.6) then ! XTDB fil(ipos:)='.XTDB' else ! filetype not used gx%bmperr=4399; goto 1000 endif endif write(*,*)'3C opening a new file',ftyp ! check if file exists ... overwriting not allowed ... open(unit=31,file=fil,access='sequential',status='new',err=900) kousave=unit unit=31 endif 99 continue call date_and_time(date) ! write(*,*)'3C select case: ',ftyp select case(ftyp) case default write(kou,*)'No such format' !---------------------------------------------------------- ! This can be written to file using the /output option case(1) ! ftyp=1 SCREEN format ! add a line if EET (Hickel T, equi-entropy check) if(globaldata%sysreal(1).gt.zero) & write(kou,'(/"Equi-entropy check (EEC) enabled above T= ",f8.2)')& globaldata%sysreal(1) call list_all_elements(kou) if(gx%bmperr.ne.0) goto 1000 call list_all_species(kou) if(gx%bmperr.ne.0) goto 1000 call list_all_funs(kou) if(gx%bmperr.ne.0) goto 1000 do iph=1,noph() call list_phase_data(iph,' ',kou) if(gx%bmperr.ne.0) goto 1000 enddo ! list reference phase last iph=0 call list_phase_data(0,' ',kou) ! finally list the data bibliography write(kou,*) call list_bibliography(' ',kou) !-------------------------------------------------------------- ! write on unit case(2) ! ftyp=2 TDB format write(*,*)'Please use the SAVE command' goto 1000 ! CHTD1 keeps track of type definitions, note: incremented before use CHTD='0' ! NOTE this is not the normal subroutine to save TDB formats, see list_tdb_ write(*,*)'3C saving TDB format' if(notallowlisting(privilege)) goto 1000 write(*,*)'Use SAVE TDB to write a TDB database file' goto 1000 ! write(*,106)date(1:4),date(5:6),date(7:8) write(unit,106)date(1:4),date(5:6),date(7:8) 106 format('$ Database file written by Open Calphad ',a,'-',a,'-',a/) call list_all_elements2(unit) write(unit,107) 107 format(/'$ =================',/) text=' ' sploop: do isp=1, nosp() ! skip vacancy species and species that are elements iph=species(isp) ipos=1 write(*,*)'3C listing using list_species_data2' call list_species_data2(text,ipos,iph) ! not very logical, using species index below and location above ... suck if(testspstat(isp,SPEL) .or. testspstat(isp,SPVA)) then cycle sploop endif write(unit,110)text(1:len_trim(text)) 110 format('SPECIES ',A,' !') end do sploop write(unit,107) text2=' ' ! skip the first two functions which are R and RTLNP (using R) ! write RTLNP in correct TDB form here text2='FUNCTION RTLNP 10 R*T*LN(1.0D-5*P); 20000 N !' write(unit,112)text2(1:len_trim(text2)) 112 format(a) ! tpfuns: do iph=3, notpf()! freetpfun-1 text2='FUNCTION ' call list_tpfun(iph,0,text2(10:)) ! skip functions with names staring with _ as they are parameters if(text2(10:10).eq.'_') cycle tpfuns ! for the remaining functions OC writes them with = T_low ... ! and for TC one must remove the = sign ipos=index(text2,'=') text2(ipos:ipos)=' ' ! then add a ! at the end ipos=len_trim(text2) text2(ipos+1:)=' !' call wrice2(unit,0,8,78,1,text2) end do tpfuns write(unit,107) write(unit,130) 130 format(/'TYPE_DEFINITION % SEQ * !'/ & 'DEFINE_SYSTEM_DEFAULT ELEMENT 2 !'/ & 'DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !'/) write(unit,107) do iph=1, noph() call list_phase_data2(iph,ftyp,CHTD,unit) enddo write(unit,107) write(unit,140) 140 format(/' LIST_OF_REFERENCES'/ ' NUMBER SOURCE') call list_bibliography(' ',unit) write(unit,141) 141 format('!') close(unit) !-------------------------------------------------------------- case(3) ! ftyp=3 MACRO format write(kou,*)'MACRO not implemented yet' !-------------------------------------------------------------- case(4) ! ftyp=4 LATEX format write(kou,*)'LaTeX not implemented yet' !-------------------------------------------------------------- case(5) ! ftyp=5 Graphics PLT format write(*,*)'PLT format is for plotting' !-------------------------------------------------------------- case(6) ! ftyp=6 XTDB format ! write(kou,*)'XTDB not implemented yet' write(*,*)'Please use the SAVE command' end select !-------------------------------------------------------------- goto 1000 ! error 900 continue ! write(kou,*)'File already exist, overwriting not allowed' close(31) gx%bmperr=4190 1000 continue if(ftyp.ne.1 .and. gx%bmperr.eq.0) write(*,*)'Output saved on ',trim(fil) ! unit=kousave return end subroutine list_many_formats !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_TDB_format !\begin{verbatim} subroutine list_TDB_format(filename) ! lists all data TDB format implicit none character filename*(*) !\end{verbatim} integer iph,ipos,unit,isp,noq ! the retured file name can be very long character text*512, text2*2000 character date*8,CHTD*1 ! if not screen then ask for file name ! for screen output of file use /option= ... ! write(*,*)'3C In list_TDB_formats' ! problem with program jus dies after gparfilex trying to write a TDB file ! gparfilex called in PMON6 call date_and_time(date) ! write on unit ! write(*,*)'3C opening a TDB file: ',trim(filename) ! check if file exists ... overwriting not allowed ... open(unit=31,file=filename,access='sequential',status='new',err=900) unit=31 ! CHTD1 keeps track of type definitions, note: incremented before use CHTD='0' ! write(*,*)'3C saving TDB format on: ',trim(filename) if(notallowlisting(privilege)) goto 1000 ! write(*,106)date(1:4),date(5:6),date(7:8) write(unit,106)date(1:4),date(5:6),date(7:8) 106 format('$ Database file written by Open Calphad ',a,'-',a,'-',a/) call list_all_elements2(unit) write(unit,107) 107 format(/'$ =================',/) text=' ' sploop: do isp=1, nosp() ! skip vacancy species and species that are elements iph=species(isp) ipos=1 ! special format of text for MQMQA species if(splista(iph)%quadindex.gt.0) then ! remove the 2 number after -Q noq=index(splista(iph)%symbol,'-Q') text=splista(iph)%symbol(1:noq+1)//' '//splista(iph)%mqmqa1 ! write(*,*)'3C quad: ',trim(text) else call list_species_data2(text,ipos,iph) ! not very logical, using species index below and location above ... suck endif if(testspstat(isp,SPEL) .or. testspstat(isp,SPVA)) then cycle sploop endif write(unit,110)trim(text) 110 format('SPECIES ',A,' !') end do sploop write(unit,107) text2=' ' ! skip the first two functions which are R and RTLNP (using R) ! write RTLNP in correct TDB form here text2='FUNCTION RTLNP 10 R*T*LN(1.0D-5*P); 20000 N !' write(unit,112)trim(text2) write(*,112)trim(text2) 112 format(a) ! tpfuns: do iph=3, notpf()! freetpfun-1 text2='FUNCTION ' call list_tpfun(iph,0,text2(10:)) ! skip functions with names staring with _ as they are parameters if(text2(10:10).eq.'_') cycle tpfuns ! for the remaining functions OC writes them with = T_low ... ! and for TC one must remove the = sign ipos=index(text2,'=') text2(ipos:ipos)=' ' ! then add a ! at the end ipos=len_trim(text2) text2(ipos+1:)=' !' call wrice2(unit,0,8,78,1,text2) end do tpfuns write(unit,107) write(unit,130) 130 format(/'TYPE_DEFINITION % SEQ * !'/ & 'DEFINE_SYSTEM_DEFAULT ELEMENT 2 !'/ & 'DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !'/) write(unit,107) do iph=1, noph() call list_phase_data2(iph,2,CHTD,unit) enddo write(unit,107) write(unit,140) 140 format(/' LIST_OF_REFERENCES'/ ' NUMBER SOURCE') call list_bibliography(' ',unit) write(unit,141) 141 format('!') close(unit) write(*,*)'Output saved on ',trim(filename) goto 1000 ! error openingfile 900 continue write(*,*)'Error opening or writing on the TDB file: ',trim(filename) 1000 continue return end subroutine list_TDB_format !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_phase_model !\begin{verbatim} subroutine list_phase_model(iph,ics,lut,CHTD,ceq) ! list model (no parameters) for a phase on lut implicit none integer iph,ics,lut TYPE(gtp_equilibrium_data), pointer :: ceq character CHTD*1 !\end{verbatim} character phname*24,l78*78 ! integer, dimension(maxsubl) :: endm,ilist integer lokcs,knr,kmr,ll,ip,lokph,ftyp TYPE(gtp_fraction_set) :: disfra type(gtp_phase_add), pointer :: addrec double precision rl ! screen ftyp=1 ! if ics=0 list fractions for all composition sets lokph=phases(iph) ! name, model name ! sublattices, status, ! additions ! sites, constituents and fractions in each disordered constituents ! number of disordered sublattices ! sites, constituents and fractions in each disordered constituents if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then ! write(*,*)'No subch composition set' gx%bmperr=4072; goto 1000 elseif(ics.eq.0) then ics=1 endif lokcs=phlista(lokph)%linktocs(ics) call get_phase_name(iph,ics,phname)! if(btest(phlista(lokph)%status1,PHQCE) .or. & btest(phlista(lokph)%status1,PHCVMCE) .or. & ! btest(phlista(lokph)%status1,PHFACTCE) .or. & btest(phlista(lokph)%status1,PHMQMQA) .or. & btest(phlista(lokph)%status1,PHSROT) .or. & btest(phlista(lokph)%status1,PHTISR)) then ! this is for the quasichemical models, qce, cvmqe, mqmqa, tisr, srot write(lut,111)phname,phlista(lokph)%models(1:40),& ceq%phase_varres(lokcs)%qcbonds,phlista(lokph)%status1,& ceq%phase_varres(lokcs)%status2 111 format(a,' model: ',a/' Number of bonds: ',F8.2,& ', status: ',z8,1x,z8,5x) else write(lut,110)phname,phlista(lokph)%models(1:40),& phlista(lokph)%noofsubl,phlista(lokph)%status1,& ceq%phase_varres(lokcs)%status2 110 format(a,' model: ',a/' Number of sublattices: ',i2,& ', status: ',z8,1x,z8,2x,a) L78=' ' knr=0 if(btest(phlista(lokph)%status1,PHFORD)) then ! Phases as FCC or BCC permutations L78=' FCC permutations.' knr=20 elseif(btest(phlista(lokph)%status1,PHBORD)) then L78=' BCC permutations' knr=20 endif if(btest(phlista(lokph)%status1,PHMFS)) then ! This phase has a disordered fraction set if(btest(phlista(lokph)%status1,PHSORD)) then L78(knr:)=' Ordered part not subtrated.' else L78(knr:)=' Ordered part subracted.' endif knr=len_trim(L78) endif if(knr.gt.0) write(lut,'(a)')trim(L78) endif addrec=>phlista(lokph)%additions lastadd: do while(associated(addrec)) call list_addition(lut,CHTD,phname,ftyp,addrec) addrec=>addrec%nextadd enddo lastadd ! return here if more composition sets 200 continue rl=zero knr=0 kmr=0 ! return here for each sublattice do ll=1,phlista(lokph)%noofsubl rl=rl+one kmr=kmr+phlista(lokph)%nooffr(ll) l78='Subl. '; ip=7 call wrinum(l78,ip,2,0,rl) ! if(btest(phlista(lokph)%status1,PHFACTCE)) then if(btest(phlista(lokph)%status1,PHMQMQA)) then l78(ip:)=', bonds: '; ip=ip+9 else l78(ip:)=', sites: '; ip=ip+9 endif ! call wrinum(l78,ip,6,0,phlista(lokph)%sites(ll)) call wrinum(l78,ip,6,0,ceq%phase_varres(lokcs)%sites(ll)) l78(ip:)=', const.: '; ip=ip+10 ! return here for each new constituent in this sublattice 320 continue knr=knr+1 if(phlista(lokph)%constitlist(knr).gt.0) then l78(ip:)=splista(phlista(lokph)%constitlist(knr))%symbol else l78(ip:)='*' endif ip=len_trim(l78)+2 l78(ip-1:ip-1)='=' ! The fractions for normal sublattice done by list result or list phase-const call wrinum(l78,ip,6,0,ceq%phase_varres(lokcs)%yfr(knr)) l78(ip:ip+1)=', ' ip=ip+2 if(ip.gt.60) then write(lut,330)l78(1:ip-3) 330 format(2x,a) l78=' ' ip=4 endif if(knr.lt.kmr) goto 320 if(ip.gt.4) write(lut,330)l78(1:ip-3) enddo if(btest(phlista(lokph)%status1,PHMFS)) then ! the phase has disordered fractions ! ?? does the = here make a copy? I just want a pointer ... disfra=ceq%phase_varres(lokcs)%disfra lokcs=disfra%varreslink if(disfra%ndd.eq.1) then write(lut,410)disfra%latd 410 format(4x,'Disordred fractions adding all fractions from all ',& i2,' sublattices together') else write(lut,420)disfra%latd 420 format(4x,'Disordred fractions adding fractions from first ',i2,& ' sublattices together in'/& 4x,'the first disordered sublattice',& ' and the remaining fractions in the second.') endif ! write the disordered constituents and fractions ll=0 rl=zero knr=0 kmr=0 ! return here for second sublattice (if any) 430 continue ll=ll+1 rl=rl+one kmr=kmr+disfra%nooffr(ll) l78='Subl. '; ip=7 call wrinum(l78,ip,2,0,rl) l78(ip:)=', sites: '; ip=ip+9 call wrinum(l78,ip,6,0,disfra%dsites(ll)) l78(ip:)=', const.: '; ip=ip+10 ! return here for each new constituent in this sublattice 440 continue knr=knr+1 l78(ip:)=splista(disfra%splink(knr))%symbol ! list fractions in disordered sublattice as this is the only place for that ip=len_trim(l78)+2 l78(ip-1:ip-1)='=' call wrinum(l78,ip,6,0,ceq%phase_varres(lokcs)%yfr(knr)) l78(ip:)=',' ip=ip+2 if(ip.gt.60) then write(lut,450)l78(1:ip-3) 450 format(4x,a) l78=' ' ip=4 endif if(knr.lt.kmr) goto 440 if(ip.gt.4) write(lut,330)l78(1:ip-3) if(ll.lt.disfra%ndd) goto 430 endif 1000 continue return end subroutine list_phase_model !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_phase_data !\begin{verbatim} subroutine list_phase_data(iph,CHTD,lut) ! list parameter data for a phase on unit lut implicit none integer iph,lut character CHTD*1 !\end{verbatim} %+ integer typty,parlist,typspec,lokph,nsl,nk,ip,ll,jnr,ics,lokcs integer nint,ideg,ij,kk,iel,ncsum,kkx,kkk,jdeg,iqnext,iqhigh,lqq,nz,ik integer intpq,linkcon,ftyp,prplink,topline,warning_endmzero ! integer con1,con2,con3 character text*3000,phname*24,prop*32,funexpr*1024,ternex(3)*24,ch1*1 character special*4,modelid*24,typedefchar*1 ! integer, dimension(2,3) :: lint ! ?? increased dimension of lint ?? integer, dimension(2,5) :: lint integer, dimension(maxsubl) :: endm,ilist logical subref,noelin1 type(gtp_fraction_set), pointer :: disfrap ! possible different gadditions for each composition sets ! double precision gadd(9) !-------------- ! special reference state for MQMQA liquids logical mqmqa !-------------- ! used to list Toop/Kohler extrapolations type(gtp_tooprec), pointer :: tooprec !--------------- ! a smart way to have an array of pointers TYPE intrecarray type(gtp_interaction), pointer :: p1 end TYPE intrecarray integer, parameter :: maxstack=20 type(intrecarray), dimension(maxstack) :: intrecstack type(gtp_property), pointer :: proprec type(gtp_interaction), pointer :: intrec type(gtp_endmember), pointer :: endmemrec TYPE(gtp_fraction_set) :: disfra TYPE(gtp_phase_add), pointer :: addrec integer powpqr(3),iiz character mqmqxchar*2 logical mqmqxess ! ! write(*,*)'3C in list_phase_data',iph ! modelid should be used to identify the model modelid=' ' mqmqa=.FALSE. mqmqxess=.false. ! this specifies the top line topline=1 ! modelid='123456789.123456789.1234' ! output on screen ftyp=1 if(iph.lt.0 .or. iph.gt.noofph) then gx%bmperr=4050; goto 1000 elseif(noofel.eq.0) then ! this needed as there is a reference phase with iph=0 when there are elements goto 1000 endif ! write(*,*)'lpd 1:',iph,phases(iph) if(iph.gt.0) then lokph=phases(iph) else lokph=0 endif ics=1 phname=phlista(lokph)%name nsl=phlista(lokph)%noofsubl special=' ' ! indicate some status bit specially ! these bits are mutually exclusive if(btest(phlista(lokph)%status1,PHFORD)) then special(1:1)='F'; modelid='FCC permutation ordering' ! 123456789.123456789.1234 elseif(btest(phlista(lokph)%status1,PHBORD)) then special(1:1)='B'; modelid='BCC permutation ordering' ! elseif(btest(phlista(lokph)%status1,PHSORD)) then ! special(1:1)='S'; modelid='Intermetallic ordering' elseif(btest(phlista(lokph)%status1,PHIONLIQ)) then special(1:1)='I'; modelid='Ionic 2-sblattice liquid' ! 123456789.123456789.1234 ! added 20201128/BoS, FACTCE, QCE and UNIQUAC ! added 20201128/BoS, MQMQA, QCE and UNIQUAC elseif(btest(phlista(lokph)%status1,PHMQMQX)) then ! modelid is just locally. this is with new excess sooftware 20251119/BoS special(1:1)='Q'; modelid='MQMQX' if(.not.btest(phlista(lokph)%status1,PHMQMQX)) then write(*,*)'3C Error, missing bit PHMQMQA' endif mqmqa=btest(phlista(lokph)%status1,PHMQMQA) ! 123456789.123456789.1234 elseif(btest(phlista(lokph)%status1,PHMQMQA)) then special(1:1)='Q'; modelid='MQMQA' mqmqa=btest(phlista(lokph)%status1,PHMQMQA) ! 123456789.123456789.1234 ! Topline 2 means bonds rather than sites ... topline=2 elseif(btest(phlista(lokph)%status1,PHQCE)) then special(1:1)='C'; modelid='QCE' topline=2 elseif(btest(phlista(lokph)%status1,PHCVMCE)) then special(1:1)='K'; modelid='CVMCE' topline=2 ! elseif(btest(phlista(lokph)%status1,PHTISR)) then ! special(1:1)='E'; modelid='TISR' elseif(btest(phlista(lokph)%status1,PHSROT)) then special(1:1)='E'; modelid='SROT' topline=2 elseif(btest(phlista(lokph)%status1,PHUNIQUAC)) then special(1:1)='U'; modelid='UNIQAC polymer model' ! 123456789.123456789.1234 endif ! end of exclusive bits kkk=2 ! if(btest(phlista(lokph)%status1,PHMFS)) then ! this indicates if there is a disordered fraction set ! write(*,*)'3C skipping suffix D, first time' ! special(kkk:kkk)='D'; kkk=kkk+1 ! endif lokcs=phlista(lokph)%linktocs(ics) ! wrong use of CSORDER, it is set if the ordered part already disordered ! no need to calculate it again ! if(btest(firsteq%phase_varres(lokcs)%status2,CSORDER)) then ! PHSORD is the correct bit to test if the ordered part should not be subrracted if(.not.btest(phlista(lokph)%status1,PHSORD)) then ! this indicates if ordered part should be subtracted as ordered special(kkk:kkk)='S'; kkk=kkk+1 endif ! if(associated(phlista(lokph)%tooplast)) then ! no attemp to include TYPE:DEF here ! endif ! special is max 4 characters ! This subroutine is independent of current equilibrium, use firsteq ! write(lut,10)phname,phlista(lokph)%status1,special,& ! nsl,(phlista(lokph)%sites(ll),ll=1,nsl) ! lokcs=phlista(lokph)%linktocs(ics) !----------------------------------------------------------------- if(topline.eq.1) then write(lut,10)phname,phlista(lokph)%status1,special,modelid,& nsl,(firsteq%phase_varres(lokcs)%sites(ll),ll=1,nsl) 10 format(/'Phase: ',A,', Status: ',Z8,1x,a,1x,a/' Subl:',I3,10(1x,F7.3)) elseif(topline.eq.2) then ! for the quasichemical models write(lut,11)phname,phlista(lokph)%status1,special,trim(modelid),& firsteq%phase_varres(lokcs)%sites(1) ! firsteq%phase_varres(lokcs)%qcbonds ! firsteq%phase_varres(lokcs)%sites(1) !11 format(/'Phase: ',A,', Status: ',Z8,1x,a,1x,a,', Bonds/at:',F7.3) ! qcbonds not used for MQMQA 11 format(/'Phase: ',A,', Status: ',Z8,1x,a,1x,a,', sites:',F7.3) endif warning_endmzero=0 nk=0 text='Constituents: ' ip=15 sublatloop: do ll=1,nsl constloop: do ik=1,phlista(lokph)%nooffr(ll) nk=nk+1 jnr=phlista(lokph)%constitlist(nk) if(jnr.gt.0) then text(ip:)=splista(jnr)%symbol else text(ip:)='*' endif ip=len_trim(text)+1 if(len(text)-ip.lt.30) then ! text is 3000 characters .... write(kou,'(a,i6)')'Warning: very long onstituent list truncated',ip exit sublatloop endif ! text(ip:ip)=',' text(ip:ip)=' ' ip=ip+1 enddo constloop text(ip-1:ip)=': ' ip=ip+1 enddo sublatloop call wrice2(lut,2,4,78,-1,text) ! write(lut,17)text(1:ip) !17 format(A) ! additions addrec=>phlista(lokph)%additions lastadd: do while(associated(addrec)) call list_addition(lut,CHTD,phname,ftyp,addrec) addrec=>addrec%nextadd enddo lastadd 60 continue ! A fixed addition? gadd Can be different for each composition set !!! do ll=1,phlista(lokph)%noofcs lokcs=phlista(lokph)%linktocs(ll) if(btest(firsteq%phase_varres(lokcs)%status2,CSADDG)) then ! if no addition then addg is not allocated! ! if(allocated(firsteq%phase_varres(lokcs)%addg)) then write(lut,33)ll,firsteq%phase_varres(lokcs)%addg(1) 33 format(' + Addition to G in composition set ',i2,': ',1pe14.6,' J/FU') endif enddo ! parameters for end members using site fractions if(btest(phlista(lokph)%status1,PHMFS)) then subref=.FALSE. else subref=.TRUE. endif parlist=1 ! write(*,*)'3C check if listing allowed',privilege,notallowlisting(privilege) if(notallowlisting(privilege)) then write(*,*)'3C You are not allowed to list data' goto 1000 endif ! warning for reference state of the MQMQA phase if(btest(phlista(lokph)%status1,PHMQMQA)) then write(lut,90) 90 format(' ** MQMQA endmembers such as AB/X-Q etc have',& ' contributions from the endmembers'/& ' ** A/X, B/X for their reference state even if AB/X-Q',& ' has no parameter!') endif !-------------------------------------------------- ! return here to list disordered parameters 100 continue ! parlist changed below for disordered fraction set if(parlist.eq.1) then endmemrec=>phlista(lokph)%ordered else if(ocv()) write(*,*)'Listing disordred parameters ',nsl endmemrec=>phlista(lokph)%disordered disfrap=>firsteq%phase_varres(lokcs)%disfra endif endmemberlist: do while(associated(endmemrec)) do ll=1,nsl ! ilist(ll)=emlista(lokem)%fraclinks(ll,1) ilist(ll)=endmemrec%fraclinks(ll,1) if(ilist(ll).gt.0) then if(parlist.eq.2) then ! what is disfra here??!! ! write(*,*)'3C disfra?: ',disfra%splink(ilist(ll)),& ! disfrap%splink(ilist(ll)) ! endm(ll)=disfra%splink(ilist(ll)) endm(ll)=disfrap%splink(ilist(ll)) else endm(ll)=phlista(lokph)%constitlist(ilist(ll)) endif else ! wildcard, write '*' endm(ll)=-99 endif enddo nint=0 ideg=0 call encode_constarr(text,nsl,endm,nint,lint,ideg) if(gx%bmperr.ne.0) goto 1000 proprec=>endmemrec%propointer ptyloop: do while(associated(proprec)) ij=proprec%proptype if(ij.ge.100) then typty=ij/100 typspec=mod(ij,100) else typty=ij endif if(typty.gt.0 .and. typty.le.ndefprop) then prop=propid(typty)%symbol ! if(parlist.eq.2) then ! disordered endmember parameter ! write(*,*)'3C skipping suffix D 2nd case' ! kk=len_trim(prop)+1 ! prop(kk:kk)='D' ! endif if(btest(propid(typty)%status,IDELSUFFIX)) then ! property like ZZ&(phase,constituent array) ! the element index should be in typsepc iel=typspec if(iel.ge.0 .and. iel.le.noofel) then ! prop=propid(typty)%symbol prop=prop(1:len_trim(prop))//'&'& //ellista(elements(iel))%symbol else gx%bmperr=4082; goto 1000 endif elseif(btest(propid(typty)%status,IDCONSUFFIX)) then ! property like mobility, MQ&(phase,constituent array) ! the suffix is a constituent iel=typspec if(iel.gt.0 .and. iel.le.phlista(lokph)%tnooffr) then if(parlist.eq.2) then ! we must consider parlist, take disordered constituent list ! we have no current equilibrium record but can use firsteq!! ! lokcs=phlista(lokph)%linktocs(1) ! write(*,*)'3C: endmember typspec 1: ',iel ! write(*,*)'3C splink: ',disfrap%splink linkcon=disfrap%splink(iel) ! write(*,*)'3C: endmember typspec 2: ',linkcon ll=0 ! ll=1 ! linkcon has nothing to do with which sublattice, ignore ll ! if(linkcon.gt.disfrap%nooffr(1)) ll=2 prop=prop(1:len_trim(prop))//'&'& //splista(linkcon)%symbol write(*,*)'3C We are here',linkcon,disfrap%nooffr(1),ll prop=prop(1:len_trim(prop)) ! goto 120 goto 121 else linkcon=phlista(lokph)%constitlist(iel) if(linkcon.le.0) then write(*,*)'Illegal use of wildcard 1' gx%bmperr=4286; goto 1000 endif prop=prop(1:len_trim(prop))//'&'& //splista(linkcon)%symbol ! also add the sublattice number ... ncsum=0 do ll=1,phlista(lokph)%noofsubl ncsum=ncsum+phlista(lokph)%nooffr(ll) if(iel.le.ncsum) goto 120 enddo endif ! error if sublattice not found write(kou,*)'Error in constituent depended parameter id' gx%bmperr=4287; goto 1000 ! jump here to append sublattice 120 continue ! write(*,*)'property 1: ',prop(1:10),ll if(ll.gt.1) then prop=prop(1:len_trim(prop))//'#'//char(ll+ichar('0')) ! else ! prop=prop(1:len_trim(prop))//'#'//char(ll+ichar('0')) endif 121 continue else write(kou,*)'lpd 7B: ',iel,typty gx%bmperr=4082; goto 1000 endif endif else ! unknown property ... write(*,*)'unknown property type xx: ',ij,typty,typspec prop='ZZ' endif ! note changes here must be repeated for interaction parameters below write(funexpr,200)prop(1:len_trim(prop)),& phname(1:len_trim(phname)),text(1:len_trim(text)) 200 format(A,'(',A,',',A,') ') ip=len_trim(funexpr)+1 ! check if FNN MQMQA parameter ... if(mqmqa) then ! ilist is index in fraction list, same as index in mqmqa_data%contyp ! intpq=ilist(1) ! write(*,*)'3C check if SNN parameter',intpq,& ! mqmqa_data%contyp(5,intpq) if(mqmqa_data%contyp(5,ilist(1)).le.0) goto 203 endif ! subtract reference states if(subref .and. typty.eq.1) then call subrefstates(funexpr,ip,lokph,parlist,endm,noelin1) if(noelin1) then ! this can happen for ionic liquids with just neutrals in sublattice 2 ! replace the constituent in sublattice 1 with "*" !!! ! write(*,*)'before: ',funexpr(1:ip) kk=index(funexpr,',') ik=index(funexpr,':') funexpr(kk+1:)='*'//funexpr(ik:) ip=len_trim(funexpr)+2 ! write(*,*)'after: ',funexpr(1:ip) endif endif 203 continue ! this writes the expression call list_tpfun(proprec%degreelink(0),1,funexpr(ip:)) ip=len_trim(funexpr) funexpr(ip+1:)=' '//proprec%reference ip=len_trim(funexpr) ! nice output over several lines if needed with indentation 12 spaces call wrice2(lut,2,12,78,1,funexpr(1:ip)) proprec=>proprec%nextpr enddo ptyloop if(btest(phlista(lokph)%status1,PHFORD).or. & btest(phlista(lokph)%status1,PHBORD)) then ! if(endmemrec%noofpermut.gt.1) then intpq=0 if(associated(endmemrec%intpointer)) then intpq=endmemrec%intpointer%antalint endif prplink=0 if(associated(endmemrec%propointer)) prplink=1 ! keep this output for the moment ! if(parlist.eq.1) write(kou,207)endmemrec%antalem,& if(parlist.eq.1) then if(prplink.eq.1) then write(kou,207)endmemrec%antalem,& endmemrec%noofpermut,intpq,prplink elseif(intpq.gt.0) then write(kou,208)endmemrec%antalem,& endmemrec%noofpermut,intpq,prplink 207 format('3C Endmember check: id, permut, inter, pty: ',4i5) 208 format('3C Link to excesss: id, permut, inter, pty: ',4i5) endif endif endif endmemrec=>endmemrec%nextem enddo endmemberlist !----------------------------------------------------------------------- ! parameters for interactions using site fractions ! write(*,*)'3C list excess model parameters' if(parlist.eq.1) then endmemrec=>phlista(lokph)%ordered else endmemrec=>phlista(lokph)%disordered endif intlist1: do while(associated(endmemrec)) intrec=>endmemrec%intpointer if(associated(intrec)) then ! write(*,*)'intlist 1B: ',intrec%status do ll=1,nsl kkx=endmemrec%fraclinks(ll,1) if(kkx.eq.-99) then ! wildcard endm(ll)=-99 elseif(parlist.eq.2) then endm(ll)=disfra%splink(kkx) else endm(ll)=phlista(lokph)%constitlist(kkx) endif enddo endif nint=0 intlist2: do while(associated(intrec)) nint=nint+1 if(nint.gt.maxstack) then write(*,*)'3C overflow in intrecstack 1' gx%bmperr=4399; goto 1000 endif intrecstack(nint)%p1=>intrec lint(1,nint)=intrec%sublattice(1) kkk=intrec%fraclink(1) if(parlist.eq.2) then lint(2,nint)=disfra%splink(kkk) else lint(2,nint)=phlista(lokph)%constitlist(kkk) endif proprec=>intrec%propointer ! loop for all properties with this composition dependence ptyloop2: do while(associated(proprec)) ! typty=proprec%proptype ij=proprec%proptype if(ij.ge.100) then typty=ij/100 typspec=mod(ij,100) else typty=ij endif ! typspec=proprec%proptype ! if(typspec.gt.100) then ! typty=typspec/100 ! typspec=mod(typty,100) ! else ! typty=typspec ! endif ! one should fix ndefprop to 33 but as typty is 34-36 for MQMQA excess SUCK ! write(*,*)'value of ndefprop',ndefprop if(typty.gt.0 .and. typty.le.ndefprop) then if(typty.ge.34 .and. typty.le.36) then ! extracting MQMQA, MQMQX powers ! write(*,*)'3C listing parameters',typty,proprec%extra ! extra=230 if(typty.eq.34) mqmqxchar='G,' if(typty.eq.35) mqmqxchar='Q,' if(typty.eq.36) mqmqxchar='B,' ! if(typty.eq.34) prop='G' ! if(typty.eq.35) prop='Q' ! if(typty.eq.36) prop='B' prop='G' mqmqxess=.true. powpqr(1)=proprec%extra/100 ! 2; 30 powpqr(2)=(proprec%extra-100*powpqr(1))/10 ! 2; 3 powpqr(3)=proprec%extra-100*powpqr(1)-10*powpqr(2) ! write(*,55)typty,proprec%extra,powpqr 55 format('3C listing 2370 MQMQA/MQMQX parameters ',i2,i5,3i4) ! the powpqr is used when listing degree below do iiz=1,3 powpqr(iiz)=powpqr(iiz)+ichar('0') enddo else prop=propid(typty)%symbol endif ! if(parlist.eq.2) then ! disordered interaction parameter ! write(*,*)'3C skipping suffix D 3rd time' ! kk=len_trim(prop)+1 ! prop(kk:kk)='D' ! endif if(btest(propid(typty)%status,IDELSUFFIX)) then ! property like ZZ&(phase,constituent array) ! the element index should be in typsepc iel=typspec if(iel.ge.0 .and. iel.le.noofel) then prop=prop(1:len_trim(prop))//'&'& //ellista(elements(iel))%symbol else ! write(*,*)'lpd 7: ',iel,typty gx%bmperr=4082; goto 1000 endif elseif(btest(propid(typty)%status,IDCONSUFFIX)) then ! property like mobility MQ&(phase,constituent array) ! the suffix is a constituent iel=typspec if(iel.gt.0 .and. iel.le.phlista(lokph)%tnooffr) then if(parlist.eq.2) then ! we must consider parlist, take disordered constituent list ! we have no current equilibrium record but can use firsteq!! ! write(*,*)'3C: typspec: 3 ',typty,iel,prop(1:10) linkcon=disfrap%splink(iel) ! write(*,*)'3C: typspec: 4 ',typty,linkcon,prop(1:10) ll=1 if(iel.gt.disfrap%nooffr(1)) ll=2 prop=prop(1:len_trim(prop))//'&'& //splista(linkcon)%symbol goto 220 else linkcon=phlista(lokph)%constitlist(iel) if(linkcon.le.0) then ! write(*,*)'Illegal use of wildcard 2' gx%bmperr=4286; goto 1000 endif prop=prop(1:len_trim(prop))//'&'& //splista(linkcon)%symbol ! also add the sublattice number ... ncsum=0 do ll=1,phlista(lokph)%noofsubl ncsum=ncsum+phlista(lokph)%nooffr(ll) if(iel.le.ncsum) goto 220 enddo endif ! there cannot be any errors here .... ! write(*,*)'Never never error 2' gx%bmperr=4288; goto 1000 220 continue ! write(*,*)'property 2: ',prop(1:10),ll ! add sublattice index only if not unity if(ll.gt.1) then prop=prop(1:len_trim(prop))//'#'//char(ll+ichar('0')) endif else ! write(*,*)'lpd 7: ',iel,typty gx%bmperr=4082; goto 1000 endif endif else ! unknown property ... write(*,*)'unknown property type yy: ',typty prop='ZZ' endif ! if disordered fraction set add D, already set above ??!! ! if(parlist.eq.2) then ! prop=prop(1:len_trim(prop))//'D' ! endif ! note changes here must be repeated for endmember parameters above degree: do jdeg=0,proprec%degree if(proprec%degreelink(jdeg).eq.0) then ! write(*,*)'Ignoring function link' cycle degree endif call encode_constarr(text,nsl,endm,nint,lint,jdeg) if(mqmqxess) then ! MQMQA excess replace degree after ; in text by G,p,q,0 for binary ! G,p,q,r for ternary ! write(*,*)'3C parameter 1: ',nint,trim(text) iiz=index(text,';') text(iiz+1:)=mqmqxchar//char(powpqr(1))//','//char(powpqr(2)) iiz=iiz+5 if(nint.eq.3) then text(iiz+1:)=','//char(powpqr(3)) endif ! write(*,*)'3C parameter 2: ',iiz,trim(text) endif write(funexpr,300)trim(prop),trim(phname),trim(text) 300 format(A,'(',A,',',A,') ') ip=len_trim(funexpr)+1 call list_tpfun(proprec%degreelink(jdeg),1,funexpr(ip:)) ip=len_trim(funexpr) funexpr(ip+1:)=' '//proprec%reference ip=len_trim(funexpr) call wrice2(lut,4,12,78,1,funexpr(1:ip)) enddo degree proprec=>proprec%nextpr enddo ptyloop2 ! list temporarily the number of permutations for FCC and BCC ordering if(btest(phlista(lokph)%status1,PHFORD).or. & btest(phlista(lokph)%status1,PHBORD)) then ! if(intrec%noofip(1).gt.1 .or. intrec%noofip(2).gt.1) then if(nint.eq.1) then nz=intrec%noofip(2) else nz=size(intrec%sublattice) lqq=intrec%noofip(size(intrec%noofip)) if(lqq.ne.nz) then write(*,*)'3C Not same 1: ',intrec%antalint,nz,lqq endif ! write(*,301)nz,intrec%noofip 301 format('noofip: ',10i3) ! nz=intrec%noofip(intrec%noofip(1)+2) endif iqnext=0 iqhigh=0 if(associated(intrec%highlink)) then iqhigh=intrec%highlink%antalint endif if(associated(intrec%nextlink)) then iqnext=intrec%nextlink%antalint endif prplink=0 if(associated(intrec%propointer)) prplink=1 ! keep this output for the moment if(parlist.eq.1) write(*,302)intrec%antalint,& nz,nint,iqhigh,iqnext,prplink 302 format('3C Inter check 1: id, permut, level, high, next, pty: ',& i5,i3,i3,i4,i4,i2) endif intrec=>intrec%highlink empty: do while(.not.associated(intrec)) if(nint.gt.0) then ! restore pointers in same clumsy way intrec=>intrecstack(nint)%p1 intrec=>intrec%nextlink ! write(*,*)'poping a pointer from intrecstack',ninit nint=nint-1 else exit intlist2 endif enddo empty enddo intlist2 endmemrec=>endmemrec%nextem enddo intlist1 ! check if there are other fraction lists ! parlist=parlist+1, hm parlist can only be 1 or 2 ! write(*,*)'checking for disordered parameters' if(parlist.eq.1 .and. associated(phlista(lokph)%disordered)) then subref=.TRUE. ! lokcs=phlista(lokph)%cslink lokcs=phlista(lokph)%linktocs(ics) ! does this make a copy? Maybe it should be a pointer disfra=firsteq%phase_varres(lokcs)%disfra write(lut,810)disfra%fsites 810 format('Disordered fraction set parameters, factor: ',F10.4,2x,10('-')) nsl=disfra%ndd parlist=2 if(ocv()) write(*,*)'Jump back to list disordered',nsl,parlist goto 100 endif ! Check if there are toop/kohler ternaries tooprec=>phlista(lokph)%tooplast if(associated(tooprec)) then write(*,'(a)')'3C Some ternaries have Toop/Kohler extrapolations methods' text=' ' kk=1 nsl=0 tkloop: do while(associated(tooprec)) ! interacive ? listing of Toop/Kohler extrapolations taken from tooprec%amend ! loop through all records, the extrapolations are some of the reconds. ! on TDB files the subrouine list_tdb_formats is used if(len(tooprec%amend1).gt.1) then if(nsl.eq.0) then text(kk:)=' AMEND '//tooprec%amend1 nsl=1 else ! remove phase name and TERNARY_EXTRA ij=index(tooprec%amend1,'_EXTRA') text(kk:)=tooprec%amend1(ij+7:) endif kk=len_trim(text)+2 ! write(*,997)1,text(1:kk),kk 997 format('3C ternary: ',i1,' "',a,'"',i4) ! This text is written by the commands list data and list phase xxx data ! Output from "save tdb" is written by list_phase_data2 endif ! there can be several AMEND !!! if(len(tooprec%amend2).gt.1) then ij=index(tooprec%amend2,'_EXTRA') text(kk:)=tooprec%amend2(ij+7:) kk=len_trim(text)+2 ! write(*,997)2,text(1:kk),kk endif if(len(tooprec%amend3).gt.1) then ij=index(tooprec%amend3,'_EXTRA') text(kk:)=tooprec%amend3(ij+7:) kk=len_trim(text)+2 ! write(*,997)3,text(1:kk),kk endif if(kk.gt.5) then ! This text is written by the commands list data and list phase xxx data ! Output from "save tdb" is written by list_phase_data2 write(*,*)'3C ',text(1:kk) text=' Y' kk=5 endif tooprec=>tooprec%nexttoop enddo tkloop if(kk.gt.6) write(*,*)'3C ',text(1:kk) endif ! write(*,*)'3C listing by list_phase_data' 1000 continue return END subroutine list_phase_data !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_phase_data2 !\begin{verbatim} %- subroutine list_phase_data2(iph,ftyp,CHTD,lut) ! ! this subroutine is USED by the command SAVE TDB ! ! list parameter data for a phase on unit lut in ftyp format, ftyp=2 is TDB implicit none integer iph,lut,ftyp character CHTD*1 !\end{verbatim} integer typty,parlist,typspec,lokph,nsl,nk,ip,ll,jnr,ics,lokcs,isp integer nint,ideg,ij,kk,iel,ncsum,kkx,kkk,jdeg,iqnext,iqhigh,lqq,nz,ik integer intpq,linkcon character text*1024,phname*24,prop*32,funexpr*1024 character special*8 character,save :: ctop*1='K' ! integer, dimension(2,3) :: lint insufficient for MQMQX integer, dimension(2,4) :: lint integer, dimension(maxsubl) :: endm,ilist logical subref,noelin1 type(gtp_fraction_set), pointer :: disfrap ! a smart way to have an array of pointers TYPE intrecarray type(gtp_interaction), pointer :: p1 end TYPE intrecarray integer, parameter :: maxstack=20 type(intrecarray), dimension(maxstack) :: intrecstack type(gtp_property), pointer :: proprec type(gtp_interaction), pointer :: intrec type(gtp_endmember), pointer :: endmemrec TYPE(gtp_fraction_set) :: disfra TYPE(gtp_phase_add), pointer :: addrec TYPE(gtp_tooprec), pointer :: tooprec ! MQMQAX logical :: mqmqax=.false. character*1 mqmqxchar*7 integer ppow,temp,rpow ! G,1,1,1 ! an empty line first write(lut,*) ! for type definitions if(iph.lt.0 .or. iph.gt.noofph) then gx%bmperr=4050; goto 1000 elseif(noofel.eq.0) then ! this needed as there is a reference phase with iph=0 when there are elements goto 1000 endif ! write(*,*)'lpd 1:',iph,phases(iph) if(iph.gt.0) then lokph=phases(iph) else lokph=0 endif ics=1 phname=phlista(lokph)%name nsl=phlista(lokph)%noofsubl special=' ' special(1:1)='%' isp=1 ! indicate some status bit specially, not useful for TDB files ... ! if(btest(phlista(lokph)%status1,PHFORD)) then ! special(2:2)='F' ! isp=2 ! elseif(btest(phlista(lokph)%status1,PHBORD)) then ! special(2:2)='B' ! isp=2 ! elseif(btest(phlista(lokph)%status1,PHSORD)) then ! special(2:2)='S' ! isp=2 ! elseif(btest(phlista(lokph)%status1,PHIONLIQ)) then ! special(2:2)='I' ! isp=2 ! endif ! here isp can be 1 or 2 ! if(btest(phlista(lokph)%status1,PHMFS)) then ! isp=isp+1 ! special(isp:isp)='D' ! endif if(btest(phlista(lokph)%status1,PHIONLIQ)) then lokcs=len_trim(phname)+1 phname(lokcs:)=':Y' elseif(btest(phlista(lokph)%status1,PHGAS)) then phname='GAS:G' elseif(btest(phlista(lokph)%status1,PHMQMQX)) then lokcs=len_trim(phname)+1 phname(lokcs:)=':X' elseif(btest(phlista(lokph)%status1,PHLIQ)) then phname='LIQUID:L' endif if(btest(phlista(lokph)%status1,PHMFS)) then ! write(*,*)'3C typedef character 1 ',ichar(CHTD),' "',chtd,'"' CHTD=char(ichar(CHTD)+1) isp=isp+1 special(isp:isp)=CHTD if(.not.btest(globaldata%status,GSSILENT)) then write(kou,53) 53 format('Disordered fraction sets need manual editing',& ' to be used by Thermo-Calc') endif ! wow, written before I learned to use trim(character) ... ! write(lut,55)CHTD,phname(1:len_trim(phname)),phname(1:len_trim(phname)) write(lut,55)CHTD,trim(phname),trim(phname) 55 format('$ *** Warning: disordered fraction sets need manual editing!'/& ' TYPE_DEFINITION ',a,' GES A_P_D ',a,' DIS_PART DIS_',a,' !') endif ! additions addrec=>phlista(lokph)%additions lastadd: do while(associated(addrec)) ! no need to increment CHTD except for magnetism if(addrec%type.eq.1) then ! write(*,*)'3C typedef character 2 ',ichar(CHTD),' "',chtd,'"' CHTD=char(ichar(CHTD)+1) isp=isp+1 special(isp:isp)=CHTD endif call list_addition(lut,CHTD,phname,ftyp,addrec) addrec=>addrec%nextadd enddo lastadd 60 continue write(*,*)'3C Not saving any asymmetric data for ',trim(phname) ! This subroutine is independent of current equilibrium, use firsteq ! write(lut,10)phname,phlista(lokph)%status1,special,& ! nsl,(phlista(lokph)%sites(ll),ll=1,nsl) ! write(*,*)'3C phase: ',phname,special lokcs=phlista(lokph)%linktocs(ics) if(associated(phlista(lokph)%tooplast)) then isp=isp+1 ! this is to refer to the ternary_extrapolations later special(isp:isp)=ctop ! write(lut,10,advance='no')phname(1:len_trim(phname)),special(1:isp),& nsl,(firsteq%phase_varres(lokcs)%sites(ll),ll=1,nsl) else write(lut,10,advance='no')phname(1:len_trim(phname)),special(1:isp),& nsl,(firsteq%phase_varres(lokcs)%sites(ll),ll=1,nsl) endif 10 format(' PHASE ',A,1x,a,1x,I2,10(1x,F7.3)) mqmqax=.false. if(btest(phlista(lokph)%status1,PHMQMQX)) then write(*,*)'3C Listing MQMQA phase' mqmqax=.true. endif write(lut,11) 11 format('!') nk=0 ! lqq=0 ! if(btest(phlista(lokph)%status1,PHMQMQX)) lqq=-1 text='CONSTITUENT '//phname(1:len_trim(phname))//' :' ip=len_trim(text)+1 sublatloop: do ll=1,nsl constloop: do ik=1,phlista(lokph)%nooffr(ll) nk=nk+1 jnr=phlista(lokph)%constitlist(nk) if(jnr.gt.0) then if(mqmqax) then kkk=index(splista(jnr)%symbol,'-Q') text(ip:)=splista(jnr)%symbol(1:kkk+1) else text(ip:)=splista(jnr)%symbol endif else text(ip:)='*' endif ip=len_trim(text)+1 ! text(ip:ip)=',' text(ip:ip)=' ' ip=ip+1 enddo constloop text(ip-1:ip)=': ' ip=ip+1 enddo sublatloop text(ip-2:)=':!' call wrice2(lut,2,4,78,-1,text) ! write(lut,17)text(1:ip) !17 format(A) ! remove any :Y, :L or :G ip=index(phname,':') if(ip.gt.0) phname(ip:)=' ' ! parameters for end members using site fractions if(btest(phlista(lokph)%status1,PHMFS)) then subref=.FALSE. else subref=.TRUE. endif parlist=1 !-------------------------------------------------- ! return here to list disordered parameters 100 continue ! check if encrypted database if(notallowlisting(privilege)) then write(*,*)'3C You are not allowed to list data' goto 1000 endif ! parlist changed below for disordered fraction set if(parlist.eq.1) then endmemrec=>phlista(lokph)%ordered else if(ocv()) write(*,*)'Listing disordred parameters ',nsl endmemrec=>phlista(lokph)%disordered disfrap=>firsteq%phase_varres(lokcs)%disfra endif endmemberlist: do while(associated(endmemrec)) do ll=1,nsl ! ilist(ll)=emlista(lokem)%fraclinks(ll,1) ilist(ll)=endmemrec%fraclinks(ll,1) if(ilist(ll).gt.0) then if(parlist.eq.2) then ! what is disfra here??!! endm(ll)=disfra%splink(ilist(ll)) else endm(ll)=phlista(lokph)%constitlist(ilist(ll)) endif else ! wildcard, write '*' endm(ll)=-99 endif enddo nint=0 ideg=0 if(btest(phlista(lokph)%status1,PHMQMQX)) ideg=-1 ! supress digits after -Q for MQMQX phases, works call encode_constarr(text,nsl,endm,nint,lint,ideg) if(gx%bmperr.ne.0) goto 1000 ideg=0 proprec=>endmemrec%propointer ptyloop: do while(associated(proprec)) ij=proprec%proptype if(ij.ge.100) then typty=ij/100 typspec=mod(ij,100) else typty=ij endif if(typty.gt.0 .and. typty.le.ndefprop) then prop=propid(typty)%symbol ! if(parlist.eq.2) then ! disordered endmember parameter ! write(*,*)'3C skipping suffix D, 4:th time' ! kk=len_trim(prop)+1 ! prop(kk:kk)='D' ! endif if(btest(propid(typty)%status,IDELSUFFIX)) then ! property like ZZ&(phase,constituent array) ! the element index should be in typsepc iel=typspec if(iel.ge.0 .and. iel.le.noofel) then ! prop=propid(typty)%symbol prop=prop(1:len_trim(prop))//'&'& //ellista(elements(iel))%symbol else gx%bmperr=4082; goto 1000 endif elseif(btest(propid(typty)%status,IDCONSUFFIX)) then ! property like mobility, MQ&(phase,constituent array) ! the suffix is a constituent iel=typspec if(iel.gt.0 .and. iel.le.phlista(lokph)%tnooffr) then if(parlist.eq.2) then ! we must consider parlist, take disordered constituent list ! we have no current equilibrium record but can use firsteq!! ! lokcs=phlista(lokph)%linktocs(1) ! write(*,*)'3C: endmember typspec 1: ',iel linkcon=disfrap%splink(iel) ! write(*,*)'3C: endmember typspec 2: ',linkcon ll=1 if(linkcon.gt.disfrap%nooffr(1)) ll=2 prop=prop(1:len_trim(prop))//'&'& //splista(linkcon)%symbol goto 120 else linkcon=phlista(lokph)%constitlist(iel) if(linkcon.le.0) then ! write(*,*)'Illegal use of wildcard 1' gx%bmperr=4286; goto 1000 endif prop=prop(1:len_trim(prop))//'&'& //splista(linkcon)%symbol ! also add the sublattice number ... ncsum=0 do ll=1,phlista(lokph)%noofsubl ncsum=ncsum+phlista(lokph)%nooffr(ll) if(iel.le.ncsum) goto 120 enddo endif ! error if sublattice not found write(kou,*)'Error in constituent depended parameter id' gx%bmperr=4287; goto 1000 ! jump here to append sublattice 120 continue ! write(*,*)'property 1: ',prop(1:10),ll prop=prop(1:len_trim(prop))//'#'//char(ll+ichar('0')) else write(kou,*)'lpd 7B: ',iel,typty gx%bmperr=4082; goto 1000 endif endif else ! unknown property ... write(*,*)'unknown property type xx: ',ij,typty,typspec prop='ZZ' endif ! if disordered fraction set add D, already done above ! if(parlist.eq.2) then ! prop=prop(1:len_trim(prop))//'D' ! endif ! note changes here must be repeated for interaction parameters below write(funexpr,200)prop(1:len_trim(prop)),& phname(1:len_trim(phname)),text(1:len_trim(text)) 200 format(' PARAMETER ',A,'(',A,',',A,') ') ip=len_trim(funexpr)+1 !-------------------------------- this is not done for TDB files ! subtract reference states ! if(subref .and. typty.eq.1) then ! call subrefstates(funexpr,ip,lokph,parlist,endm,noelin1) ! if(noelin1) then ! this can happen for ionic liquids with just neutrals in sublattice 2 ! replace the constituent in sublattice 1 with "*" !!! ! write(*,*)'before: ',funexpr(1:ip) ! kk=index(funexpr,',') ! ik=index(funexpr,':') ! funexpr(kk+1:)='*'//funexpr(ik:) ! ip=len_trim(funexpr)+2 ! write(*,*)'after: ',funexpr(1:ip) ! endif ! endif ! this writes the expression, problem if function is zero call list_tpfun(proprec%degreelink(0),1,funexpr(ip:)) ! remove = sign ip=index(funexpr,'=') funexpr(ip:ip)=' ' ip=len_trim(funexpr) funexpr(ip+1:)=' '//proprec%reference ip=len_trim(funexpr) funexpr(ip+1:)=' !' ! nice output over several lines if needed with indentation 12 spaces call wrice2(lut,2,12,78,1,funexpr(1:ip+2)) proprec=>proprec%nextpr enddo ptyloop if(endmemrec%noofpermut.gt.1) then intpq=0 if(associated(endmemrec%intpointer)) then intpq=endmemrec%intpointer%antalint endif ! write(kou,207)endmemrec%antalem,endmemrec%noofpermut,intpq 207 format('@$ Endmember, permutations, interaction: ',3i5) endif endmemrec=>endmemrec%nextem enddo endmemberlist !----------------------------------------------------------------------- ! parameters for interactions using site fractions if(parlist.eq.1) then endmemrec=>phlista(lokph)%ordered else endmemrec=>phlista(lokph)%disordered endif write(*,210) ! write(lut,210) 210 format('$ 3C list_phase_data2 for TDB?XTDB files') intlist1: do while(associated(endmemrec)) intrec=>endmemrec%intpointer if(associated(intrec)) then ! write(*,*)'intlist 1B: ',intrec%status do ll=1,nsl kkx=endmemrec%fraclinks(ll,1) if(kkx.eq.-99) then ! wildcard endm(ll)=-99 elseif(parlist.eq.2) then endm(ll)=disfra%splink(kkx) else endm(ll)=phlista(lokph)%constitlist(kkx) endif enddo endif nint=0 intlist2: do while(associated(intrec)) nint=nint+1 if(nint.gt.maxstack) then write(*,*)'3C overflow in intrecstack 2' gx%bmperr=4399; goto 1000 endif intrecstack(nint)%p1=>intrec lint(1,nint)=intrec%sublattice(1) kkk=intrec%fraclink(1) if(parlist.eq.2) then lint(2,nint)=disfra%splink(kkk) else lint(2,nint)=phlista(lokph)%constitlist(kkk) endif proprec=>intrec%propointer ptyloop2: do while(associated(proprec)) ! typty=proprec%proptype ij=proprec%proptype if(ij.ge.100) then typty=ij/100 typspec=mod(ij,100) else typty=ij endif ! typspec=proprec%proptype ! if(typspec.gt.100) then ! typty=typspec/100 ! typspec=mod(typty,100) ! else ! typty=typspec ! endif if(typty.gt.0 .and. typty.le.ndefprop) then prop=propid(typty)%symbol ! if(parlist.eq.2) then ! disordered interaction parameter ! write(*,*)'3C skipping suffix D, 5th time' ! kk=len_trim(prop)+1 ! prop(kk:kk)='D' ! endif if(btest(propid(typty)%status,IDELSUFFIX)) then ! property like ZZ&(phase,constituent array) ! the element index should be in typsepc iel=typspec if(iel.ge.0 .and. iel.le.noofel) then prop=prop(1:len_trim(prop))//'&'& //ellista(elements(iel))%symbol else ! write(*,*)'lpd 7: ',iel,typty gx%bmperr=4082; goto 1000 endif elseif(btest(propid(typty)%status,IDCONSUFFIX)) then ! property like mobility MQ&(phase,constituent array) ! the suffix is a constituent iel=typspec if(iel.gt.0 .and. iel.le.phlista(lokph)%tnooffr) then if(parlist.eq.2) then ! we must consider parlist, take disordered constituent list ! we have no current equilibrium record but can use firsteq!! ! write(*,*)'3C: typspec: 3 ',typty,iel,prop(1:10) linkcon=disfrap%splink(iel) ! write(*,*)'3C: typspec: 4 ',typty,linkcon,prop(1:10) ll=1 if(iel.gt.disfrap%nooffr(1)) ll=2 prop=prop(1:len_trim(prop))//'&'& //splista(linkcon)%symbol goto 220 else linkcon=phlista(lokph)%constitlist(iel) if(linkcon.le.0) then ! write(*,*)'Illegal use of wildcard 2' gx%bmperr=4286; goto 1000 endif prop=prop(1:len_trim(prop))//'&'& //splista(linkcon)%symbol ! also add the sublattice number ... ncsum=0 do ll=1,phlista(lokph)%noofsubl ncsum=ncsum+phlista(lokph)%nooffr(ll) if(iel.le.ncsum) goto 220 enddo endif ! there cannot be any errors here .... ! write(*,*)'Never never error 2' gx%bmperr=4288; goto 1000 220 continue ! write(*,*)'property 2: ',prop(1:10),ll prop=prop(1:len_trim(prop))//'#'//char(ll+ichar('0')) else ! write(*,*)'lpd 7: ',iel,typty gx%bmperr=4082; goto 1000 endif endif else ! unknown property ... write(*,*)'unknown property type yy: ',typty prop='ZZ' endif ! if disordered fraction set add D, already set above ??!! ! if(parlist.eq.2) then ! prop=prop(1:len_trim(prop))//'D' ! endif if(mqmqax) then ! this is just for mqmqax excess parameters if(typty.ge.34 .and. typty.le.36) then ! MQMQX excess parameter with additional data after ; ! initial parameter symbol is G ! write(*,*)'3C line 3071 MQMQX excess: ',proprec%extra if(typty.eq.34) mqmqxchar(1:2)='G,' if(typty.eq.35) mqmqxchar(1:2)='Q,' if(typty.eq.36) mqmqxchar(1:2)='B,' prop='G' ! we have to add powers after the letter 100*p + 10*p + r ppow=proprec%extra/100 mqmqxchar(3:4)=char(ppow+ichar('0'))//',' temp=(proprec%extra-100*ppow)/10 mqmqxchar(5:6)=char(temp+ichar('0'))//',' rpow=proprec%extra-100*ppow-10*temp mqmqxchar(7:7)=char(rpow+ichar('0')) else write(*,298)typty 298 format('3C illegal excess parameter for MQMQX phase',i7) endif ! excess constituents should also be listed with just -Q NO DIGITS! jdeg=-1 call encode_constarr(text,nsl,endm,nint,lint,jdeg) write(funexpr,300)prop(1:len_trim(prop)), & phname(1:len_trim(phname)),text(1:len_trim(text)) 300 format('PARAMETER ',A,'(',A,',',A,') ') ! the expression ends with ";0)" replace "0) by mqmqxchar! ip=len_trim(funexpr)-1 funexpr(ip:)=mqmqxchar//')' ip=ip+8 ! add expression after ip, there is just one jdeg=0 call list_tpfun(proprec%degreelink(jdeg),1,funexpr(ip:)) ! remove = sign ip=index(funexpr,'=') funexpr(ip:ip)=' ' ip=len_trim(funexpr) funexpr(ip+1:)=' '//proprec%reference ip=len_trim(funexpr) funexpr(ip+1:)=' !' call wrice2(lut,4,12,78,1,funexpr(1:ip+2)) else ! note changes below must be repeated for endmember parameters above ! all other phases degree: do jdeg=0,proprec%degree if(proprec%degreelink(jdeg).eq.0) then ! write(*,*)'Ignoring function link' cycle degree endif call encode_constarr(text,nsl,endm,nint,lint,jdeg) write(funexpr,300)prop(1:len_trim(prop)), & phname(1:len_trim(phname)),text(1:len_trim(text)) !300 format('PARAMETER ',A,'(',A,',',A,') ') ip=len_trim(funexpr)+1 call list_tpfun(proprec%degreelink(jdeg),1,funexpr(ip:)) ! remove = sign ip=index(funexpr,'=') funexpr(ip:ip)=' ' ip=len_trim(funexpr) funexpr(ip+1:)=' '//proprec%reference ip=len_trim(funexpr) funexpr(ip+1:)=' !' call wrice2(lut,4,12,78,1,funexpr(1:ip+2)) enddo degree endif proprec=>proprec%nextpr enddo ptyloop2 ! list temporarily the number of permutations if(btest(phlista(lokph)%status1,PHFORD).or. & btest(phlista(lokph)%status1,PHBORD)) then ! if(intrec%noofip(1).gt.1 .or. intrec%noofip(2).gt.1) then if(nint.eq.1) then nz=intrec%noofip(2) else nz=size(intrec%sublattice) lqq=intrec%noofip(size(intrec%noofip)) if(lqq.ne.nz) then write(*,*)'3C Not same 2: ',intrec%antalint,nz,lqq endif ! write(*,301)nz,intrec%noofip 301 format('noofip: ',10i3) ! nz=intrec%noofip(intrec%noofip(1)+2) endif iqnext=0 iqhigh=0 if(associated(intrec%highlink)) then iqhigh=intrec%highlink%antalint endif if(associated(intrec%nextlink)) then iqnext=intrec%nextlink%antalint endif write(*,302)intrec%antalint,nz,nint,iqhigh,iqnext 302 format('3C Interaction check 2: permut, level, high, next: ',5i4) endif intrec=>intrec%highlink empty: do while(.not.associated(intrec)) if(nint.gt.0) then ! restore pointers in same clumsy way intrec=>intrecstack(nint)%p1 intrec=>intrec%nextlink ! write(*,*)'poping a pointer from intrecstack',ninit nint=nint-1 else exit intlist2 endif enddo empty enddo intlist2 endmemrec=>endmemrec%nextem enddo intlist1 ! check if there are other fraction lists ! parlist=parlist+1, hm parlist can only be 1 or 2 ! write(*,*)'checking for disordered parameters' if(parlist.eq.1 .and. associated(phlista(lokph)%disordered)) then write(lut,810) 810 format('$ Disordered fraction parameters:',20('-')) subref=.TRUE. ! lokcs=phlista(lokph)%cslink lokcs=phlista(lokph)%linktocs(ics) ! does this make a copy? Maybe it should be a pointer disfra=firsteq%phase_varres(lokcs)%disfra nsl=disfra%ndd parlist=2 if(ocv()) write(*,*)'Jump back to list disordered',nsl,parlist goto 100 endif 1000 continue ! add ternary extrapolations as commands, not TYPE_DEF ! This listing is not for TDB files ?? tooprec=>phlista(lokph)%tooplast if(associated(tooprec)) then ! this is writing a TDB database file text='TYPE_DEFINITION '//ctop//' GES A_P_D ' ik=30 ! increment ctop for next phase ... ctop=char(ichar(ctop)+1) nsl=0 do while(associated(tooprec)) if(len(tooprec%amend1).gt.1) then if(nsl.eq.0) then ! keep phase if nsl=0 text(ik:)=tooprec%amend1 ik=len_trim(text)+2 nsl=nsl+1 else ! otherwise remove phase and "TERNARY_EXTRA" as alredy set ij=index(tooprec%amend1,'_EXTRA') ! ij will be position of "_", add 7 ?? text(ik:)=tooprec%amend1(ij+7:) ik=len_trim(text)+2 endif endif ! there can be 3 amends ... if(len(tooprec%amend2).gt.1) then ij=index(tooprec%amend2,'_EXTRA') text(ik:)=tooprec%amend2(ij+7:) ik=len_trim(text)+2 endif if(len(tooprec%amend3).gt.1) then ij=index(tooprec%amend3,'_EXTRA') text(ik:)=tooprec%amend3(ij+7:) ik=len_trim(text)+2 endif ! write if too long if(ik.gt.70) then write(lut,1100)text(1:ik) text=' ' ik=1 endif tooprec=>tooprec%nexttoop 1100 format(a) enddo write(lut,1100)' !' endif ! write(*,*)'3C listing by list_phase_data2' return END subroutine list_phase_data2 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine subrefstates !\begin{verbatim} subroutine subrefstates(funexpr,jp,lokph,parlist,endm,noelin1) ! list a sum of reference states for a G parameter ! like "-H298(BCC_A2,FE)-3*H298(GRAPITE,C)" implicit none integer jp,lokph,parlist,endm(*) character funexpr*(*) logical noelin1 !\end{verbatim} ! special care for ionic liquid as sites varies ... character text*80,els*2 integer element(maxel),lokel double precision coef(maxel),xx,pqval(2),bonds ! TYPE(gtp_fraction_set) :: disfra TYPE(gtp_fraction_set), pointer :: disfra integer nsl,lokcs,ie,ll,jsp,nrel,ik,je,more,is,ip ! noelin1=.FALSE. lokcs=phlista(lokph)%linktocs(1) if(btest(phlista(lokph)%status1,PHIONLIQ)) goto 210 if(parlist.eq.1) then nsl=phlista(lokph)%noofsubl else ! for disordered fraction set always use 1 as factor ?? ! How about bcc with C? the second sublattice should count ... ! CONCLUSION: If disordered fraction set has 2 sublattices calculate ! should disfra be a pointer?? It seems to work like this .... ! disfra=firsteq%phase_varres(lokcs)%disfra disfra=>firsteq%phase_varres(lokcs)%disfra nsl=disfra%ndd endif ie=0 ! do not multiply swith sites for models PHCVMCQ, TISR, MQMQA, CRC, SROT if(nsl.eq.1 .and. & (btest(phlista(lokph)%status1,PHCVMCE) .or.& ! btest(phlista(lokph)%status1,PHFACTCE) .or.& btest(phlista(lokph)%status1,PHMQMQA) .or.& btest(phlista(lokph)%status1,PHQCE) .or.& btest(phlista(lokph)%status1,PHSROT) .or.& btest(phlista(lokph)%status1,PHTISR))) then bonds=firsteq%phase_varres(lokcs)%sites(1) firsteq%phase_varres(lokcs)%sites(1)=one endif sublat: do ll=1,nsl jsp=endm(ll) if(jsp.gt.0) then nrel=splista(jsp)%noofel elem: do ik=1,nrel do je=1,ie if(splista(jsp)%ellinks(ik).eq.element(je)) then if(parlist.eq.1) then coef(je)=coef(je)+& firsteq%phase_varres(lokcs)%sites(ll)*& splista(jsp)%stoichiometry(ik) ! phlista(lokph)%sites(ll)*splista(jsp)%stoichiometry(ik) else coef(je)=coef(je)+& disfra%dsites(ll)*splista(jsp)%stoichiometry(ik) endif goto 200 endif enddo ! new element, increment ie and initiate coef ! ignore the element VA with element index 0 if(splista(jsp)%ellinks(ik).eq.0) goto 200 ie=ie+1 element(ie)=splista(jsp)%ellinks(ik) if(parlist.eq.1) then coef(ie)=& firsteq%phase_varres(lokcs)%sites(ll)*& splista(jsp)%stoichiometry(ik) ! phlista(lokph)%sites(ll)*splista(jsp)%stoichiometry(ik) else ! if a single disordered sublattice ignore the number of sites !!! if(nsl.eq.1) then coef(ie)=splista(jsp)%stoichiometry(ik) else coef(ie)=disfra%dsites(ll)*splista(jsp)%stoichiometry(ik) endif endif 200 continue enddo elem else ! wildcard, ignore references continue endif enddo sublat goto 300 !------------------------------------------------------------ ! ionic liquid special, 2 sublattices but sites varies with charges 210 continue ie=0 jsp=endm(1) if(jsp.gt.0) then pqval(2)=splista(jsp)%charge else pqval(2)=one endif jsp=endm(2) if(jsp.gt.0) then if(btest(splista(jsp)%status,SPVA)) then pqval(1)=one else pqval(1)=-splista(jsp)%charge if(pqval(1).eq.zero) then noelin1=.TRUE. pqval(2)=one endif endif else ! write(*,*)'Illegal with wildcards in 2nd sublattice' gx%bmperr=4262; goto 1000 endif ionsl: do ll=1,2 jsp=endm(ll) if(jsp.lt.0) cycle nrel=splista(jsp)%noofel ionel: do ik=1,nrel do je=1,ie if(splista(jsp)%ellinks(ik).eq.element(je)) then coef(je)=coef(je)+& pqval(ll)*splista(jsp)%stoichiometry(ik) cycle ionel endif enddo ! new element, increment ie and initiate coef ! ignore the element VA with element index 0 if(splista(jsp)%ellinks(ik).ne.0) then ie=ie+1 element(ie)=splista(jsp)%ellinks(ik) coef(ie)=& pqval(ll)*splista(jsp)%stoichiometry(ik) endif enddo ionel enddo ionsl !------------------------------------------------------------ ! sort the elements 300 continue more=0 do je=1,ie-1 if(element(je).gt.element(je+1)) then is=element(je) element(je)=element(je+1) element(je+1)=is xx=coef(je) coef(je)=coef(je+1) coef(je+1)=xx more=1 endif enddo ! restore bonds in sites(1) .... if(btest(phlista(lokph)%status1,PHCVMCE) .or.& ! btest(phlista(lokph)%status1,PHFACTCE) .or.& btest(phlista(lokph)%status1,PHMQMQA) .or.& btest(phlista(lokph)%status1,PHQCE) .or.& btest(phlista(lokph)%status1,PHSROT) .or. & btest(phlista(lokph)%status1,PHTISR)) then firsteq%phase_varres(lokcs)%sites(1)=bonds endif if(more.gt.0) goto 300 ! list the elements as -10*H298(SER,element) ! write(*,*)'subrefstate 2:',ie,(element(i),i=1,ie) ip=1 text=' ' do je=1,ie if(coef(je).ne.one) then call wrinum(text,ip,10,6,-coef(je)) text(ip:ip)='*' else text(ip:ip)='-' endif ip=ip+1 lokel=element(je) els=ellista(lokel)%symbol if(ellista(lokel)%refstatesymbol.eq.0) then text(ip:)='H298(SER,'//els(1:len_trim(els))//')' else text(ip:)='G(SER,'//els(1:len_trim(els))//')' endif ip=len_trim(text)+1 enddo ! write(*,*)'subrefstate 9: ',ip,text(1:ip) funexpr(jp:)=text jp=jp+ip 1000 continue return end subroutine subrefstates !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine encode_stoik !\begin{verbatim} subroutine encode_stoik(text,ipos,mdig,spno) ! generate a stoichiometric formula of species from element list ! mdig is max number of digits in stoichiometry implicit none integer ipos,mdig,spno character text*(*) !\end{verbatim} character elnam*2,ltext*60 integer eli,noelx,iel,isto,jpos,ich,nlen,iq,tdb double precision stoi,charge if(spno.lt.1 .or. spno.gt.noofsp) then ! write(*,*)'3C in encode_stoik, no species: ',spno gx%bmperr=4051 goto 1000 endif ipos=1 noelx=splista(spno)%noofel ! write(6,*)'3C encode_stoik 1: ',spno,noelx ltext=splista(spno)%symbol iq=index(ltext,'/') ! if(iq.gt.0 .and. (ichar(ltext(iq+1:iq+1)).gt.ichar('9'))) then ! this is a quas, special output in TDB files ... ! write(*,*)'3C next species is a quad "',trim(ltext),'"' ! endif loop1: do iel=1,noelx eli=splista(spno)%ellinks(iel) elnam=ellista(eli)%symbol ! write(6,*)'3C encode_stoik 2: ',eli,elnam if(elnam(2:2).ne.' ') then ltext(ipos:ipos+1)=elnam nlen=2 else ltext(ipos:ipos)=elnam nlen=1 endif ipos=ipos+nlen stoi=splista(spno)%stoichiometry(iel) isto=int(stoi) if(abs(dble(isto)-stoi).lt.1.0D-3) then ! try to handle integer stoichiometries nicely if(isto.gt.99) then write(ltext(ipos:ipos+2),200)isto 200 format(I3) ipos=ipos+3 elseif(isto.gt.9) then write(ltext(ipos:ipos+1),205)isto 205 format(I2) ipos=ipos+2 elseif(isto.gt.1) then write(ltext(ipos:ipos),210)isto 210 format(i1) ipos=ipos+1 ! write(6,*)'3C encode_stoik 4B: ',ltext(ipos-3:ipos) elseif(nlen.eq.1 .and. iel.ne.noelx) then ltext(ipos:ipos)='1' ipos=ipos+1 endif else ! stoichiometry is a non-integer value, max mdig digits jpos=ipos ! call wrinum(ltext,ipos,8,0,stoi) call wrinum(ltext,ipos,mdig,0,stoi) if(buperr.ne.0) then gx%bmperr=buperr; goto 1000 endif ! remove trailing zeroes 300 continue if(ltext(ipos:ipos).eq.'0') then ipos=ipos-1; goto 300 endif endif enddo loop1 charge=splista(spno)%charge ich=int(charge) ! write(6,*)'3C encode_stoik 5: ',ich,charge if(ich.lt.zero) then ! limit output to integer charges <10 ltext(ipos:ipos+3)='/-'//char(ichar('0')-ich) ipos=ipos+3 elseif(charge.gt.zero) then ltext(ipos:ipos+3)='/+'//char(ichar('0')+ich) ipos=ipos+3 endif text=ltext ipos=ipos-1 ! write(6,*)'encode_stoik 6: ',ipos,ltext(1:ipos) 1000 continue return END subroutine encode_stoik !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine decode_stoik !\begin{verbatim} subroutine decode_stoik(name,noelx,elsyms,stoik) ! decode a species stoichiometry in name to element index and stoichiometry ! all in upper case implicit none character name*(*),elsyms(*)*2 double precision stoik(*) integer noelx !\end{verbatim} character lname*72,ch2*2 double precision xx integer ip,jp,ii lname=name call capson(lname) noelx=0 ip=1 ! expect element symbol ! write(*,'(a,a,i2)')'3C decode_stoik 1: ',lname,ip if(eolch(lname,ip)) then ! empty line, expected species stoichiometry gx%bmperr=4083; goto 1000 endif 100 continue ch2=lname(ip:ip+1) ! write(*,*)'Looking for element: ',ip,ch2 if(ch2(2:2).ge.'A' .and. ch2(2:2).le.'Z') then noelx=noelx+1 elsyms(noelx)=ch2 ip=ip+2 elseif(ch2(1:1).ge.'A' .and. ch2(1:1).le.'Z') then noelx=noelx+1 elsyms(noelx)=ch2(1:1) ip=ip+1 elseif(ch2(1:1).eq.'/') then ! electron is always /-, if /+ is given change sign in lname noelx=noelx+1 elsyms(noelx)='/-' if(ch2(2:2).eq.'+') then lname(ip+1:ip+1)='-' ip=ip+1 elseif(ch2(2:2).eq.'-') then ip=ip+2 else ! Hm, how come A/X is accepted? 211119/BoS ! do not accept Fe/2 for Fe/+2, always require + or - ! write(*,*)'Charge must always be given as /+ or /-' gx%bmperr=4289; goto 1000 endif ! write(*,*)'Found charge: ',ip,noelx,'>',lname(ip:ip+5),'<' else goto 900 endif ! an element found, no stoichiometry number means stoik=1 ! write(*,17)'3C decode_stoik 2: ',ip,ch2,lname(ip:ip+5) 17 format(a,i3,'>',a,'<>',a,'<') if(lname(ip:ip).eq.' ') then stoik(noelx)=one else jp=ip call getrel(lname,ip,xx) ! write(*,*)'decode_stoik 3: ',jp,ip,buperr,xx if(buperr.eq.0) then stoik(noelx)=xx else ! Strange error entering stoichiometry U1EUO3.83, ip=4, jp=2 and buperr=1937 ! getrel evidently did not find the "1". Check explictly if lname(jp:jp) ! is a number! if(lname(jp:jp).ge.'1' .and. lname(jp:jp).le.'9') then stoik(noelx)=dble(ichar(lname(jp:jp))-ichar('0')) ip=jp+1 buperr=0 goto 100 else ! accept missing stoichiometry value as 1, it is accepted to write cao as cao stoik(noelx)=one ! buperr=0 ! the error can be due to another element follows directly, restore ip an check ! ip=jp ! goto 100 endif endif ! in one case of missing stoichiometry ip exceeded length of lname ! write(*,*)'3C decode_stoik 4: ',stoik(noelx),buperr fraction: if(buperr.eq.0 .and. lname(ip:ip).eq.'/') then ! a stoichiometric factor followed by / without sign will be interpreted ! as a fraction like AL2/3O. Note AL2/+3 means AL2 with charge +3 jp=ip+1 if(.not.(lname(jp:jp).eq.'+' .or. lname(jp:jp).eq.'-')) then call getrel(lname,jp,xx) ! write(*,*)'decode_stoik 5: ',ip,jp,buperr,xx if(buperr.eq.0) then stoik(noelx)=stoik(noelx)/xx ip=jp else buperr=0 endif ! else ! write(*,*)'Interpret / as charge!' endif else ! write(*,*)'3C decode: ',ip,trim(lname) buperr=0 endif fraction if(ip.lt.len(lname)) goto 100 endif 900 continue if(noelx.eq.0) then write(*,*)'3C error in species stoichiometry: ',trim(name),ip gx%bmperr=4084 endif ! write(*,19)(stoik(ii),ii=1,noelx) 19 format('3C decode_stoik 5: ',5(1PE12.3)) 1000 continue return end subroutine decode_stoik !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine encode_constarr !\begin{verbatim} subroutine encode_constarr(constarr,nsl,endm,nint,lint,ideg) ! creates a constituent array implicit none character constarr*(*) character dummy*24 integer, dimension(*) :: endm integer nsl,nint,ideg,rp integer, dimension(2,*) :: lint !\end{verbatim} integer ip,mint,ll,l2 ip=1 constarr=' ' mint=1 ! special MQMQX ! if(ideg.lt.0) write(*,*)'3C line 3665 removing digits after -Q' ! if(nint.gt.0) then ! write(*,*)'encode_contarr ',lint(1,1),lint(2,1) ! endif do ll=1,nsl if(endm(ll).gt.0) then if(ideg.lt.0) then ! this is for TDB files using the MQMQA model. Remove 2 digits after -Q. WORKS rp=index(splista(endm(ll))%symbol,'-Q') ! write(*,*)'3C in encode_constarr no digits after -Q',rp if(rp.le.0) then write(*,*)'3C Warning, MQMQA constituent missing "-Q"' endif constarr(ip:)=splista(endm(ll))%symbol(1:rp+1) else constarr(ip:)=splista(endm(ll))%symbol endif else constarr(ip:)='*' endif ip=len_trim(constarr) if(mint.le.nint) then ! write(*,*)'encode_contarr ',lint(1,1),lint(2,1) do l2=mint,nint if(lint(1,mint).eq.ll) then constarr(ip+1:ip+1)=',' ip=ip+2 if(ideg.lt.0) then rp=index(splista(lint(2,mint))%symbol,'-Q') ! take into account the , constarr(ip:)=splista(lint(2,mint))%symbol(1:rp+1) else constarr(ip:)=splista(lint(2,mint))%symbol endif ip=len_trim(constarr) mint=mint+1 endif enddo endif constarr(ip+1:ip+1)=':' ip=ip+2 enddo ! for MQMQA phases the part after ";" is replaced on TDB files ... (ideg -1) constarr(ip-1:ip-1)=';' constarr(ip:ip)='0' if(ideg.gt.0) constarr(ip:ip)=char(ideg+ichar('0')) return end subroutine encode_constarr !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine decode_constarr !\begin{verbatim} subroutine decode_constarr(lokph,constarr,nsl,endm,nint,lint,ideg) ! deconde a text string with a constituent array ! a constituent array has separated by , or : and ; before degree implicit none character constarr*(*) integer endm(*),lint(2,*) integer nsl,nint,ideg,lokph,lord !\end{verbatim} character const*24,ch1*1 integer ll,ip,jp,isep,loksp,mord,isp,jsp,nord,mqmqa1 integer constlist(5),klok(5),knr(2) ! nint=0; ideg=0; ll=1 endm(ll)=0 ip=1 ! write(*,*)'3C decode_constarr 1: ',ip,trim(constarr) if(eolch(constarr,ip)) then gx%bmperr=4061; goto 1000 endif jp=ip-1 ! write(*,*)'3C decode_constarr 2: ',ip,jp loop: do while(.true.) ! find separators between constituents, no spaces allowed jp=jp+1 ch1=biglet(constarr(jp:jp)) ! write(*,*)'decode_constarr 3: ',jp,ch1 letter: if(ch1.eq.',') then isep=1 elseif(ch1.eq.':') then isep=2 elseif(ch1.eq.';') then isep=3 elseif(ch1.eq.' ') then isep=4 elseif(.not.(ch1.ge.'A' .and. ch1.le.'Z')) then ! write(*,*)'3C decode_constarr 3B: ',jp,ip,ch1 if(jp.gt.ip) then ! accept 0-9 and _ and . and / and + and - ! after the first character of a constituent ! write(*,24)'decode constarr 24A: "',ch1 if(.not.((ch1.ge.'0' .and. ch1.le.'9') .or. & ch1.eq.'_' .or. ch1.eq.'.' .or. & ch1.eq.'/' .or. ch1.eq.'+' .or. ch1.eq.'-')) then ! write(*,24)'3C: decode constarr 24B: "',ch1 24 format(a,a,'"') gx%bmperr=4062; goto 1000 endif elseif(ch1.ne.'*') then ! last possibility: wildcard ! write(*,24)'decode constarr 24C: "',ch1 gx%bmperr=4062; goto 1000 endif ! write(*,24)'decode constarr 24D: "',ch1 cycle else cycle endif letter ! we have a species name between ip and jp const=constarr(ip:jp-1) ! write(*,*)'3C decode_constarr species: "',trim(const),'"' call find_species_record_exact(const,loksp) if(gx%bmperr.ne.0) then if(const(1:2).eq.'* ') then ! wildcard, the parameter is independent of the fraction in this sublattice loksp=-99; gx%bmperr=0 else goto 1000 endif endif ! write(*,11)'decode constarr 11: ',ip,jp,loksp,const !11 format(a,3i4,'"',a,'"') place: if(endm(ll).eq.0) then ! first constituent of sublattice ll independent of separator endm(ll)=loksp else lint(1,nint)=ll lint(2,nint)=loksp endif place next: if(isep.eq.1) then ! separator was a , next constituent an interaction nint=nint+1 elseif(isep.eq.2) then ! separator was a ":" meaning new sublattice ll=ll+1 endm(ll)=0 elseif(isep.eq.3) then ! this is the end of a constituent array, normally followed by a degree 0-9 if(btest(phlista(lokph)%status1,PHMQMQX)) then ! begin MQMQA special: phase with asymmetrical excess with more data after ; ! typically G,1,1. position jp indicate the ";" ch1=constarr(jp+1:jp+1) if(ch1.eq.'0') then ! MQMQA endmember parameter ideg=0; exit loop endif jp=jp+2 ! write(*,50)1,jp,ch1,trim(constarr),ideg 50 format('3C MQMQA excess ',i1,i5,' "',a,'" "',a,'" ideg',i5) call capson(ch1) if(ch1.eq.'G') then ideg=1000 elseif(ch1.eq.'Q') then ideg=2000 elseif(ch1.eq.'B') then ideg=3000 else write(*,*)'3C *** Error: illegal MQMQA excess letter: "',ch1,'"' gx%bmperr=4063; goto 1000 endif ! write(*,50)2,jp,ch1,trim(constarr(jp:)),ideg ! there will be one or more integers after the letter ! skip the "," jp=jp+1 call getint(constarr,jp,mqmqa1) if(buperr.ne.0) then ! write(*,50)3,jp,ch1,trim(constarr),mqmqa1 ! gx%bmperr=4399; goto 1000 endif ideg=ideg+100*mqmqa1 ! write(*,*)'3C first value of ideg: ',ideg ! skip the "," character jp=jp+1 call getint(constarr,jp,mqmqa1) if(buperr.ne.0) then ! write(*,50)4,jp,ch1,trim(constarr(jp:)),mqmqa1 ! it is not an error, there may be just a single number ! gx%bmperr=4399; goto 1000 buperr=0 else ideg=ideg+10*mqmqa1 endif ! write(*,*)'3C second value of ideg: ',ideg,mqmqa1 ! skip the "," character jp=jp+1 call getint(constarr,jp,mqmqa1) if(buperr.ne.0) then ! write(*,50)4,jp,ch1,trim(constarr(jp:)),mqmqa1 ! it is not an error, there may be just a single number ! gx%bmperr=4399; goto 1000 buperr=0 else ideg=ideg+mqmqa1 endif ! write(*,*)'3C final ideg: ',ideg,mqmqa1 ! end of special MQMQA excess else ! normally a digit 0 to 9 is allowed after the ";" ideg=ichar(constarr(jp+1:jp+1))-ichar('0') if(ideg.lt.0 .or. ideg.gt.9) then ! a degree must be between 0 and 9 gx%bmperr=4063; goto 1000 endif endif exit loop elseif(isep.eq.4) then exit loop endif next ! beginning of next constituent ip=jp+1 enddo loop ! number of sublattices nsl=ll ! make sure the constituents are in alphabetcal order for each sublattice. !-------------------------------------------------------- ! Special order of constituents for ionic liquid .... if(btest(phlista(lokph)%status1,PHIONLIQ)) then constlist(1)=endm(1) if(nsl.ne.2) then if(nsl.eq.1) then ! when ionic liquid parameters entered from TDB-TC files parameters ! with just neutrals may have only one sublattice. Error cleared by ! the readtdb subroutine. ! BUT we must sort constituents on the sublattice, must be only neutrals ... ! I hope that will be chacked later ... do jsp=1,nint constlist(1+jsp)=lint(2,jsp) enddo ! simple bubble sort of constlist 44 continue do jsp=1,nint if(constlist(jsp+1).lt.constlist(jsp)) then lord=constlist(jsp) constlist(jsp)=constlist(jsp+1) constlist(jsp+1)=lord goto 44 endif enddo endif endm(1)=constlist(1) do jsp=1,nint lint(2,jsp)=constlist(1+jsp) enddo ! if(ocv()) write(*,*)'Ionic liquid has always 2 sublattices' gx%bmperr=4255; goto 1000 endif lord=1 do jsp=1,nint if(lint(1,jsp).eq.1) then lord=lord+1 constlist(lord)=lint(2,jsp) endif enddo knr(1)=lord lord=lord+1 constlist(lord)=endm(2) do jsp=1,nint if(lint(1,jsp).eq.2) then lord=lord+1 constlist(lord)=lint(2,jsp) endif enddo knr(2)=lord-knr(1) call sort_ionliqconst(lokph,1,knr,constlist,klok) if(gx%bmperr.ne.0) then write(*,*)'3C Error return from sort_ionliqconst ',gx%bmperr ! write(*,65)lord,(klok(ll),ll=1,lord) !65 format('3C constarr: ',i5,5x,5i3) write(*,64)trim(constarr) 64 format('3C constarr: ',a) goto 1000 endif lord=0 endm(1)=klok(1) do jsp=2,knr(1) lord=lord+1 lint(1,lord)=1 lint(2,lord)=klok(lord+1) enddo endm(2)=klok(lord+2) do jsp=2,knr(2) lord=lord+1 lint(1,lord)=2 lint(2,lord)=klok(lord+2) enddo ! write(*,66)endm(1),endm(2),(lint(1,ll),lint(2,ll),ll=1,nint) 66 format('decode: ',2i5,5x,3(2i3,2x)) goto 1000 endif !-------------------------------------------------------- ! first the endmember must be in order of the constituents, except wildcard order1: do mord=1,nint ll=lint(1,mord) isp=lint(2,mord) jsp=endm(ll) ! we can have isp or jsp or both negative if wildcard, WILDCARD ALWAYS IN ENDM if(isp.lt.0 .and. jsp.lt.0) then ! only one wildcard in each sublattice gx%bmperr=4032; goto 1000 elseif(isp.lt.0 .and. jsp.gt.0) then endm(ll)=isp lint(2,mord)=jsp elseif(isp.gt.0 .and. jsp.lt.0) then endm(ll)=jsp lint(2,mord)=isp elseif(splista(isp)%alphaindex.lt.splista(jsp)%alphaindex) then endm(ll)=isp lint(2,mord)=jsp endif enddo order1 ! then order if there are two interacting in same sublattice ! There are almost never more than 3 constituents interacting in one sublattice order2: do mord=1,nint ll=lint(1,mord) order3: do nord=mord+1,nint if(lint(1,nord).eq.ll) then isp=lint(2,nord) jsp=lint(2,mord) if(isp.lt.0 .or. jsp.lt.0) then gx%bmperr=4032; goto 1000 endif if(splista(isp)%alphaindex.lt.splista(jsp)%alphaindex) then lint(2,mord)=isp lint(2,nord)=jsp endif endif enddo order3 enddo order2 ! write(*,77)(splista(endm(i))%alphaindex,i=1,nsl), & ! (lint(1,j),lint(2,j),j=1,nint) !77 format('decode_contarr 7: ',3I3,5x,2i2) 1000 continue return end subroutine decode_constarr !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_bibliography !\begin{verbatim} subroutine list_bibliography(bibid,lut) ! list bibliographic references implicit none integer lut character bibid*(*) !\end{verbatim} character longline*2048 integer ir,jp,nl,ll,maxl if(lut.eq.kou) then write(lut,10)reffree-1 ! else ! write(lut,11)reffree-1 endif 10 format('There are ',i5,' bibliographic references') 11 format('$ There are ',i5,' bibliographic references') maxl=0 do ir=1,reffree-1 if(bibid(1:1).ne.' ' .and. & .not.compare_abbrev(bibid,bibrefs(ir)%reference)) cycle longline=bibrefs(ir)%reference longline(17:17)="'" jp=18 ! nl=size(bibrefs(ir)%refspec) ! do ll=1,nl ! longline(jp:)=bibrefs(ir)%refspec(ll) ! jp=jp+64 ! enddo ! this require Fortran standard 2003/2008 ! longline(jp:)=bibrefs(ir)%nyrefspec ll=bibrefs(ir)%wprefspec(1) ! loadc/storc are WPACK routines to store/load characters in integer arrays call loadc(2,bibrefs(ir)%wprefspec,longline(jp:jp+ll-1)) jp=len_trim(longline)+1 longline(jp:jp)="'" call wrice(lut,0,17,78,longline(1:jp)) maxl=maxl+1 if(lut.ne.kou .and. maxl.gt.50) then ! Thermo-Calc limit is 150 lines for each LIST_OF_REFERENCES on a TDB file write(lut,17) 17 format(' !'//' ADD_REFERENCES'/' NUMBER SOURCE'/" dummy ' '") maxl=0 endif enddo ! write(*,*)'3C refs: ',reffree,maxl 1000 continue return end subroutine list_bibliography !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_conditions !\begin{verbatim} subroutine list_conditions(lut,ceq) ! lists conditions on lut implicit none integer lut type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} character*1024 text integer kl text=' ' call get_all_conditions(text,0,ceq) if(gx%bmperr.ne.0) goto 1000 kl=index(text,'CRLF') if(kl.gt.1) then call wrice2(lut,2,4,78,1,text(1:kl-1)) endif write(lut,50)text(kl+4:len_trim(text)) 50 format(a) 1000 continue return end subroutine list_conditions !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine get_one_condition !\begin{verbatim} subroutine get_one_condition(ip,text,seqz,ceq) ! list the condition with the index seqz into text ! It lists also fix phases (and conditions that are not active?) implicit none integer ip,seqz character text*(*) TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer jl,iterm,indx(4) TYPE(gtp_condition), pointer :: last,current type(gtp_state_variable), pointer :: svrrec double precision wone ! if(ip.le.0) ip=1 text(ip:)=' ' if(.not.associated(ceq%lastcondition)) then ! write(*,*)'3C No conditions at all' gx%bmperr=4143; goto 1000 endif last=>ceq%lastcondition current=>last 70 continue ! write(*,*)'3C get_one_cond: ',current%seqz if(current%seqz.eq.seqz) goto 100 current=>current%next if(.not.associated(current,last)) goto 70 ! no condition with this index found gx%bmperr=4131; goto 1000 ! 100 continue iterm=1 ! return here for each term if several 150 continue do jl=1,4 indx(jl)=current%indices(jl,iterm) enddo ! write(*,*)'3C g1c: ',indx if(abs(current%condcoeff(iterm)-one).gt.1.0D-10) then wone=current%condcoeff(iterm)+one if(abs(wone).lt.1.0D-10) then text(ip:ip)='-' ip=ip+1 else ! not +1 or -1, write number ! if iterm=1 no not write a positive sign if(iterm.eq.1) then call wrinum(text,ip,8,1,current%condcoeff(iterm)) else call wrinum(text,ip,8,0,current%condcoeff(iterm)) endif text(ip:ip)='*' ip=ip+1 endif elseif(iterm.gt.1) then ! must be a + in front of second and later terms even if coeff is +1 text(ip:ip)='+' ip=ip+1 endif ! why is ceq needed?? BECAUSE COMPONENTS CAN BE DIFFERENT ... hm?? !! ! call encode_state_variable2(text,ip,current%statev,indx,& ! current%iunit,current%iref,ceq) svrrec=>current%statvar(1) call encode_state_variable(text,ip,svrrec,ceq) if(iterm.lt.current%noofterms) then iterm=iterm+1; goto 150 endif ! write = followed by the value if(text(ip:ip).ne.' ') ip=ip+1 text(ip:)='=' ip=ip+1 ! write(*,*)'3C symlink: ',current%symlink1,current%prescribed if(current%symlink1.gt.0) then ! the value is a symbol text(ip:)=svflista(current%symlink1)%name ip=len_trim(text)+1 else call wrinum(text,ip,10,0,current%prescribed) endif 1000 continue return end subroutine get_one_condition !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine get_one_experiment !\begin{verbatim} subroutine get_one_experiment(ip,text,seqz,eval,ceq) ! list the experiment with the index seqz into text ! It lists also experiments that are not active ?? ! UNFINISHED current value should be appended implicit none integer ip,seqz character text*(*) logical eval TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer jl,iterm,indx(4),symsym TYPE(gtp_condition), pointer :: last,current type(gtp_state_variable), pointer :: svrrec double precision wone,xxx character actual_arg*16 ! if(ip.le.0) ip=1 text(ip:)=' ' if(.not.associated(ceq%lastexperiment)) then ! write(*,*)'3C No experiments' gx%bmperr=4249; goto 1000 endif last=>ceq%lastexperiment current=>last ! write(*,*)'3C index of last experiment: ',current%seqz 70 continue ! write(*,*)'3C experiment number: ',seqz,current%seqz if(current%seqz.eq.seqz) goto 100 current=>current%next if(.not.associated(current,last)) goto 70 ! no experiment with this index found or it is inactivated gx%bmperr=4131; goto 1000 ! 100 continue if(current%active.eq.1) then ! write(*,*)'3C Experiment not active ' gx%bmperr=4218; goto 1000 endif iterm=1 150 continue ! write(*,*)'3C Testing is symbol or state variable record',& ! allocated(current%statvar) nostv: if(.not.allocated(current%statvar)) then ! an experiment is a symbol!!! Then statvar is not allocated symsym=current%statev ! write(*,*)'3C A symbol, not a state variable for this experiment',symsym ! get the symbol name text=svflista(symsym)%name ip=len_trim(text)+1 ! text(ip-1:ip-1)='=' ! write(*,*)'3C experiment: ',text(1:ip),ip else ! write(*,*)'3C This experiment has a state variable record',& ! allocated(current%statvar),allocated(current%indices),iterm symsym=0 ! these are not needed?? ! do jl=1,4 ! indx(jl)=current%indices(jl,iterm) ! enddo ! if(abs(current%condcoeff(iterm)-one).gt.1.0D-10) then ! wone=current%condcoeff(iterm)+one ! if(abs(wone).lt.1.0D-10) then ! text(ip:ip)='-' ! ip=ip+1 ! else ! not +1 or -1, write number ! call wrinum(text,ip,8,1,current%condcoeff(iterm)) ! text(ip:ip)='*' ! ip=ip+1 ! endif ! elseif(iterm.gt.1) then ! must be a + in front of second and later terms ! text(ip:ip)='+' ! ip=ip+1 ! endif ! why is ceq needed?? BECAUSE COMPONENTS CAN BE DIFFERENT ... hm?? !! ! call encode_state_variable2(text,ip,current%statev,indx,& ! current%iunit,current%iref,ceq) svrrec=>current%statvar(1) call encode_state_variable(text,ip,svrrec,ceq) if(iterm.lt.current%noofterms) then iterm=iterm+1; goto 150 endif endif nostv ! write(*,*)'3C ok here',symsym if(current%experimenttype.eq.0 .or. current%experimenttype.eq.100) then ! write = followed by the value ! if(text(ip:ip).ne.' ') ip=ip+1 text(ip:)='=' ip=ip+1 elseif(current%experimenttype.eq.-1) then ! if(text(ip:ip).ne.' ') ip=ip+1 text(ip:)='<' ip=ip+1 elseif(current%experimenttype.eq.1) then ! if(text(ip:ip).ne.' ') ip=ip+1 text(ip:)='>' ip=ip+1 endif ! write(*,*)'3C experiment line 2: ',text(1:ip),ip if(current%symlink1.gt.0) then ! the value is a symbol text(ip:)=svflista(current%symlink1)%name ip=len_trim(text)+1 else ! call wrinum(text,ip,10,0,current%prescribed) call wrinum(text,ip,8,0,current%prescribed) endif ! uncertainty can also be a symbol text(ip:ip)=':' ip=ip+1 ! write(*,*)'3C experiment line 3: ',text(1:ip),ip ! write(*,*)'3C uncertainty: ',current%symlink2 if(current%symlink2.gt.0) then ! the value is a symbol text(ip:)=svflista(current%symlink2)%name ip=len_trim(text)+1 else ! call wrinum(text,ip,10,0,current%uncertainty) call wrinum(text,ip,8,0,current%uncertainty) endif ! write(*,*)'3C ok here 2',symsym,text(1:ip) ! write(*,*)'3C experiment line 2: ',text(1:ip),ip if(current%experimenttype.eq.100) then text(ip:ip)='%' ip=ip+1 endif ! write(*,*)'3C ok here 3',symsym ! if eval TRUE add the current value of the experiment after a $ sign ! TROUBLE GETTING WRONG VALUE HERE WHEN USER DEFINED REFERENCE STATES if(.not.eval) then text(ip+2:)='$ ?? ' goto 1000 endif if(symsym.eq.0) then call state_variable_val(svrrec,xxx,ceq) else ! write(*,*)'3C ok here 4',symsym actual_arg=' ' xxx=evaluate_svfun_old(symsym,actual_arg,1,ceq) endif if(gx%bmperr.ne.0) then ! it is maybe a derivative ... write(*,*)'3C we cannot evaluate a derivative here ...',gx%bmperr ! but meq_evaluate_svfun not available here ... it is part of the minimizer ! gx%bmperr=0 ! xxx=meq_evaluate_svfun(symsym,actual_arg,0,ceq) ! endif ! if(gx%bmperr.ne.0) then write(*,*)'3C Error evaluating symbol: ',gx%bmperr text(ip:)=' $ ?? ' ip=ip+5 gx%bmperr=0 else ! write(*,*)'3C experimental state variable current value: ',xxx text(ip:)=' $' ip=ip+3 ! call wrinum(text,ip,12,0,xxx) call wrinum(text,ip,8,0,xxx) ! write(*,*)'3C experiment line 3: ',text(1:ip),ip endif ! write(*,*)'3C ok here 5' 1000 continue ! write(*,*)'3C experiment line 4: ',text(1:ip),ip,gx%bmperr return end subroutine get_one_experiment !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine get_all_conditions !\begin{verbatim} subroutine get_all_conditions(text,mode,ceq) ! list all conditions if mode=0, experiments if mode=1, -1 if no numbers implicit none integer mode character text*(*) TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} TYPE(gtp_condition), pointer :: last,current,first type(gtp_state_variable), pointer :: svrrec character phname*32 integer ntot,nc,ip,iterm,iph,ics,jl double precision value,wone integer indx(4) ntot=0 text=' ' if(mode.eq.1) then ! cannot enter experiments yet goto 1000 endif if(noofel.eq.0) then ! The CRLF indicates CR+LF at output text='CRLF No elements' goto 1000 endif last=>ceq%lastcondition if(.not.associated(last)) then if(mode.eq.-1) then text=' ' else ! The CRLF indicates CR+LF at output write(text,50)noofel+2 50 format('CRLF Degrees of freedom are ',i3) endif goto 1000 endif current=>last%next first=>current nc=1 ip=1 100 continue ! conditions can also be fixed phases !!! ntot=ntot+1 if(current%active.ne.0) then ! if active is nonzero the condition is not active goto 200 endif if(mode.ne.-1) then ! no condition numbers for mode=-1 call wriint(text,ip,nc) ! number the conditions text(ip:)=':' ! ip=ip+2 ! No space after : ip=ip+1 endif iterm=1 if(current%statev.lt.0) then ! handle FIX phases iph=-current%statev ics=current%iref call get_phase_name(iph,ics,phname) if(gx%bmperr.ne.0) then write(*,*)'3C list condition error for phase ',iph,ics gx%bmperr=4178; goto 1000 endif text(ip:)='<'//phname ip=len_trim(text)+3 text(ip-2:ip-1)='>=' value=current%prescribed if(value.lt.1.0d-8) then value=zero endif call wrinum(text,ip,4,0,value) goto 190 endif ! return here for each term if several 150 continue do jl=1,4 indx(jl)=current%indices(jl,iterm) enddo ! if(iterm.gt.1) write(*,152)'3C 150: ',iterm,indx,current%condcoeff(iterm) 152 format(a,5i4,1pe12.4) if(abs(current%condcoeff(iterm)-one).gt.1.0D-10) then wone=current%condcoeff(iterm)+one if(abs(wone).lt.1.0D-10) then text(ip:ip)='-' ip=ip+1 else ! not +1 or -1, write number ! write(*,*)'3C list cond: ',current%condcoeff(iterm),one,wone if(iterm.eq.1) then ! do not write a + in front of first term call wrinum(text,ip,8,0,current%condcoeff(iterm)) else call wrinum(text,ip,8,1,current%condcoeff(iterm)) endif text(ip:ip)='*' ip=ip+1 endif elseif(iterm.gt.1) then ! must be a + or - in front of second and later terms text(ip:ip)='+' ip=ip+1 endif ! why is ceq needed?? BECAUSE COMPONENTS CAN BE DIFFERENT ... hm?? !! ! write(*,*)'3C encode: ',current%statev,indx ! call encode_state_variable2(text,ip,current%statev,indx,& ! current%iunit,current%iref,ceq) ! svrrec=>current%statvar(1) svrrec=>current%statvar(iterm) if(svrrec%argtyp.eq.3) then ! write(*,153)svrrec%argtyp,svrrec%phase,svrrec%compset,svrrec%component 153 format('3C gac 2: ',4i4) endif call encode_state_variable(text,ip,svrrec,ceq) if(iterm.lt.current%noofterms) then iterm=iterm+1; goto 150 endif ! problem with current position ... LNAC(CR) had the last ) overwritten ... ! write(*,157)ip,text(1:ip) 157 format('3C gc: ',i2,'"',a,'"') if(text(ip:ip).ne.' ') ip=ip+1 text(ip:)='=' ip=ip+1 if(current%symlink1.gt.0) then ! the value is a symbol ! write(*,*)'3C value is a symbol: ',current%symlink1 text(ip:)=svflista(current%symlink1)%name ip=len_trim(text)+1 else call wrinum(text,ip,10,0,current%prescribed) endif 190 continue if(ip.ge.len(text)) then write(*,*)'3C text: "',text,'" ',ip,len(text) endif text(ip:ip)=', ' ip=ip+2 nc=nc+1 200 continue current=>current%next if(.not.associated(current,first)) goto 100 ! there can be non-active conditions only if(nc.gt.1) then ! write without the last , text(ip-2:)=' ' ! write(kou,99)text(1:ip-3) !99 format(a) endif if(mode.eq.0) then ! the degrees of freedoms write(text(ip:),50)noofel+3-nc endif 1000 return end subroutine get_all_conditions !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable integer function degrees_of_freedom !\begin{verbatim} integer function degrees_of_freedom(ceq) ! returns the degrees of freedom implicit none TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} TYPE(gtp_condition), pointer :: last,current,first integer ntot ! ntot=-noofel-2 last=>ceq%lastcondition if(.not.associated(last)) then goto 1000 elseif(last%active.eq.0) then ntot=ntot+1 endif current=>last%next 100 do while(.not.associated(current,last)) if(current%active.eq.0) ntot=ntot+1 current=>current%next enddo 1000 continue ! write(*,*)'3C degrees of freedom: ',ntot,noofel degrees_of_freedom=ntot return end function degrees_of_freedom !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine list_defined_properties !\begin{verbatim} subroutine list_defined_properties(lut) ! lists all parameter identifiers allowed implicit none integer lut !\end{verbatim} ! character special*32,tdep*1,pdep*1 character special*26,tdep*1,pdep*1 integer typty,kk write(lut,10) 10 format('Indx Ident T P Specification',15x,' Status Note') !10 format('Index Ident T P Specification',23x,' Status Note') !10 format('Index Symbol Specification',26x,' Status Note') do typty=1,ndefprop special=' ' if(btest(propid(typty)%status,IDELSUFFIX)) then special='&' elseif(btest(propid(typty)%status,IDCONSUFFIX)) then special='&' endif kk=len_trim(special) if(kk.gt.0) then special(kk+1:)=';' kk=kk+2 else kk=1 endif tdep='T' pdep='P' if(btest(propid(typty)%status,IDNOTP)) then ! special(kk:)='Not T- and P-dependent' tdep='-' pdep='-' elseif(btest(propid(typty)%status,IDONLYP)) then ! special(kk:)='Not T-dependant' tdep='-' elseif(btest(propid(typty)%status,IDONLYT)) then ! special(kk:)='Not P-dependant' pdep='-' endif write(lut,50)typty,propid(typty)%symbol,tdep,pdep,special,& propid(typty)%status,trim(propid(typty)%note) 50 format(i4,1x,a,2x,a,1x,a,1x,a,1x,z8,1x,a) enddo 1000 continue return end subroutine list_defined_properties !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine find_defined_property !\begin{verbatim} subroutine find_defined_property(symbol,mode,typty,iph,ics) ! searches the propid list for one with symbol or identifiction typty ! if mode=0 then symbol given, if mode=1 then typty given ! symbol can be TC(BCC), BM(FCC), MQ&FE(HCP) etc, the phase must be ! given in symbol as otherwise it is impossible to find the consititent!!! ! A constituent may have a sublattice specifier, MQ&FE#3(SIGMA) implicit none integer mode,typty,iph,ics character symbol*(*) !\end{verbatim} character phsym*24,specid*24,nude*4 integer splink,k1,k2,lattice,lokph,ityp,iel,kk,ll,jj integer jtyp ! write(*,7)'3C fdp 1: ',symbol(1:5),mode,typty,iph,ics 7 format(a,a,5i5) if(mode.eq.0) then ! parameter identifier given, can include & # and ( ) like MQ&FE#3(SIGMA) lattice=0 nude=' ' specid=' ' k1=index(symbol,'&') if(k1.gt.0) then nude=symbol(1:k1-1) k2=index(symbol,'#') if(k2.eq.0) then k2=index(symbol,'(') if(k2.eq.0) then ! write(*,*)'3C: Missing phase specifier in property symbol 1' ! write(*,*)'Error in symbol: ',symbol gx%bmperr=4290; goto 1000 endif else lattice=ichar(symbol(k2+1:k2+1))-ichar('0') if(lattice.le.0 .or. lattice.gt.9) then ! write(*,*)'3C Sublattice outside range in property symbol' gx%bmperr=4290; goto 1000 endif endif specid=symbol(k1+1:k2-1) call capson(specid) endif ! there must be a phase name within ( ) k1=index(symbol,'(') if(k1.gt.0) then k2=index(symbol,')') if(k2.lt.k1) then ! write(*,*)'3C Missing phase specifier in property symbol 2' ! write(*,*)'Symbol: ',symbol gx%bmperr=4291; goto 1000 endif phsym=symbol(k1+1:k2-1) call find_phase_by_name(phsym,iph,ics) if(gx%bmperr.ne.0) goto 1000 lokph=phases(iph) if(nude(1:1).eq.' ') nude=symbol(1:k1-1) elseif(mode.ne.0) then write(*,*)'3C Missing phase specifier in property symbol 3' write(*,*)'Symbol: ',symbol,mode gx%bmperr=4291; goto 1000 ! else ! mode=0 means just ignore ! write(*,*)'3C mode: ',mode,iph,ics ! goto 1000 endif ! now nude is the property id, lokph is phase location, specid is element or ! constituent symbol, lattice is sublattice number ! skip index 1 as G is a state variable call capson(nude) ! write(*,*)'3C fdp 2: ',iph,ics,nude do ityp=2,ndefprop ! write(*,*)'3C fdp 3: ',ityp,nude,propid(ityp)%symbol if(propid(ityp)%symbol.ne.nude) cycle if(btest(propid(ityp)%status,IDELSUFFIX)) then ! element specifier, IBM&CR(BCC) (when we have element specific Bohr magnetons) ! write(*,*)'3C fdp 4: element: ',specid call find_element_by_name(specid,iel) if(gx%bmperr.ne.0) goto 1000 typty=100*ityp+iel goto 200 elseif(btest(propid(ityp)%status,IDCONSUFFIX)) then ! constituent specifier, for example: MQ&FE#3(SIGMA) ! write(*,*)'3C fdp 5: constituent: ',specid kk=0 do ll=1,phlista(lokph)%noofsubl do jj=1,phlista(lokph)%nooffr(ll) kk=kk+1 splink=phlista(lokph)%constitlist(kk) if(splink.le.0) then ! write(*,*)'3C Illegal use of woildcard 3' gx%bmperr=4286; goto 1000 endif if(specid.eq.splista(splink)%symbol .and. & (lattice.eq.0 .or. lattice.eq.ll)) then typty=100*ityp+kk goto 200 endif enddo enddo else ! property without specifier like TC(FCC) typty=ityp goto 200 endif enddo ! if we come here we have not found the constituent or element or property ! it may be OK anyway if this is a call to test if symbol exists ?? ! write(*,*)'3C Illegal property symbol' gx%bmperr=4290; goto 1000 ! we must return property number, phase location, element ! the value TYPTY stored in property records is "idprop" or ! if IDELSUFFIX set then 100*"idprop"+ellista index of element ! if IDCONSUFFIX set then 100*"idprop"+constituent index 200 continue else ! indices given, typty, iph and ics, construct the symbol ! if typty>100 there is also an element or constituent specifier lokph=phases(iph) ! write(*,*)'3C fdp 10: ',typty,iph,ics,lokph ityp=typty jtyp=-1 if(ityp.gt.100) then ityp=typty/100 jtyp=typty-100*ityp endif if(ityp.le.1 .or. ityp.gt.ndefprop) then ! write(*,*)'3C Property number outside range ',ityp,typty gx%bmperr=4292; goto 1000 endif symbol=propid(ityp)%symbol if(btest(propid(ityp)%status,IDELSUFFIX)) then ! could one have /- as specifier??? NO !! But maye Va if(jtyp.lt.0) then ! write(*,*)'3C Missing element index in property symbol' gx%bmperr=4290; goto 1000 endif if(jtyp.lt.0 .or. jtyp.gt.noofel) then ! write(*,*)'3C Too high element index in property symbol' gx%bmperr=4290; goto 1000 endif symbol=symbol(1:len_trim(symbol))//'&'//ellista(jtyp)%symbol elseif(btest(propid(ityp)%status,IDCONSUFFIX)) then if(jtyp.lt.0) then ! write(*,*)'3C Missing constituent index in property symbol' gx%bmperr=4290; goto 1000 endif if(iph.le.0 .or. iph.gt.noofph) then ! write(*,*)'3C Illegal phase location in property symbol' gx%bmperr=4290; goto 1000 endif kk=0 do ll=1,phlista(lokph)%noofsubl do jj=1,phlista(lokph)%nooffr(ll) kk=kk+1 if(kk.eq.jtyp) then splink=phlista(lokph)%constitlist(kk) if(splink.le.0) then ! write(*,*)'3C Illegal use of woildcard 4' gx%bmperr=4286; goto 1000 endif specid=splista(splink)%symbol if(ll.gt.1) then specid=specid(1:len_trim(specid))//& '#'//char(ichar('0')+ll) endif goto 400 endif enddo enddo ! we come here is we failed to find the constituent write(*,*)'3C Illegal constituent index in property symbol' gx%bmperr=4290; goto 1000 400 continue symbol=symbol(1:len_trim(symbol))//'&'//specid elseif(jtyp.gt.0) then write(*,*)'3C This property has no specifier' gx%bmperr=4290; goto 1000 endif ! add the phase ! write(*,*)'3C fdp 11: ',lokph,ics symbol=symbol(1:len_trim(symbol))//'('//phlista(lokph)%name if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then ! write(*,*)'3C No such composition set' gx%bmperr=4072; goto 1000 endif if(ics.gt.1) symbol=symbol(1:len_trim(symbol))//'#'//char(ichar('0')+ics) symbol=symbol(1:len_trim(symbol))//')' ! write(*,*)'3C fdp 12: ',symbol(1:20) endif 1000 continue return end subroutine find_defined_property !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine find_defined_property3 !\begin{verbatim} subroutine find_defined_property3(symbol,mode,typty,iph,ics) ! Revised version of old routine called by get_many_svar ! allows wildcards in some cases and should handle # and * better ... ! searches the propid list for one with symbol or identifiction typty ! if mode=0 then symbol given, if mode=1 then typty given ! symbol can be TC(BCC), BM(FCC), MQ&FE(HCP) etc, the phase must be ! given in symbol as otherwise it is impossible to find the consititent!!! ! A constituent may have a sublattice specifier, MQ&FE#3(SIGMA) implicit none integer mode,typty,iph,ics character symbol*(*) !\end{verbatim} character phsym*24,specid*24,nude*4,mpi*32 integer splink,k1,k2,lattice,lokph,ityp,iel,kk,ll,jj integer jtyp ! write(*,7)'3C fdp 1: ',symbol(1:5),mode,typty,iph,ics 7 format(a,a,5i5) lokph=0 if(mode.eq.0) then ! parameter identifier given, can include & # and ( ) like MQ&FE#3(SIGMA) lattice=0 nude=' ' specid=' ' ! extract the part before ( k1=index(symbol,'(') mpi=symbol(1:k1-1) k1=index(mpi,'&') if(k1.gt.0) then ! there is a component included in the mpi, extract it nude=mpi(1:k1-1) k2=index(symbol,'#') if(k2.gt.0) then ! there is a sublattice indication ! k2=index(symbol,'(') ! if(k2.eq.0) then ! write(*,*)'3C: Missing phase specifier in property symbol 1' ! write(*,*)'Error in symbol: ',symbol ! gx%bmperr=4290; goto 1000 ! endif ! else lattice=ichar(symbol(k2+1:k2+1))-ichar('0') if(lattice.le.0 .or. lattice.gt.9) then ! write(*,*)'3C Sublattice outside range in property symbol' gx%bmperr=4290; goto 1000 endif endif specid=symbol(k1+1:k2-1) call capson(specid) endif k1=index(symbol,'(') if(k1.gt.0) then ! there must be a phase name within ( ) unless mode=0 k2=index(symbol,')') if(k2.lt.k1) then ! write(*,*)'3C Missing phase specifier in property symbol 2' ! write(*,*)'Symbol: ',symbol gx%bmperr=4291; goto 1000 endif ! we should allow phase name * and maybe # phsym=symbol(k1+1:k2-1) if(phsym(1:1).eq.'*') then iph=-1; ics=-1 elseif(phsym(1:1).eq.'#') then iph=-100; ics=-100 else call find_phase_by_name(phsym,iph,ics) if(gx%bmperr.ne.0) goto 1000 lokph=phases(iph) endif if(nude(1:1).eq.' ') nude=symbol(1:k1-1) ! elseif(mode.ne.0) then else ! we are here because mode=0 write(*,*)'3C Missing phase specifier in property symbol 3' write(*,*)'Symbol: ',symbol,mode gx%bmperr=4291; goto 1000 ! else ! mode=0 means just ignore ! write(*,*)'3C mode: ',mode,iph,ics ! goto 1000 endif ! now nude is the property id, lokph is phase location, specid is element or ! constituent symbol, lattice is sublattice number call capson(nude) ! write(*,*)'3C fdp 2: ',iph,ics,nude do ityp=2,ndefprop ! skip index 1 as G is a state variable ! write(*,*)'3C fdp 3: ',ityp,nude,propid(ityp)%symbol if(propid(ityp)%symbol.ne.nude) cycle if(btest(propid(ityp)%status,IDELSUFFIX)) then ! element specifier, IBM&CR(BCC) (when we have element specific Bohr magnetons) ! write(*,*)'3C fdp 4: element: ',specid call find_element_by_name(specid,iel) if(gx%bmperr.ne.0) goto 1000 typty=100*ityp+iel goto 200 elseif(btest(propid(ityp)%status,IDCONSUFFIX)) then ! constituent specifier, for example: MQ&FE#3(SIGMA) ! in this case ! write(*,*)'3C fdp 5: constituent: ',specid if(lokph.eq.0) then write(*,*)'3C phase specification needed for: ',trim(mpi) gx%bmperr=4399; goto 1000 endif kk=0 do ll=1,phlista(lokph)%noofsubl do jj=1,phlista(lokph)%nooffr(ll) kk=kk+1 splink=phlista(lokph)%constitlist(kk) if(splink.le.0) then ! write(*,*)'3C Illegal use of woildcard 3' gx%bmperr=4286; goto 1000 endif if(specid.eq.splista(splink)%symbol .and. & (lattice.eq.0 .or. lattice.eq.ll)) then typty=100*ityp+kk goto 200 endif enddo enddo else ! property without specifier like TC(FCC) typty=ityp goto 200 endif enddo ! if we come here we have not found the constituent or element or property ! it may be OK anyway if this is a call to test if symbol exists ?? ! write(*,*)'3C Illegal property symbol' gx%bmperr=4290; goto 1000 ! we must return property number, phase location, element ! the value TYPTY stored in property records is "idprop" or ! if IDELSUFFIX set then 100*"idprop"+ellista index of element ! if IDCONSUFFIX set then 100*"idprop"+constituent index 200 continue else ! indices given, typty, iph and ics, construct the symbol ! if typty>100 there is also an element or constituent specifier lokph=phases(iph) ! write(*,*)'3C fdp 10: ',typty,iph,ics,lokph ityp=typty jtyp=-1 if(ityp.gt.100) then ityp=typty/100 jtyp=typty-100*ityp endif if(ityp.le.1 .or. ityp.gt.ndefprop) then ! write(*,*)'3C Property number outside range ',ityp,typty gx%bmperr=4292; goto 1000 endif symbol=propid(ityp)%symbol if(btest(propid(ityp)%status,IDELSUFFIX)) then ! could one have /- as specifier??? NO !! But maye Va if(jtyp.lt.0) then ! write(*,*)'3C Missing element index in property symbol' gx%bmperr=4290; goto 1000 endif if(jtyp.lt.0 .or. jtyp.gt.noofel) then ! write(*,*)'3C Too high element index in property symbol' gx%bmperr=4290; goto 1000 endif symbol=symbol(1:len_trim(symbol))//'&'//ellista(jtyp)%symbol elseif(btest(propid(ityp)%status,IDCONSUFFIX)) then if(jtyp.lt.0) then ! write(*,*)'3C Missing constituent index in property symbol' gx%bmperr=4290; goto 1000 endif if(iph.le.0 .or. iph.gt.noofph) then ! write(*,*)'3C Illegal phase location in property symbol' gx%bmperr=4290; goto 1000 endif kk=0 do ll=1,phlista(lokph)%noofsubl do jj=1,phlista(lokph)%nooffr(ll) kk=kk+1 if(kk.eq.jtyp) then splink=phlista(lokph)%constitlist(kk) if(splink.le.0) then ! write(*,*)'3C Illegal use of woildcard 4' gx%bmperr=4286; goto 1000 endif specid=splista(splink)%symbol if(ll.gt.1) then specid=specid(1:len_trim(specid))//& '#'//char(ichar('0')+ll) endif goto 400 endif enddo enddo ! we come here is we failed to find the constituent write(*,*)'3C Illegal constituent index in property symbol' gx%bmperr=4290; goto 1000 400 continue symbol=symbol(1:len_trim(symbol))//'&'//specid elseif(jtyp.gt.0) then write(*,*)'3C This property has no specifier' gx%bmperr=4290; goto 1000 endif ! add the phase ! write(*,*)'3C fdp 11: ',lokph,ics symbol=symbol(1:len_trim(symbol))//'('//phlista(lokph)%name if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then ! write(*,*)'3C No such composition set' gx%bmperr=4072; goto 1000 endif if(ics.gt.1) symbol=symbol(1:len_trim(symbol))//'#'//char(ichar('0')+ics) symbol=symbol(1:len_trim(symbol))//')' ! write(*,*)'3C fdp 12: ',symbol(1:20) endif 1000 continue return end subroutine find_defined_property3 !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine line_with_phases_withdgm0 !\begin{verbatim} subroutine line_with_phases_withdgm0(line,ceq) ! used in amend lines with stored STEP/MAP results ! enter first 6, two .. and last 2 characters of phase names with abs(dgm)<1-8 ! line LIQUID#2, PHYRRO..#2 implicit none TYPE(gtp_equilibrium_data), pointer :: ceq character line*(*) !\end{verbatim} integer iph,ik,jk,tup character name*32 ik=1 ! number of phases is equal to number of phase tuples?? no do iph=1,noofph ! iph=phasetuple(phtupx(isort(jd)))%phaseix ! ics=phasetuple(phtupx(isort(jd)))%compset ! call get_phase_compset(iph,ics,lokph,lokcs) tup=iph 100 continue if(abs(ceq%phase_varres(phasetuple(tup)%lokvares)%dgm).lt.1.0D-9) then call get_phasetup_name(tup,name) if(gx%bmperr.ne.0) goto 1000 jk=len_trim(name) if(ik+10.gt.len(line)) then line(ik:)=' ...' elseif(jk.gt.8) then line(ik:)=name(1:6)//'..' line(ik+8:)=name(jk-1:jk) ik=ik+11 else line(ik:)=name ik=len_trim(line)+2 endif ! else ! continue endif ! find higher composition sets of this phase tup=phasetuple(tup)%nextcs if(tup.gt.0) goto 100 enddo ! write(*,*)'3C phaseline: ',line 1000 continue return end subroutine line_with_phases_withdgm0 !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine list_equilibria_details !\begin{verbatim} subroutine list_equilibria_details(mode,teq) ! not used yet ... ?? implicit none TYPE(gtp_equilibrium_data), pointer :: teq integer mode !\end{verbatim} TYPE(gtp_equilibrium_data), pointer :: ceq ! TYPE(gtp_phase_varres) :: varres integer ieq,noofeq,iph noofeq=noeq() select case(mode) case default write(*,*)'3C No such mode: ',mode !-------------------------------------------------- case(1) ! list equilibria and some general data write(*,10)noofeq 10 format('3C Number of equilibria: ',i3) do ieq=1,noofeq ceq=>eqlista(ieq) write(*,11)ceq%eqno,ceq%eqname 11 format('3C Equilibrium ',i3,', ',a) enddo !-------------------------------------------------- case(100:199) ! list phase varres data for phase mod(mode,100) iph=mod(mode,100) if(iph.eq.0) then write(*,*)'3C all phases' else write(*,*)'3C phase ',iph endif end select 1000 continue return end subroutine list_equilibria_details !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable logical function gtp_error_message !\begin{verbatim} logical function gtp_error_message(reset) ! tests the error code and writes the error message (if any) ! and reset error code if reset=0 ! if reset >0 that is set as new error message ! if reset <0 the error code is not changed ! return TRUE if error code set, FALSE if error code is zero implicit none integer reset !\end{verbatim} if(gx%bmperr.ne.0) then if(gx%bmperr.ge.4000 .and. gx%bmperr.le.nooferm) then write(kou,10)gx%bmperr,bmperrmess(gx%bmperr) 10 format(' *** Error ',i5/a) elseif(gx%bmperr.ne.0) then write(*,20)gx%bmperr 20 format('3C Error without message: ',i7) endif if(reset.eq.0) then ! if reset zero reset error code gx%bmperr=0 elseif(gx%bmperr.gt.0) then ! if reset positive set this as error code gx%bmperr=reset endif ! if reset negative do not change error code. Set function to TRUE gtp_error_message=.TRUE. else ! no error, return false gtp_error_message=.FALSE. endif 1000 continue return end function gtp_error_message !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine listoptcoeff !\begin{verbatim} subroutine listoptcoeff(mexp,error2,done,lut) ! listing of optimizing coefficients integer lut,mexp ! error2 is an array with 1: old error, 2: new error; 3: normalized error double precision error2(*) logical done ! integer lut,mexp ! double precision errs(*) ! type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} type(gtp_equilibrium_data), pointer :: neweq integer i1,i2,j1,j2,j3,k1,nvcoeff character name1*24,where*80 double precision xxx logical rescale ! rescale=.false. write(lut,610) 610 format(/'List of coefficients with non-zero values'/& 'Name Current value Start value Scaling factor RSD',10x,& 'Used in') name1=' ' nvcoeff=0 do i1=0,size(firstash%coeffstate)-1 ! write(*,*)'3C coeffstate: ',i1,firstash%coeffstate(i1) coeffstate: if(firstash%coeffstate(i1).ge.10) then ! optimized variable, read from TP constant array call get_value_of_constant_index(firstash%coeffindex(i1),xxx) call makeoptvname(name1,i1) call findtpused(firstash%coeffindex(i1),where) ! write(lut,615)name1(1:3),xxx,& write(lut,615)name1(1:3),xxx,& ! firstash%coeffvalues(i1)*firstash%coeffscale(i1),& firstash%coeffstart(i1),firstash%coeffscale(i1),& firstash%coeffrsd(i1),trim(where) 615 format(a,2x,4(1pe14.5),2x,a) if(abs(xxx-firstash%coeffscale(i1)).gt.1.0D-4*abs(xxx)) then ! write(*,*)'3C why?:' rescale=.true. endif ! if(abs(xxx-firstash%coeffvalues(i1)*firstash%coeffscale(i1))& ! .gt.1e-4) then ! write(*,*)'3C scaled and current: ',xxx,& ! firstash%coeffvalues(i1)*firstash%coeffscale(i1) ! endif if(firstash%coeffstate(i1).eq.11) then ! there is a prescribed minimum write(lut,616)' minimum ',firstash%coeffmin(i1) 616 format(6x,'Prescribed ',a,': ',1pe12.4) nvcoeff=nvcoeff+1 elseif(firstash%coeffstate(i1).eq.12) then ! there is a prescribed maximum write(lut,616)' maximum ',firstash%coeffmax(i1) nvcoeff=nvcoeff+1 elseif(firstash%coeffstate(i1).eq.13) then ! there are prescribed minimum and maximum write(lut,617)firstash%coeffmin(i1),firstash%coeffmax(i1) 617 format(6x,'Prescribed min and max: ',2(1pe12.4)) nvcoeff=nvcoeff+1 elseif(firstash%coeffstate(i1).gt.13) then write(lut,*)'Wrong coefficient state, set to 10' !?? ! firstash%coeffstate(i2)=10 firstash%coeffstate(i1)=10 endif nvcoeff=nvcoeff+1 elseif(firstash%coeffstate(i1).gt.0) then ! coefficient is fix with non-zero value call get_value_of_constant_index(firstash%coeffindex(i1),xxx) call makeoptvname(name1,i1) call findtpused(firstash%coeffindex(i1),where) write(lut,618)name1(1:3),xxx,trim(where) 618 format(a,2x,1pe14.5,44x,a) ! elseif(firstash%coeffscale(i1).ne.0) then ! No idea why this code exits why check coeffscale ?? ! coefficient with negative status, status set to 1 ?why? ! call get_value_of_constant_index(firstash%coeffindex(i1),xxx) ! write(lut,619)i1,firstash%coeffscale(i1),xxx,zero !619 format('Wrong state for coefficient ',i3,4(1pe12.4)) ! firstash%coeffstate(i1)=1 endif coeffstate enddo ! give a warning if parameters need to be rescaled if(rescale) then write(lut,717) 717 format(/'In order to have correct RSD values use the command',& ' AMEND OPT_COEF Y'/'and optimize again.'/) endif ! sum=zero ! do j1=1,mexp ! sum=sum+errs(j1)**2 ! enddo ! IGNORE DONE and repeat results ... ! if(done) then ! only if there are results j1=mexp-nvcoeff ! if(j1.gt.0) then write(lut,621)error2(2),mexp,nvcoeff,j1,error2(3) ! else ! write(lut,621)error2(2),mexp,nvcoeff,0,zero ! endif 621 format(/'Final sum of squared errors: ',1pe16.5/& 'using ',i4,' experiments and ',i3,' coefficients.'/& 'Degrees of freedom: ',i4,', normalized error: ',1pe13.4/) ! endif 1000 continue return end subroutine listoptcoeff !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ ================================================ FILE: src/models/gtp3D.F90 ================================================ ! ! gtp3D included in gtp3.F90 ! !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !> 8. Interactive things !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine ask_phase_constitution !\begin{verbatim} subroutine ask_phase_constitution(cline,last,iph,ics,lokcs,ceq) ! interactive input of a constitution of phase iph implicit none integer last,iph,ics,lokcs character cline*(*) !\end{verbatim} %+ ! NOTE a strange bug when calculating a phase ! the result is different if one sets the constitution explicitly the same!! character name1*24,quest*32 double precision yarr(maxcons2),sites(maxsubl),qq(5),yyy,xxx,sss,ydef integer knl(maxsubl),knr(maxcons2) character line*64,ch1*1,crest*24 character :: lastph*24=' ' ! changed default to N ! character*1 :: chd='Y' character*1 :: chd='N' integer qph,lokph,nsl,kkk,loksp,ip,ll,nr,yrest TYPE(gtp_equilibrium_data), pointer :: ceq logical once ! save here to use the same default as last time save chd,lastph call gparcdx('Phase name: ',cline,last,1,name1,lastph,'?Amend phase constit') if(name1(1:2).eq.'* ') then ! this means all phases and composition sets ! If iph is -1 than this is not allowed!! if(iph.lt.0) then write(kou,*)'Wildcard not allowed in this case' goto 1000 endif qph=-1 iph=1 ics=1 call get_phase_name(iph,ics,name1) if(gx%bmperr.ne.0) goto 1000 else qph=0 call find_phase_by_name(name1,iph,ics) if(gx%bmperr.ne.0) goto 1000 ! remember the phase name lastph=name1 endif 100 continue ! write(*,*)'3D spc 1',qph,iph,ics,name1 ! skip hidden and suspended phases, test_phase_status return ! -4 hidden, -3 suspend, -2 dormant, -1,0, entered, 2 fixed if(qph.lt.0 .and. test_phase_status(iph,ics,xxx,ceq).le.PHDORM) goto 200 ! if(qph.lt.0 .and. (phase_status(iph,ics,PHHID,ceq) .or.& ! phase_status(iph,ics,PHIMHID,ceq) .or.& ! (phase_status(iph,ics,CSSUS,ceq) .and. & ! .not.phase_status(iph,ics,CSFIXDORM,ceq)))) goto 200 ! lokph=phases(iph) call get_phase_compset(iph,ics,lokph,lokcs) if(gx%bmperr.ne.0) goto 1000 call get_phase_data(iph,ics,nsl,knl,knr,yarr,sites,qq,ceq) if(gx%bmperr.ne.0) goto 1000 !-------------------- ! strange error 2026.02.10 ! write(*,55)(yarr(ll),ll=1,knr(1)) !55 format(' bug: ',15(f8.5)) !-------------------- ! ask for amount of formula units, default is current amount yyy=ceq%phase_varres(lokcs)%amfu quest='Amount of '//name1 call gparrdx(quest,cline,last,xxx,yyy,'?Amend phase constit') ! if input error quit asking more if(buperr.ne.0) then buperr=0; goto 1000 endif ceq%phase_varres(lokcs)%amfu=xxx ! ask if we should set the current constitution, ignore default ! write(*,*)'3D we are here!' call gparcdx('Current (Y), default (D) or new (N) constitution?',& cline,last,1,ch1,chd,'?Amend phase constit') if(ch1.eq.'Y' .or. ch1.eq.'y') then chd='Y' ! set the old constitution explicitly!! ! without this seemingly unnecessary call to set the same constution the ! calculate phase gives sometimes wrong values! call set_constitution(iph,ics,yarr,qq,ceq) goto 200 elseif(ch1.eq.'d' .or. ch1.eq.'D') then chd='D' call set_default_constitution(iph,ics,ceq) goto 200 else ! constitution entered interactivly chd='N' endif ! ask for constitution write(kou,'(a,a)')'NOTE: For a constituent which should be the rest,',& ' give "rest"' kkk=0 nylat: do ll=1,nsl yrest=0 ! ydef=one sss=one if(knl(ll).eq.1) then kkk=kkk+1; cycle nylat else ! default new constitution is 1/(constituents in sublattice) ydef=one/real(knl(ll)) endif nycon: do nr=1,knl(ll) if(nr.eq.knl(ll) .and. yrest.eq.0) then cycle nycon endif kkk=kkk+1 loksp=phlista(lokph)%constitlist(kkk) line='Fraction of '//splista(loksp)%symbol ip=len_trim(line)+1 if(ll.gt.1) then line(ip:)='#'//char(ll+ichar('0')) ip=ip+2 endif once=.true. 20 continue ydef=min(yarr(kkk),ydef) call gparrdx(line(1:ip+2),cline,last,xxx,ydef,'?Amend phase constit') if(buperr.ne.0) then ! write(*,*)'3D Allow REST: ',trim(cline),last,buperr,yrest buperr=0 if(yrest.eq.0) then crest=cline(last:last+3) call capson(crest) if(crest(1:4).eq.'REST') then yrest=nr last=len(cline) crest=splista(loksp)%symbol cycle nycon endif endif endif if(xxx.lt.zero) then if(once) then write(*,*)'A fraction must be greater than zero' yarr(kkk)=1.0D-12 once=.false. goto 20 else gx%bmperr=4146; goto 1000 endif endif sss=sss-xxx if(sss.lt.zero) then xxx=max(sss+xxx,1.0D-12) sss=-1.0D12 write(*,21)'Sum of fractions larger 1.0, fraction set to: ',xxx 21 format(a,1pe12.4) ydef=1.0D-12 else ! ydef=sss ! reduce by dividing with the remaining constituents ydef=sss/real(knl(ll)-nr) endif ! write(*,*)'ydef: ',ydef,sss yarr(kkk)=xxx enddo nycon ! if yrest is zero the last constituent is set to the rest, otherwise yrest if(yrest.eq.0) then kkk=kkk+1 yarr(kkk)=max(sss,1.0D-12) write(*,21)'Last fraction set to: ',yarr(kkk) else yarr(yrest)=max(sss,1.0D-12) write(*,21)'Fraction of '//trim(crest)//' set to: ',yarr(yrest) endif enddo nylat ! set the new constitution call set_constitution(iph,ics,yarr,qq,ceq) ! if all phases loop 200 continue if(qph.lt.0) then if(gx%bmperr.eq.4050) then ! error no such phase, quit gx%bmperr=0; goto 1000 elseif(gx%bmperr.eq.4072) then ! error no such composition set, take next phase gx%bmperr=0 iph=iph+1 ics=1 else ics=ics+1 endif call get_phase_name(iph,ics,name1) if(gx%bmperr.ne.0) goto 200 goto 100 endif 1000 continue ! return -1 as phase number of loop for all phases made if(qph.lt.0) iph=-1 return end subroutine ask_phase_constitution !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine ask_phase_new_constitution !\begin{verbatim} %- subroutine ask_phase_new_constitution(cline,last,iph,ics,lokcs,ceq) ! interactive input of a constitution of phase iph implicit none integer last,iph,ics,lokcs character cline*(*) !\end{verbatim} character name1*24,quest*32 double precision yarr(maxcons2),sites(maxsubl),qq(5),yyy,xxx,sss,ydef integer knl(maxsubl),knr(maxcons2) character line*64,ch1*1 character*1 :: chd='Y' integer qph,lokph,nsl,kkk,loksp,ip,ll,nr TYPE(gtp_equilibrium_data), pointer :: ceq logical once ! save here to use the same default as last time save chd qph=0 ! call gparc('Phase name: ',cline,last,1,name1,' ',q1help) ! if(name1(1:2).eq.'* ') then ! this means all phases and composition sets ! qph=-1 ! iph=1 ! ics=1 ! call get_phase_name(iph,ics,name1) ! if(gx%bmperr.ne.0) goto 1000 ! else ! qph=0 ! call find_phase_by_name(name1,iph,ics) ! if(gx%bmperr.ne.0) goto 1000 ! endif 100 continue ! write(*,*)'3D spc 1',qph,iph,ics,name1 ! skip hidden and suspended phases, test_phase_status return ! -4 hidden, -3 suspend, -2 dormant, -1,0, entered, 2 fixed ! if(qph.lt.0 .and. test_phase_status(iph,ics,xxx,ceq).le.PHDORM) goto 200 ! if(qph.lt.0 .and. (phase_status(iph,ics,PHHID,ceq) .or.& ! phase_status(iph,ics,PHIMHID,ceq) .or.& ! (phase_status(iph,ics,CSSUS,ceq) .and. & ! .not.phase_status(iph,ics,CSFIXDORM,ceq)))) goto 200 ! lokph=phases(iph) call get_phase_compset(iph,ics,lokph,lokcs) if(gx%bmperr.ne.0) goto 1000 call get_phase_data(iph,ics,nsl,knl,knr,yarr,sites,qq,ceq) if(gx%bmperr.ne.0) goto 1000 ! ask for amount of formula units, default is current amount ! yyy=ceq%phase_varres(lokcs)%amfu ! quest='Amount of '//name1 ! NOTE name is not set! ! call gparrd(quest,cline,last,xxx,yyy,q1help) ! if input error quit asking more ! if(buperr.ne.0) then ! buperr=0; goto 1000 ! endif ! ceq%phase_varres(lokcs)%amfu=abs(xxx) ! ask if we should set the default constitution ! write(*,*)'3D we are really here?' call gparcdx('Default constitution?',cline,last,1,ch1,chd,& '?Amend phase constit') if(ch1.eq.'Y' .or. ch1.eq.'y') then call set_default_constitution(iph,ics,ceq) if(gx%bmperr.ne.0) goto 1000 chd='Y' goto 200 else chd='N' endif ! ask for constitution kkk=0 nylat: do ll=1,nsl sss=one ydef=one nycon: do nr=1,knl(ll)-1 kkk=kkk+1 loksp=phlista(lokph)%constitlist(kkk) line='Fraction of '//splista(loksp)%symbol ip=len_trim(line)+1 if(ll.gt.1) then line(ip:)='#'//char(ll+ichar('0')) ip=ip+2 endif once=.true. 20 continue ydef=min(yarr(kkk),ydef) call gparrdx(line(1:ip+2),cline,last,xxx,ydef,'?Amend phase constit') if(xxx.lt.zero) then if(once) then write(*,*)'A fraction must be greater than zero' yarr(kkk)=1.0D-12 once=.false. goto 20 else gx%bmperr=4146; goto 1000 endif endif sss=sss-xxx if(sss.lt.zero) then xxx=max(sss+xxx,1.0D-12) sss=-1.0D12 write(*,21)'Sum of fractions larger 1.0, fraction set to: ',xxx 21 format(a,1pe12.4) ydef=1.0D-12 else ydef=sss endif ! write(*,*)'ydef: ',ydef,sss yarr(kkk)=xxx enddo nycon ! the last constituent is set to the rest kkk=kkk+1 yarr(kkk)=max(sss,1.0D-12) write(*,21)'Last fraction set to: ',yarr(kkk) enddo nylat ! set the new constitution call set_constitution(iph,ics,yarr,qq,ceq) ! if all phases loop 200 continue ! if(qph.lt.0) then ! if(gx%bmperr.eq.4050) then ! error no such phase, quit ! gx%bmperr=0; goto 1000 ! elseif(gx%bmperr.eq.4072) then ! error no such composition set, take next phase ! gx%bmperr=0 ! iph=iph+1 ! ics=1 ! else ! ics=ics+1 ! endif ! call get_phase_name(iph,ics,name1) ! if(gx%bmperr.ne.0) goto 200 ! goto 100 ! endif 1000 continue ! return -1 as phase number of loop for all phases made if(qph.lt.0) iph=-1 return end subroutine ask_phase_new_constitution !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine enter_parameter_interactivly !\begin{verbatim} subroutine enter_parameter_interactivly(cline,ip,mode) ! enter a parameter from terminal or macro ! NOTE both for ordered and disordered fraction set !! ! mode = 0 for entering ! 1 for listing on screen (kou) implicit none integer ip,mode character cline*(*) !\end{verbatim} character name1*24,name2*24,longline*256,refx*16,elnam*24 ! funame only 16 first characters will be used character name3*64,ch1*1,line*64,parname*64,funame*24 integer typty,lint(2,5),fractyp,typty1,kp,lp1,kel,kq,iel,isp,lk3,lp2 integer jph,ics,lokph,ll,k4,nint,jp,lsc,ideg,kk,lfun,nsl,loksp integer, dimension(maxsubl) :: endm(maxsubl) double precision xxx ! lk3=0 10 continue if(mode.eq.1) then call gparcx('Parameter name: ',cline,ip,7,parname,' ','?Amend parameter') else call gparcx('Parameter name: ',cline,ip,7,parname,' ','?Enter parameter') endif ! simple parameter names are like G(SIGMA,FE:CR:FE,CR;1) ! no spaces allowed .... kp=index(parname,' ') jp=index(parname,')') ! check if there is ext after space if(jp.eq.0) then write(*,*)'A parameter name must be terminated by ), please reenter' gx%bmperr=4028; goto 1000 elseif(kp.lt.jp) then write(*,*)'No spaces allowed in a parameter name, please reenter' gx%bmperr=4028; goto 1000 endif ! this has been here since the beginning, keep it parname(kp:)=' ' ! ! extract symbol, normally G or L but TC and others can occur ! for example a mobility like MQ&FE+2#3 where FE+2#3 is a constinuent ! in sublattice 3 ! NO ABBREVIATION IS ACCEPTED, for example not BM for BMAGN lp1=index(parname,'(') ! write(*,*)'3D in parname: ',trim(parname),lp1 if(lp1.le.1) then gx%bmperr=4027; goto 1000 endif ! name1 is everything up to ( name1=parname(1:lp1-1) call capson(name1) ! It can be a mobility with a & inside kel=index(name1,'&') if(kel.gt.0) then ! note that elnam may contain sublattice specification like Fe+2#2 elnam=name1(kel+1:) name1=name1(1:kel-1) ! write(*,*)'3D elnam: ',elnam endif kq=len_trim(name1) ! write(*,*)'3D: fractyp: ',kq,name1(1:kq) ! if(name1(kq:kq).eq.'D') then ! A final "D" on the paramer symbol indicates fractyp=2 ! THIS FEATURE NO LONGER SUPPORTED ! name1(kq:kq)=' ' ! fractyp=2 ! else ! fractyp=1 ! endif ! the fractyp must be checked inside enter_parameter fractyp=1 ! find the property associated with this symbol do typty=1,ndefprop ! write(*,*)'Property symbol: "',propid(typty)%symbol,'"' if(name1(1:4).eq.propid(typty)%symbol) then goto 70 endif enddo ! no matching symbol write(kou,*)'3D unknown parameter type, please reenter: ',& name1(1:len_trim(name1)) parname=' '; goto 10 ! typty is the parameter symbol index 70 continue typty1=typty iel=0; isp=0 ! the beginning of the TP function name ! funame='_'//propid(typty1)%symbol(1:1) funame='_'//propid(typty1)%symbol if(kel.gt.0) then ! there is a specifier, check if correct element or species kel=index(elnam,'#') if(kel.gt.0) then ! extract sublattice number 1-9 specification lk3=ichar(elnam(kel+1:kel+1))-ichar('0') ! write(*,73)elnam(kel+1:kel+1),kel,elnam,lk3 !73 format('3D sublattice: "',a,'" position: ',i3,' in ',a,' : ',i3) elnam(kel:)=' ' endif if(btest(propid(typty)%status,IDELSUFFIX)) then ! write(*,*)'3D: elnam: ',kel,lk3,typty,elnam call find_element_by_name(elnam,iel) if(gx%bmperr.ne.0) then write(kou,*)'3D Unknown element ',elnam,& ' in parameter type MQ, please reenter' goto 1000 ! parname=' '; gx%bmperr=0; goto 10 endif typty=100*typty+iel elseif(btest(propid(typty)%status,IDCONSUFFIX)) then ! to know the constituents we must know the phase but as we do not know ! the phase name yet but check the species exists !!! ! write(*,*)'3D: conname: ',kel,lk3,typty,elnam call find_species_by_name(elnam,isp) if(gx%bmperr.ne.0) then ! This is not an error, the species may simply not be selected !!! write(kou,*)'Unknown species ',trim(elnam),& ' in parameter type MQ, please reenter',gx%bmperr goto 1000 ! parname=' '; gx%bmperr=0; goto 10 endif ! convert from index to location, loksp loksp=species(isp) if(lk3.eq.0) then ! sublattice after # saved in lk3 above, if none (0) assume 1 lk3=1 endif else write(kou,*)'3D This model parameter identifier has no specifier' gx%bmperr=4168; goto 1000 endif ! this is the property type stored in property record else ! check if there should be a specifier !! if(btest(propid(typty)%status,IDELSUFFIX) .or. & btest(propid(typty)%status,IDCONSUFFIX)) then write(*,*)'3D Parameter specifier missing' gx%bmperr=4169; goto 1000 endif endif ! 4027? ! extract phase name and constituent array lp1=index(parname,'(') lp2=index(parname,',') if(lp2.lt.lp1) then gx%bmperr=4028; goto 1000 endif name2=parname(lp1+1:lp2-1) ! write(*,*)'enter_parameter_inter 1: ',lp1,lp2,name2 call find_phase_by_name_exact(name2,jph,ics) if(gx%bmperr.ne.0) then ! special case for reference phase gx%bmperr=0; call capson(name2) if(name2.eq.'SELECT_ELEMENT_REFERENCE') then jph=0; ics=1 else write(kou,*)'Unknown phase name, please reenter' kp=len(cline) goto 10 endif endif lokph=phases(jph) ! add the full phase name to the function name. Remove any _ or numbers ,,, ! ll=len_trim(funame)+1 ! funame(3:)=phlista(lokph)%name ! only save first letter of parameter type, no problem with duplicate names ll=3 funame(ll:)=phlista(lokph)%name ! write(*,*)'3D funame 1: ',trim(funame),', ',name2 ll=4 74 continue if(funame(ll:ll).eq.'_') then funame(ll:)=funame(ll+1:) goto 74 elseif(ll.lt.9) then ll=ll+1 goto 74 endif ! eliminate anything from position 9 MODIFIED when adding MQMQA ! eliminate anything from position 7 funame(7:)=' ' ! write(*,*)'3D funame 2: ',trim(funame) ! if the parameter symbol has a constituent specification check that now ! write(*,*)'3D lk3 and isp: ',lk3,isp if(lk3.gt.0 .and. isp.gt.0) then ! No check for elements ... k4=0 do ll=1,phlista(lokph)%noofsubl ! careful ll is double letter l, not 11 (eleven) if(lk3.eq.0 .or. lk3.eq.ll) then do kk=1,phlista(lokph)%nooffr(ll) k4=k4+1 if(phlista(lokph)%constitlist(k4).eq.loksp) goto 80 enddo elseif(ll.lt.lk3) then k4=k4+phlista(lokph)%nooffr(ll) endif enddo ! constituent not found write(kou,*)'3D Parameter symbol contains unknown constituent' gx%bmperr=4066; goto 1000 ! constituent found in right sublattice 80 continue typty=100*typty+k4 ! write(*,81)'3D: found: ',typty1,typty,lk3,k4,loksp 81 format(a,10i4) endif ! write(*,*)'enter_parameter_inter 2: ',jph,lokph ! extract constituent array, remove final ) and decode name3=parname(lp2+1:) lp1=len_trim(name3) ! this removes the final ) name3(lp1:)=' ' ! ! write(*,*)'3D decoding constituent array' call decode_constarr(lokph,name3,nsl,endm,nint,lint,ideg) if(gx%bmperr.ne.0) goto 1000 ! write(*,83)'3D after d_c: ',name3(1:lp1),nint,(lint(2,kp),kp=1,nint) 83 format(a,a,i5,2x,5i4) kp=len_trim(funame) funame(kp+1:)=name3 call capson(funame) ! finally remove all non-alphabetical characters in the function name by _ kp=3 100 continue kp=kp+1 105 continue ! ch1=parname(kp:kp) ch1=funame(kp:kp) ! should use ?? ! if(ucletter(ch1)) goto 100 if(ch1.ge.'A' .and. ch1.le.'Z') goto 100 if(ch1.ne.' ') then ! parname(kp:)=parname(kp+1:) funame(kp:)=funame(kp+1:) if(kp.lt.16) goto 105 endif funame(17:)=' ' kp=len_trim(funame) if(kp.lt.16) funame(kp+1:kp+1)=char(ideg+ichar('0')) ! write(*,*)'3D funame 3: ',trim(funame),', ',trim(name3) ! parname='_'//parname !------------------------------------------------- ! if mode=0 enter the parameter, ! if mode=1 just list the parameter ! if mode=2 maybe amending (does FOOLED) work? if(mode.eq.1) then lfun=-1 ! write(*,*)'3D calling enter_parameter with lfun=',lfun call enter_parameter(lokph,typty,fractyp,nsl,endm,nint,lint,ideg,& lfun,refx) ! this error means illegal reference ... ! irrelevant but I am not sure where it is set ... if(gx%bmperr.eq.4154) gx%bmperr=0 goto 1000 endif ! continue here to enter the parameter ! If parameter has no T dependendence just ask for value if(btest(propid(typty1)%status,IDNOTP)) then write(kou,*)'This parameter can only be a constant' call gparrx('Value: ',cline,ip,xxx,zero,'?Enter parameter') if(buperr.ne.0) then xxx=zero; buperr=0 endif ! the tpfun always want a low-T, expression; high-T N write(longline,110)xxx 110 format(' 1 ',1pe16.7,'; 20000 N ') jp=len_trim(longline)+2 goto 200 endif if(btest(propid(typty1)%status,IDONLYP)) then write(kou,*)'This parameter may not depend on T, only on P' endif !------------------------------------------------- ! now read the function. call gparrx('Low temperature limit /298.15/:',cline,ip,xxx,2.9815D2,& '?Enter parameter') if(buperr.ne.0) then buperr=0; longline=' 298.15 ' jp=8 else longline=' ' jp=1 call wrinum(longline,jp,8,0,xxx) if(buperr.ne.0) goto 1000 jp=jp+1 endif ! write(*,152)-1,jp,longline(1:jp) !----------------------------------------------- ! return here for new expression in another range lsc=1 115 continue call gparcx('Expression, end with ";":',cline,ip,6,line,';',& '?Enter parameter') if(buperr.ne.0) then buperr=0; line=';' endif 120 continue longline(jp:)=line jp=len_trim(longline)+1 ! write(*,152)0,jp,longline(1:jp) if(index(longline(lsc:),';').le.0) then call gparcx('&',cline,ip,6,line,';','?Enter parameter') if(buperr.ne.0) then buperr=0; line=';' endif goto 120 ! else ! write(*,*)'Found ; at ',index(longline,';') endif 150 continue jp=jp+1 ! write(*,152)0,jp,longline(1:jp) ! lsc is positioned after the ; of previous ranges lsc=jp ! write(*,152)1,ip,cline(1:ip) call gparrx('Upper temperature limit /6000/:',cline,ip,xxx,6.0D3,& '?Enter parameter') if(buperr.ne.0) then buperr=0; xxx=6.0D3 endif call wrinum(longline,jp,8,0,xxx) if(buperr.ne.0) goto 1000 call gparcdx('Any more ranges',cline,ip,1,ch1,'N','?Enter parameter') if(ch1.eq.'n' .or. ch1.eq.'N') then longline(jp:)=' N' jp=jp+3 else longline(jp:)='Y' jp=jp+2 goto 115 endif ! jump here for parameters that are constants 200 continue call gparcdx('Reference symbol:',cline,ip,1,refx,'UNKNOWN',& '?Enter parameter') call capson(refx) longline(jp:)=refx jp=len_trim(longline)+1 ! write(*,252)2,jp,longline(1:jp) 252 format('3D ep: ',2i3,'>',a,'<') ! call capson(longline(1:jp)) ! write(*,*)'3D epi: ',longline(1:jp) ! call enter_tpfun(parname,longline,lfun,.FALSE.) ! write(*,*)'3D funame: ',trim(funame) ! call store_tpfun(funame,longline,lfun,.FALSE.) ! last argumnent -1 means not reading from TDB file call store_tpfun(funame,longline,lfun,-1) if(gx%bmperr.ne.0) goto 1000 ! write(*,290)'3D enter_par 7: ',lokph,nsl,nint,ideg,lfun,refx 290 format(a,5i4,1x,a) ! call enter_parameter(lokph,typty,fractyp,nsl,endm,nint,lint,ideg,lfun,refx) ! 1000 continue return end subroutine enter_parameter_interactivly !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine amend_global_data !\begin{verbatim} subroutine amend_global_data(cline,ipos) implicit none character cline*(*) integer ipos !\end{verbatim} character name*24,current*24,ch1*1,chd*1 current=globaldata%name ! write(*,*)'entering amend_global_data: ',cline(1:30) call gparcdx('System name: ',cline,ipos,1,name,current,'?Amend general') if(proper_symbol_name(name,0)) then globaldata%name=name else write(kou,*)'Illegal name ignored' goto 1000 endif 100 continue chd='N' if(btest(globaldata%status,GSBEG)) then chd='B' elseif(btest(globaldata%status,GSADV)) then chd='E' else chd='F' endif call gparcdx('I am a beginner (B), frequent user (F) or expert (E): ',& cline,ipos,1,ch1,chd,'?Amend general') call capson(ch1) globaldata%status=ibclr(globaldata%status,GSBEG) globaldata%status=ibclr(globaldata%status,GSADV) globaldata%status=ibclr(globaldata%status,GSOCC) if(ch1.eq.'B') then globaldata%status=ibset(globaldata%status,GSBEG) elseif(ch1.eq.'E') then globaldata%status=ibset(globaldata%status,GSADV) else ! set as frequent (occational?) user globaldata%status=ibset(globaldata%status,GSOCC) endif 120 continue ! is global minimization allowed? chd='Y' if(btest(globaldata%status,GSNOGLOB)) chd='N' call gparcdx('Global gridminimization allowed: ',& cline,ipos,1,ch1,chd,'?Amend general') if(ch1.eq.'Y' .or. ch1.eq.'y') then globaldata%status=ibclr(globaldata%status,GSNOGLOB) else globaldata%status=ibset(globaldata%status,GSNOGLOB) endif ! allow merging gridpoints after global? chd='Y' if(btest(globaldata%status,GSNOMERGE)) chd='N' call gparcdx('Merging gridpoints in same phase allowed: ',& cline,ipos,1,ch1,chd,'?Amend general') if(ch1.eq.'Y' .or. ch1.eq.'y') then globaldata%status=ibclr(globaldata%status,GSNOMERGE) else globaldata%status=ibset(globaldata%status,GSNOMERGE) endif ! GSNOACS can be changed interactivly, 0 means allowed chd='Y' if(btest(globaldata%status,GSNOACS)) chd='N' call gparcdx('Composition sets can be created automatically? ',& cline,ipos,1,ch1,chd,'?Amend general') if(ch1.eq.'Y' .or. ch1.eq.'y') then globaldata%status=ibclr(globaldata%status,GSNOACS) else globaldata%status=ibset(globaldata%status,GSNOACS) endif ! GSNOREMCS can be changed interactivly, 0 means not remove chd='Y' if(btest(globaldata%status,GSNOREMCS)) chd='N' call gparcdx('Delete unnecessary composition sets automatically? ',& cline,ipos,1,ch1,chd,'?Amend general') if(ch1.eq.'Y' .or. ch1.eq.'y') then globaldata%status=ibclr(globaldata%status,GSNOREMCS) else globaldata%status=ibset(globaldata%status,GSNOREMCS) endif 1000 continue return end subroutine amend_global_data !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine enter_bibliography_interactivly !\begin{verbatim} subroutine enter_bibliography_interactivly(cline,last,mode,iref) ! enter a reference for a parameter interactivly ! mode=0 means enter, =1 amend implicit none character cline*(*) integer last,mode,iref logical twotries !\end{verbatim} ! stupid with a variable called CHAR80 character line*256,refid*16,CHAR80*80 integer jl,ip call gparcx('Reference identifier:',cline,last,1,refid,' ',& '?Amend bibliography') if(buperr.ne.0 .or. refid(1:1).eq.' ') then ! write(kou,*)'There must be an identifier' gx%bmperr=4155; goto 1000 endif call capson(refid) ! check if unique, if mode=0 illegal do jl=1,reffree-1 if(refid.eq.bibrefs(jl)%reference) then if(mode.eq.0) then ! write(kou,*)'Reference identifier not unique' gx%bmperr=4156;goto 1000 else goto 70 endif endif enddo ! if mode=1 one should have found the reference if(mode.eq.1) then write(kou,*)'No such reference' goto 1000 endif 70 continue ip=0 line=' ' twotries=.TRUE. 100 continue ! call gparc('Reference text, end with ";":',cline,last,5,char80,';',q1help) call gparcx('Reference text, end with ";":',cline,last,5,char80,';',& '?Amend bibliography') line(ip+1:)=char80 ip=len_trim(line) if(ip.le.1 .and. twotries) then twotries=.FALSE. write(kou,*)'There must be some bibilograpic text!' ip=1; goto 100 elseif(line(ip:ip).ne.';') then twotries=.FALSE. write(*,*)'Terminate text with a ";"' ip=ip+1; goto 100 elseif(ip.le.1 .and. .not.twotries) then if(mode.eq.1) then write(*,*)'Bibliogaphic reference unchanged' else write(*,*)'Bibliogaphic reference not entered' endif goto 1000 else line(ip:)=' ' endif call tdbrefs(refid,line,1,iref) 1000 continue return end subroutine enter_bibliography_interactivly !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine enter_experiment !\begin{verbatim} subroutine enter_experiment(cline,ip,ceq) ! enters an experiment, almost the same as set_condition implicit none character cline*(*) integer ip type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ ! New is set to the new condition or experiment ! in set_condition new is not used for anything. ! in this subroutine the new variable is removed from the condition list ! and instead added to the experimenal list integer kp,jc,istv,qp type(gtp_condition), pointer :: new,temp ! integer nidlast,nidfirst,nidpre double precision xxx,yyy character usymbol*16,ch1*1 ! do not allow experiments in first equilibrium!! if(ceq%eqno.eq.1) then write(kou,16) 16 format('Experiments are not allowed in the default equilibrium') goto 1000 endif ! ! return here if more experiments 17 continue ! inside here things are done ! write(*,*)'3D exp1: ',trim(cline),ip call set_cond_or_exp(cline,ip,new,1,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,'(a,a,2i4)')'3D exp2: ',trim(cline),ip,new%active if(new%active.ne.1) then ! the experiment is removed (inactivated) if activate is 1 ! otherwise read the uncertainty to be set ! write(*,*)'3D after set_c_or_e:',ip,': ',trim(cline),new%uncertainty ! set the default uncertainty to 10% of value if(new%uncertainty.gt.zero) then yyy=1.0D-1*abs(new%prescribed) else yyy=new%uncertainty endif kp=ip ! bug reading the value after : ?? ! write(*,*)'3D uncertanity 2: ',ip,'"'//trim(cline)//'"' ! NOTE that gparcd increments ip before seaching for value ! write(*,*)'3D Calling gparcd: ',trim(cline),ip call gparcdx('Uncertainty: ',cline,ip,1,usymbol,'1.0',& '?Enter experiment') ! write(*,*)'3D extracted uncertainity: ',ip,buperr,'"'//usymbol//'"' jc=1 call getrel(usymbol,jc,xxx) ! read(*,'(a)')ch1 ! if(ch1.eq.'q') stop 'wrong place ...' ! write(*,*)'3D even more: ',xxx,buperr if(buperr.eq.0) then ! usymbol is a numeric value !! if(xxx.le.zero) then write(*,*)'Uncertainty must not be zero, set to 0.1 of value' xxx=0.1*new%prescribed endif new%symlink2=0 new%uncertainty=abs(xxx) else ! we should check that the symbol is not an expression ... how? buperr=0 call capson(usymbol) call find_svfun(usymbol,istv) ! write(*,*)'3D uncertainty symbol: ',usymbol,istv if(gx%bmperr.ne.0) then write(*,*)'3D No such symbol: ',usymbol,& ' uncertainty set to 0.1 of value' xxx=0.1*new%prescribed new%symlink2=0 new%uncertainty=abs(xxx) else ! check that the symbol is a constant if(.not.btest(svflista(istv)%status,SVCONST)) then write(*,*)'3D Experimental uncertainty symbol must be a value' gx%bmperr=4399; goto 1000 endif new%symlink2=istv endif endif ! this is for relative errors, if last character is % it is a relative error!! ! write(*,*)'3D relative errors: ',ip,len_trim(cline),'"',trim(cline),'"' if(ip.lt.len(cline)) then qp=len_trim(cline) if(cline(ip:ip).eq.'%' .or. cline(qp:qp).eq.'%') then if(new%experimenttype.eq.0) then new%experimenttype=100 ! write(*,*)'3D error is relative!' else ! the experiment is an inequality write(kou,*)'3D *** Inequalites must have absolute uncertainty' ! new%experimenttype=101*new%experimenttype ??? endif endif endif ! if weight is negative (meaning first experiment) set to unity if(ceq%weight.lt.zero) then ceq%weight=one endif endif ! any more experiments? ! write(*,*)'3D exp4: ',trim(cline),ip,kp,len(cline),len_trim(cline) if(kp.le.ip .and. len_trim(cline).gt.ip) then ! write(*,*)'3D more experiments',trim(cline),kp,ip goto 17 endif 1000 continue end subroutine enter_experiment !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable logical function same_statevariable !\begin{verbatim} %- logical function same_statevariable(svr1,svr2) ! returns TRUE if the state variable records are identical type(gtp_state_variable), pointer :: svr1,svr2 !\end{verbatim} logical same same=.FALSE. if(svr1%statevarid.ne.svr2%statevarid) goto 1000 if(svr1%unit.ne.svr2%unit) goto 1000 if(svr1%phref.ne.svr2%phref) goto 1000 if(svr1%argtyp.ne.svr2%argtyp) goto 1000 if(svr1%argtyp.gt.0) then if(svr1%phase.ne.svr2%phase) goto 1000 if(svr1%argtyp.gt.1) then if(svr1%compset.ne.svr2%compset) goto 1000 if(svr1%argtyp.gt.2) then if(svr1%component.ne.svr2%component) goto 1000 if(svr1%argtyp.gt.3) then if(svr1%constituent.ne.svr2%constituent) goto 1000 endif endif endif endif ! they are the same !!! same=.TRUE. 1000 continue same_statevariable=same return end function same_statevariable !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine set_condition !\begin{verbatim} subroutine set_condition(cline,ip,ceq) ! to set a condition implicit none character cline*(*) integer ip type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ ! New is set to the new condition or experiment ! in this subroutine new is not used for anything. ! in enter_experiment the new variable is removed from the condition list ! and instead added to the experimenal list type(gtp_condition), pointer :: new ! write(*,*)'3D set_cond: ',cline(1:len_trim(cline)),ip call set_cond_or_exp(cline,ip,new,0,ceq) 1000 continue ! always mark that current equilibrium may not be consistent with conditions ceq%status=ibset(ceq%status,EQINCON) nullify(new) end subroutine set_condition !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine set_cond_or_exp !\begin{verbatim} %- subroutine set_cond_or_exp(cline,ip,new,notcond,ceq) ! decode an equilibrium condition, can be an expression with + and - ! the expression should be terminated with an = or value supplied on next line ! like "T=1000", "x(liq,s)-x(pyrrh,s)=0", "mu(cr)-1.5*mu(o)=muval" ! Illegal with number before first state variable !!! ! It can also be a "NOFIX=" or "FIX= value" ! The routine should also accept conditions identified with the ":" ! where is that preceeding each condition in a list_condition ! It should also accept changing conditions by :=new_value ! The pointer to the (most recent) condition or experiment is returned in new ! notcond is 0 if a condition should be created, otherwise an experiment implicit none integer ip,notcond character cline*(*) TYPE(gtp_equilibrium_data), pointer :: ceq TYPE(gtp_condition), pointer :: new !\end{verbatim} %+ integer nterm,kolon,iqz,krp,jp,istv,iref,iunit,jstv,jref,junit,jl,ks integer linkix,norem,ics,kstv,iph,nidfirst,nidlast,nidpre,qp,firstc,lpos ! a long line with conditions can create overflow and lost values ... character stvexp*500,stvrest*500,textval*32,c5*5,ch1 character svtext*500,encoded*60,defval*18,actual_arg*24,svfuname*16 integer indices(4),allterms(4,10),seqz,experimenttype integer ich,back,condvalsym,symsym,nextexp,colon double precision coeffs(10),xxx,value,ccc logical inactivate ! memory leak type(gtp_state_variable), target :: svrvar type(gtp_state_variable), pointer :: svr,svr2 type(gtp_state_variable), dimension(10), target :: svrarr TYPE(gtp_condition), pointer :: temp ! safeguard: call old messy routine ! call set_cond_or_exp_old(cline,ip,new,notcond,ceq) ! return !========================================================================= if(len_trim(cline).gt.400) then write(*,*)'3D *** Too long line with conditions:',len_trim(cline) gx%bmperr=4399; goto 1000 endif ! nullify(temp) xxx=zero symsym=0 iunit=0 iref=0 actual_arg=' ' ! write(*,*)'3D set cond or enter exper: ',trim(cline),ip ! return here to deconde another condition on the same line 50 continue nterm=0 allterms=0 !========================================================================== ! return here to decode anther state variable term for condition ! step 1 extract the state variable termintade by + - = > < or := ! NOT SUFFICIENT, a constituent can have a + or - !!! 55 continue experimenttype=0 nullify(new) if(nterm.eq.0) then ! for second and later term coeffs already set below after call to termterm coeffs(1)=one endif indices=0 ! the list of experiments changes ??? ! NOTE we can have several conditions on the same line!! ! argument 4 equal to 5 of gpar* means extract the whole line stvexp=' ' nextexp=ip ! write(*,56)'3D scoe: ',nterm,ip,trim(cline) 56 format(a,2i3,' "',a,'" ') if(nterm.eq.0) then ! the whole line is read into stvexp, ip is increemented by 1 call gparcdx('State variable: ',cline,ip,5,stvexp,'T','?Set condition') else ! the whole expression must have been entered on the same line ! note cline is updated below !! ip=ip-1 call gparcdx(' ',cline,ip,5,stvexp,'!','?Set condition') endif if(stvexp(1:1).eq.' ') then ! if an expression is terminated with an empty line ask for value if(nterm.gt.0) goto 67 ! if no terms and the line empty return error code for no condition gx%bmperr=4126; goto 1000 elseif(stvexp(1:1).eq.'!') then ! this is an error while continuing reading an expression gx%bmperr=4126; goto 1000 elseif(stvexp(1:3).eq.'FIX') then ! special case when called internally for setting phase fix inactivate=.FALSE. ip=5 goto 299 elseif(stvexp(1:5).eq.'NOFIX') then inactivate=.TRUE. ! write(*,*)'3D Inactivate phase fix condition' ip=7 goto 299 endif ! this can be a condition or experiment ... and have several terms ! check for +, -, =, <, >, or := ! previous value of ip irrelevant, ! ip points at terminator inside stvexp for current state variable ! if lpos>0 is where to start for next term call termterm(stvexp,ich,ip,lpos,ccc) if(gx%bmperr.ne.0) goto 1000 ! write(*,48)'3D tt: ',ich,ip,lpos,trim(stvexp),stvexp(1:ip),ccc 48 format(a,3i4,' "',a,'" >',a,'< ',1pe12.4) if(ich.eq.6) then ! special case when condition number provided, extract the number, can be * ! meaning "all conditions", for example *:=NONE if(notcond.ne.0) then ! write(*,*)'Experiments have no number' gx%bmperr=4131; goto 1000 endif qp=1 if(stvexp(qp:qp).eq.'*') then ! write(*,*)'3D Special case of deleting all conditions' ! 0 means only conditions deleted, not the equilibrium call delete_all_conditions(0,ceq) goto 1000 endif call getrel(stvexp,qp,xxx) if(buperr.ne.0) then ! write(*,*)'No such condition number' gx%bmperr=4131; goto 1000 endif ! the condition number must be an integer qp=-int(xxx) ! search for condition with number -qp ! write(*,*)'3D looking for condition: ',-qp ! UNFINISHED: one should look for the qp:th ACTIVE condition .... temp=>ceq%lastcondition ! write(*,*)'3D calling get_condition A' call get_condition(qp,svr,temp) ! write(*,*)'3D Back from calling get_condition A' if(gx%bmperr.ne.0) goto 1000 ! save link to old condition in new new=>temp xxx=new%prescribed nterm=1 ! write(*,*)'Found condition',-qp,xxx ! jump from here to 67 if condition specified as number:=value goto 67 elseif(ich.lt.3 .and. nterm.eq.0) then ! first term of state variable which is an expression, ! this term is terminated by + or - ! if(stvexp(1:1).ge.'0' .and. stvexp(1:1).le.'9') then ! write(*,*)'3D extract coeff for first term, if none set to 1',ich firstc=1 call getrel(stvexp,firstc,coeffs(1)) if(buperr.ne.0) then ! write(*,*)'3D error in coefficient for first condition term',buperr ! ignore error, means no coefficient buperr=0 coeffs(1)=one else ! character after coefficient must be a * if(stvexp(firstc:firstc).ne.'*') then write(*,*)'3D coefficient is not terminated by *: ',& stvexp(firstc:firstc) gx%bmperr=4130 else ! update stvexp for next term, we must also update lpos ... lousy coding stvexp=stvexp(firstc+1:) lpos=lpos-firstc endif endif endif !--------------------------------- ! check it is a legal state variable, ignore terminator svtext=stvexp(1:ip-1) symsym=0 ! write(*,*)'3D calling decode for "',trim(svtext),'" upt to:',ip-1 ! memory leak svr=>svrvar call decode_state_variable(svtext,svr,ceq) ! write(*,*)'3D state var: ',trim(svtext),gx%bmperr if(gx%bmperr.ne.0) then ! Experiments can be symbols ! write(*,*)'3D not a state variable: ',svtext(1:5),gx%bmperr,notcond if(notcond.ne.0) then gx%bmperr=0 svfuname=svtext call capson(svfuname) ! write(*,*)'3D Searching for symbol: ',svfuname ! call find_svfun(svfuname,symsym,ceq) call find_svfun(svfuname,symsym) if(gx%bmperr.ne.0) then write(*,*)'3D Experimental symbol neither state variable nor symbol' goto 1000 endif ! write(*,*)'3D experiment is a symbol ',symsym ! we do not have a state variable ... bypass some checks nullify(svr) goto 77 else goto 1000 endif endif ! convert to old state variable format ! write(*,12)svr%argtyp,svr%phase,svr%compset,svr%component,svr%constituent 12 format('3D Decoded: ',5i5) indices=0 if(svr%argtyp.eq.1) then indices(1)=svr%component elseif(svr%argtyp.eq.2) then indices(1)=svr%phase indices(2)=svr%compset elseif(svr%argtyp.eq.3) then indices(1)=svr%phase indices(2)=svr%compset indices(3)=svr%component elseif(svr%argtyp.eq.4) then indices(1)=svr%phase indices(2)=svr%compset indices(3)=svr%constituent endif ! write(*,12)svr%argtyp,indices ! do ks=1,4 ! allterms(nterm,ks)=indices(ks) ! enddo ! write(*,*)'3D newcond: ',svtext(1:20),ip !---------------------------------------------------- 77 continue ! write(*,*)'3D error search ',notcond,ich,associated(temp) ! check that we we have a legal state variable for conditions if(notcond.eq.0) then ! it is a condition, check if allowed as condition istv=svr%oldstv if(istv.lt.0) then ! this means a symbol like TC or BMAGN, not allowed gx%bmperr=4127; goto 1000 endif kstv=(svr%oldstv+1)/10+5 if(kstv.eq.14 .or. kstv.eq.15) then ! this means state variables Q or DGM which cannot be used as condition gx%bmperr=4127; goto 1000 endif if(istv.ge.3 .and. istv.le.5) then ! this is MU, AC and LNAC, do not allow with phase index (at present at least) if(indices(2).ne.0) then write(*,*)'Phase specific chemical potentials not allowed',& ' as conditions' gx%bmperr=4127; goto 1000 endif endif ! state variables with a single term will be prompted with current value encoded=' ' call get_state_var_value(svtext,xxx,encoded,ceq) if(gx%bmperr.ne.0) then ! This error occurs when setting the first compositions before any calculations gx%bmperr=0; xxx=zero endif else ! It is an experiment, search for old value if experiment already entered ! write(*,*)'3D experiment 1',notcond,ich if(ich.eq.4) then experimenttype=-1 elseif(ich.eq.5) then experimenttype=1 endif temp=>ceq%lastexperiment if(.not.associated(temp)) then xxx=zero else ! new is nullified, temp set above for search of conditions or experiments, 88 continue temp=>temp%next if(symsym.eq.0) then ! new experiment is a state variable, what about temp? ! write(*,*)'3D oldexp 1: ',symsym,temp%statev if(temp%statev.eq.0) then svr2=>temp%statvar(1) if(same_statevariable(svr,svr2) .and. & experimenttype.eq.temp%experimenttype) then xxx=temp%prescribed ! found experimental record, save link in new new=>temp endif endif if(.not.associated(temp,ceq%lastexperiment)) goto 88 else ! experiment is a symbol compare with other experiments for symbols ! write(*,*)'3D oldexp 2: ',symsym,temp%statev if(symsym.eq.temp%statev .and. & experimenttype.eq.temp%experimenttype) then xxx=temp%prescribed ! we have found a record for this experiment new=>temp else if(.not.associated(temp,ceq%lastexperiment)) goto 88 endif endif endif endif ! write(*,*)'3D Found old condition or experiment?',notcond if(notcond.eq.0) then !---------------------------------------------------------------- ! Only for conditions: save current term if several nterm=nterm+1 ! write(*,*)'3D several terms: ',nterm svrarr(nterm)=svr ! write(*,*)'3D segfault search 3',nterm ! convert to old format, currently we need to store both formats .... ! istv=svr%oldstv iref=svr%phref iunit=svr%unit do ks=1,4 allterms(ks,nterm)=indices(ks) enddo ! write(*,*)'3D segfault search 4',nterm,ich ! write(*,*)'3D old indices:',nterm,indices if(ich.eq.1 .or. ich.eq.2) then ! terminator + or - means state variable expression with several terms if(nterm.gt.1) then ! UNFINISHED check the second or later state variable of same type as first continue endif ! multiterm expression, jump back to 55 ! write(*,*)'3D problems entering expression: ',trim(stvexp),lpos coeffs(nterm+1)=ccc ! cline=stvexp(ip-1:); ip=1 cline=stvexp(lpos:); ip=1 goto 55 endif else ! it is an existing experiment, we have only one term for experiments nterm=1 ! write(*,*)'3D segfault search 2C',nterm,associated(svr),notcond if(associated(svr)) then svrarr(nterm)=svr ! else ! write(*,*)'3D svr not associated, experiment is a symbol' endif endif ! jump here for qp:= or if several terms are terminated with empty line 67 continue !================================================================== ! Step 2 ask for the numerical value or symbol, first insert a default value jp=1 defval=' ' ! write(*,*)'3D default value: ',xxx,ip,' "',stvexp(ip:ip+5),'" ' call wrinum(defval,jp,10,0,xxx) if(buperr.ne.0) then buperr=0; defval=' ' endif !157 continue ! stvexp is the whole line after the command colon=index(stvexp,':') ! colon=index(cline,':') ! write(*,*)'3D value: ',ip,' "',trim(stvexp),'" ',defval,colon call gparcdx('Value: ',stvexp,ip,1,textval,defval,'?Set condition') ! write(*,*)'3D value: ',textval c5=textval(1:5) call capson(c5) none: if(c5.eq.'NONE ' .or. c5.eq.'NONE') then inactivate=.true. ! write(*,158)'Inactivate condition: ',-qp,value,xxx 158 format(a,i5,2(1pe12.4)) value=xxx else if(notcond.ne.0) then if(textval(1:1).eq.'<') then experimenttype=-1 textval(1:1)=' ' elseif(textval(1:1).eq.'<') then experimenttype=-1 textval(1:1)=' ' endif endif linkix=-1 inactivate=.FALSE. jp=1 call getrel(textval,jp,value) if(buperr.ne.0) then ! it can be a symbol buperr=0 svfuname=textval call capson(svfuname) ! call find_svfun(svfuname,condvalsym,ceq) call find_svfun(svfuname,condvalsym) ! write(*,*)'3D Symbol link: ',textval(1:10),condvalsym,gx%bmperr if(gx%bmperr.ne.0) then write(*,*)'Condition value must be numeric or a symbol'; goto 1000 endif ! only allowed if symbol is constant SVCONST or SVFVAL set ! check we actually have correct symbol!! ! write(*,*)'Symbol name: ',svflista(condvalsym)%name if(btest(svflista(condvalsym)%status,SVCONST) .or. & btest(svflista(condvalsym)%status,SVFVAL)) then linkix=condvalsym value=evaluate_svfun_old(linkix,actual_arg,1,ceq) else write(*,*)'3D Symbol must be constant or "evaluate explicit"' gx%bmperr=4293; goto 1000 endif endif ! we must update ip in cline for uncertainty and another experiment if(colon.gt.0) then ip=colon istv=0 ! write(*,*)'3D changed experiment 1: ',ip,'"',trim(stvexp),'"',value endif endif none ! findrecord: if(notcond.eq.0) then ! remove a condition ! write(*,*)'3D avoiding creating expression:',associated(new) if(.not.associated(new)) then ! search if condition already exist ! write(*,*)'3D searching for condition or experiment?' temp=>ceq%lastcondition if(nterm.eq.1) then call get_condition(nterm,svr,temp) else call get_condition_expression(nterm,svrarr,temp) endif if(gx%bmperr.ne.0 .and. inactivate) then write(kou,140) 140 format('Attempt to remove a non-existing condition') goto 1000 endif ! the error code it will be tested below to create a condition record endif else ! remove or change an experiment if(.not.associated(new)) then ! write(*,*)'3D First experiment: ',associated(temp) ! search for an experiment with state variable svr or symbol symsym temp=>ceq%lastexperiment 142 continue ! write(*,*)'3D searching for experiment' if(symsym.eq.0) then istv=symsym ! if(associated(temp)) then ! write(*,*)'3D Calling get_condition C',allocated(temp%condcoeff) ! else ! write(*,*)'3D Calling get_condition C with temp null' ! endif call get_condition(nterm,svr,temp) ! write(*,*)'3D Back from calling get_condition C',gx%bmperr if(gx%bmperr.eq.0) then ! we must also test eperimenttype, if not same continue search if(temp%experimenttype.eq.experimenttype) goto 142 else ! ensure temp is OK temp=>ceq%lastexperiment ! write(*,*)'3D We are here',associated(temp),gx%bmperr endif else ! write(*,*)'3D searching for experiment with symbol' ! temp is changed inside !! new=>temp ! call get_experiment_with_symbol(symsym,experimenttype,temp) call get_experiment_with_symbol(symsym,experimenttype,new) endif ! else ! write(*,*)'We have a condition record in new', gx%bmperr endif endif findrecord !====================================================== ! step 3 create condition or experiment record, jump here from fix phase 199 continue ! write(*,*)'3D at 199: ',associated(new),associated(temp),gx%bmperr,ip createrecord: if(gx%bmperr.eq.0) then ! no error code means we have found the condition/experiment if(.not.associated(new)) then ! the existing condition/experiment is in temp new=>temp endif if(inactivate) then new%active=1 ! write(*,*)'Inactivating condition',new%prescribed,new%active else ! write(*,*)'3D looking for missing % ...' ! set the new value in the old condition/experiment remove any previous link!! ! linkix is link to symbol representing the value new%active=0 new%prescribed=value new%symlink1=linkix ! write(*,*)'3D Changing value of condition',istv,linkix,value ! special if istv=1 or 2 as ceq%tpfun should be updated if(istv.eq.1) then ! Save new T also locally in ceq ! write(*,*)'3D we are here 1',ceq%tpval(1) ! if(linkix.gt.0) then ! write(*,*)'Cannot handle symbol as T value' ! it is allowed now ! gx%bmperr=4293; goto 1000 ! endif ceq%tpval(1)=value elseif(istv.eq.2) then ! if(linkix.gt.0) then ! write(*,*)'Cannot handle symbol as P value' ! it is allowed now ! gx%bmperr=4293; goto 1000 ! endif ceq%tpval(2)=value endif ! the uncertainty for experiments will be asked for later ! To avoid that valgrind compains uncertainty is not initiallized ... ! write(*,*)'3D initiallizing uncertainty 2' ! write(*,*)'3D changed experiment: ',ip,'"',trim(cline),'"',value new%uncertainty=zero endif else ! If we have an error from findrecord then create condition/experiment record ! write(*,113)inactivate,gx%bmperr,nterm,istv,iunit,iref,linkix,& ! allterms(1,1),value 113 format('Creating condition record',l2,2x,7i4,1pe12.4) gx%bmperr=0 if(notcond.eq.0) then if(associated(ceq%lastcondition)) then seqz=ceq%lastcondition%seqz+1 else seqz=1 endif temp=>ceq%lastcondition allocate(ceq%lastcondition) new=>ceq%lastcondition ! write(*,*)'3D new condition ',istv,symsym else ! it is an experiment ... ip OK here ! write(*,13)'3D Creating new experiment record: ',symsym,value,linkix,ip 13 format(a,i5,1pe12.4,5i5) if(associated(ceq%lastexperiment)) then seqz=ceq%lastexperiment%seqz+1 else seqz=1 endif temp=>ceq%lastexperiment allocate(ceq%lastexperiment) new=>ceq%lastexperiment ! write(*,*)'3D new experiment 2',istv,symsym,seqz istv=symsym endif ! write(*,*)'3D we are here 3' ! for new conditions and experiments new%noofterms=nterm new%statev=istv new%iunit=iunit new%iref=iref new%active=0 new%seqz=seqz ! To avoid that valgrind compains uncertainty is not initiallized ... ! write(*,*)'3D initiallizing uncertainty 3',value new%uncertainty=zero ! write(*,*)'3D experimenttype: ',experimenttype,symsym,nterm new%experimenttype=experimenttype ! write(*,*)'3D symsym: ',symsym,nterm if(symsym.eq.0) then ! DO NOT allocate terms for condcoeff and indices if symbol allocate(new%condcoeff(nterm)) allocate(new%indices(4,nterm)) ! write(*,*)'3D allocations ok',linkix,value do jl=1,nterm new%condcoeff(jl)=coeffs(jl) ! write(*,111)'3D allterms: ',istv,jl,(allterms(ks,jl),ks=1,4) do ks=1,4 new%indices(ks,jl)=allterms(ks,jl) enddo ! write(*,111)'3D in record: ',istv,jl,(new%indices(ks,jl),ks=1,4) 111 format(a,i3,i5,2x,4i4) enddo ! Only experiments can be symbols, what to do next? endif ! write(*,*)'3D storing value: ',value,linkix if(linkix.lt.0) then new%prescribed=value new%symlink1=-1 else new%symlink1=linkix value=evaluate_svfun_old(linkix,actual_arg,1,ceq) ! write(*,*)'3D evaluating condition sysmbol ',linkix,value if(gx%bmperr.ne.0) then goto 1000 endif new%prescribed=value ! write(*,*)'3D prescribed condition value: ',new%prescribed endif ! first test if condition on P or T is larger than 0.1 if(istv.eq.1 .or. istv.eq.2) then if(value.lt.0.1D0) then gx%bmperr=4187; goto 1000 endif endif ! special for T and P, change the local value and mark tpres ! write(*,*)'3D set condition/enter experiment ',istv,value if(istv.eq.1) then ceq%tpval(1)=value ! Force recalculation of all TP functions but only in current equilibrium ceq%eq_tpres%tpused(1)=ceq%tpval(1)+one ! write(*,*)'3D Changing tpused: ',ceq%eq_tpres%tpused(1) elseif(istv.eq.2) then ceq%tpval(2)=value ! Force recalculation of all TP functions. Is there a better way? ceq%eq_tpres%tpused(2)=ceq%tpval(2)+one endif ! Another way to force recalculation of all TP functions by incrementing ! an integer in the tpfuns record of all TPFUN. Used during assessments ! do jl=1,freetpfun-1 ! tpfuns(jl)%forcenewcalc=tpfuns(jl)%forcenewcalc+1 ! enddo ! write(*,*)'3D allocation of statvar ',symsym,istv,nterm if(symsym.eq.0) then ! store the state variable record in the condition, if symbol do not allocate allocate(new%statvar(nterm)) do jl=1,nterm new%statvar(jl)=svrarr(jl) enddo ! else ! experiment is a symbol, no statvar record !! ! The index to the state variable symbol is symsym stored in new%statev ! write(*,*)'3D experiment is a symbol 2',istv,symsym,linkix ! allocate(new%statvar(1)) ! new%statvar(1)%statevarid=0 ! new%statvar(1)%argtyp=-symsym endif ! link the new record into the condition list ! write(*,*)'3D linking condition or experiment' if(associated(temp)) then ! write(*,*)'Second or later condition' nidlast=temp%next%nid nidfirst=temp%nid nidpre=temp%previous%nid new%nid=nidlast+1 temp%next%previous=>new new%next=>temp%next temp%next=>new new%previous=>temp else ! create the circular list new%nid=1 new%next=>new new%previous=>new endif if(notcond.ne.0) then ! STRANGE ERRORS HERE ! we are actually entering an experiment, terminate here ! if textval(jp:jp) is ":" we have to step back ip one position ! increment ip with nextexp! ip=ip+nextexp ! write(*,*)'3D exit? "',trim(cline),'" "',trim(textval),'"',& ! ip,jp,nextexp if(cline(ip:ip).eq.':') then ! the colon should be the character at ip to extract uncertainty by getrel goto 1000 endif 200 continue ip=ip+1 ! write(*,*)'3D looking for ":"',trim(cline),ip if(cline(ip:ip).eq.':' .or. ip.gt.len(cline)) goto 1000 goto 200 ! if(ip.lt.len_trim(cline)) goto 200 ! confusion of subtexts ... move ip forward to point at colon ! write(*,*)'3D where is :? ',cline(ip+1:ip+1),ip ! if(cline(ip+1:ip+1).ne.':') then ! ip=ip+1; if(ip.lt.70) goto 200 ! endif ! ip=ip+1 very confused !! ! ip=ip-1 ! endif ! stop here so I can check ! read(*,'(a)')ch1 ! if(ch1.eq.'q') stop 'cannot find ":"' ! allow for more experiments on the same line ... ! cline=textval(jp:) ! ip=1 ! goto 1000 endif endif createrecord ! write(*,*)'3D end of createrecord',ip,'"',trim(stvexp),'"' !---------------------------------------------------------------- ! if there is more in stvexp go back to label 50 ... if(.not.eolch(stvexp,ip)) then ! write(*,*)'3d first character: "',stvexp(ip:ip),'" ' ! NOTE gparc skips the first character in cline if(stvexp(ip:ip).eq.':') then ! if experiment there can be an uncertainty ... ! write(*,*)'3D where is the value?' cline=stvexp(ip:) cline(ip:ip)=' ' ip=1 goto 1000 elseif(stvexp(ip:ip).eq.',') then cline=stvexp(ip:) else cline=stvexp(ip-1:) endif ! write(*,*)'3d next condition: "',stvexp(ip:ip+20),'"' ip=1; goto 50 endif goto 1000 !==================================================================== ! Special below is for fix/unfix phases 299 continue if(notcond.ne.0) then write(kou,*)'3D Illegal to set a fix phase as experiment' gx%bmperr=4294; goto 1000 endif ! write(*,*)'3D fix phase 2: ',ip,stvexp(ip:40) call find_phase_by_name(stvexp(ip:),iph,ics) if(gx%bmperr.ne.0) then goto 1000 endif ! write(*,*)'3D Phase index: ',iph,ics nterm=1 istv=-iph iref=ics iunit=0 linkix=-1 coeffs(1)=1.0D0 do jl=1,4 allterms(jl,1)=0 enddo ! convert to state variable ! write(*,*)'3D Setting svrarr(1) values' svrarr(1)%statevarid=istv svrarr(1)%oldstv=istv svrarr(1)%phase=ics svrarr(1)%unit=0 svrarr(1)%argtyp=0 svrarr(1)%phase=iph svrarr(1)%compset=ics svrarr(1)%component=0 svrarr(1)%constituent=0 ! temp=>ceq%lastcondition ! if not inactivate get value if(inactivate) then ! bypass phase name ip=index(stvexp,' ') else ip=index(stvexp,'==')+2 call getrel(stvexp,ip,value) if(buperr.ne.0) then write(*,*)'3D error setting fix amount ',ip,stvexp(1:40) gx%bmperr=4100; goto 1000 endif endif svr=>svrarr(1) ! write(*,*)'3D set_cond_or_exp for fix phase: ',svr%statevarid,svr%phase ! new must be unassociated, for inactivate temp will be set to condition. nullify(new) call get_condition(nterm,svr,temp) ! write(*,*)'3D Back from get_condition ',gx%bmperr,ip goto 199 ! ! finally, for conditions T or P copy value to ceq%tpval ! This may be a bit inconsistent .... but?? 900 continue if(istv.eq.1 .and. iunit.eq.0 .and. iref.eq.0) then ceq%tpval(1)=value elseif(istv.eq.2 .and. iunit.eq.0 .and. iref.eq.0) then ceq%tpval(2)=value endif ! mark that any current results may be inconsistent with new conditions ! globaldata%status=ibset(globaldata%status,GSINCON) ceq%status=ibset(ceq%status,EQINCON) 1000 continue ! write(*,*)'exit set_condition, T= ',ceq%tpval(1) ! possible memory leaks nullify(svr) nullify(svr2) ! nullify(svrarr) nullify(temp) return end subroutine set_cond_or_exp !svr ip !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine get_experiment_with_symbol !\begin{verbatim} %- subroutine get_experiment_with_symbol(symsym,experimenttype,temp) ! finds an experiment with s symbol index symsym and exp.type implicit none integer symsym,experimenttype type(gtp_condition), pointer :: temp ! NOTE: temp must have been set to ceq%lastcondition before calling this !\end{verbatim} ! pcond: pointer, to a gtp_condition record for this equilibrium type(gtp_condition), pointer :: pcond,last if(.not.associated(temp)) goto 900 last=>temp pcond=>last 100 continue if(pcond%statev.eq.symsym .and. pcond%experimenttype.eq.experimenttype) then ! the index of the symbol is stored in statev, we have found the experiment goto 1000 else ! Wow = here instead of => created a lot of problems!!! pcond=>pcond%next ! this is true unless we have circulated the whole list if(.not.associated(pcond,last)) goto 100 endif ! we have not found this experiment 900 continue gx%bmperr=4131 1000 continue return end subroutine get_experiment_with_symbol !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine get_condition_expression !\begin{verbatim} subroutine get_condition_expression(nterm,svrarr,pcond) ! I do not want to change get_condition ,,,,, suck ! finds a condition/experiment record with the given state variable expression ! If nterm<0 svr is irrelevant, the absolute value of nterm is the sequential ! number of the ACTIVE conditions implicit none integer nterm type(gtp_state_variable), dimension(*), target :: svrarr ! NOTE: pcond must have been set to ceq%lastcondition before calling this ! pcond: pointer, to a gtp_condition record for this equilibrium type(gtp_condition), pointer :: pcond !\end{verbatim} %+ type(gtp_condition), pointer :: last type(gtp_state_variable), pointer :: svr,condvar integer jj ! ! write(*,*)'3D get_condition_expression: ',nterm ! start from first equilibrium in circular list ! write(*,*)'3D one more line ...' ! this write statement caused crash if first condition had 2 terms ... ! write(*,*)'3D size of pcond%statvar: ',size(pcond%statvar) if(nterm.gt.1) then write(*,*)'3D A condition with several terms sometimes causes crash' gx%bmperr=4399; goto 1000 endif pcond=>pcond%next last=>pcond 100 continue write(*,*)'3D at label 100' ploop: do while(.true.) terms: do jj=1,nterm svr=>svrarr(jj) ! write(*,*)'3D gce: ',jj,svr%component if(jj.gt.size(pcond%statvar)) then write(*,*)'3D too many terms in condition',jj,size(pcond%statvar) write(*,*)'3D more:',nterm,pcond%statvar(1)%oldstv gx%bmperr=4399; goto 1000 endif condvar=>pcond%statvar(jj) ! write(*,*)'3D get_condition: ',jj,condvar%oldstv,condvar%argtyp ! dissapointment, one cannot compare two structures ... unless pointers same if(condvar%oldstv.ne.svr%oldstv) goto 200 if(condvar%argtyp.ne.svr%argtyp) goto 200 if(condvar%phase.ne.svr%phase) goto 200 if(condvar%compset.ne.svr%compset) goto 200 ! skip fix phases if(condvar%statevarid.lt.0) goto 1000 ! most conditions with 2 terms are x(a)-x(b) ore similar ! write(*,*)'3D component: ',condvar%component,svr%component if(condvar%component.ne.svr%component) goto 200 if(condvar%constituent.ne.svr%constituent) goto 200 if(condvar%norm.ne.svr%norm) goto 200 if(condvar%unit.ne.svr%unit) goto 200 enddo terms ! we have found a condition with these state variables ! write(*,*)'3D Found condition',pcond%active goto 1000 200 continue pcond=>pcond%next if(associated(pcond,last)) exit ploop enddo ploop ! we did not find this condition, maybe create it? gx%bmperr=4131; goto 1000 1000 continue return end subroutine get_condition_expression !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine get_condition !\begin{verbatim} subroutine get_condition(nterm,svr,pcond) ! finds a condition/experiment record with the given state variable expression ! If nterm<0 svr is irrelevant, the absolute value of nterm is the sequential ! number of the ACTIVE conditions implicit none integer nterm type(gtp_state_variable), pointer :: svr ! NOTE: pcond must have been set to ceq%lastcondition before calling this ! pcond: pointer, to a gtp_condition record for this equilibrium type(gtp_condition), pointer :: pcond !\end{verbatim} %+ type(gtp_condition), pointer :: last type(gtp_state_variable), pointer :: condvar integer j1,num,iact if(.not.associated(pcond)) goto 900 ! write(*,*)'3D in get_condition: ',svr%statevarid,svr%oldstv,svr%argtyp,nterm ! if(nterm.lt.0) write(*,*)'3D Condition number: ',-nterm ! last=>pcond ! start from first equilibrium in circular list pcond=>pcond%next last=>pcond num=0 iact=0 100 continue num=num+1 ! iact is incremented with the active conditions if(pcond%active.eq.0) iact=iact+1 if(nterm.lt.0) then ! we have found the active condition with number -nterm ! write(*,102)'Cond #: ',pcond%active,nterm,iact,num,pcond%prescribed !102 format(a,4i3,1pe12.4) ! pcond starts with the last equilibria, not the first ... if(iact+nterm.eq.0) goto 1000 elseif(.not.allocated(pcond%condcoeff)) then ! problem when experiment is a symbol ... ! elseif(.not.allocated(pcond%condcoeff) .and. istv.ne.0) then ! no coefficients allocated, it must be an experiment with a symbol as variable !- write(*,*)'3D experiment as symbol',pcond%statev,pcond%seqz,num ! we must transfer the symbol index ... ! if(pcond%statev.eq. )then ! goto 1000 ! endif ! goto 200 continue elseif(pcond%noofterms.eq.nterm) then ! we should never be here if nterm>1 if(nterm.gt.1) then write(*,*)'3D call to get_contition with nterm: ',nterm gx%bmperr=4399; goto 1000 endif ! write(*,*)'3D nterm: ',nterm,pcond%noofterms ! experiments that are symbols have not allocated any coefficent record do j1=1,nterm ! if nterm>1 compare just nterm as this routine called for each term!! condvar=>pcond%statvar(j1) ! write(*,*)'3D get_condition: ',j1,num,condvar%oldstv,condvar%argtyp ! dissapointment, one cannot compare two structures ... unless pointers same ! if(condvar.ne.svr) goto 200 if(condvar%oldstv.ne.svr%oldstv) goto 200 if(condvar%argtyp.ne.svr%argtyp) goto 200 if(condvar%phase.ne.svr%phase) goto 200 if(condvar%compset.ne.svr%compset) goto 200 if(condvar%statevarid.lt.0) goto 1000 ! for fix phase the remaining have no importance ! write(*,*)'3D component: ',condvar%component,svr%component if(condvar%component.ne.svr%component) goto 200 if(condvar%constituent.ne.svr%constituent) goto 200 if(condvar%norm.ne.svr%norm) goto 200 if(condvar%unit.ne.svr%unit) goto 200 ! we must have experimenttype=0 ?? ! if(condvar%experimenttype.ne.0) goto 200 enddo ! we have found a condition with these state variables ! write(*,*)'3D Found condition',pcond%active goto 1000 ! else ! write(*,*)'3D ignoring condition with wrong number of terms',& ! nterm,pcond%noofterms endif 200 continue ! write(*,*)'Conditions not same' pcond=>pcond%next if(.not.associated(pcond,last)) goto 100 900 continue ! write(*,*)'3D get_condition: No such condition or experiment' gx%bmperr=4131; goto 1000 1000 continue return end subroutine get_condition !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_condition2 !\begin{verbatim} %- subroutine get_condition2(nterm,coeffs,istv,indices,iref,iunit,pcond) ! finds a condition record with the given state variable expression ! nterm: integer, number of terms in the condition expression ! istv: integer, state variable used in the condition ! indices: 2D integer array, state variable indices used in the condition ! iref: integer, reference state of the condition (if applicable) ! iunit: integer, unit of the condition value ! NOTE: pcond must have been set to ceq%lastcond before calling this routine!!! ! pcond: pointer, to a gtp_condition record for this equilibrium ! NOTE: conditions like expressions x(mg)-2*x(si)=0 not implemeneted ! fix phases as conditions have negative condition variable implicit none TYPE(gtp_condition), pointer :: pcond integer, dimension(4,*) :: indices integer nterm,istv,iref,iunit double precision coeffs(*) !\end{verbatim} %+ TYPE(gtp_condition), pointer :: current,first ! integer, dimension(4) :: indx integer ncc,nac,j1,j2 ! write(*,*)'looking for condition' ! pcond must have been set to ceq%lastcond before calling this routine!!! if(.not.associated(pcond)) goto 900 first=>pcond%next current=>first ! write(*,*)'get_condition start: ',current%statev,current%active ncc=1 nac=0 if(ocv()) write(*,98)'new:',0,nterm,istv,(indices(j1,1),j1=1,4),iref,iunit 98 format(a,2x,i2,5x,2i4,5x,4i4,5x,2i3) 100 continue if(ocv()) write(*,98)'old:' ,current%nid,current%noofterms,current%statev,& (current%indices(j1,1),j1=1,4),current%iref,current%iunit if(nterm.eq.0) then ! why nterm=0? Check!!! if(ocv()) write(*,*)'3D get_condition: ',istv,ncc,nac if(current%active.eq.0) then ! this call just looks for active condition istv nac=nac+1 ! why should fix phase conditions have istv=nac?? Check!! if(nac.eq.istv) then ! a condition specified like this must not be a phase status change if(current%statev.lt.0) then write(kou,*)'You must use "set phase status" to change fix status' else goto 150 endif endif endif goto 200 endif if(ocv()) write(*,103)'Checking terms, istv, iref and unit ',& nac,ncc,nterm,current%noofterms 103 format(a,6i5) if(current%noofterms.ne.nterm .or. current%statev.ne.istv .or. & current%iref.ne.iref .or. current%iunit.ne.iunit) goto 200 if(ocv()) write(*,*)'Checking indices' do j1=1,nterm do j2=1,4 if(current%indices(j2,j1).ne.indices(j2,j1)) goto 200 enddo enddo 150 continue ! found condition pcond=>current ! write(*,*)'Found condition: ',pcond%nid,ncc goto 1000 200 continue current=>current%next ncc=ncc+1 if(.not. associated(current,first)) goto 100 900 continue ! no such condition gx%bmperr=4131; goto 1000 1000 continue return end subroutine get_condition2 !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine extract_stvr_of_condition !\begin{verbatim} %- subroutine extract_stvr_of_condition(pcond,nterm) ! finds a condition record with the given state variable record ! returns it as a state variable record !!! ! nterm: integer, number of terms in the condition expression ! pcond: pointer, to a gtp_condition record implicit none TYPE(gtp_condition), pointer :: pcond integer nterm !\end{verbatim} TYPE(gtp_condition), pointer :: current,first ! integer, dimension(4) :: indx integer ncc,nac,j1,istv,iref,iunit ! ! write(*,*)'not implemented!!' gx%bmperr=4078; goto 1000 !-------------------------------------------------------- if(.not.associated(pcond)) goto 900 first=>pcond%next current=>first ! write(*,*)'get_condition start: ',current%statev,current%active ncc=1 nac=0 ! write(*,98)'new:',0,nterm,istv,(indices(i,1),i=1,4),iref,iunit 98 format(a,2x,i2,5x,2i4,5x,4i4,5x,2i3) 100 continue ! write(*,98)'old:' ,current%nid,current%noofterms,current%statev,& ! (current%indices(i,1),i=1,4),current%iref,current%iunit if(nterm.eq.0) then ! write(*,*)'get_condition: ',istv,ncc,nac if(current%active.eq.0) then ! this call just looks for active condition istv nac=nac+1 ! why should fix phase conditions have istv=nac?? Check!! if(nac.eq.istv) then ! a condition specified like this must not be a phase status change if(current%statev.lt.0) then write(kou,*)'You must use "set phase status" to change fix status' else goto 150 endif endif endif goto 200 endif if(current%noofterms.ne.nterm .or. current%statev.ne.istv .or. & current%iref.ne.iref .or. current%iunit.ne.iunit) goto 200 do j1=1,nterm ! do j2=1,4 ! if(current%indices(j2,j1).ne.indices(j2,j1)) goto 200 ! enddo enddo 150 continue ! found condition pcond=>current ! write(*,*)'Found condition: ',pcond%nid,ncc goto 1000 200 continue current=>current%next ncc=ncc+1 if(.not. associated(current,first)) goto 100 900 continue ! no such condition gx%bmperr=4131; goto 1000 1000 continue return end subroutine extract_stvr_of_condition !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine locate_condition !\begin{verbatim} subroutine locate_condition(seqz,pcond,ceq) ! locate a condition using a sequential number implicit none integer seqz type(gtp_condition), pointer :: pcond type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer ij ! write(*,*)'In locate_condition 1' pcond=>ceq%lastcondition ! write(*,*)'In locate_condition 2',seqz do ij=1,seqz pcond=>pcond%next ! segmentation faults in this routine when locating ceq saved during step/map ! write(*,*)'In locate_condition 3',ij if(seqz.gt.ij .and. associated(pcond,ceq%lastcondition)) then ! write(*,*)'Locate condition called with illegal index: ',seqz gx%bmperr=4295; goto 1000 endif enddo 1000 continue return end subroutine locate_condition !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine apply_condition_value !\begin{verbatim} subroutine apply_condition_value(current,what,value,cmix,ccf,ceq) ! This is called when calculating an equilibrium. ! It returns a condition at each call, at first call current must be nullified? ! When all conditions done the current is nullified again ! If what=-1 then return degrees of freedoms and maybe something more ! what=0 means calculate current values of conditions ! calculate the value of a condition, used in minimizing G ! ccf are the coefficients for conditions with several terms implicit none integer what,cmix(*) double precision value,ccf(*) TYPE(gtp_equilibrium_data), pointer :: ceq TYPE(gtp_condition), pointer :: current !\end{verbatim} %+ ! ceq is actually redundant as current is a pointer to condition list in ceq integer, dimension(4) :: indices integer iref,iunit,jx,istv,ip,linkix,nterms character encoded*60,actual_arg*60 double precision xxx ! 100 continue if(current%active.ne.0) then ! return 0 for inactive conditions cmix(1)=0; goto 1000 endif if(what.ge.0) goto 200 !---------------------------------------------------------- ! Here we should return information about conditions on potentials (T, P, MU) ! and fix phases cmix(1)=0 if(current%noofterms.gt.1) then if(current%statev.eq.111 .or.current%statev.eq.110) then ! allow several terms for mole fractions and \sum_i a_i*N(i)=0 !! ! write(*,69)'3D in apply: ',current%statev,current%noofterms,& ! ((current%indices(jx,nterms),jx=1,4),nterms=1,current%noofterms) 69 format(a,i4,i2,3(2x,4i5)) nterms=current%noofterms do jx=1,nterms ccf(jx)=current%condcoeff(jx) enddo ! write(*,68)nterms,(ccf(jx),jx=1,nterms) !68 format('3D coeff: ',i2,6(1pe12.4)) ! VERY CLUMSY but maybe good for the moment elseif(current%statev.eq.21 .or. & current%statev.eq.130) then ! implement S-S for EET calculations ... ! and y-y for constitutions .... ! write(*,*)'3D Apply_condition with several terms 1',current%statev,& ! current%iref,current%iunit nterms=current%noofterms do jx=1,current%noofterms ccf(jx)=current%condcoeff(jx) ! write(*,*)'3D: ',jx,(current%indices(istv,jx),istv=1,4) enddo ! gx%bmperr=4207; goto 900 else ! cannot handle other conditions with several terms write(*,*)'3D Apply_condition with several terms 2',current%statev,& current%noofterms gx%bmperr=4207; goto 900 endif else ! one term with coefficient one ccf(1)=one nterms=1 endif ! for debugging istv=current%statev do jx=1,4 indices(jx)=current%indices(jx,1) enddo iref=current%iref iunit=current%iunit ip=1 encoded=' ' actual_arg=' ' ! fetch value of symbol link if any if(current%symlink1.gt.0) then linkix=current%symlink1 ! if(btest(svflista(linkix)%status,SVFVAL)) then if(btest(svflista(linkix)%status,SVCONST)) then xxx=svflista(linkix)%linkpnode%value ! wrong xxx=svflista(linkix)%svfv ceq%svfunres(linkix)=xxx ! write(*,*)'3D SVFVAL apply: ',linkix,xxx else actual_arg=' ' ! no pointer to equilibrim record ... use firsteq ?? ! NOTE if symbol has bit SVCONST set then do not evaluate, use xxx=evaluate_svfun_old(linkix,actual_arg,1,ceq) if(gx%bmperr.ne.0) then write(*,*)'3D error evaluate symbolic link as condition',linkix,xxx goto 1000 endif endif current%prescribed=xxx endif !------------------ if(current%statev.lt.0) then ! a FIX PHASE condition has state variable equal to -iph, ics is stored in iref cmix(1)=4 cmix(2)=-current%statev cmix(3)=current%iref value=current%prescribed ! write(*,*)'3D Fix phase: ',-current%statev,current%iref,value elseif(current%statev.eq.1) then ! temperature cmix(1)=1 value=current%prescribed ! write(*,*)'3D conditon on T' elseif(current%statev.eq.2) then ! pressure cmix(1)=2 value=current%prescribed ! write(*,*)'3D conditon on P' elseif(current%statev.le.5) then ! potentials has statev=1..5 (T, P, MU, AC, LNAC) cmix(1)=3 cmix(2)=current%statev cmix(3)=current%indices(1,1) value=current%prescribed ! write(*,*)'3D condition on MU/AC/LNAC' elseif(current%statev.ge.10) then ! other condition must be on (normalized) extensive properties (N, X, H etc) cmix(1)=5 ! write(*,*)'3D Extensive condition: ',current%statev ! SPECIAL FOR CONDITIONS ON Y to inhibit grid minimizer if(current%statev.eq.130) cmix(1)=6 else ! write(*,*)'3D Illegal condition',current%statev gx%bmperr=4208; goto 1000 endif goto 900 !-------------------------------------- ! Here we should return extensive condition, maybe calculate value 200 if(what.ne.0) goto 300 cmix(1)=0 ! for debugging istv=current%statev do jx=1,4 indices(jx)=current%indices(jx,1) enddo iref=current%iref iunit=current%iunit ip=1 encoded=' ' actual_arg=' ' !------------------ if(current%statev.lt.10) goto 900 ! condition must be on extensive properties (N, X, B, W, H etc) cmix(1)=5 cmix(2)=current%statev ! indices are dimensioned (4,nterms) cmix(3)=current%indices(1,1) cmix(4)=current%indices(2,1) cmix(5)=current%indices(3,1) cmix(6)=current%indices(4,1) ! for one term set coefficient to one ccf(1)=one ! more than one term ... this is very clumy ... if(current%noofterms.gt.1) then do nterms=2,current%noofterms ! 7, 8, 9 10 for second term, 11, 12, 13 14 for third etc cmix(4*nterms-1)=current%indices(1,nterms) cmix(4*nterms)=current%indices(2,nterms) cmix(4*nterms+1)=current%indices(3,nterms) cmix(4*nterms+2)=current%indices(4,nterms) enddo ip=current%noofterms do jx=1,ip ccf(jx)=current%condcoeff(jx) enddo ! write(*,211)'3D Many terms: ',(cmix(jx),jx=1,4*ip+2) ! write(*,212)'3D more: ',(ccf(jx),jx=1,ip) 211 format(a,2i4,4(2x,44i3)) 212 format(a,4(1pe12.4)) endif ! if(current%noofterms.gt.2) then ! write(*,*)'3D Apply_condition with more than 2 terms',current%noofterms ! gx%bmperr=4207; goto 1000 ! endif value=current%prescribed if(iunit.eq.100) then ! Prescribed value is in percent, divide value by 100 value=1.0D-2*value ! write(*,*)'3D iunit: ',iunit,value endif goto 900 !-------------------------------------- ! this part is redundant .... 300 continue ! write(*,*)'Calling apply_condition with illegal option' gx%bmperr=4296; goto 1000 !----------------------------------------------------------- ! maybe something common 900 continue ! 1000 continue return end subroutine apply_condition_value !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine condition_value !\begin{verbatim} %- subroutine condition_value(mode,pcond,value,ceq) ! set (mode=0) or get (mode=1) a new value of a condition. Used in mapping implicit none integer mode type(gtp_condition), pointer :: pcond type(gtp_equilibrium_data), pointer :: ceq double precision value !\end{verbatim} if(mode.eq.0) then ! set the value pcond%prescribed=value ! special for T and P if(pcond%statev.eq.1) then ceq%tpval(1)=value elseif(pcond%statev.eq.2) then ceq%tpval(2)=value endif elseif(mode.eq.1) then value=pcond%prescribed else write(*,*)'Condition value called with illegal mode' endif 1000 continue return end subroutine condition_value !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine ask_default_constitution !\begin{verbatim} subroutine ask_default_constitution(cline,last,iph,ics,ceq) ! set values of default constitution interactivly ! phase and composition set already given implicit none character cline*(*) integer last,iph,ics TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer lokph,lokcs,ky,ll,iy,jy,is,ip,abel,subl real mmyfr(maxconst) character quest*32,name*24,vdef*4,fdef*8 double precision xxx,mass call get_phase_compset(iph,ics,lokph,lokcs) if(gx%bmperr.ne.0) goto 1000 ! if PHNOCV set the composition is fixed if(btest(phlista(lokph)%status1,PHNOCV)) goto 1000 write(*,10)ics 10 format('Give min or max fractions for composition set ',i2/& ' use < or negative value for max, > or positive for min',& ' or NONE for no default') name=' ' ky=0 do ll=1,phlista(lokph)%noofsubl if(phlista(lokph)%nooffr(ll).gt.1) then ! more than one constituent do iy=1,phlista(lokph)%nooffr(ll) ky=ky+1 ! call get_phase_constituent_name(iph,ky,name,subl) call get_constituent_name(iph,ky,name,mass) if(gx%bmperr.ne.0) then write(*,*)'3D default: ',iph,ky,iy goto 1000 endif quest='Default for '//name(1:len_trim(name))//& '#'//char(ichar('0')+ll) ! use current value as default if nonzero vdef=' ' abel=10*abs(ceq%phase_varres(lokcs)%mmyfr(ky)) ! write(*,*)'3D abel:',ky,abel,ceq%phase_varres(lokcs)%mmyfr(ky) if(abel.ge.10) then vdef=' 1.0' elseif(abel.le.0) then vdef=' 0.1' else vdef=' 0.'//char(ichar('0')+abel) endif if(ceq%phase_varres(lokcs)%mmyfr(ky).lt.0.0) then vdef(1:1)='<' elseif(ceq%phase_varres(lokcs)%mmyfr(ky).gt.0.0) then vdef(1:1)='>' else vdef='NONE' endif ! modified for new online help ! call gparcd(quest,cline,last,1,fdef,vdef,q1help) call gparcdx(quest,cline,last,1,fdef,vdef,& '?Amend phase default constit') jy=1 if(fdef(1:4).eq.'NONE') then xxx=0 is=1 elseif(eolch(fdef,jy)) then xxx=-1.0D-1 else is=1 if(fdef(jy:jy).eq.'<') then is=-1 jy=jy+1 elseif(fdef(jy:jy).eq.'>') then jy=jy+1 endif ! write(*,*)'3D def1: ',fdef,jy call getrel(fdef,jy,xxx) if(buperr.ne.0) then ! write(*,*)'3D buperr ',buperr buperr=0 endif if(is.lt.0) xxx=-xxx endif if(abs(xxx).gt.one) xxx=sign(xxx,one) ! write(*,*)'3D default: ',xxx mmyfr(ky)=real(xxx) enddo else ! a single constituent, we must increment ky as there may be more ky=ky+1 mmyfr(ky)=1.0 endif enddo call enter_default_constitution(iph,ics,mmyfr,ceq) ! write(*,99)(mmyfr(jy),jy=1,ky) 99 format('3D defy: ',15(f5.1)) 1000 continue return end subroutine ask_default_constitution !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine enter_default_constitution !\begin{verbatim} subroutine enter_default_constitution(iph,ics,mmyfr,ceq) ! user specification of default constitution for a composition set implicit none TYPE(gtp_equilibrium_data), pointer :: ceq integer iph,ics real mmyfr(*) !\end{verbatim} integer lokph,lokcs,jl,jk ! write(*,*)'3D In enter_default_constitution ',iph,ics call get_phase_compset(iph,ics,lokph,lokcs) if(gx%bmperr.ne.0) goto 1000 jk=size(ceq%phase_varres(lokcs)%yfr) ! write(*,909)lokph,lokcs,phlista(lokph)%tnooffr,ceq%eqno,& ! size(ceq%phase_varres),size(ceq%phase_varres(lokcs)%mmyfr),jk 909 format('3D 2699: ',10i4) ! write(*,46)'3D y: ',(ceq%phase_varres(lokcs)%yfr(jl),jl=1,jk) 46 format(a,10(F7.3)) if(.not.allocated(ceq%phase_varres(lokcs)%mmyfr)) then ! for some reason I have not always allocated this ... allocate(ceq%phase_varres(lokcs)%mmyfr(phlista(lokph)%tnooffr)) endif do jl=1,phlista(lokph)%tnooffr ceq%phase_varres(lokcs)%mmyfr(jl)=mmyfr(jl) ! write(*,47)'3D jl: ',jl,mmyfr(jl),& ! firsteq%phase_varres(lokcs)%mmyfr(jl),& ! ceq%phase_varres(lokcs)%mmyfr(jl) enddo 47 format(a,i2,10F7.3) ! set bit indicating that this composition set has a default constitution ! write(*,*)'3D enter_default_constitution?? ',lokcs,& ! ceq%phase_varres(lokcs)%mmyfr(phlista(lokph)%tnooffr) ceq%phase_varres(lokcs)%status2=& ibset(ceq%phase_varres(lokcs)%status2,CSDEFCON) 1000 continue return end subroutine enter_default_constitution !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine set_input_amounts !\begin{verbatim} subroutine set_input_amounts(cline,lpos,ceq) ! set amounts like n(specie)=value or b(specie)=value ! value can be negative removing amounts ! values are converted to moles and set or added to conditions implicit none integer lpos character cline*(*) TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} TYPE(gtp_state_variable), target :: svr1 TYPE(gtp_state_variable), pointer :: svr TYPE(gtp_condition), pointer :: current,first,last character species*32,cval*16,statevar*4,condline*32 integer ielno(10) double precision addval(maxel) integer k,loksp,istv,jel,ip double precision xval,sumstoi,xmols ! repeat reading until empty line 100 continue addval=zero call gparcx('Species and amount as N(..)= or B(...)= : ',& cline,lpos,1,species,' ','?Set input amounts') call capson(species) statevar=species(1:1) if(statevar.ne.' ') then if(.not.(statevar(1:1).ne.'N' .or. statevar(1:1).ne.'B')) then write(*,*)'Illegal state variable for input amounts' goto 1000 endif k=index(species,')') if(k.le.3) then write(*,*)'Species must be surrounded by ( )' gx%bmperr=4297; goto 1000 endif cval=species(k+1:) ! this line gave compilation warning moving 32 bytes from a space of (max) 30 species=species(3:k-1)//' ' ! write(*,*)'3D Species: ',trim(species),' <',trim(cval),'> ' if(index(species,',').gt.0 .or. index(species,'(').gt.0) then write(*,*)'Use only N(species) or B(species) in input amounts' goto 1000 endif else goto 1000 endif call find_species_record(species,loksp) ! not needed as we can access splista ! call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp) if(gx%bmperr.ne.0) goto 1000 ! if user writes N(C)=2 the =2 will be in cval, if a space after = in cline if(cval(1:1).eq.'=') goto 300 ! goto 300 200 continue ! the user can also give values without = or with a space before = ! but no space allowed after = ! write(*,*)'3D cline: ',trim(cline),lpos call gparcx('Amount: ',cline,lpos,1,cval,' ','?Set input amounts') 300 continue if(cval(1:1).eq.'=') cval(1:1)=' ' ip=1 ! write(*,*)'3D cval: ',trim(cval),ip call getrel(cval,ip,xval) if(buperr.ne.0) then write(*,*)'Amount must be a real number' goto 1000 endif ! write(*,*)'3D xval: ',xval ! this return the internal code for N ! BUG here as svr is no longer allocated in decode_state_variable to avoid ! memory leaks svr=>svr1 call decode_state_variable('N ',svr,ceq) if(gx%bmperr.ne.0) then write(*,*)'Error decoding N in set_input_amounts' goto 1000 endif istv=svr%oldstv ! if B convert to N: moles of species = input_mass/mass_of_species ! moles of element = stoiciometry_of_element/total_number_of_elements if(statevar(1:1).eq.'B') then write(kou,*)'Note: set input in mass converted to moles' xmols=xval/splista(loksp)%mass else xmols=xval endif sumstoi=zero do jel=1,splista(loksp)%noofel ielno(jel)=splista(loksp)%ellinks(jel) addval(ielno(jel))=splista(loksp)%stoichiometry(jel)*xmols sumstoi=sumstoi+splista(loksp)%stoichiometry(jel) enddo ! now create or att to existing conditions last=>ceq%lastcondition jel=1 if(.not.associated(last)) goto 600 ! return here to look for condition for another element 500 continue ! write(*,*)'At 500',last%nid,last%next%nid first=>last%next current=>first ! loop for all condition 510 continue ! write(*,*)'loop: ',current%nid,current%indices(1,1),ielno(jel) ! check if this condition match amount of element jel if(current%noofterms.eq.1) then if(current%statev.eq.istv) then if(current%indices(1,1).eq.ielno(jel) .and. & current%indices(2,1).eq.0) then ! we have found an identical contition, add the new amount ! if condition not active (active=/=0) then activate and zero prescibed amount if(current%active.ne.0) then current%active=0 current%prescribed=zero endif current%prescribed=current%prescribed+addval(ielno(jel)) goto 700 endif endif endif current=>current%next ! write(*,*)'next: ',current%nid,first%nid if(.not.associated(current,first)) goto 510 600 continue ! new condition needed condline='N('//ellista(ielno(jel))%symbol& (1:len_trim(ellista(ielno(jel))%symbol))//')=' ip=len_trim(condline)+1 call wrinum(condline,ip,10,0,addval(ielno(jel))) ! write(*,*)'new condition: ',condline ! set_condition starts by incementing ip ip=0 call set_condition(condline,ip,ceq) if(gx%bmperr.ne.0) goto 1000 if(.not.associated(last)) then ! if ceq%lastcondition was not associated above the call to set_condition ! will have set link in ceq%lastcondition last=>ceq%lastcondition ! write(*,*)'condition id: ',last%nid endif 700 continue jel=jel+1 if(jel.le.splista(loksp)%noofel) goto 500 ! all elements for this species set as conditions, check if any more if(.not.eolch(cline,lpos)) goto 100 ! 1000 continue ! possible memory leaks. Maybe also current, last nullify(svr) return end subroutine set_input_amounts !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ ================================================ FILE: src/models/gtp3E.F90 ================================================ ! ! gtp3E included in gtp3.F90 ! !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !> 9A. Section: read and save on files using TDB/UNFORMATTED MM !> The XML read/write is in gtp3EX.F90 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine gtpsave !\begin{verbatim} subroutine gtpsave(filename,str) ! save all data on file: unformatted, direct, TDB, LaTeX, XTDB or macro ! header ! element list ! species list ! phase list with sublattices, endmembers, interactions and parameters etc ! tpfuns ! state variable functions ! references ! implicit none character*(*) filename,str !\end{verbatim} ! separate UNFORMATTED, DIRECT, TDB, MACRO or LaTeX or XTDB if(str(1:1).eq.'U') then ! unformatted call gtpsaveu(filename,str(3:)) elseif(str(1:1).eq.'D') then ! direct (random access) ..... not implemented call gtpsavedir(filename,str(3:)) elseif(str(1:1).eq.'T') then ! TDB format write(*,*)'In gtpsave ' call gtpsavetdb(filename,str(3:)) elseif(str(1:1).eq.'L') then ! LaTeX format NOT IMPLEMENTED call gtpsavelatex(filename,str(3:)) elseif(str(1:1).eq.'X') then ! XTDB format call write_xtdbformat(filename,str(3:)) else ! macro format call gtpsavetm(filename,str) endif 1000 continue return end subroutine gtpsave !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine gtpsavelatex !\begin{verbatim} subroutine gtpsavelatex(filename,specification) ! save all data on LaTeX format on a file (for publishing) ! header ! element list ! species list ! phase list with sublattices, endmembers, interactions and parameters etc ! tpfuns ! state variable functions ! references ! equilibrium record(s) with conditions, componenets, phase_varres records etc ! anything else? implicit none character*(*) filename,specification !\end{verbatim} %+ 1000 continue return end subroutine gtpsavelatex !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine gtpsavedir !\begin{verbatim} %- subroutine gtpsavedir(filename,specification) ! save all data on a direct file (random access) ! header ! element list ! species list ! phase list with sublattices, endmembers, interactions and parameters etc ! tpfuns ! state variable functions ! references ! equilibrium record(s) with conditions, componenets, phase_varres records etc ! anything else? implicit none character*(*) filename,specification !\end{verbatim} %+ 1000 continue return end subroutine gtpsavedir !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine gtpsavetm !\begin{verbatim} subroutine gtpsavetm(filename,str) ! save all data on file in macro format ! header ! element list ! species list ! phase list with sublattices, endmembers, interactions and parameters etc ! tpfuns ! state variable functions ! references ! implicit none character*(*) filename,str !\end{verbatim} %+ logical tdbmode if(str(1:1).eq.'T') then ! TDB file tdbmode=.true. else ! MACRO mode tdbmode=.false. endif write(*,*)'TDB and MACRO save not implemented yet' goto 1000 ! UNFINISHED .... ! open file and write a macro file ! header ! element list ! species list ! phase list with sublattices, endmembers, interactions and parameters etc ! tpfuns ! state variable functions ! references ! ! For inspiration look at the LIST subroutines in pmod25E.F90 ! 1000 continue return end subroutine gtpsavetm !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine gtpsavetdb !\begin{verbatim} subroutine gtpsavetdb(filename,specification) ! save all data in TDB format on an file UNFINISHED ! header ! element list ! species list ! phase list with sublattices, endmembers, interactions and parameters etc ! tpfuns ! state variable functions ! references ! equilibrium record(s) with conditions, componenets, phase_varres records etc ! anything else? implicit none character*(*) filename,specification !\end{verbatim} write(*,*)'Save TDB using gtpsavetdb not implemented' 1000 continue return end subroutine gtpsavetdb !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine gtpsaveu !\begin{verbatim} subroutine gtpsaveu(filename,specification) ! save all data unformatted on an file ! First move it to an integer workspace, then write that on a file ! header ! element list ! species list ! phase list with sublattices, endmembers, interactions and parameters etc ! tpfuns ! state variable functions ! references ! equilibrium record(s) with conditions, componenets, phase_varres records etc ! anything else? implicit none character*(*) filename,specification !\end{verbatim} %+ ! character id*40,comment*72 ! size of workspace for unformatted storage integer miws integer, allocatable, dimension(:) :: iws integer i,isp,jph,lokph,lut,last,lok,rsize,displace,ibug,ffun,lokeq,ccc integer nspx,check ! these depend on hardware, bytes/word and words/double. Defined in metlib3 ! integer, parameter :: nbpw=4,nwpr=2 ! integer function nwch calculates the number of words to store a character ! write(*,*)'3E In gtpsaveu: ',trim(specification),' version: ',trim(savefile) ! ! positions reserved in the beginning of the workspace ! 3 element list ! 4 element version ! 5 species list ! 6 species version ! 7 tpfun list ! 8 tpfun version ! 9 phlista lista ! 10 phase version ! 11 endmember version ! 12 interaction version ! 13 property version ! 14 phase tuples lista ! 15 phase tuples version ! 16 equilibrium lista ! 17 equilibrium data version ! 18 component version ! 19 phase_varres version ! 20 global data record ! 21 global data version (not saved?) ! 22 bibliography lista ! 23 bibliography version ! 24 svfun lista ! 25 svfun version ! 26 assessment record list ! 27 assessment version ! 28 zero for unencypted, nonzero for encrypted ! 29 ! 30 ! missing: parameter_id_lista ... step/map/plot data ! range record? experiments ... !---------------------------------------------------------------------- ! allocate the workspace, words 3-102 for pointers and things listed above ! write(*,*)'3E allocating iws',miws if(btest(globaldata%status,GSNOPHASE)) then write(*,1) 1 format('There is no data to save!') goto 1001 endif ! dimension iws depending on number of equuilibria stored ! 7000 is for a 6 component system with 50 phases ! steel1 with 6 elements: 30000 static and 6000 per equilibrium ! TAFID 15 elements: 90000 for static and 30000 per equilibrium ! TAFID 41 elements, 350 phases: 300000 for static and 120000 per equilibrium ! estimate static: nel*nph*x; x=30: static=100000+nel*nph*30 ! equilibrium: 40*350*10 ... too small when few elements ccc=max(20*noofel*noofph,10000) ! eqfree may not be the higest used equilibrium record!! i=eqfree last=eqfree do while(eqlista(i)%nexteq.gt.0) if(eqlista(i)%nexteq.ne.i+1) then ! if eqlista(i)%nexteq does not increment sequentially there are some holes! last=eqlista(i)%nexteq write(*,*)'3E Beware: unused equilibria before the last used,'//& ' cannot be saved' gx%bmperr=4399; goto 1000 endif i=eqlista(i)%nexteq enddo ! miws=100000+noofel*noofph*30+ccc*last ! miws=2000000+50000*eqfree ! write(*,*)'3E allocating workspace: ',miws write(*,7)'3E allocating workspace: ',miws,30*noofel*noofph,ccc,last 7 format(a,i10,10x,'(',i7,', ',i7,', ',i4,')') allocate(iws(miws)) call winit(miws,100,iws) if(buperr.ne.0) goto 1100 !---------------------------------------------------------------------- ! note the use of gtp_xxx_version to handle versions of data structures !---------------------------------------------------------------------- ! !>>>>> 1: elementlist ! write(*,*)'3E nbpw and nwpr: ',nbpw,nwpr,nwch(1) ! rsize=1+1+12/nbpw+24/nbpw+3*nwpr+4 should be enough but .... rsize=1+1+nwch(12)+nwch(24)+3*nwpr+5 ! write(*,*)'3E Storing elements',noofel,rsize last=3 iws(last+1)=gtp_element_version do i=1,noofel ! next, symbol*2, name*12, ref_state*24, mass, h298, s298, ! splink, status, alphaindex, refstatesymbol call wtake(lok,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving element record' gx%bmperr=4356; goto 1100 endif call storc(lok+1,iws,ellista(i)%symbol) call storc(lok+2,iws,ellista(i)%name) displace=3+nwch(12) call storc(lok+displace,iws,ellista(i)%ref_state) displace=displace+nwch(24) call storr(lok+displace,iws,ellista(i)%mass) call storr(lok+displace+nwpr,iws,ellista(i)%h298_h0) call storr(lok+displace+2*nwpr,iws,ellista(i)%s298) displace=displace+3*nwpr iws(lok+displace)=ellista(i)%splink iws(lok+displace+1)=ellista(i)%status iws(lok+displace+2)=ellista(i)%alphaindex iws(lok+displace+3)=ellista(i)%refstatesymbol ! write(*,*)'3E element: ',i,displace+3,rsize,ellista(i)%refstatesymbol ! link sequentially in first word iws(last)=lok last=lok ibug=lok+displace+3 ! write(*,*)'3E refstatesymbol 0: ',ibug,iws(ibug),iws(1) enddo ! bug?? ! added one saved integer for size of spextra (normally zero) ibug=lok+displace+4 ! write(*,*)'3E refstatesymbol 1: ',ibug,iws(ibug),iws(1) !----------- !>>>>> 2: specieslist rsize=1+nwch(24)+3*nwpr+3 ! next, symbol*24, mass, charge, extra, noofel, status, alphaindex ! (allocated) ellinks, stoichiometry ! write(*,*)'3E storing species',noofsp,rsize,'+ellinks' last=5 iws(last+1)=gtp_species_version do isp=1,noofsp if(allocated(splista(isp)%spextra)) then nspx=size(splista(isp)%spextra) else nspx=0 endif check=rsize+splista(isp)%noofel*(1+nwpr)+nspx*nwpr call wtake(lok,rsize+splista(isp)%noofel*(1+nwpr)+nspx*nwpr,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving species record' gx%bmperr=4356; goto 1100 endif ! write(*,*)'3E refstatesymbol 2: ',ibug,iws(ibug),lok call storc(lok+1,iws,splista(isp)%symbol) displace=2+nwch(24) call storr(lok+displace,iws,splista(isp)%mass) call storr(lok+displace+nwpr,iws,splista(isp)%charge) iws(lok+displace+2*nwpr)=splista(isp)%noofel iws(lok+displace+2*nwpr+1)=splista(isp)%status iws(lok+displace+2*nwpr+2)=splista(isp)%alphaindex iws(lok+displace+2*nwpr+3)=nspx ! displace one less as the index i is added displace=displace+2*nwpr+3 do i=1,splista(isp)%noofel iws(lok+displace+i)=splista(isp)%ellinks(i) enddo displace=displace+splista(isp)%noofel+1 ! storing splista(isp)%noofel doubles in iws(lok+displace) ! write(*,*)'3E displace store: ',lok,displace ! storrn starts storing in iws(lok+displace) call storrn(splista(isp)%noofel,& iws(lok+displace),splista(isp)%stoichiometry) ! if nspx>0 save also all double variables in spextra if(nspx.gt.0) then displace=displace+splista(isp)%noofel*nwpr call storrn(nspx,iws(lok+displace),splista(isp)%spextra) ! write(*,*)'3E species with extra data: ',isp,nspx endif ! write(*,'(a,2i5)')'3E species record check: ',check,& ! displace+nspx*nwpr ! write(*,*)'3E refstatesymbol 3: ',ibug,iws(ibug),lok+displace ! do i=1,splista(isp)%noofel ! call storr(lok+displace+(i-1)*nwpr,iws, ! enddo ! write(*,*)'3E stored species ',isp,lok,displace+splista(isp)%noofel*nwpr ! link records sequentially in first word iws(last)=lok last=lok enddo ! write(*,*)'3E last species link: ',last,lok,iws(lok),iws(1) ! !------------- tpfuns !>>>>> 20: tpfuns call wtake(lok,freetpfun,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving tpfun record' gx%bmperr=4356; goto 1100 endif iws(7)=lok iws(8)=tpfun_expression_version iws(lok)=freetpfun ! write(*,*)'3E saving TPfuns: ',iws(7),iws(iws(7)) do i=1,freetpfun-1 ! store all TPfuns here. In parameters just store an index! ! we have to pass iws also .... call save0tpfun(ffun,iws,i) if(gx%bmperr.ne.0) goto 1100 ! write(*,*)'3E TPfun: ',i,' stored in ',iws(lok+i),iws(iws(lok+i)) iws(lok+i)=ffun enddo ! write the record for TP function 3 as check ! call wrttprec(3,iws) ! All seems OK this far !------------- phases and parameters, static data !>>>>> 3: phaselist, start from 0 (reference phase) ! including sublattces, endmembers, interactions, properties etc ! save version of various records ! write(*,*)'3E saving phases',noofph last=9 iws(last+1)=gtp_phase_version iws(last+2)=gtp_endmember_version iws(last+3)=gtp_interaction_version iws(last+4)=gtp_property_version call savephases(last,iws) if(gx%bmperr.ne.0) goto 1100 ! save all phase tuples in a single reord last=14 iws(last+1)=gtp_phasetuple_version ! write(*,*)'3E Saving tuples: ',nooftuples if(nooftuples.gt.0) then call wtake(lok,1+nooftuples*5,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving phase tuple record' gx%bmperr=4356; goto 1100 endif iws(lok)=nooftuples do i=0,nooftuples-1 iws(lok+5*i+1)=phasetuple(i+1)%lokph iws(lok+5*i+2)=phasetuple(i+1)%compset iws(lok+5*i+3)=phasetuple(i+1)%ixphase iws(lok+5*i+4)=phasetuple(i+1)%lokvares iws(lok+5*i+5)=phasetuple(i+1)%nextcs enddo iws(last)=lok else ! no phase tuples iws(last)=0 endif ! write(*,*)'3E tuples saved: ' !------------------------------------ ! save link to the global data record and version in 20-21 last=20 ! extended globaldata record 190317/BoS rsize=1+nwch(24)+3*nwpr+11+5*nwpr call wtake(lok,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving globaldata record' gx%bmperr=4356; goto 1100 endif iws(last)=lok iws(lok+1)=globaldata%status call storc(lok+2,iws,globaldata%name) ! BUG name was ovewritten by rgas etc !!! displace=2+nwch(24) call storr(lok+displace,iws,globaldata%rgas) call storr(lok+displace+nwpr,iws,globaldata%rgasuser) call storr(lok+displace+2*nwpr,iws,globaldata%pnorm) ! extended globaldata record 190317/BoS displace=displace+3*nwpr ! these used for testing when reading ! globaldata%sysparam(1)=987 ! globaldata%sysparam(10)=17 do i=0,9 iws(lok+displace+i)=globaldata%sysparam(i+1) enddo displace=displace+10 ! globaldata%sysreal(5)=12345678.9D0 call storrn(5,iws(lok+displace),globaldata%sysreal) ! write(*,*)'3E globalsave:: ',rsize,displace+5*nwpr ! write(*,*)'3E name: "',globaldata%name,'"' ! goto 900 ! unfinished !------------- state variable functions !>>>>> 30: svfuns ! write(*,*)'3E saving state variable functions' call svfunsave(lok,iws,firsteq) if(gx%bmperr.ne.0) goto 1100 iws(24)=lok iws(25)=gtp_putfun_lista_version !------------- references !>>>>> 40: bibliographic references ! write(*,*)'3E saving bibliography' ! link to bibliography is stored in 22 call bibliosave(lok,iws) if(gx%bmperr.ne.0) goto 1100 iws(22)=lok iws(23)=gtp_biblioref_version ! document use of workspace call wrkchk(rsize,miws,iws) write(*,*)'3E used ',rsize,' words out of ',miws,' for storing static data' !------------------------------------------------------- ! write the equilibrium records ! conditions, components, phase_varres for all composition sets etc !>>>>> 50: equilibria ! write(*,*)'3E saving equilibria' ! write(lut)gtp_equilibrium_data_version,gtp_component_version,& ! gtp_phase_varres_version lokeq=0 ! all equilibria are saved here call saveequil(lokeq,iws) if(gx%bmperr.ne.0) goto 1100 ! finished saving equilibria ! write(*,*)'3E first saved equilibrium at: ',lokeq iws(16)=lokeq iws(17)=gtp_equilibrium_data_version iws(18)=gtp_component_version iws(19)=gtp_phase_varres_version ! disfra record version?? !------------------------------------------------------- ! assessment head record write(*,*)'3E Saving assessment record' if(associated(firstash)) then iws(27)=gtp_assessment_version lok=26 call saveash(lok,iws) if(gx%bmperr.ne.0) goto 1100 endif ! free list for phase_varres records ! write(*,*)'3E Phase_varres first free/highcs: ',csfree,highcs ! UNFINISHED we should write assessment records and step/map/plot records !------------------------------------------------------- ! finally write the workspace to the file ... 900 continue if(index(filename,'.').eq.0) then filename(len_trim(filename)+1:)='.OCU' endif lut=21 !********************************************************** ! IMPORTANT savefile ! is a variable in gtp3.F90 ! which MUST BE CHANGED whenever there is a change in the unformatted ! file layout !*********************************************************** open(lut,file=filename,access='sequential',status='unknown',& form='unformatted',iostat=gx%bmperr,err=1000) id='This is a save file for OC version: ' comment=specification call wrkchk(rsize,miws,iws) ! NOTE: savefile is a character*8 in gtp3.F90 last=5+nwch(40)+nwch(8)+nwch(72) !---------------------------------------------------------------------- ! write(*,*)'3E save unformatted:',rsize,globaldata%encrypted if(globaldata%encrypted.ne.0) then iws(rsize+1)=18 else ! not encrypted iws(rsize+1)=0 endif !---------------------------------------------------------------------- write(lut)id,savefile,comment,noofel,noofsp,noofph,nooftuples,rsize+5 write(lut)(iws(i),i=1,rsize+5) close(lut) if(buperr.ne.0) then write(kou,990)buperr 990 format(/' *** WARNING *** , workspace save error: ',i7/) endif write(kou,989)rsize+5+last,miws,1.0D2*real(rsize+5+last)/real(miws) 989 format('Used ',i8,' words out of ',i8,', ',& F6.2,'% for unformatted memory save') write(kou,991)nbpw*(rsize+5+last),trim(filename) 991 format('Written workspace ',i10,' bytes unformatted on ',a) 1000 continue deallocate(iws) 1001 continue return 1100 continue write(*,*)'3E Error storing record, nothing written on file',buperr,gx%bmperr gx%bmperr=4357 goto 1000 end subroutine gtpsaveu !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine savephases !\begin{verbatim} subroutine savephases(phroot,iws) ! save data for all phases and store pointer in iws(phroot) ! For phases with disordered set of parameters we must access the number of ! sublattices via firsteq implicit none integer phroot,iws(*) !\end{verbatim} %+ integer doneord,i,j,level,lokcs,nem,noi,nop,nox,nsl,nup,noendm,fipsize integer iph,lok,rsize,displace,lokph,iwsph,lokem,lastem,lokpty,last integer phreclink type(gtp_endmember), pointer :: emrec type(gtp_interaction), pointer :: intrec type(gtp_property), pointer :: proprec character*8 dummy logical higher ! to keep track of interaction records type saveint type(gtp_interaction), pointer :: p1 integer lok end type saveint type(saveint), dimension(:), pointer :: stack type(gtp_phase_add), pointer :: addlink allocate(stack(5)) ! do not save the phases array, regenerate it on read ! call wtake(lok,noofph+1,iws) ! do i=1,noofph ! iws(lok+i)=phases(i) ! enddo ! store this link in last and set link to next in first word ! iws(last)=lok ! last=lok ! loop for all phases iwsph=phroot ! phases start from 0, the SER phase do iph=0,noofph ! lokph=phases(iph) lokph=iph !>>>>> 5: phase header ! link,name*24,model*72,phletter*1,status1,alphaindex,noofcs,nooffs,additionlink rsize=1+nwch(24)+nwch(72)+nwch(1)+5 ! the endmember_ord, endmember_dis and endmemrecarray is not used ... ! noofsubl,tnooffr,linktocs(9),nooffr(subl),constlist(tnooffr),i2slx rsize=rsize+2+9+phlista(lokph)%noofsubl+phlista(lokph)%tnooffr+2 ! we must also have links to two endmember lists and addtions rsize=rsize+3 call wtake(lok,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving phase record',trim(phlista(lokph)%name),& buperr gx%bmperr=4356; goto 1000 endif ! link all phase records sequentially from phroot using iwsph iws(iwsph)=lok iwsph=lok ! store phase data ! write(*,*)'3E creating record for ',trim(phlista(lokph)%name),lok call storc(lok+1,iws,phlista(lokph)%name) displace=1+nwch(24) call storc(lok+displace,iws,phlista(lokph)%models) displace=displace+nwch(72) ! we should store at least 4 characters ... dummy=phlista(lokph)%phletter call storc(lok+displace,iws,dummy(1:4)) displace=displace+1 iws(lok+displace)=phlista(lokph)%status1 iws(lok+displace+1)=phlista(lokph)%alphaindex iws(lok+displace+2)=phlista(lokph)%noofcs iws(lok+displace+3)=phlista(lokph)%nooffs ! mark there are additions, it is handled below ! if(associated(phlista(lokph)%additions)) then ! iws(lok+displace+4)=1 ! endif if(allocated(phlista(lokph)%oendmemarr)) then write(*,*)'3E Attention!! ignoring endmemberrec array!' endif !>>>>> 6: sublattice and constituent info nsl=phlista(lokph)%noofsubl iws(lok+displace+4)=nsl j=phlista(lokph)%tnooffr iws(lok+displace+5)=j ! displace one less as loops starts from 1 displace=displace+5 do i=1,9 iws(lok+displace+i)=phlista(lokph)%linktocs(i) enddo displace=displace+9 do i=1,nsl iws(lok+displace+i)=phlista(lokph)%nooffr(i) enddo displace=displace+nsl do i=1,j iws(lok+displace+i)=phlista(lokph)%constitlist(i) enddo displace=displace+j+1 ! saving i2sl is probably not necessary as it is calculated each time ?? iws(lok+displace)=phlista(lokph)%i2slx(1) iws(lok+displace+1)=phlista(lokph)%i2slx(2) ! links to endmembers and additions to be stored here and afterwards ! iws(phreclink) ordered, iws(phreclink+1) disordered, iws(phreclink+2) addition phreclink=lok+displace+2 ! write(*,*)'3E phreclink 1: ',phreclink,iws(1) !--------- endmember list, interaction tree and property records ! save all parameter data starting from the endmember list doneord=0 emrec=>phlista(lokph)%ordered ! write(*,*)'3E saving endmembers',doneord,nsl ! there can be phases without any ordered parameters ... if(.not.associated(emrec)) goto 400 ! The start of the sequentail list of endmember records (for ordered fractions) lokem=phreclink ! we come back here if there are disordered parameters 200 continue ! if doneord=1 then we have listed the ordered parameters if(doneord.eq.1) then emrec=>phlista(lokph)%disordered if(ocv()) write(*,*)'3E Saving disordered parameters' endif emlista: do while(associated(emrec)) proprec=>emrec%propointer intrec=>emrec%intpointer ! nop=0 ! noi=0 ! nem=0 ! if(associated(proprec)) nop=1 ! if(associated(intrec)) noi=1 ! if(associated(emrec%nextem)) nem=1 !>>>>> 7: endmember record (basic or disordered) ! write(lut)emrec%noofpermut,emrec%phaselink,emrec%antalem,nop,noi,nem ! do j=1,emrec%noofpermut ! write(lut)(emrec%fraclinks(i,j),i=1,nsl) ! enddo ! In the endmember recorde we store: ! link to next endmember, link to interaction, link to property record : 3 ! link to phase record, number of permutations, seq.order of creation? : 3 ! for each permutation nsl indices to fractions : perm*nsl ! rsize=6+emrec%noofpermut*nsl call wtake(lok,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving endmember record' gx%bmperr=4356; goto 1000 endif ! write(*,*)'3E emrec: ',emrec%noofpermut,lok,rsize,emrec%antalem ! maintain the sequential link between all endmember records iws(lokem)=lok lokem=lok ! iws(lok) to next, iws(nop=lok+1) to property, iws(noi=lok+2) to intercation, ! these are nem, noi, nop ! write(lut)emrec%noofpermut,emrec%phaselink,emrec%antalem,nop,noi,nem iws(lok+3)=emrec%noofpermut iws(lok+4)=emrec%phaselink iws(lok+5)=emrec%antalem displace=5 do j=1,emrec%noofpermut do i=1,nsl iws(lok+displace+i)=emrec%fraclinks(i,j) enddo displace=displace+nsl ! write(lut)(emrec%fraclinks(i,j),i=1,nsl) enddo ! this is the place to store the start of property records nop=lok+1 level=nop emproplista: do while(associated(proprec)) ! if(associated(proprec%nextpr)) nox=1 !>>>>> 8: endmember property record (loop) add place for %modelparamid ! rsize=5+nwch(16)+proprec%degree+1 rsize=5+nwch(20)+proprec%degree+1 call wtake(lokpty,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving endmember record' gx%bmperr=4356; goto 1000 endif ! link the property recordds sequentially iws(nop)=lokpty ! write(*,*)'3E endmem property record',iws(nop),lokpty,& ! proprec%proptype,proprec%degree level=nop nop=lokpty ! write(lut)proprec%reference,proprec%proptype,& ! proprec%degree,proprec%extra,proprec%antalprop,nox iws(lokpty+1)=proprec%proptype iws(lokpty+2)=proprec%degree iws(lokpty+3)=proprec%extra iws(lokpty+4)=proprec%antalprop call storc(lokpty+5,iws,proprec%reference) displace=5+nwch(16) ! write(*,*)'place to save modelparamid 1: ',& ! proprec%modelparamid,lokpty+displace call storc(lokpty+displace,iws,proprec%modelparamid) displace=displace+nwch(4) do i=0,proprec%degree ! store a link in iws(lokpty+displace+i) to the TP fun stored as a text ! we have to pass iws also .... ! call save1tpfun(lut,.FALSE.,proprec%degreelink(i)) ! third argument 1 means do not store function name ! call save2tpfun(lokpty+displace+i,iws,1,proprec%degreelink(i)) ! if(gx%bmperr.ne.0) goto 1000 iws(lokpty+displace+i)=proprec%degreelink(i) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'3E place of function: ',iws(lokpty+displace+i),& ! ' stored in ',lokpty+displace+i,iws(1) enddo proprec=>proprec%nextpr enddo emproplista ! at the end of the propoerty list iws(lokpty)=0 (zero) ! start interaction tree level=0 noi=lokem+2 ! return here for new interaction record 300 continue intlista: do while(associated(intrec)) ! noi is next, nup is higher, nop is property 310 continue !>>>>> 9: interaction record ! next, higher,property,status,antalint,order,fipsize :7 ! very complex for permutations ... ! look in gtp3G, create_interaction, for use of intrec%noofip ! noofip,sublattice(noofip),fraclink(noofip) ! write(*,*)'3E save link: ',intrec%antalint,intrec%noofip(2) fipsize=size(intrec%noofip) ! 2020.06.08/BoS problem handling interactions permutations ??? ! should there be something separate for level=2 ??? ! Sometimes error when reading a parameter level=2 WITHOUT any permutations if(level.eq.1) then rsize=7+fipsize+2*intrec%noofip(fipsize) else rsize=7+fipsize+2*intrec%noofip(2) endif call wtake(lok,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving interaction record',& buperr,rsize,fipsize gx%bmperr=4356; goto 1000 endif ! store data iws(lok+3)=intrec%status iws(lok+4)=intrec%antalint iws(lok+5)=intrec%order iws(lok+6)=fipsize displace=6 do i=1,fipsize iws(lok+displace+i)=intrec%noofip(i) enddo displace=displace+fipsize ! intrec%noofip(2) is OK for 1st order, for 2nd order we must use ! intrec%noofip(fipsize) ! write(*,*)'3E fipsize: ',level,fipsize,& ! intrec%noofip(2),intrec%noofip(fipsize) if(level.ne.1) then do i=1,intrec%noofip(2) iws(lok+displace+2*i-1)=intrec%sublattice(i) iws(lok+displace+2*i)=intrec%fraclink(i) enddo elseif(level.eq.1) then do i=1,intrec%noofip(fipsize) iws(lok+displace+2*i-1)=intrec%sublattice(i) iws(lok+displace+2*i)=intrec%fraclink(i) enddo endif ! write(*,11)'3E interaction: ',intrec%antalint,higher,lok,noi,& ! intrec%noofip(2),intrec%sublattice(1),intrec%fraclink(1) 11 format(a,i3,l3,10i5) ! link from previous, iws(lok+1) is link to higher, iws(lok+2) is property iws(noi)=lok noi=lok ! Any Toop/Kohler records should be saved here ... gtp_tooprec if(associated(intrec%tooprec)) then write(*,*)'3E 20240731: *** WARNING Toop/Kohler records not saved' endif ! interaction property, link from nop proprec=>intrec%propointer nop=lok+2 intproplista: do while(associated(proprec)) !>>>>> 10: interaction property record (loop) ! rsize=5+nwch(16)+proprec%degree+1 rsize=5+nwch(20)+proprec%degree+1 call wtake(lokpty,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving inteaction property record' gx%bmperr=4356; goto 1000 endif ! link the property records sequentially iws(nop)=lokpty nop=lokpty ! write(*,*)'3E interact property record',lokpty,& ! proprec%proptype ! write(lut)proprec%reference,proprec%proptype,& ! proprec%degree,proprec%extra,proprec%antalprop,nox iws(lokpty+1)=proprec%proptype iws(lokpty+2)=proprec%degree iws(lokpty+3)=proprec%extra iws(lokpty+4)=proprec%antalprop call storc(lokpty+5,iws,proprec%reference) displace=5+nwch(16) ! write(*,*)'place to save modelparamid 2: ',& ! proprec%modelparamid,lokpty+displace call storc(lokpty+displace,iws,proprec%modelparamid) displace=displace+nwch(4) do i=0,proprec%degree ! store a link in iws(lokpty+displace+i) to the TP fun stored as a text ! we have to pass iws also .... ! call save2tpfun(lokpty+displace+i,iws,1,& ! proprec%degreelink(i)) iws(lokpty+displace+i)=proprec%degreelink(i) enddo proprec=>proprec%nextpr enddo intproplista ! save on stack and check if higher level level=level+1 if(level.gt.5) then ! write(*,*)'3E Too many interaction levels' gx%bmperr=4164; goto 1000 endif ! save this interaction record and take link to higher stack(level)%p1=>intrec stack(level)%lok=lok intrec=>intrec%highlink ! link to higher should be in lok+1 noi=lok+1 if(associated(intrec)) higher=.true. enddo intlista ! we come here when there is no higher level ! pop previous intrec and take link to next interaction (on same level) higher=.false. if(level.gt.0) then intrec=>stack(level)%p1 noi=stack(level)%lok intrec=>intrec%nextlink level=level-1 goto 300 endif !---- next endmember emrec=>emrec%nextem enddo emlista ! no more endmembers, check if the disordered (if any) has been written 400 continue ! take link to higher higher interaction if(doneord.eq.0) then if(ocv()) write(*,*)'3E any disordered endmembers?' if(associated(phlista(lokph)%disordered)) then ! there are also disordered parameters ! the disfra record is written in saveequil?? ! we have to change nsl ...three % vojvoj doneord=1 lokcs=phlista(lokph)%linktocs(1) nsl=firsteq%phase_varres(lokcs)%disfra%ndd !>>>>> 11A: write disordered endmemebers ! write(lut)2,nsl ! emrec should already be null but for security .... nullify(emrec) lokem=phreclink+1 goto 200 endif endif !------ save additions list, use lokpty... 500 continue ! iws error check addlink=>phlista(lokph)%additions lokpty=phreclink+2 addition: do while(associated(addlink)) ! WHEN SAVING MORE ADDITION YOU MUST ALSO CHANGE READING UNFORMATTED readphases ! integer, public, parameter :: INDENMAGNETIC=1 ! integer, public, parameter :: XIONGMAGNETIC=2 ! integer, public, parameter :: DEBYECP=3 ! integer, public, parameter :: EINSTEINCP=4 ! integer, public, parameter :: TWOSTATEMODEL1=5 ! integer, public, parameter :: ELASTICMODEL1=6 ! integer, public, parameter :: VOLMOD1=7 ! integer, public, parameter :: UNUSED_CRYSTALBREAKDOWNMOD=8 ! integer, public, parameter :: SECONDEINSTEIN=9 ! integer, public, parameter :: SCHOTTKYANOMALY=10 ! integer, public, parameter :: DIFFCOEFS=11 ! with composition independent G2 parameter ! if(addlink%type.eq.1) then if(addlink%type.eq.INDENMAGNETIC) then !>>>>> 12A: additions id, regenerate all when reading this ! rsize=3 ! also saving status rsize=4 call wtake(lok,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving addition record' gx%bmperr=4356; goto 1000 endif iws(lokpty)=lok lokpty=lok iws(lok+1)=addlink%type iws(lok+2)=addlink%aff iws(lok+3)=addlink%status ! write(*,*)'3E saving additions in: ',phreclink+2,lok,iws(lok+1),& ! iws(lok+2) elseif(addlink%type.eq.XIONGMAGNETIC) then ! 2 !>>>>> 12A: additions id, regenerate all when reading this ! rsize=3 ! also saving status, there is a real rsize=4 call wtake(lok,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving addition record' gx%bmperr=4356; goto 1000 endif iws(lokpty)=lok lokpty=lok iws(lok+1)=addlink%type ! we have no aff but for xiongmagnetic we specify -1 for BCC ! write(*,*)'3E xiongmagnetic: ',addlink%status,ADDBCCMAG if(btest(addlink%status,ADDBCCMAG)) then iws(lok+2)=-1 else iws(lok+2)=0 endif ! there is no need to save this because record is will be regenerated iws(lok+3)=addlink%status ! addrecord typ 3 not used ! link the property recordds sequentially elseif(addlink%type.eq.EINSTEINCP) then ! 4 ! write(*,*)'Not saving Einstein addition' rsize=4 call wtake(lok,rsize,iws) if(buperr.ne.0) then write(*,*)'3E error saving addition record' gx%bmperr=4356; goto 1000 endif iws(lokpty)=lok lokpty=lok iws(lok+1)=addlink%type iws(lok+3)=addlink%status elseif(addlink%type.eq.TWOSTATEMODEL1) then ! 5 ! write(*,*)'Not saving liquid two-state addition' rsize=4 call wtake(lok,rsize,iws) if(buperr.ne.0) then write(*,*)'3E error saving addition record' gx%bmperr=4356; goto 1000 endif iws(lokpty)=lok lokpty=lok iws(lok+1)=addlink%type iws(lok+3)=addlink%status ! addrecord typ 6 not used elseif(addlink%type.eq.VOLMOD1) then ! 7 !>>>>> 12A: additions id, regenerate all when reading this ! rsize=3 rsize=4 call wtake(lok,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving addition record' gx%bmperr=4356; goto 1000 endif iws(lokpty)=lok lokpty=lok iws(lok+1)=addlink%type ! save also the status word iws(lok+3)=addlink%status ! iws(lok+2)=addlink%aff ! write(*,*)'3E saving additions in: ',phreclink+2,lok,iws(lok+1),& ! iws(lok+2) elseif(addlink%type.eq.DIFFCOEFS) then ! 11 write(*,*)'Not saving Diffusion addition' else write(*,99)addlink%type 99 format(78('*')/'3E *** NOT SAVED addition record type ',i3/78('*')/) endif addlink=>addlink%nextadd enddo addition enddo ! write(*,*)'3E phreclink 2: ',phreclink,iws(phreclink),iws(phreclink+1),& ! iws(phreclink+2) 1000 continue return end subroutine savephases !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine saveequil !\begin{verbatim} subroutine saveequil(lok1,iws) ! subroutine saveequil(lok1,iws,ceq) ! save data for equilibrium record ceq including phase_varres implicit none integer lok1,iws(*),jeq !\end{verbatim} %+ character text*1024 type(gtp_phase_varres), pointer :: firstvarres TYPE(gtp_fraction_set), pointer :: fslink ! TYPE(gtp_condition), pointer :: condrec integer i,isp,j,k,kl,lokcs,lokph,mc,mc2,nsl,lokeq,rsize,displace,lokvares integer lokdis,disz,lok,qsize,eqdis,iws1,dcheck,lokcc,seqz,offset,dmc integer loklast,eqnumber,lokhighcs,ceqsize,ceqsize2 type(gtp_equilibrium_data), pointer :: ceq ! loop to save all equilibria eqnumber=0 ceqsize2=ceqrecsize() 17 continue eqnumber=eqnumber+1 if(eqnumber.eq.1) then ! calculate the size of the first equilibrium record saved ceqsize=iws(1) elseif(eqnumber.eq.2) then ceqsize=iws(1)-ceqsize write(*,18)ceqsize,ceqsize2 18 format(' 3E Saving an equilibrium record requires ',2i8,' words') endif ceq=>eqlista(eqnumber) ! check if enything entered ... if(.not.allocated(ceq%complist)) then write(*,*)'3E not storing unused equilibria from: ',eqnumber goto 1000 ! else ! write(*,*)'3E storing equilibrium number: ',eqnumber endif !>>>>> 50: ! write(lut)ceq%eqname,ceq%eqno,ceq%status,ceq%next ! status,multi,eqno,next,name,comment,tpval(2),rtn,weight, ! (links to cond,exper), complist(nel),(link to compstoi*(nel*nel)) ! old: highcs, (link to phase_varres), mu(nel), xconc,gmind,eqextra,maxiter ! highcs, (link to phase_varres),mu(nel),xconc, gdconv(2),gmind,eqextra,maxiter ! rsize=4+nwch(24)+nwch(72)+4*nwpr+2+2*noofel+4+3*nwpr rsize=4+nwch(24)+nwch(72)+4*nwpr+2+2*noofel+4+5*nwpr call wtake(lokeq,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving equilibrium record' gx%bmperr=4356; goto 1000 endif if(lok1.eq.0) then ! return pointer to first lok1=lokeq else ! else link from previous ! write(*,*)'Linking equilibria: ',lok1,loklast,lokeq iws(loklast)=lokeq endif loklast=lokeq ! iws(lokeq) is pointer to next ! write(*,16)lokeq,ceq%status 16 format('3E equilibrium status word: ',i8,1x,z8) iws(lokeq+1)=ceq%status iws(lokeq+2)=ceq%multiuse iws(lokeq+3)=ceq%eqno iws(lokeq+4)=ceq%nexteq call storc(lokeq+5,iws,ceq%eqname) displace=5+nwch(24) call storc(lokeq+displace,iws,ceq%comment) displace=displace+nwch(72) call storrn(2,iws(lokeq+displace),ceq%tpval) call storr(lokeq+displace+2*nwpr,iws,ceq%weight) displace=displace+3*nwpr ! svfunres not stored !---- conditions, write as text and recreated when reading file call get_all_conditions(text,0,ceq) if(gx%bmperr.ne.0) goto 1000 kl=index(text,'CRLF')-1 ! write(*,*)'3E cond: ',trim(text),kl if(kl.gt.1) then call wtake(lok,1+nwch(kl),iws) if(buperr.ne.0) then write(*,*)'3E Error reserving condition record' gx%bmperr=4356; goto 1000 endif call storc(lok+1,iws,text(1:kl)) iws(lok)=kl iws(lokeq+displace)=lok else ! no conditions iws(lokeq+displace)=0 endif !---- save experiments as text ! a bit strange one has to loop incrementing seqz until there is an error ... iws(lokeq+displace+1)=0 seqz=0 lokcc=lokeq+displace+1 133 continue seqz=seqz+1 j=1 text=' ' call get_one_experiment(j,text,seqz,.FALSE.,ceq) if(gx%bmperr.ne.0) then ! no or no more experiments gx%bmperr=0 else ! do not save the "current value" after the $ ! write(*,*)'3E save experiment: "',trim(text),'"' kl=index(text,'$')-1 if(kl.le.0) then kl=len_trim(text) endif if(kl.gt.0) then ! write(*,*)'3E experiment: ',text(1:kl),seqz call wtake(lok,2+nwch(kl),iws) if(buperr.ne.0) then write(*,*)'3E Error reserving experiments record' gx%bmperr=4356; goto 1000 endif call storc(lok+2,iws,text(1:kl)) iws(lok+1)=kl ! create a linear list iws(lokcc)=lok lokcc=lok endif goto 133 endif ! write(*,*)'3E buperr 1: ',buperr !---- if components different from elements if(btest(globaldata%status,GSNOTELCOMP)) then write(*,*)'3E Not implemented saving other components than elements' gx%bmperr=4399; goto 1000 ! do i=1,noofel ! isp=ceq%complist(i)%splink ! write(lut)isp ! write(lut)ceq%complist(i)%phlink,ceq%complist(i)%status,& ! ceq%complist(i)%refstate,ceq%complist(i)%tpref,& ! ceq%complist(i)%mass ! enddo ! do i=1,noofel ! if(ocv()) write(*,99)'comp.matrix: ',(ceq%invcompstoi(j,i),j=1,noofel) ! enddo !99 format(a,7e11.3) ! do i=1,noofel ! write(lut)(ceq%compstoi(j,i),j=1,noofel) ! enddo else ! save component records in a linked list NEEDED FOR MANY THINGS ! like reference state etc lokcc=lokeq+displace+2 rsize=5+nwch(16)+1+6*nwpr do j=1,noofel if(allocated(ceq%complist(j)%endmember)) then ! this component has a user defined reference state kl=size(ceq%complist(j)%endmember) else kl=0 endif call wtake(lok,rsize+kl,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving varres record 1',j,rsize+kl gx%bmperr=4356; goto 1000 endif ! sequential link iws(lokcc)=lok lokcc=lok ! data iws(lok+1)=ceq%complist(j)%splink iws(lok+2)=ceq%complist(j)%phlink iws(lok+3)=ceq%complist(j)%status call storc(lok+4,iws,ceq%complist(j)%refstate) disz=4+nwch(16) iws(lok+disz)=kl if(kl.gt.0) then do mc=1,kl iws(lok+disz+mc)=ceq%complist(j)%endmember(mc) enddo disz=disz+kl+1 else disz=disz+1 endif ! write(*,*)'3E refstate 1: ',ceq%complist(j)%tpref call storrn(2,iws(lok+disz),ceq%complist(j)%tpref) disz=disz+2*nwpr call storrn(2,iws(lok+disz),ceq%complist(j)%chempot) disz=disz+2*nwpr call storr(lok+disz,iws,ceq%complist(j)%mass) ! write(*,*)'3E saving component mass',lok,disz,j,ceq%complist(j)%mass call storr(lok+disz+nwpr,iws,ceq%complist(j)%molat) ! write(*,*)'3e comprec size: ',lok,lok+disz+nwpr,iws(1) enddo endif 117 continue ! LINKED LIST of phase_varres records stored from lokeq+lokvares lokhighcs=lokeq+displace+3 ! write(*,118)'3E highcs: ',eqnumber,highcs,csfree,lokhighcs 118 format(a,3i5,i10) iws(lokhighcs)=highcs lokvares=lokhighcs+1 eqdis=displace+5 ! write(*,*)'3E buperr 2: ',buperr ! write(*,*)'3E link to first phase_varres in ',lokvares,highcs !--------------------------------------------------------- below is varres !---- varres records, one for each composition set of the phases and sometimes ! one for disordered fraction sets .... ! write them in records linked from lokvares as they can be very different compset: do j=1,highcs ! loop for all composition sets firstvarres=>ceq%phase_varres(j) if(.not.allocated(firstvarres%yfr)) then ! if this phase_varres is no longer used this should be unallocated call wtake(lok,4,iws) if(buperr.ne.0) then gx%bmperr=4356; goto 1000 endif write(*,*)'3E unused phase_varres:',j,highcs,lok ! this is the free list iws(lok+1)=firstvarres%nextfree ! this should be phlink but set to illegal value iws(lok+2)=-1 ! this links all phase varres records together iws(lokvares)=lok lokvares=lok cycle compset endif lokph=firstvarres%phlink if(btest(firstvarres%status2,CSDFS)) then ! this phase_varres/parres record belong to disordered fraction_set ! A bit tricky to find the number of sublattices and constituents .... lokcs=phlista(lokph)%linktocs(1) nsl=ceq%phase_varres(lokcs)%disfra%ndd mc=ceq%phase_varres(lokcs)%disfra%tnoofxfr else ! lokcs=0 nsl=phlista(firstvarres%phlink)%noofsubl ! mc=phlista(firstvarres%phlink)%tnooffr ! if this phase_varres has been removed this may be unallocated if(.not.allocated(firstvarres%yfr)) then write(*,*)'3E highcs not updated when removing compset!',j,highcs ! we should update?? iws(lokeq+displace+3)=highcs cycle compset endif ! wow, firstvarres%yfr is dimensioned to 1000 mc=phlista(firstvarres%phlink)%tnooffr ! write(*,*)'3E mc: ',trim(phlista(lokph)%name),mc,size(firstvarres%yfr) endif if(btest(firstvarres%status2,CSDLNK)) then ! the offset here shold be the place to store the disfra record ... offset=6+2*nwch(4)+3*nwpr+mc*(1+2*nwpr)+nsl*nwpr ! write(*,202)'3E offset 0: ',j,highcs,lokph,nsl,mc,offset endif mc2=mc*(mc+1)/2 ! nextfree,phlink,status2,phstate,phtupx,abnorm(3),prefix*4,suffix*4 ! constat(mc),yfr(mc),mmyfr(mc)+2 extra for nsl and mc rsize=6+2*nwch(4)+3*nwpr+mc+2*mc*nwpr ! sites(nsl),disfralink,amfu,netcharge,dgm and link to ionliq dpqdy record!! ! also added qcbonds!! ! rsize=rsize+nsl*nwpr+1+4*nwpr+2 rsize=rsize+nsl*nwpr+1+5*nwpr+2 ! results g, dg, d2g some exra space rsize=rsize+6*nwpr+3*mc*nwpr+mc2*nwpr+5+2 qsize=rsize call wtake(lok,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving varres record 2',j,rsize,nsl,mc gx%bmperr=4356; goto 1000 endif iws1=iws(1) ! lokph=firstvarres%phlink ! write(*,107)'3E saving: ',j,lok,rsize,mc,nsl,trim(phlista(lokph)%name) ! write(*,107)'3E saving: ',j,phasetuple(j)%ixphase,nsl,0,0 107 format(a,i3,2i10,i4,i3,2x,a) ! link from lokvares and use iws(lok) to link to next iws(lokvares)=lok lokvares=lok ! data iws(lok+1)=firstvarres%nextfree iws(lok+2)=firstvarres%phlink iws(lok+3)=firstvarres%status2 iws(lok+4)=firstvarres%phstate iws(lok+5)=firstvarres%phtupx iws(lok+6)=nsl iws(lok+7)=mc call storc(lok+8,iws,firstvarres%prefix) displace=8+nwch(4) call storc(lok+displace,iws,firstvarres%suffix) displace=displace+nwch(4) call storrn(3,iws(lok+displace),firstvarres%abnorm) displace=displace+3*nwpr ! write(*,*)'3E sizes:',allocated(firstvarres%constat),& ! size(firstvarres%constat),size(firstvarres%yfr),mc do i=1,mc iws(lok+displace+i-1)=firstvarres%constat(i) enddo displace=displace+mc call storrn(mc,iws(lok+displace),firstvarres%yfr) displace=displace+mc*nwpr ! mmyfr is just reals ... do not bother (although space for double reserved) ! write(lut)(firstvarres%mmyfr(i),i=1,mc) displace=displace+mc*nwpr ! write(*,*)'3E sites:',lok,displace,lok+displace call storrn(nsl,iws(lok+displace),firstvarres%sites) displace=displace+nsl*nwpr ! do not save the cmuval array ! dsitesdy is interesting only for ionic liquids ! if(btest(phlista(lokph)%status1,PHIONLIQ)) then ! call wtake(mc+mc2,iws ! call storrn(mc,iws(lok+displace),firstvarres%dpqdy) ! displace=displace+mc ! call storrn(mc2,iws(lok+displace),firstvarres%d2pqdvay) ! displace=displace+mc2 ! write(*,*)'3E odd: ',lok,displace ! else ! iws( ! endif fsrec: if(btest(firstvarres%status2,CSDLNK)) then ! we need a record for a disordered fraction_set record ! latd,ndd,tnoofxfr,tnoofyfr,varreslink,totdis, id*1, dsites(nsl), ! nooffr(mc), splink(mc), y2x(mc), dxidyj(mc),fsites fslink=>firstvarres%disfra nsl=fslink%ndd ! dmc because we store G and dG/dy later for original mc dmc=fslink%tnoofxfr rsize=8+nwch(1)+nsl+dmc+1+mc*(1+nwpr)+nsl*nwpr+nwpr call wtake(lokdis,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving disordered varres record',rsize gx%bmperr=4356; goto 1000 endif ! write(*,202)'3E disfracset 1: ',j,lok,displace,lokdis,nsl,dmc 202 format(a,10i6) ! set link from varres record iws(lok+displace)=lokdis ! store data iws(lokdis)=fslink%latd iws(lokdis+1)=fslink%ndd iws(lokdis+2)=fslink%tnoofxfr iws(lokdis+3)=fslink%tnoofyfr iws(lokdis+4)=fslink%totdis iws(lokdis+5)=fslink%varreslink call storc(lokdis+6,iws,fslink%id) ! write(*,202)'3E disfracset 2: ',j,iws(lokdis+1),iws(lokdis+2),& ! iws(lokdis+5) ! set disz to one less as i starts from 1 disz=6+nwch(1) ! number of constituents in each sublattice do i=1,nsl iws(lokdis+disz+i)=fslink%nooffr(i) enddo disz=disz+nsl ! write(*,*)'3E disfra 1: ',lokdis,disz ! species index for all constituents do i=1,dmc iws(lokdis+disz+i)=fslink%splink(i) enddo disz=disz+dmc+1 iws(lokdis+disz)=mc disz=disz ! NOTE y2x and dxidy1 has dimension mc!! ! write(*,*)'3E disfra 2: ',lokdis,disz,dmc,mc,size(fslink%y2x) ! This has to do with the fractions that should be added together do i=1,mc iws(lokdis+disz+i)=fslink%y2x(i) enddo disz=disz+mc+1 ! write(*,*)'3E disfra 3: ',lokdis,disz ! number of sites in each sublattice call storrn(nsl,iws(lokdis+disz),fslink%dsites) disz=disz+nsl*nwpr ! write(*,*)'3E disfra 4: ',lokdis,disz,dmc,mc,size(fslink%y2x) ! converting ordered fractions to disordered fractions call storrn(mc,iws(lokdis+disz),fslink%dxidyj) ! formula unit factor disz=disz+mc*nwpr ! write(*,*)'3E disfra 5: ',lokdis,disz call storr(lokdis+disz,iws,fslink%fsites) ! write(*,*)'3E disfra: ',lokdis+disz+nwpr,iws(1) else ! mark no link to disordered record ! write(*,*)'3E no disorderd record',lok+displace,iws(1),iws(2) iws(lok+displace)=0 endif fsrec ! write(*,*)'3E buperr 7: ',buperr,lok,displace !------------------------------------- end of disorderd record ! save some results stored in the phase_varres record displace=displace+1 call storr(lok+displace,iws,firstvarres%amfu) call storr(lok+displace+nwpr,iws,firstvarres%netcharge) call storr(lok+displace+2*nwpr,iws,firstvarres%dgm) ! record size increased to save qcbonds ... and increment of displace below call storr(lok+displace+3*nwpr,iws,firstvarres%qcbonds) ! Maybe firstvarres%nprop is not always initiated?? ! it seems that additional compsets have an arbitrary value ... if(firstvarres%nprop.ne.20) then iws(lok+displace+4*nwpr)=20 else iws(lok+displace+4*nwpr)=firstvarres%nprop endif ! write(*,303)'3E saving nprop: ',lok,displace+3*nwpr,lok+displace+3*nwpr,& ! iws(lok+displace+3*nwpr),trim(phlista(lokph)%name) 303 format(a,4i8,2x,a) displace=displace+4*nwpr+1 ! only save G and derivatives do i=1,6 call storr(lok+displace+nwpr*(i-1),iws,firstvarres%gval(i,1)) enddo ! problem here with SELECT_ELEMENT_REFERENCE phase ... ! write(*,304)'3E bug: ',trim(phlista(lokph)%name),mc,& ! size(firstvarres%dgval) !304 format(a,a,5i5) ! in the ENTER_EQUILIBRIUM the incorrect size of dgval was allocated !!! fixed displace=displace+6*nwpr do i=1,3 do k=1,mc ! write(*,*)'indices: ',i,k call storr(lok+displace,iws,firstvarres%dgval(i,k,1)) displace=displace+nwpr enddo enddo do i=1,mc2 call storr(lok+displace+nwpr*(i-1),iws,firstvarres%d2gval(i,1)) enddo ! write(*,*)'3E last values used ',j,lok+displace+mc2*nwpr,lok+qsize,iws1 enddo compset !---------------------------------------- ! we must set csfree to highcs+1 ! as new composition sets will use that as the free list pointer csfree=highcs+1 !----------------------------------------- ! mu(nel), xconc,gmind,eqextra,maxiter ! MODIFIED: mu(nel), xconc, gdconv(2), gmind,eqextra,maxiter iws(lokeq+eqdis)=ceq%maxiter call storrn(noofel,iws(lokeq+eqdis+1),ceq%cmuval) eqdis=eqdis+1+noofel*nwpr call storr(lokeq+eqdis,iws,ceq%xconv) call storr(lokeq+eqdis+nwpr,iws,ceq%gdconv(1)) call storr(lokeq+eqdis+2*nwpr,iws,ceq%gdconv(2)) call storr(lokeq+eqdis+3*nwpr,iws,ceq%gmindif) ! last use of lokeq !! ! write(*,*)'3E NOT saving the character eqextra!' ! call storc(lokeq+displace+2*nwpr,iws,ceq%eqextra) ! write(*,*)'3E check rsize: ',rsize,eqdis+2*nwpr !>>>>>> 64: savesysmat ! write(*,*)'3E not saving sysmat?',ceq%sysmatdim,ceq%nfixmu,ceq%nfixph ! NOTE:: ceq%sysmatdim negative, not initiallized?? ! NOTE:: phasetuples not saved !!! ! write(lut)ceq%sysmatdim,ceq%nfixmu,ceq%nfixph ! if(ceq%nfixmu.gt.0) write(lut)(ceq%fixmu(kl),kl=1,ceq%nfixmu) ! if(ceq%nfixph.gt.0) write(lut)& ! (ceq%fixph(1,kl),ceq%fixph(2,kl),kl=1,ceq%nfixph) ! if(ceq%sysmatdim.gt.0) then ! do mc=1,ceq%sysmatdim ! write(lut)(ceq%savesysmat(mc,kl),kl=1,ceq%sysmatdim) ! enddo ! endif ! loop for all entered equilibria goto 17 !---------- 1000 continue return end subroutine saveequil !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine svfunsave !\begin{verbatim} subroutine svfunsave(loksvf,iws,ceq) ! saves all state variable functions as texts in iws implicit none integer iws(*),loksvf type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ character text*512,symbols(20)*32,afterdot*32 integer ip,ipos,istv,js,jt,kl,ks,lrot,rsize,lok type(gtp_state_variable), target :: svr2 type(gtp_state_variable), pointer :: svrrec rsize=nsvfun+5 call wtake(loksvf,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving state variable function record',rsize,iws(1) gx%bmperr=4356; goto 1000 endif iws(loksvf)=nsvfun iws(loksvf+1)=3 ! do not save the first three, R, RT and T_C symbols=' ' write(*,*)'3E saving ',nsvfun,' symbols as texts' do lrot=4,nsvfun ipos=1 text=' ' call list_svfun(text,ipos,lrot,ceq) rsize=1+nwch(ipos) call wtake(lok,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving state variable func record',rsize,iws(1) gx%bmperr=4356; goto 1000 endif ! write(*,*)'3E storing svfun: ',text(1:ipos) iws(lok)=ipos ! NOTE position 1-7 is equilibrium number and status call storc(lok+1,iws,text(1:ipos)) iws(loksvf+lrot)=lok enddo 1000 continue return end subroutine svfunsave !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine bibliosave !\begin{verbatim} subroutine bibliosave(bibhead,iws) ! saves references on a file implicit none integer bibhead,iws(*) !\end{verbatim} %+ character longline*2048 integer ir,jp,ll,nl,lok,rsize !>>>>> 40: ! write(*,*)'3E Saving reference version and number of:',& ! gtp_biblioref_version,reffree-1 rsize=3+reffree-1 call wtake(bibhead,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving biblographiic record',rsize,iws(1) gx%bmperr=4356; goto 1000 endif iws(bibhead)=reffree-1 do ir=1,reffree-1 ! a bibliographic reference contains 16 character identifier and a variable ! characters text. Concatinate that into a single text and save one ! reference in each record linked from bibhead longline=bibrefs(ir)%reference jp=17 ! This require Fortran 2003/2008 standard, not available in GNU Fortran 4.8 ! longline(17:)=bibrefs(ir)%nyrefspec ll=bibrefs(ir)%wprefspec(1) call loadc(2,bibrefs(ir)%wprefspec,longline(17:ll+16)) ! nl=size(bibrefs(ir)%refspec) ! do ll=1,nl ! longline(jp:)=bibrefs(ir)%refspec(ll) ! jp=jp+64 ! enddo jp=len_trim(longline) rsize=1+nwch(jp) call wtake(lok,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving biblographiic record',rsize,iws(1) gx%bmperr=4356; goto 1000 endif iws(lok)=jp call storc(lok+1,iws,longline(1:jp)) iws(bibhead+ir)=lok enddo 1000 continue return end subroutine bibliosave !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine saveash !\begin{verbatim} subroutine saveash(lok,iws) ! saving assessment records integer lok,iws(*) !\end{verbatim} %+ integer lok1,lok2,last,rsize,i1,i2,disp type(gtp_assessmenthead), pointer :: assrec ! type(gtp_equilibrium_data), pointer :: ceq ! assrec=>firstash%nextash if(.not.allocated(assrec%eqlista)) then write(kou,*)'3E No experimental equilibrium range set' ! iws(lok)=0 ! goto 1000 endif 20 continue ! next, status, varcoef, first, and 8 allocatable arrays ! rsize=4+2*nwch(64)+10 ! added one location for pointer to RSD values ! rsize=4+2*nwch(64)+11 rsize=5+2*nwch(64)+11 write(*,*)'3E allocating assessment head record',rsize call wtake(lok1,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving assessment record',rsize,iws(1) gx%bmperr=4356; goto 1000 endif if(iws(lok).eq.0) then iws(lok)=lok1 last=lok1 else iws(last)=lok1 last=lok1 endif iws(lok1+1)=assrec%status iws(lok1+2)=assrec%varcoef iws(lok1+3)=assrec%firstexpeq iws(lok1+4)=assrec%lwam ! call storc(lok1+4,iws,assrec%general) call storc(lok1+5,iws,assrec%general) disp=5+nwch(64) call storc(lok1+disp,iws,assrec%special) disp=disp+nwch(64) ! eqlista CAN BE EMPTY! if(allocated(assrec%eqlista)) then i1=size(assrec%eqlista) rsize=1+i1 call wtake(lok2,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving assessment record array',rsize,iws(1) gx%bmperr=4356; goto 1000 endif ! write(*,*)'3E in saveash 1:',lok,lok1,lok2,i1 iws(lok2)=i1 if(i1.gt.0) then ! Hm assrec%eqlista(i2)%p1 is a pointer to an element in the global eqlists ! ceq=>assrec%eqlista(1)%p1 do i2=1,i1 iws(lok2+i2)=assrec%eqlista(i2)%p1%eqno enddo endif else ! mark that no experimental records lok2=0 endif iws(lok1+disp+1)=lok2 ! coeffvalues if(allocated(assrec%coeffvalues)) then i1=size(assrec%coeffvalues) rsize=1+nwpr*i1 call wtake(lok2,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving assessment record array',rsize,iws(1) gx%bmperr=4356; goto 1000 endif ! write(*,*)'3E in saveash 2:',lok2,i1,rsize iws(lok2)=i1 call storrn(i1,iws(lok2+1),assrec%coeffvalues) iws(lok1+disp+2)=lok2 ! relative standard deviation i1=size(assrec%coeffvalues) rsize=1+nwpr*i1 call wtake(lok2,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving assessment record array',rsize,iws(1) gx%bmperr=4356; goto 1000 endif ! write(*,*)'3E in saveash 2 RSD:',lok2,i1,rsize iws(lok2)=i1 call storrn(i1,iws(lok2+1),assrec%coeffrsd) iws(lok1+disp+3)=lok2 ! coeffscale i1=size(assrec%coeffscale) rsize=1+nwpr*i1 call wtake(lok2,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving assessment record array',rsize,iws(1) gx%bmperr=4356; goto 1000 endif iws(lok2)=i1 ! write(*,*)'3E in saveash 3:',lok2,i1 call storrn(i1,iws(lok2+1),assrec%coeffscale) ! iws(lok1+disp+3)=lok2 iws(lok1+disp+4)=lok2 ! coeffstart i1=size(assrec%coeffstart) rsize=1+nwpr*i1 call wtake(lok2,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving assessment record array',rsize,iws(1) gx%bmperr=4356; goto 1000 endif iws(lok2)=i1 ! write(*,*)'3E in saveash 4:',lok2,i1 call storrn(i1,iws(lok2+1),assrec%coeffstart) ! iws(lok1+disp+4)=lok2 iws(lok1+disp+5)=lok2 ! coeffmin i1=size(assrec%coeffmin) rsize=1+nwpr*i1 call wtake(lok2,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving assessment record array',rsize,iws(1) gx%bmperr=4356; goto 1000 endif iws(lok2)=i1 ! write(*,*)'3E in saveash 5:',lok2,i1 call storrn(i1,iws(lok2+1),assrec%coeffmin) ! iws(lok1+disp+5)=lok2 iws(lok1+disp+6)=lok2 ! coeffmax i1=size(assrec%coeffmax) rsize=1+nwpr*i1 call wtake(lok2,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving assessment record array',rsize,iws(1) gx%bmperr=4356; goto 1000 endif iws(lok2)=i1 call storrn(i1,iws(lok2+1),assrec%coeffmax) ! iws(lok1+disp+6)=lok2 iws(lok1+disp+7)=lok2 ! coeffindices i1=size(assrec%coeffindex) rsize=1+i1 call wtake(lok2,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving assessment record array',rsize,iws(1) gx%bmperr=4356; goto 1000 endif ! write(*,*)'3E in saveash 6:',lok2,i1 iws(lok2)=i1 do i2=1,i1 iws(lok2+i2)=assrec%coeffindex(i2-1) enddo ! iws(lok1+disp+7)=lok2 iws(lok1+disp+8)=lok2 ! coeffstate i1=size(assrec%coeffstate) rsize=1+i1 call wtake(lok2,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving assessment record array',rsize,iws(1) gx%bmperr=4356; goto 1000 endif iws(lok2)=i1 do i2=1,i1 iws(lok2+i2)=assrec%coeffstate(i2-1) enddo ! iws(lok1+disp+8)=lok2 iws(lok1+disp+9)=lok2 else ! pointers are zero write(*,*)'3E no coefficients allocated' endif ! maybe work array should not be saved? if(allocated(assrec%wopt)) then i1=size(assrec%wopt) rsize=1+nwpr*i1 write(*,*)'3E saving assessment record: (assrec%wopt)',lok1,rsize call wtake(lok2,rsize,iws) if(buperr.ne.0) then write(*,*)'3E Error reserving assessment record array',rsize,iws(1) gx%bmperr=4356; goto 1000 endif iws(lok2)=i1 call storrn(i1,iws(lok2+1),assrec%wopt) ! iws(lok1+disp+9)=lok2 iws(lok1+disp+10)=lok2 else write(*,*)'3E no work array (assrec%wopt) allocated' ! iws(lok1+disp+9)=0 iws(lok1+disp+10)=0 endif ! check if there are several assessment records if(.not.associated(assrec,firstash)) then assrec=>assrec%nextash write(*,*)'3E more than one assessment records' goto 20 endif 1000 continue return end subroutine saveash !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable integer function ceqrecsize !\begin{verbatim} integer function ceqrecsize() ! calculates the number of words needed to save an equilibrium record !\end{verbatim} integer rsize,jj,seqz,kl,dmc,mc,mc2,nsl type(gtp_equilibrium_data), pointer :: ceq type(gtp_phase_varres), pointer :: firstvarres TYPE(gtp_fraction_set), pointer :: fslink character text*512 ! write(*,*)'ceqrecsize not implemented',highcs rsize=0 goto 1000 ceq=>firsteq rsize=4+nwch(24)+nwch(72)+4*nwpr+2+2*noofel+4+5*nwpr text=' ' call get_all_conditions(text,0,ceq) rsize=rsize+nwch(index(text,'CRLF')) 100 continue text=' ' call get_one_experiment(jj,text,seqz,.FALSE.,ceq) if(gx%bmperr.ne.0) then kl=index(text,'$')-1 if(kl.le.0) then kl=len_trim(text) endif rsize=rsize+2+nwch(kl) goto 100 endif gx%bmperr=0 ! ignore if a component has a defined reference state ... rsize=rsize+(5+nwch(16)+1+6*nwpr)*noofel do jj=1,highcs ! loop for phase_varres records .. firstvarres=>ceq%phase_varres(jj) if(.not.allocated(firstvarres%yfr)) then rsize=rsize+4 else rsize=rsize+6+2*nwch(4)+3*nwpr+mc+2*mc*nwpr rsize=rsize+6*nwpr+3*mc*nwpr+mc2*nwpr+5+2 if(btest(firstvarres%status2,CSDLNK)) then ! there is a disordered fraction set ... fslink=>firstvarres%disfra nsl=fslink%ndd rsize=8+nwch(1)+nsl+dmc+1+mc*(1+nwpr)+nsl*nwpr+nwpr endif endif enddo 1000 continue ceqrecsize=rsize return end function ceqrecsize !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine gtpread !\begin{verbatim} subroutine gtpread(filename,str) ! read unformatted all data in the following order ! header ! element list ! species list ! phase list with sublattices, endmembers, interactions and parameters etc ! tpfuns ! references ! first equilibrium record with conditions, componenets, phase_varres etc ! state variable functions ! equilibrium record(s) with conditions, componenets, phase_varres, experim etc ! CCI changed to use iso_fortran_env to find file unit number for C++ use :: iso_fortran_env ! CCI implicit none character*(*) filename,str !\end{verbatim} %+ ! character id*40,version*8,comment*72 integer i,i1,i2,i3,isp,jph,kontroll,nel,ivers,lin,last,lok,displace,jfun integer nspx,saverr integer, allocatable :: iws(:) ! CCI logical is_op ! CCI ! type(gtp_equilibrium_data), pointer :: ceq 10 format(i8) if(index(filename,'.').eq.0) then filename(len_trim(filename)+1:)='.OCU' endif !CCI The previous commented lines are removed by the following lines !CCI that enable to find the first available logical unit. !CCI Such an approach can generalized in order to enable the !CCI opening file by several threads in the same time. !CCI To do this, the following lines should in a dedicated subroutine. !CCI lin=21 lunit: do lin=8,99 inquire(lin,opened=is_op) if(.not.is_op) exit lunit enddo lunit if( lin.eq.100 ) then write(*,*)'3E Error, no logical unit available for opening file: ',& trim(filename) goto 1000 endif ! CCI end change open(lin,file=filename,access='sequential',status='old',& form='unformatted',iostat=gx%bmperr,err=1100) ! write(*,*)'3E opening file: ',trim(filename),' for unformatted read' ! read(lin)id,version,comment,noofel,noofsp,noofph,nooftuples,last !********************************************************** ! IMPORTANT savefile ! is a variable in gtp3.F90 ! which MUST BE CHANGED whenever there is a change in the unformatted ! file layout !*********************************************************** if(version.ne.savefile) then write(*,11)id,version,savefile 11 format('File not same version as program: ',A/a,' : ',a) gx%bmperr=4299; goto 900 endif write(*,12)id,version,trim(comment) 12 format(/'Read unformatted file: ',a,a/'Generated: ',a/) str=comment ! write(*,*)'3E numbers: ',noofel,noofsp,noofph,nooftuples,last !------- allocate(iws(last)) read(lin)(iws(i),i=1,last) close(lin) !------------------------ write(*,*)'3E reading unformatted: ',last,iws(last-4),globaldata%encrypted if(iws(last-4).ne.0 .and. globaldata%encrypted.eq.0) then write(*,*)'3E Illegal attempt to read an encrypted save file' stop endif !------------------------ !>>>>> 2: elementlist, follow link from iws(3) if(iws(4).ne.gtp_element_version) then write(*,*)'3E Element data structure not same:',iws(4),gtp_element_version gx%bmperr=4355; goto 1000 endif nel=0 last=iws(3) do while(last.gt.0) nel=nel+1 lok=last call loadc(lok+1,iws,ellista(nel)%symbol) call loadc(lok+2,iws,ellista(nel)%name) displace=3+nwch(12) call loadc(lok+displace,iws,ellista(nel)%ref_state) displace=displace+nwch(24) call loadr(lok+displace,iws,ellista(nel)%mass) call loadr(lok+displace+nwpr,iws,ellista(nel)%h298_h0) call loadr(lok+displace+2*nwpr,iws,ellista(nel)%s298) displace=displace+3*nwpr ellista(nel)%splink=iws(lok+displace) ellista(nel)%status=iws(lok+displace+1) ellista(nel)%alphaindex=iws(lok+displace+2) ellista(nel)%refstatesymbol=iws(lok+displace+3) ! write(*,17)ellista(nel)%symbol,ellista(nel)%name,ellista(nel)%ref_state,& ! ellista(nel)%mass,ellista(nel)%h298_h0,ellista(nel)%s298,& ! ellista(nel)%splink,ellista(nel)%status,ellista(nel)%alphaindex,& ! ellista(nel)%refstatesymbol 17 format('3E ',a2,2x,a12,2x,a24,2x,3(1pe12.4),4i5) ! do not forget the element array! elements(ellista(nel)%alphaindex)=nel ! last=iws(last) ! write(*,*)'3E elloop: ',nel,lok,last,iws(1) enddo if(nel.ne.noofel) then write(*,*)'3E Number of elements wrong: ',nel,noofel endif ! write(*,*)'3E Now the species!!' !------- !>>>>> 3: specieslist NOTE ADDES SPEXTRA if(iws(6).ne.gtp_species_version) then write(*,*)'3E Species version wrong: ',iws(5),gtp_species_version gx%bmperr=4355; goto 1000 endif last=iws(5) ! VA is entered automatically at first index in splista when reinitiating ! so keep that. We just skip the first species in iws and extract ! its alphaindex splista(1)%alphaindex=iws(last+2+nwch(24)+2*nwpr+2) species(splista(1)%alphaindex)=1 ! skip the first species (this is VA) last=iws(last) isp=1 do while(last.gt.0) isp=isp+1 ! write(*,*)'3E loop: ',last,isp,splista(isp-1)%symbol call loadc(last+1,iws,splista(isp)%symbol) displace=2+nwch(24) call loadr(last+displace,iws,splista(isp)%mass) call loadr(last+displace+nwpr,iws,splista(isp)%charge) splista(isp)%noofel=iws(last+displace+2*nwpr) splista(isp)%status=iws(last+displace+2*nwpr+1) splista(isp)%alphaindex=iws(last+displace+2*nwpr+2) ! new spextra array nspx=iws(last+displace+2*nwpr+3) ! if(nspx.ne.0) write(*,*)'3E nspx value: ',nspx allocate(splista(isp)%ellinks(splista(isp)%noofel)) allocate(splista(isp)%stoichiometry(splista(isp)%noofel)) displace=displace+2*nwpr+3 do i=1,splista(isp)%noofel splista(isp)%ellinks(i)=iws(last+displace+i) enddo displace=displace+splista(isp)%noofel+1 ! write(*,*)'3E displace load: ',last,displace call loadrn(splista(isp)%noofel,& iws(last+displace),splista(isp)%stoichiometry) species(splista(isp)%alphaindex)=isp ! handle spextra values if any if(nspx.gt.0) then ! write(*,*)'We have nonzero nxsp: ',nspx allocate(splista(isp)%spextra(nspx)) displace=displace+splista(isp)%noofel*nwpr call loadrn(nspx,iws(last+displace),splista(isp)%spextra) ! new property ?? ! if(allocated(mqmqa1) then endif ! next species last=iws(last) enddo if(isp.ne.noofsp) then write(*,*)'3E wrong number of species: ',isp,noofsp gx%bmperr=4399; goto 1000 endif !---------- component record ! read inside the equilibrium record !---------- tpfuns !>>>>> 20.. inside tpfunread, skip functions already read last=7 if(iws(8).ne.tpfun_expression_version) then write(*,*)'3E tpfun_expression_version not same',iws(8),& tpfun_expression_version gx%bmperr=4355; goto 1000 endif isp=iws(last) i3=iws(isp) ! write(*,*)'3E tpfuns',iws(7),iws(8),i3 if(isp.gt.0) then ! skip first 2 (R and RTLNP) do i=3,i3-1 call read0tpfun(iws(isp+i),iws,i) if(gx%bmperr.ne.0) then write(*,*)'3E Error reading TP function: ',gx%bmperr goto 1000 endif enddo endif ! we cannot update freetpfun before all functions are entered .... freetpfun=i3 ! hopefully the TP functions will keep the same index ... so for parameters ! one just store the index! !------- !>>>>> 5: phaselist, starting from 0, the reference phase ! zero number of phases etc noofph=0 nooftuples=0 noofem=0 noofint=0 ! noofprop=0 ! link to phaselist is in 9 (+10, 11, 12, 13) call readphases(noofph,iws) if(gx%bmperr.ne.0) goto 1000 !----------- ! restore phase tuples ! write(*,*)'3E Reading phase tuples',iws(14),noofph lok=iws(14) if(lok.gt.0) then if(iws(15).ne.gtp_phasetuple_version) then write(*,*)'3E wrong phasetuple version',gtp_phasetuple_version,iws(15) gx%bmperr=4355; goto 1000 endif nooftuples=iws(lok) do i=1,nooftuples phasetuple(i)%lokph=iws(lok+5*i-4) phasetuple(i)%compset=iws(lok+5*i-3) phasetuple(i)%ixphase=iws(lok+5*i-2) phasetuple(i)%lokvares=iws(lok+5*i-1) phasetuple(i)%nextcs=iws(lok+5*i) enddo endif ! restore the phases lista using phase tuples! do jph=1,noofph phases(jph)=phasetuple(jph)%lokph enddo !------------------------------- ! the global status word in 20-21 lok=iws(20) globaldata%status=iws(lok+1) ! BUGFIX and extended call loadc(lok+2,iws,globaldata%name) displace=2+nwch(24) call loadr(lok+displace,iws,globaldata%rgas) call loadr(lok+displace+nwpr,iws,globaldata%rgasuser) call loadr(lok+displace+2*nwpr,iws,globaldata%pnorm) displace=displace+3*nwpr do i=0,9 globaldata%sysparam(i+1)=iws(lok+displace+i) enddo ! this was used to test record read correctly ! if(globaldata%sysparam(1).ne.987 .or. & ! globaldata%sysparam(10).ne.17) then ! write(*,'(a,10i4)')'3E error globaldata: ',globaldata%sysparam ! endif displace=displace+10 call loadrn(5,iws(lok+displace),globaldata%sysreal) ! if(abs(globaldata%sysreal(5)-12345678.9D0).gt.1.0D-12) then ! this was used to test the storing ! write(*,'(a,5(1pe12.4))')'3E error 2: ',globaldata%sysreal ! endif ! write(*,*)'3E name: "',globaldata%name,'"' ! partly unfinished below !---------- bibliographic references !>>>>> 40.. inside refread ! write(*,*)'3E reading bibliography' if(iws(23).ne.gtp_biblioref_version) then write(*,*)'3E Bibliography version wrong ',iws(23),gtp_biblioref_version else call biblioread(iws(22),iws) if(gx%bmperr.ne.0) goto 1000 endif !---------- enter the first equilibrium record without experiments!! if(iws(17).ne.gtp_equilibrium_data_version) then write(*,*)'3E Wrong equilibrium data version',& iws(17),gtp_equilibrium_data_version gx%bmperr=4355; goto 1000 elseif(iws(18).ne.gtp_component_version) then write(*,*)'3E Wrong component version',iws(18),gtp_component_version gx%bmperr=4355; goto 1000 elseif(iws(19).ne.gtp_phase_varres_version) then write(*,*)'3E Wrong phase varres version',iws(19),gtp_phase_varres_version gx%bmperr=4355; goto 1000 endif ! link to first saved in equilibrium in iws(16). firsteq is eqlista(1) i=iws(16) ! call readequil(i,iws,1,firsteq) call readequil(i,iws,1) if(gx%bmperr.ne.0) goto 1000 !---------- state variable functions must be present when reading experiments ! and the equilibria must !>>>>> 30... inside svfunread ! write(*,*)'3E reading state variable functions',iws(24) if(iws(25).eq.gtp_putfun_lista_version) then call svfunread(iws(24),iws) if(gx%bmperr.ne.0) goto 1000 else write(*,*)'3E state variable function version error',iws(25),& gtp_putfun_lista_version endif ! we cannot list svfun as we have no ceq ... ! call list_all_svfun(kou,ceq) ! call list_some_svfun(kou) ! write(*,*)'3E Now reading equilibria',iws(16) !-------------------------------------------------------------------- ! read remaining equilibria which may contain experiments ! link to first saved in equilibrium in iws(16) i=iws(16) i3=2 call readequil(i,iws,-1) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'3E read all equilibria' !------------------------------------------------------------------- ! read assessment head recods if(iws(27).ne.gtp_assessment_version) then write(*,*)'3E wrong assemmenst record version',iws(27),& gtp_assessment_version endif lok=26 call readash(lok,iws) if(gx%bmperr.ne.0) goto 1000 write(*,*)'3E Read assessment record' !------ read all ?? 800 continue ! emergency exit 900 continue ! file already closed above ! close(lin) ! 1000 continue !CCI free the iws memory (should be done automatically?) if(allocated(iws)) deallocate(iws) if(gx%bmperr.eq.4355) then write(*,*)'3E *** ERROR unformatted file wrong version' saverr=gx%bmperr; gx%bmperr=0 ! clear errr code to reinitiate ... it may not work as datastructure bad call new_gtp ! if(gx%bmperr.ne.0) then ! write(*,*)'Failed to reinitiate',gx%bmperr ! endif stop 'Cannot restore data structures' gx%bmperr=saverr endif return ! error opening files 1100 continue write(*,1110)gx%bmperr,trim(filename) 1110 format('I/O error: ',i5,', opening file; ',a) goto 1000 end subroutine gtpread !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine readphases !\begin{verbatim} subroutine readphases(kkk,iws) ! read data for phlista and all endmembers etc ! works for test case without disordered fraction test implicit none integer kkk,iws(*) !\end{verbatim} %+ integer firstendmem,i,i1,i2,i3,jph,level,nem,noi,nop,nox,nup,nsl,mult,lin integer lok,displace,totcon,phreclink,lokem,lokint character more*4 type(gtp_endmember), allocatable, target :: nyemrec type(gtp_endmember), pointer :: emrec,lem type(gtp_interaction), pointer :: intrec type(gtp_property), pointer :: proprec logical ifbcc type saveint type(gtp_interaction), pointer :: p1 integer noi end type saveint type(saveint), dimension(:), pointer :: stack type(gtp_phase_add), pointer :: addlink,nyaddlink ! allocate(stack(5)) ! write(*,*)'3E in readphase:',iws(9),iws(10),iws(11),iws(12),iws(13),& ! iws(7),iws(8) ! as the phlista record contain pointers each item must be read separately ! the phaes are stored sequentially from iws(9) lok=9 if(iws(lok+1).ne.gtp_phase_version) then write(*,*)'3E phase version not the same ',iws(lok+1),gtp_phase_version gx%bmperr=4355; goto 1000 elseif(iws(lok+2).ne.gtp_endmember_version) then write(*,*)'3E endmember not the same ',iws(lok+2),gtp_endmember_version gx%bmperr=4355; goto 1000 elseif(iws(lok+3).ne.gtp_interaction_version) then write(*,*)'3E interaction not the same ',iws(lok+3),& gtp_interaction_version gx%bmperr=4355; goto 1000 elseif(iws(lok+4).ne.gtp_property_version) then write(*,*)'3E property version not the same ',iws(lok+4),& gtp_property_version gx%bmperr=4355; goto 1000 endif ! first phase (number 0) is SER phase jph=-1 lok=iws(lok) bigloop: do while(lok.gt.0) jph=jph+1 call loadc(lok+1,iws,phlista(jph)%name) displace=1+nwch(24) call loadc(lok+1,iws,phlista(jph)%models) displace=displace+nwch(72) call loadc(lok+1,iws,phlista(jph)%phletter) displace=displace+1 phlista(jph)%status1=iws(lok+displace) phlista(jph)%alphaindex=iws(lok+displace+1) phlista(jph)%noofcs=iws(lok+displace+2) phlista(jph)%nooffs=iws(lok+displace+3) ! emergy fix for Kohler/Toop records gtp_tooprec, also for intrec !!! nullify(phlista(jph)%toopfirst) nullify(phlista(jph)%tooplast) ! read(lin)jph,phlista(jph)%name,& ! phlista(jph)%models,phlista(jph)%phletter,phlista(jph)%status1,& ! phlista(jph)%alphaindex,phlista(jph)%noofcs,phlista(jph)%nooffs !>>>>> 6: sublattice info ! read(lin)phlista(jph)%noofsubl,phlista(jph)%linktocs,phlista(jph)%tnooffr nsl=iws(lok+displace+4) phlista(jph)%noofsubl=nsl totcon=iws(lok+displace+5) phlista(jph)%tnooffr=totcon allocate(phlista(jph)%nooffr(nsl)) allocate(phlista(jph)%constitlist(phlista(jph)%tnooffr)) ! read(lin)(phlista(jph)%nooffr(i),i=1,nsl),& ! (phlista(jph)%constitlist(i),i=1,phlista(jph)%tnooffr),nem displace=displace+5 do i=1,9 phlista(jph)%linktocs(i)=iws(lok+displace+i) enddo ! write(*,*)'3E Reading phase: ',trim(phlista(jph)%name),& ! phlista(jph)%alphaindex,phlista(jph)%linktocs(1) displace=displace+9 do i=1,nsl phlista(jph)%nooffr(i)=iws(lok+displace+i) enddo displace=displace+nsl do i=1,totcon phlista(jph)%constitlist(i)=iws(lok+displace+i) enddo displace=displace+totcon+1 phlista(jph)%i2slx(1)=iws(lok+displace) phlista(jph)%i2slx(2)=iws(lok+displace+1) ! here are stored endmember records and additions phreclink=lok+displace+2 !------ endmember records, these must be allocated and linked now nullify(phlista(jph)%ordered) nullify(phlista(jph)%disordered) nullify(emrec) ! if(associated(emrec)) then ! write(*,*)'3E nullify does not work' ! stop ! endif ! if nem=0 now there are no basic (ordered) endmember (can that happen?) ! return here when endmember list empty and there is a disordered list firstendmem=1 lokem=iws(phreclink) ! write(*,*)'3E read endmember data',nsl,phreclink,iws(phreclink),lokem !------------------ 200 continue newendmem: do while(lokem.gt.0) ! this could probably be made nicer ... if(associated(emrec)) then ! emrec is allocated and the property record is also read ! write(*,*)'3E next endmember',lokem,iws(lokem) call readendmem(lokem,iws,nsl,emrec%nextem) emrec=>emrec%nextem elseif(firstendmem.eq.1) then ! write(*,*)'3E Read first endmember',jph call readendmem(lokem,iws,nsl,phlista(jph)%ordered) emrec=>phlista(jph)%ordered elseif(firstendmem.eq.2) then call readendmem(lokem,iws,nsl,phlista(jph)%disordered) emrec=>phlista(jph)%disordered endif ! in iws(lokem+2=noi) is the location of interaction records (if any) lokint=iws(lokem+2) level=0 inttree: if(lokint.gt.0) then !>>>>> 9A: first interaction record call readintrec(lokint,iws,level,emrec%intpointer) intrec=>emrec%intpointer ! emergency fix for Kohler/Toop records gtp_tooprec nullify(intrec%tooprec) 300 continue ! push before going to higher level=level+1 stack(level)%p1=>intrec stack(level)%noi=lokint ! iws(lokint+1) is link to higher interaction higher: if(iws(lokint+1).gt.0) then call readintrec(iws(lokint+1),iws,level,intrec%highlink) intrec=>intrec%highlink ! problem pushing .... lokint=iws(lokint+1) ! lokint=lokint+1 goto 300 endif higher ! There are no higher records, pop records from stack 350 continue pop: if(level.le.0) then ! no more interactions, take next endmember goto 390 else ! loosing parameters when comming back from higher level intrec=>stack(level)%p1 lokint=iws(stack(level)%noi) level=level-1 if(lokint.gt.0) then call readintrec(lokint,iws,level,intrec%nextlink) intrec=>intrec%nextlink else goto 350 endif if(lokint.gt.0) goto 300 goto 350 endif pop endif inttree 390 continue lokem=iws(lokem) enddo newendmem ! list endmembers ! emrec=>phlista(jph)%ordered ! i1=1 ! do while(associated(emrec) .and. i1.lt.20) ! write(*,*)'3E Found endmember ',i1 ! emrec=>emrec%nextem ! i1=i1+1 ! enddo ! make sure the list of endmember as a null ending if(associated(emrec)) then nullify(emrec%nextem) endif ! we come here when no more endmembers in this list if(firstendmem.eq.1) then !>>>>> 11: if nem read here is zero there are no disordered endmembers if(ocv()) write(*,*)'3E checking for disordered endmembers' ! read(lin)nem,nsl ! we must nullify emrec to start a new list of endmembers nullify(emrec) lokem=iws(phreclink+1) if(lokem.ne.0) then firstendmem=2 goto 200 endif endif !------ restore additions list !500 continue lokem=phreclink+2 ! write(*,*)'3E Any addition for ',trim(phlista(jph)%name),lokem if(iws(lokem).gt.0) then lokem=iws(lokem) nullify(addlink) 510 continue if(iws(lokem+1).ge.1 .and. iws(lokem+1).le.11) then ! all phases has volume addition ... if(iws(lokem+1).ne.7) write(*,515)iws(lokem+1),& additioname(iws(lokem+1)),trim(phlista(jph)%name) 515 format('3E Addition type ',i3,', ',a,' for ',a) elseif(iws(lokem+1).ne.0) then write(*,515)iws(lokem+1),'Unknown type ',& trim(phlista(jph)%name) endif if(iws(lokem+1).eq.INDENMAGNETIC) then call create_magrec_inden(nyaddlink,iws(lokem+2)) if(gx%bmperr.ne.0) goto 1000 elseif(iws(lokem+1).eq.XIONGMAGNETIC) then ifbcc=.FALSE. if(iws(lokem+2).eq.-1) ifbcc=.TRUE. ! ibm .TRUE. not implemented, that require more(1:1)='I' ! write(*,*)'3E creating xiomagnetic record for BCC ',ifbcc call create_xiongmagnetic(nyaddlink,more,ifbcc) if(gx%bmperr.ne.0) goto 1000 elseif(iws(lokem+1).eq.VOLMOD1) then call create_volmod1(nyaddlink) if(gx%bmperr.ne.0) goto 1000 ! just set it as a link, do not care if there are other additions ... ! Why this? it is done below ... ! phlista(jph)%additions=>nyaddlink ! nullify(nyaddlink%nextadd) elseif(iws(lokem+1).eq.EINSTEINCP) then call create_einsteincp(nyaddlink) if(gx%bmperr.ne.0) goto 1000 elseif(iws(lokem+1).eq.TWOSTATEMODEL1) then call create_twostate_model1(nyaddlink) if(gx%bmperr.ne.0) goto 1000 else write(*,*)'3E unknown addition' nullify(phlista(jph)%additions) goto 550 endif ! copy the old status word nyaddlink%status=iws(lokem+3) ! link the additions sequentially if(associated(addlink)) then addlink%nextadd=>nyaddlink else phlista(jph)%additions=>nyaddlink endif nullify(nyaddlink%nextadd) addlink=>nyaddlink 550 continue lokem=iws(lokem) if(lokem.gt.0) goto 510 else nullify(phlista(jph)%additions) endif 900 continue ! take next phase lok=iws(lok) enddo bigloop ! all data for the phase read 1000 continue kkk=jph return end subroutine readphases !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine readendmem !\begin{verbatim} subroutine readendmem(lokem,iws,nsl,emrec) ! allocates and reads an endmember record and its property record from iws ! emrec is an un-allocated pointer in the parameter tree structure implicit none integer lokem,nsl,iws(*) type(gtp_endmember), pointer :: emrec !\end{verbatim} %+ integer i,j,displace,lokpty type(gtp_property), pointer :: proprec ! allocate(emrec) ! write(*,*)'3E Allocating endmember for',lokem,iws(lokem),iws(lokem+1),& ! iws(lokem+2) ! iws(lokem) is next endmember ! iws(lokem+1) is property ! iws(lokem+2) is interaction ! read(lin)emrec%noofpermut,emrec%phaselink,emrec%antalem,nop,noi,nem emrec%noofpermut=iws(lokem+3) emrec%phaselink=iws(lokem+4) emrec%antalem=iws(lokem+5) displace=5 allocate(emrec%fraclinks(nsl,emrec%noofpermut)) do j=1,emrec%noofpermut ! read(lin)(emrec%fraclinks(i,j),i=1,nsl) do i=1,nsl emrec%fraclinks(i,j)=iws(lokem+displace+i) enddo displace=displace+nsl enddo nullify(emrec%nextem) nullify(emrec%intpointer) nullify(emrec%propointer) ! called nop when storing in iws lokpty=lokem+1 if(iws(lokpty).gt.0) then ! property list loop inside readproprec call readproprec(lokpty,iws,emrec%propointer) ! write(*,*)'3E Back from readproprec 1' endif 1000 continue return end subroutine readendmem !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine readproprec !\begin{verbatim} subroutine readproprec(lokpty,iws,firstproprec) ! allocates and a property record for both endmembers and interactions implicit none integer lokpty,iws(*) type(gtp_property), pointer :: firstproprec !\end{verbatim} %+ integer i,lokfun,displace ! type(gtp_property), allocatable, target :: prec type(gtp_property), pointer :: proprec ! lokpty is the location where there can be a property record pointer nullify(proprec) do while(iws(lokpty).gt.0) lokpty=iws(lokpty) if(associated(proprec)) then allocate(proprec%nextpr) proprec=>proprec%nextpr else allocate(firstproprec) proprec=>firstproprec endif ! read(lin)proprec%reference,proprec%proptype,& ! proprec%degree,proprec%extra,proprec%antalprop,nox ! write(*,88)lokpty,iws(lokpty),iws(lokpty+1),iws(lokpty+2) proprec%proptype=iws(lokpty+1) proprec%degree=iws(lokpty+2) proprec%extra=iws(lokpty+3) proprec%antalprop=iws(lokpty+4) call loadc(lokpty+5,iws,proprec%reference) displace=5+nwch(16) call loadc(lokpty+displace,iws,proprec%modelparamid) ! write(*,*)'3E place to find modelparamid: ',& ! proprec%modelparamid,lokpty+displace ! check that this is the same as the proptype!! i=proprec%proptype if(i.gt.100) i=i/100 if(proprec%modelparamid.ne.propid(i)%symbol) then write(*,96)i,proprec%modelparamid,propid(i)%symbol 96 format('3E Model property ',i2,' has changed from ',& a,' to ',a/'Please contact Bo Sundman for help!') ! else ! debug ! write(*,96)i,proprec%modelparamid,propid(i)%symbol endif ! lokfun=lokpty+5+nwch(16) lokfun=lokpty+displace+nwch(4) ! links to function as stored as integer indices allocate(proprec%degreelink(0:proprec%degree)) do i=0,proprec%degree ! functions already read and hopefully stored with same index! proprec%degreelink(i)=iws(lokfun+i) enddo ! write(*,*)'3E Allocated property record ',lokpty,iws(lokpty),& ! proprec%proptype,proprec%degree ! nullify(proprec%nextpr) enddo ! make sure the list is terminated by a null pointer nullify(proprec%nextpr) 1000 continue return end subroutine readproprec !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine readintrec !\begin{verbatim} subroutine readintrec(lokint,iws,level,intrec) ! allocates and reads an interaction record implicit none integer lokint,iws(*),level type(gtp_interaction), pointer :: intrec !\end{verbatim} %+ integer fipsize,noofperm,i,displace,lokpty,lokalint type(gtp_property), pointer :: proprec ! the storage of permutations in interaction records is complex ... one must ! take into account the number of permutations in lower order intecations ... ! for an fcc endmember A:A:A:B (4 perm) the binary interaction A:A:A,B:B has ! 3; 3; 3 and 3 perms and the ternary A:A,B:A,B:B has 2; 2; 2; 2 ! mult may not be needed ... ! one should never allocate a pointer ... but this is more or less permanent allocate(intrec) !>>>>> 9D: actually read the interaction record ! lokalint=iws(lokint) lokalint=lokint intrec%status=iws(lokalint+3) intrec%antalint=iws(lokalint+4) intrec%order=iws(lokalint+5) ! nullify Toop-Kohler link nullify(intrec%tooprec) fipsize=iws(lokalint+6) ! write(*,'(a,5i5)')'3E readintrec 1:',intrec%antalint,lokalint,fipsize,level allocate(intrec%noofip(fipsize)) ! read(lin)intrec%noofip,intrec%status,noi,nup,nop displace=6 do i=1,fipsize intrec%noofip(i)=iws(lokalint+displace+i) enddo displace=displace+fipsize ! 2020.06.08/BoS error saving a parameter with level=2 ??? but when saveing ! an interaction record there are only level=1 separate ??? if(level.eq.1) then noofperm=intrec%noofip(fipsize) else noofperm=intrec%noofip(2) ! else ! I do not understand this error ... ! write(*,*)'3E too many interaction levels for permutations',level ! gx%bmperr=4399; goto 1000 endif ! if(level.eq.0) then ! noofperm=intrec%noofip(2) ! elseif(level.eq.1) then ! noofperm=intrec%noofip(fipsize) ! else ! write(*,*)'3E too many interaction levels for permutations',level ! gx%bmperr=4399; goto 1000 ! endif ! end of code changes 2020.06.08/BoS allocate(intrec%sublattice(noofperm)) allocate(intrec%fraclink(noofperm)) ! write(*,*)'3E allocate link: ',intrec%antalint,intrec%noofip(2) do i=1,noofperm intrec%sublattice(i)=iws(lokalint+displace+2*i-1) intrec%fraclink(i)=iws(lokalint+displace+2*i) enddo nullify(intrec%nextlink) nullify(intrec%highlink) nullify(intrec%propointer) ! link to property record in lokalint+2 lokpty=lokalint+2 if(iws(lokpty).gt.0) then call readproprec(lokpty,iws,intrec%propointer) ! write(*,*)'3E Back from readproprec 2' ! if there are no property records proprec is still nullified endif 1000 continue return end subroutine readintrec !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine readequil !\begin{verbatim} subroutine readequil(lokeq,iws,elope) ! subroutine readequil(lokeq,iws,elope,ceq) ! lokeq is index for equilibrium record in iws implicit none integer lokeq,iws(*),elope !\end{verbatim} %+ type(gtp_equilibrium_data), pointer :: ceq character text*2048,dum16*16,line*72,ctext*72 type(gtp_phase_varres), pointer :: firstvarres TYPE(gtp_fraction_set), pointer :: fslink integer i,ierr,ip,isp,ivar,j,jp,k,lokcs,lokph,mc,mc2,nprop,nsl,kp,kl integer displace,llen,lok,lokvares,lokdiz,eqdis,lokcc,disz,conditionplace integer offset,lokd,dmc,eqnumber,fixph double precision, dimension(:,:), allocatable :: ca,ci double precision xxx ! containing conditions, components and phase varres records for wach compset !>>>>> 50: ! read(lin)ceq%eqname,ceq%eqno,ceq%status,ceq%next ! write(*,*)'3E In readequil ',lokeq,elope ! constat ! elope=1 to read first equilibrium, -1 to read second or later eqnumber=1 17 continue if(elope.lt.0) then ! take next equilibrium and increment eqnumber lokeq=iws(lokeq) eqnumber=eqnumber+1 endif ceq=>eqlista(eqnumber) if(lokeq.le.0) then if(elope.gt.0) then ! if this is the first equilibrium this is an error, otherwise just end of list write(*,*)'3E Not an equilibrium record' gx%bmperr=4399 endif goto 1000 endif ! write(*,12)'3E Reading equilibrium ',lokeq,eqnumber,iws(lokeq+3),& ! iws(lokeq+1) 12 format(a,3i5,1x,z8) ceq%status=iws(lokeq+1) ! set that no calculation is made in status word to prevent listing ?? why ?? ! ceq%status=ibset(ceq%status,EQNOEQCAL) ceq%multiuse=iws(lokeq+2) ! Hm, eqno should not be changed? By default arbitrary value!! if(eqnumber.ne.iws(lokeq+3)) then write(*,*)'3E Should be same equilibrium number ',eqnumber,iws(lokeq+3) endif ceq%eqno=iws(lokeq+3) ceq%nexteq=iws(lokeq+4) call loadc(lokeq+5,iws,ceq%eqname) ! write(*,*)'3E Reading equilibrium with name: ',ceq%eqname displace=5+nwch(24) call loadc(lokeq+displace,iws,ceq%comment) ! write(*,*)'3E comment: "',trim(ceq%comment),'" ',len_trim(ceq%comment) displace=displace+nwch(72) ! values of T and P and weight call loadrn(2,iws(lokeq+displace),ceq%tpval) call loadr(lokeq+displace+2*nwpr,iws,ceq%weight) displace=displace+3*nwpr !----- components (must be elements). Must be entered before conditions ! complist already allocated for 20 if(allocated(ceq%complist)) then deallocate(ceq%complist) endif allocate(ceq%complist(noofel)) if(eqnumber.gt.1) then allocate(ceq%compstoi(noofel,noofel)) allocate(ceq%invcompstoi(noofel,noofel)) endif ceq%compstoi=zero ceq%invcompstoi=zero do kl=1,noofel ! when the elements are components ... ceq%compstoi(kl,kl)=one ceq%invcompstoi(kl,kl)=one enddo llen=0 lokcc=iws(lokeq+displace+2) do while(lokcc.gt.0) llen=llen+1 if(llen.gt.noofel) then write(*,*)'3E Too many components' gx%bmperr=4399; goto 1000 endif ceq%complist(llen)%splink=iws(lokcc+1) ceq%complist(llen)%phlink=iws(lokcc+2) ceq%complist(llen)%status=iws(lokcc+3) call loadc(lokcc+4,iws,ceq%complist(llen)%refstate) disz=4+nwch(16) kl=iws(lokcc+disz) if(kl.gt.0) then allocate(ceq%complist(llen)%endmember(kl)) do mc=1,kl ceq%complist(llen)%endmember(mc)=iws(lokcc+disz+mc) enddo ! write(*,*)'3E endmem: ',kl,(ceq%complist(llen)%endmember(mc),mc=1,kl) disz=disz+kl+1 else disz=disz+1 endif call loadrn(2,iws(lokcc+disz),ceq%complist(llen)%tpref) ! write(*,*)'3E refstate 2: ',ceq%complist(llen)%tpref disz=disz+2*nwpr call loadrn(2,iws(lokcc+disz),ceq%complist(llen)%chempot) disz=disz+2*nwpr call loadr(lokcc+disz,iws,ceq%complist(llen)%mass) ! write(*,*)'3E loading component mass',lokcc,disz,llen,& ! ceq%complist(llen)%mass call loadr(lokcc+disz+nwpr,iws,ceq%complist(llen)%molat) lokcc=iws(lokcc) enddo !----- conditions (note that inactive conditions not set) ! conditions cannot be entered before the phase_varres for all phases conditionplace=displace !----------- phase_varres record !>>>>> 54: highcs=iws(lokeq+displace+3) if(ocv()) then write(*,*)'3E Number of phase_varres records: ',highcs write(*,*)'phase_varres size: ',size(ceq%phase_varres) endif ! link to first varres record stored here lokvares=iws(lokeq+displace+4) ! write(*,*)'3E lokvares: ',lokvares,highcs,lokeq,displace+4 eqdis=displace+5 ! for equilibria 2 and higher phase_varees must be allocated!! if(eqnumber.gt.1) then ! write(*,*)'3E allocating phase_varres for equilibrium: ',eqnumber allocate(ceq%phase_varres(highcs+5)) ! we should also allocate a few other things allocate(ceq%eq_tpres(maxtpf)) allocate(ceq%svfunres(maxsvfun)) do j=1,maxtpf ceq%eq_tpres(j)%forcenewcalc=0 enddo ceq%tpval(1)=1.0D3 ceq%tpval(2)=1.0D5 endif compset: do j=1,highcs if(lokvares.le.100) then write(*,*)'3E error linking phase_varres records ...',lokvares,j goto 1000 endif !------------------------------------------ ! DEBUGPROBLEM BEWARE, using = instead of => below took 2 days to find !------------------------------------------ ! >>> firstvarres=ceq%phase_varres(j) <<< error firstvarres=>ceq%phase_varres(j) !>>>>> 55: firstvarres%nextfree=iws(lokvares+1) lokph=iws(lokvares+2) if(lokph.lt.0) then ! this means this phase_varres record is not used ! we have already save the free list link, just skip the rest write(*,*)'3E found unused phase_varres record: ',j,lokvares lokvares=iws(lokvares) cycle compset endif firstvarres%phlink=lokph firstvarres%status2=iws(lokvares+3) firstvarres%phstate=iws(lokvares+4) firstvarres%phtupx=iws(lokvares+5) nsl=iws(lokvares+6) mc=iws(lokvares+7) ! write(*,*)'3E read mc ',trim(phlista(lokph)%name),nsl,mc,j call loadc(lokvares+8,iws,firstvarres%prefix) displace=8+nwch(4) call loadc(lokvares+displace,iws,firstvarres%suffix) displace=displace+nwch(4) call loadrn(3,iws(lokvares+displace),firstvarres%abnorm) displace=displace+3*nwpr ! we need these values here! but now they are stored in iws!! ! nsl=phlista(lokph)%noofsubl ! mc=phlista(lokph)%tnooffr mc2=mc*(mc+1)/2 if(btest(firstvarres%status2,CSDLNK)) then ! varres record with link to disordered varres record, some data to be stored ! NOTE necessary data for nsl and mc stored later ... ! we need these values here! ! write(*,*)'3E varres with link to disordered fraction varres' offset=6+2*nwch(4)+3*nwpr+mc*(1+2*nwpr)+nsl*nwpr ! write(*,202)'3E offset:',j,lokvares,displace,iws(lokvares+displace),& ! nsl,mc,offset,iws(lokvares+offset),iws(lokvares+26) 202 format(a,10i6) ! stop ! elseif(btest(firstvarres%status2,CSDFS)) then ! write(*,*)'3E varres for disordered fraction set OK',j,nsl,mc ! this phase_varres/parres record belong to disordered fraction_set ! we should use nsl and mc from disordered fraction set! ! but they are not yet created... endif ! write(*,88)'3E reading phase_varres ',j,highcs,lokvares,nsl,mc,& ! trim(phlista(lokph)%name) !88 format(a,5i7,2x,a) ! ! write(*,*)'3E allocating constat: ',j,mc allocate(firstvarres%constat(mc)) do i=1,mc firstvarres%constat(i)=iws(lokvares+displace+i-1) enddo displace=displace+mc allocate(firstvarres%yfr(mc)) call loadrn(mc,iws(lokvares+displace),firstvarres%yfr) displace=displace+mc*nwpr ! write(*,*)'3E not allocating mmyfr' displace=displace+mc*nwpr allocate(firstvarres%sites(nsl)) ! write(*,*)'3E sites: ',lokvares,displace,lokvares+displace call loadrn(nsl,iws(lokvares+displace),firstvarres%sites) displace=displace+nsl*nwpr !----------------------------------- ! BEWHERE allocation of the dpqdy and d2pqdvay!!! ! They are not saved but should be allocated here! need lokph if(btest(phlista(lokph)%status1,PHIONLIQ)) then ! write(*,*)'3E ionic liquid',lokph,eqnumber allocate(firstvarres%dpqdy(mc)) allocate(firstvarres%d2pqdvay(mc)) firstvarres%dpqdy=zero firstvarres%d2pqdvay=zero endif !------------------------------------- ! write(*,*)'3E odd: ',lokvares,displace fsrec: if(btest(firstvarres%status2,CSDLNK)) then ! write(*,*)'3E disfra record:',lokvares,displace,iws(lokvares+displace) ! disfra record lokd=iws(lokvares+displace) fslink=>firstvarres%disfra fslink%latd=iws(lokd) nsl=iws(lokd+1) fslink%ndd=nsl dmc=iws(lokd+2) fslink%tnoofxfr=dmc fslink%tnoofyfr=iws(lokd+3) fslink%totdis=iws(lokd+4) fslink%varreslink=iws(lokd+5) call storc(lokd+6,iws,fslink%id) disz=6+nwch(1) allocate(fslink%nooffr(nsl)) allocate(fslink%splink(dmc)) allocate(fslink%y2x(mc)) allocate(fslink%dsites(nsl)) allocate(fslink%dxidyj(mc)) disz=6+nwch(1) do i=1,nsl fslink%nooffr(i)=iws(lokd+disz+i) enddo disz=disz+nsl ! write(*,202)'3E disfra 1: ',lokd,disz do i=1,dmc fslink%splink(i)=iws(lokd+disz+i) enddo disz=disz+dmc+1 ! we must use the ordered number of constituents here!! if(mc.ne.iws(lokd+disz)) then write(*,*)'3E constituent number error: ',mc,iws(lokd+disz) mc=iws(lokd+disz) endif ! write(*,202)'3E disfra 2: ',lokd,disz do i=1,mc fslink%y2x(i)=iws(lokd+disz+i) enddo disz=disz+mc+1 ! write(*,202)'3E disfra 3: ',lokd,disz call loadrn(nsl,iws(lokd+disz),fslink%dsites) disz=disz+nsl*nwpr ! write(*,202)'3E disfra 4: ',lokd,disz call loadrn(mc,iws(lokd+disz),fslink%dxidyj) disz=disz+mc*nwpr ! write(*,202)'3E disfra 5: ',lokd,disz call loadr(lokd+disz,iws,fslink%fsites) ! write(*,*)'3E disfra last: ',lokd+disz+nwpr else firstvarres%disfra%varreslink=0 endif fsrec displace=displace+1 call loadr(lokvares+displace,iws,firstvarres%amfu) call loadr(lokvares+displace+nwpr,iws,firstvarres%netcharge) call loadr(lokvares+displace+2*nwpr,iws,firstvarres%dgm) ! NEW value of qcbonds for quasichemical model, increment of displace!! call loadr(lokvares+displace+3*nwpr,iws,firstvarres%qcbonds) displace=displace+4*nwpr nprop=iws(lokvares+displace) if(nprop.lt.20) then ! write(*,303)'3E get nprop: ',lokvares,displace,lokvares+displace,& ! nprop,trim(phlista(lokph)%name) nprop=20 endif 303 format(a,4i7,2x,a) firstvarres%nprop=nprop allocate(firstvarres%listprop(nprop)) ! calculated results, only G saved allocate(firstvarres%gval(6,nprop)) displace=displace+1 ! we have saved only G values do i=1,6 call loadr(lokvares+displace+nwpr*(i-1),iws,firstvarres%gval(i,1)) enddo displace=displace+6*nwpr allocate(firstvarres%dgval(3,mc,nprop)) do i=1,3 do k=1,mc call loadr(lokvares+displace,iws,firstvarres%dgval(i,k,1)) displace=displace+nwpr enddo enddo allocate(firstvarres%d2gval(mc2,nprop)) do i=1,mc2 call loadr(lokvares+displace+nwpr*(i-1),iws,firstvarres%d2gval(i,1)) enddo ! link to next stored phase_varres record lokvares=iws(lokvares) enddo compset ! if(elope.lt.0) then csfree=highcs+1 ! endif ! write(*,*)'3E csfree: ',highcs,csfree,elope ! write(*,*)'3E All phase_varres records created for ',ceq%eqno !----- conditions (note that inactive conditions not set) ! lok=iws(lokeq+displace) lok=iws(lokeq+conditionplace) nullify(ceq%lastcondition) nullify(ceq%lastexperiment) if(lok.gt.0) then llen=iws(lok) call loadc(lok+1,iws,text(1:llen)) ! write(*,*)'3E Conditions: "',text(1:llen),'"',llen if(llen.gt.0) then ! set the conditions, kp will be incremented by 1 in enter_condition ! the text contains " number: variable expression=value, " ! we have to set each condition separately. There can be , but no : ! in the variable expressions. jp=1; ip=llen cloop: do while(jp.lt.ip) k=index(text(jp:ip),':') if(k.le.0) exit cloop line=text(jp+k:ip) jp=jp+k+2 ! remove any commma followed by space ", " as that indicates there are more ! conditions on the same line kp=index(line,', ') if(kp.gt.0) then line(kp:)=' ' else kp=index(line,' ') line(kp:)=' ' endif ! We must handle fix phases :: =value transforms to fix=phase == value if(line(1:1).eq.'<') then kp=index(line,'>') fixph=kp+1 call getrel(line,fixph,xxx) if(buperr.ne.0) then buperr=0; xxx=zero endif ctext=' FIX='//line(2:kp-1)//' == '//line(fixph+1:) ! write(*,*)'3E fixph: ',trim(ctext) line=ctext endif kp=0 ! write(*,*)'3E set condition "',trim(line),'"',jp,ip call set_condition(line,kp,ceq) ! write(*,*)'3E back from set condition "',gx%bmperr if(gx%bmperr.ne.0) then write(*,*)'3E Error setting conditions' write(*,*)'3E condition "',trim(line),'"',kp goto 1000 endif enddo cloop endif ! else ! write(*,*)'3E no conditions on unformatted file' endif !----- experiments lok=iws(lokeq+conditionplace+1) 733 continue kp=0 if(lok.gt.0) then ! experiments are stored individually in a linked list kp=kp+1 llen=iws(lok+1) text=' ' call loadc(lok+2,iws,text(1:llen)) ! write(*,*)'3E found experiment: "',trim(text),'"' llen=0 call enter_experiment(text,llen,ceq) ! write(*,*)'3E Back from enter_experiment' if(gx%bmperr.ne.0) then write(*,*)'3E error entering experiment ',gx%bmperr,' continuing' gx%bmperr=0 endif lok=iws(lok) goto 733 endif if(kp.gt.0) write(*,*)'3E Found ',kp,' experiments' !-------------------------- a few remaining things ceq%maxiter=iws(lokeq+eqdis) if(.not.allocated(ceq%cmuval)) then allocate(ceq%cmuval(noofel)) endif call loadrn(noofel,iws(lokeq+eqdis+1),ceq%cmuval) eqdis=eqdis+1+noofel*nwpr call loadr(lokeq+eqdis,iws,ceq%xconv) ! modifed 2018.05.28 by adding gdconv(2) call loadr(lokeq+eqdis+nwpr,iws,ceq%gdconv(1)) call loadr(lokeq+eqdis+2*nwpr,iws,ceq%gdconv(2)) call loadr(lokeq+eqdis+3*nwpr,iws,ceq%gmindif) ! if elope negative continue reading next equilibrium if(elope.lt.0) then ! write(*,*)'3E read the next equilibrium' ! increment the index of first free equilibrium eqfree=eqfree+1 goto 17 endif ! 1000 continue if(eqfree.gt.2) write(*,1010)eqfree-1 1010 format('3E Read ',i4,' equilibria') return end subroutine readequil !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine svfunread !\begin{verbatim} subroutine svfunread(loksvf,iws) ! read a state variable function from save file and store it. ! by default there are some state variable functions, make sure ! they are deleted. Done here just by setting nsvfun=0 implicit none integer loksvf,iws(*) !\end{verbatim} %+ integer nsvfun,i,ip,lok,eqno character*512 text nsvfun=iws(loksvf) ! first 3 symbols are R, RT and T_C do i=iws(loksvf+1)+1,nsvfun lok=iws(loksvf+i) ip=iws(lok) text=' ' call loadc(lok+1,iws,text(1:ip)) ! write(*,*)'3E Entering saved svf: "',text(1:ip),'"' ! NOTE: position 1-7 are equilibrium number and status ip=7 call enter_svfun(text,ip,firsteq) if(gx%bmperr.ne.0) then write(*,*)'3E Error entering saved svf',gx%bmperr if(gx%bmperr.ne.4136) goto 1000 gx%bmperr=0 endif ! if this function should be evaluated at a particular equilibrium that is ! in position 1-5. Extra status in position 6 and 7 ! write(*,*)'3E read symbol: ',i,': ',text(1:ip),ip ! Letters used for the status bits: ! A SVNOAM a function or constant that cannot be amended ! C SVCONST a constant that can be amended ! D SVFDOT a dot derivative (also SVFVAL set) ! N SVFVAL symbol evaluated only if explitly referenced) ! X SVFEXT only evaluated for a specific equilibrium (preceeded by eq.number) ! I SVIMPORT import value from TP function (preceeded by TP index) ! E SVEXPORT expert value to TP function constant (preceeded by TP index) ! check if symbol is a constant (can be amended) if(text(5:5).eq.'C') then svflista(i)%status=ibset(svflista(i)%status,SVNOAM) elseif(text(5:5).eq.'C') then svflista(i)%status=ibset(svflista(i)%status,SVCONST) ! check if symbol should only be evaluated when explicitly requested elseif(text(5:5).eq.'D') then ! D means the symbol is a dot variable, evaluates only when explitly refered svflista(i)%status=ibset(svflista(i)%status,SVFDOT) svflista(i)%status=ibset(svflista(i)%status,SVFVAL) elseif(text(5:5).eq.'V') then svflista(i)%status=ibset(svflista(i)%status,SVFVAL) endif ! extract any number before postion 5 ip=0 ! ip is incremented in getint call getint(text,ip,eqno) if(buperr.ne.0) then buperr=0 else if(text(5:5).eq.'X') then ! symbol should be evaluated at a specific equilibrium (eqno) svflista(i)%status=ibset(svflista(i)%status,SVFEXT) svflista(i)%eqnoval=eqno elseif(text(5:5).eq.'I') then ! symbol should be imported from TP function svflista(i)%status=ibset(svflista(i)%status,SVIMPORT) svflista(i)%tplink=eqno elseif(text(5:5).eq.'E') then ! symbol should be exported to TP constant svflista(i)%status=ibset(svflista(i)%status,SVEXPORT) svflista(i)%tplink=eqno else ! a number with no meaning! write(*,*)trim(text) 100 format(' *** Warning, error reading symbol:'/a) endif endif enddo 1000 continue return end subroutine svfunread !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine biblioread !\begin{verbatim} subroutine biblioread(bibhead,iws) ! read references from save file implicit none integer bibhead,iws(*) !\end{verbatim} %+ character text*2048 integer i,iref,jp,nrefs,lok,kk,ir,nr !>>>>> 40: number of references ! write(*,*)'3E Reading reference version and nummer of' nrefs=iws(bibhead) do i=1,nrefs lok=iws(bibhead+i) jp=iws(lok) call loadc(lok+1,iws,text(1:jp)) call tdbrefs(text(1:16),text(17:jp),0,iref) enddo 1000 continue return end subroutine biblioread !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\addtotable subroutine readash !\begin{verbatim} subroutine readash(lok,iws) ! reading assessment records integer lok,iws(*) !\end{verbatim} integer lok1,lok2,last,rsize,i1,i2,disp,kk double precision xxx type(gtp_assessmenthead), pointer :: assrec type(gtp_equilibrium_data), pointer :: ceq ! lok1=lok assrec=>firstash%nextash 20 continue if(iws(lok1).eq.0) goto 1000 lok1=iws(lok1) assrec%status=iws(lok1+1) assrec%varcoef=iws(lok1+2) assrec%firstexpeq=iws(lok1+3) assrec%lwam=iws(lok1+4) call loadc(lok1+5,iws,assrec%general) disp=5+nwch(64) call loadc(lok1+disp,iws,assrec%special) disp=disp+nwch(64) lok2=iws(lok1+disp+1) if(lok2.gt.0) then ! eqlista ! lok2=iws(lok2) i1=iws(lok2) if(i1.gt.0) then ! write(*,'(a,4i10)')'3E In readash 1: ',lok,lok1,lok2,i1 allocate(assrec%eqlista(i1)) ! in iws(lok2+i2) the index to eqlista is stored, ! assrec%eqlista(i2)%p1 is a pointer to this equilibrium do i2=1,i1 ceq=>eqlista(iws(lok2+i2)) assrec%eqlista(i2)%p1=>ceq enddo endif else write(*,*)'3E no experimental data' endif lok2=iws(lok1+disp+2) if(lok2.le.0) then write(*,*)'3E no coefficient values saved' goto 777 else ! coeffvalues ! lok2=iws(lok2) i1=iws(lok2) ! write(*,*)'3E In readash 2: ',lok2,i1 allocate(assrec%coeffvalues(0:i1-1)) call loadrn(i1,iws(lok2+1),assrec%coeffvalues) endif lok2=iws(lok1+disp+3) ! coeffrsd ! lok2=iws(lok2) if(lok2.gt.0) then i1=iws(lok2) ! write(*,*)'3E In readash RSD: ',lok2,i1 allocate(assrec%coeffrsd(0:i1-1)) call loadrn(i1,iws(lok2+1),assrec%coeffrsd) endif ! lok2=iws(lok1+disp+3) lok2=iws(lok1+disp+4) if(iws(lok2).gt.0) then ! coeffscale ! lok2=iws(lok2) i1=iws(lok2) ! write(*,*)'3E In readash 3: ',lok2,i1 allocate(assrec%coeffscale(0:i1-1)) call loadrn(i1,iws(lok2+1),assrec%coeffscale) endif ! lok2=iws(lok1+disp+4) lok2=iws(lok1+disp+5) if(iws(lok2).gt.0) then ! coeffstart ! lok2=iws(lok2) i1=iws(lok2) ! write(*,*)'3E In readash 4: ',lok2,i1 allocate(assrec%coeffstart(0:i1-1)) call loadrn(i1,iws(lok2+1),assrec%coeffstart) endif ! lok2=iws(lok1+disp+5) lok2=iws(lok1+disp+6) if(iws(lok2).gt.0) then ! coeffmin ! lok2=iws(lok2) i1=iws(lok2) ! write(*,*)'3E In readash 5: ',lok2,i1 allocate(assrec%coeffmin(0:i1-1)) call loadrn(i1,iws(lok2+1),assrec%coeffmin) endif ! lok2=iws(lok1+disp+6) lok2=iws(lok1+disp+7) if(iws(lok2).gt.0) then ! coeffmax ! lok2=iws(lok2) i1=iws(lok2) ! write(*,*)'3E In readash 6: ',lok2,i1 allocate(assrec%coeffmax(0:i1-1)) call loadrn(i1,iws(lok2+1),assrec%coeffmax) endif ! lok2=iws(lok1+disp+7) lok2=iws(lok1+disp+8) if(iws(lok2).gt.0) then ! coeffindices ! lok2=iws(lok2) i1=iws(lok2) ! write(*,*)'3E In readash 7: ',lok2,i1 allocate(assrec%coeffindex(0:i1-1)) do i2=1,i1 assrec%coeffindex(i2-1)=iws(lok2+i2) enddo ! store these values in tpfun ... do kk=0,i1-1 ! write(*,333)'3E storing as TP funs ',kk,assrec%coeffindex(kk),& ! assrec%coeffvalues(kk),assrec%coeffscale(kk) 333 format(a,2i4,6(1pe12.4)) ! firstash or assrec?? xxx=assrec%coeffvalues(kk)*assrec%coeffscale(kk) call change_optcoeff(assrec%coeffindex(kk),xxx) if(gx%bmperr.ne.0) goto 1000 enddo endif ! lok2=iws(lok1+disp+8) lok2=iws(lok1+disp+9) if(iws(lok2).gt.0) then ! coeffstate ! lok2=iws(lok2) i1=iws(lok2) ! write(*,*)'3E In readash 8: ',lok2,i1 allocate(assrec%coeffstate(0:i1-1)) do i2=1,i1 assrec%coeffstate(i2-1)=iws(lok2+i2) enddo endif 777 continue ! maybe work array has been daved also? ! lok2=iws(lok1+disp+9) lok2=iws(lok1+disp+10) if(lok2.gt.0) then if(iws(lok2).gt.0) then ! lok2=iws(lok2) i1=iws(lok2) ! write(*,*)'3E In readash 9: ',lok2,i1 allocate(assrec%wopt(i1)) call loadrn(i1,iws(lok2+1),assrec%wopt) endif endif ! check if there are several assessmentheads if(iws(lok1).gt.0) then ! There are more records, try to create a circular list in both directions write(*,*)'3E In readash 10: ',lok1,iws(lok1) allocate(assrec%nextash) assrec%nextash%prevash=>assrec assrec=>assrec%nextash firstash%prevash=>assrec write(*,*)'3E more assessment records' goto 20 endif 1000 continue return end subroutine readash !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable logical function iskeyword !\begin{verbatim} logical function iskeyword(text,keyword,nextc) ! compare a text with a given keyword. Abbreviations allowed ! but the keyword and abbreviation must be surrounded by spaces ! nextc set to space character in text after the (abbreviated) keyword implicit none character text*(*),keyword*(*),key*64 integer nextc !\end{verbatim} %+ character word*64 logical ok integer kl,ks,kt ! extract the first word of text ks=1 if(eolch(text,ks)) then ! if empty line, just exit ok=.false.; goto 1000 else ! find the space after the first word kt=ks+index(text(ks:),' ')-1 ! the abbreviation of the keyword must be at least 3 character !!! if(kt-ks.lt.3 .or. kt-ks.ge.64) then ok=.false.; goto 1000 endif endif word=text(ks:kt) kt=kt-ks key=keyword kl=len_trim(key) ! check if word is an abbreviation of key if(word(1:kt).eq.key(1:kt)) then ! found keyword at start of line, set nextc to be positioned at the final space nextc=ks+kt ok=.true. else ok=.false. endif ! write(*,100)ok,text(1:15),word(1:15),key(1:15),nextc,ks,kt,kl !100 format('iskeyword: ',l1,' >',a,'<>',a,'<>',a,'<',5i3) 1000 continue iskeyword=ok return end function iskeyword !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable integer function istdbkeyword !\begin{verbatim} %- integer function istdbkeyword(text,nextc) ! compare a text with a given keyword. Abbreviations allowed (not within _) ! but the keyword and abbreviation must be surrounded by spaces ! nextc set to space character in text after the (abbreviated) keyword implicit none character text*(*) integer nextc !\end{verbatim} %+ ! only those currently implemented ... rest ignored integer, parameter :: kwl=20 integer, parameter :: nkw=14 character (len=kwl), dimension(nkw), parameter :: keyword=& ['ELEMENT ','SPECIES ',& 'PHASE ','CONSTITUENT ',& 'FUNCTION ','PARAMETER ',& 'TYPE_DEFINITION ','LIST_OF_REFERENCES ',& 'ADD_REFERENCES ','ASSESSED_SYSTEMS ',& 'DATABASE_INFORMATION','VERSION ',& 'DEFAULT_COMMAND ','DEFINE '] ! character word*64 integer j,ks,kt ! extract the first word of text ks=1 if(eolch(text,ks)) then ! if empty line, just exit j=0; goto 1000 else ! find the space after the first word kt=ks+index(text(ks:),' ')-1 ! the abbreviation of the keyword must be at least 3 character, max kwl if(kt-ks.lt.3 .or. kt-ks.ge.kwl) then ! write(*,*)'3E too long keyword: ',trim(text),kt-ks,kwl j=0; goto 1000 endif endif word=text(ks:kt) kt=kt-ks call capson(word) ! replace - by _ 90 continue j=index(word,'-') if(j.gt.0) then word(j:j)='_' goto 90 endif ! check if word is an abbreviation of a keyword ! write(*,*)'abbreviation: ',kt,'>',word(1:kt),'<' ! do j=1,10 do j=1,nkw if(word(1:kt).eq.keyword(j)(1:kt)) goto 100 enddo j=0 ! write(*,99)j,nextc,text(1:nextc),trim(text) 99 format('3E Not a keyword: ',2i3,'>',a,'<'/1x,a) goto 1000 ! found keyword at start of line, set nextc to be positioned at the final space 100 continue if(j.eq.11 .and. kt.lt.8) then ! we found 'DATA' at the start of several lines that is not DATABASE_INFO ! write(*,*)'3E why? ',trim(text),kt j=0 goto 1000 endif nextc=ks+kt ! write(*,101)j,nextc,text(1:nextc),trim(text) 101 format('3E Found keyword: ',2i3,'>',a,'<'/1x,a) 1000 continue istdbkeyword=j return end function istdbkeyword !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine readtdb !\begin{verbatim} subroutine readtdb(filename,nel,selel) ! reading data from a TDB file with selection of elements, read_tdb !------------------------------------------------------- ! Not all TYPE_DEFS implemented ! MODIFIED FOR ENCRYPTED DATABASES !------------------------------------------------------- implicit none integer nel character filename*(*),selel(*)*2 !\end{verbatim} %+ integer, parameter :: maxrejph=30,maxorddis=10,maxtypedefs=100,mtxp=100 character line*128,elsym*2,name1*24,name2*24,elsyms(10)*2,stoiline*72 ! character longline*10000,reftext*512 ! to read references in MatCalc TDB files character longline*40000,reftext*512 ! to handle ternary_extrapolation lines character ternaryxpol(mtxp)*2000 character phtype*1,ch1*1,const(maxsp)*24,name3*24,funname*60,name4*60,chd*1 character refx*16,more*4 character (len=1), dimension(maxtypedefs) :: typedefchar integer, dimension(maxtypedefs) :: typedefaction integer, dimension(5) :: addphasetypedef double precision mass,h298,s298 integer, dimension(10) :: knr,endm ! lint(1,*) is sublattice, lint(2,*) is species double precision stoik(10),xsl,xxx integer lint(2,3),TDthisphase,nytypedef,nextc,keyw,tdbv,rewindx,nend integer typty,fractyp,lp1,lp2,ix,jph,kkk,lcs,nint,noelx,idum,jdum logical onlyfun,nophase,ionliq,notent,mqmqa,ferroref integer norew,newfun,nfail,nooftypedefs,nl,ipp,jp,jss,lrot,ip,iq,jt,bmabbr integer nsl,ll,kp,nr,nrr,mode,lokph,lokcs,km,nrefs,ideg,iph,ics,ndisph integer ntxp,ctxp ! disparttc and dispartph to handle phases with disordered parts integer nofunent,disparttc,dodis,jl,nd1,thisdis,cbug,nphrej,never,always character*24 dispartph(maxorddis),ordpartph(maxorddis),phreject(maxrejph)*24 ! character*24 disph(20) integer orddistyp(maxorddis),suck,notusedpar,totalpar,reason,zz,dismag integer enteredpar,loop,emodel,manylonglines,zp,noparref,pz1,pz2 type(gtp_phase_add), pointer :: addrec logical tdbwarning,only_typedefs ! this is used for reading encrypted FUNCTION and PARAMETER part of a TDB file ! integer encrypted ---- replaced by globaldata%encrypted ! character encryptline*128 character encryptline*256 ! set to TRUE if element present in database logical, allocatable :: present(:) ! to prevent any output logical silent,thisphaserejected,addternaryxpol ! if tdbwarning is true at the end pause before listing bibliography #ifdef encrypopt write(*,*)'3E compiled with option to read encrypted files',& globaldata%encrypted #endif ! write(*,*)'3E in readtdb 1:',allocated(seltdbph),nselph emodel=0 nsl=0 bmabbr=0 noparref=0 ! for mqmqa we need to initiate nend to a negative value nend=-100 ! dbcheck made global ! dbcheck=.FALSE. tdbwarning=.FALSE. silent=.FALSE. addternaryxpol=.FALSE. ! grobaldata%encrypted=0 ! this was Ting request to have ferromanetic reference state for alloys ferroref=.FALSE. nphrej=0 nytypedef=0 totalpar=0 notusedpar=0 enteredpar=0 manylonglines=0 ntxp=0 ctxp=0 ! this counts number of undefined/unused model-parameter-identifiers nundefmpi=0 if(btest(globaldata%status,GSSILENT)) then silent=.TRUE. ! write(*,*)'3E in readtdb reading database silent' endif ! write(*,*)'3E in readtdb reading a TDB file: ',globaldata%encrypted if(ocv()) write(*,*)'3E reading a TDB file' if(.not.(index(filename,'.tdb').gt.0 & .or. index(filename,'.TDB').gt.0)) then ! no extention provided filename(len_trim(filename)+1:)='.TDB' endif if(nel.gt.0) then allocate(present(nel)) present=.FALSE. endif ! disparttc counts the number of disordered phases to read, the ! disordered phase names are in dispartph(1..disparttc) ! dodis is nonzero only when reading the disordered part of phases. disparttc=0 dodis=0 !==================================================== #ifdef encrypopt ! compiled for reading encrypted files ! write(*,*)'3E compiled for encrypted file: ',globaldata%encrypted ! globaldata%encrypted nonzero if used given READ ENCRYPTED if(globaldata%encrypted.ne.0) then ! the value of globaldata%encrypted is set in pmon6 write(*,*)'3E trying to read an encrypted database',trim(filename) ! stop !---------------------------------------------------------------- ! decrypt the file and provide the decrypted file line by line ! ! call decrypting software from thalesgroup <<<<<<<<<<<<<<<<<<< line 3987 ! !---------------------------------------------------------------- ! As the file is rewinded several times it may be clumsy? write(*,*)'3E reading encrypted database: ',trim(filename) open(21,file=filename,access='sequential',form='formatted',& err=1010,iostat=gx%bmperr,status='old') ! ! the decrypted line provided as unit 21 else ! allow reading non-encrypted files if(.not.silent) write(*,*)'3E nonencrypted database: ',trim(filename) open(21,file=filename,access='sequential',form='formatted',& err=1010,iostat=gx%bmperr,status='old') endif #else ! ====================================================== if(.not.silent) write(*,19)trim(filename) 19 format('3E reading database file: ',a) ! open(21,file=filename,access='sequential',form='formatted',& err=1010,iostat=gx%bmperr,status='old') #endif ! read whole TDB file to extract TYPE_DEFS with DIS_PART so disordered parts ! are not entered ! call any_disordered_part(21,ndisph,disph) call any_disordered_part(21,ndisph,dispartph,ordpartph,orddistyp) if(ndisph.gt.0) then ! write(*,*)'3E ndisph: ',ndisph ! write(*,11)(trim(ordpartph(ip)),trim(dispartph(ip)),orddistyp(ip),& ! ip=1,ndisph) 11 format('3E ord/dis: "',a,'"+"',a,'" ',i2) endif onlyfun=.FALSE. tdbv=1 norew=0 newfun=0 nfail=0 nrefs=0 ! always is a dummy variable always=0 nooftypedefs=0 ! nophase set false after reading a PHASE keyword, ! expecting next keyword to be CONSTITUENT nophase=.TRUE. rewindx=0 ! read whole file FIRST to pick up TYPE_DEFs only_typedefs=.TRUE. ! return here after rewind 90 continue nl=0 ! return here to look for a new keyword, end-of-file OK here 100 continue read(21,110,end=2000)line 110 format(a) nl=nl+1 ! missing capson?? ! call capson(line) ! REDUNDANT CODE when attempting to separate TDB files in 2 parts ! if(nl.eq.1) then ! if(line(1:10).eq.'ENCRYPTED ') then ! encrypted files consists of a "structure" part with elements, phases etc ! which are not encrypted and a file name with the encrypted FUNCTION and ! PARAMETER keywords. After reading the structure part call readencrypt ! onlyfun is set TRUE and that triggers read the encrypted part ! encrypted=encrypted+1 ! encryptline=line ! if(encrypted.eq.1) write(*,*)'3E this database has an encrypted part' ! goto 100 ! endif ! endif ! if(len_trim(line).gt.80) then ! lines longer than 200 characters give warning ... can mess up a lot if(len_trim(line).gt.120) then manylonglines=manylonglines+1 if(.not.silent) then ! if(manylonglines.lt.5) then write(*,121)nl 121 format(' *** Warning: line ',i5,' has characters beyond position',& ' 120, some information may be lost') ! elseif(manylonglines.eq.5) then ! write(*,*)' Ignoring subsequent longline warnings' ! endif endif endif ! One should remove TAB characters !! ?? YES !! ! if(line(1:1).eq.'$') goto 100 ipp=1 if(eolch(line,ipp)) goto 100 if(line(ipp:ipp).eq.'$') goto 100 ! replace TAB by space call replacetab(line,nl) ! goto 120 !--------------------------------------------------------- ! handle all TDB keywords except function 120 continue keyw=istdbkeyword(line,nextc) if(.not.(keyw.eq.11 .or. keyw.eq.9 .or. keyw.eq.8)) then ! added 2023.10.22/BoS. kew=11 is database_information, =8,9 is bibliography call capson(line) endif if(.not.onlyfun) then ! write(*,71)'3E back from istdbkeyword',keyw if(keyw.eq.0) then if(trim(line).eq.' DEFINE_SYSTEM_DEFAULT ELEMENT 2 !') then goto 100 elseif(trim(line).eq.'DEFINE_SYSTEM_DEFAULT ELEMENT 2 !') then goto 100 ! elseif(dodis.ne.1) then elseif(dodis.ne.1 .and. .not.only_typedefs) then ! do not give this warning when reading disordered phases ... ! This message came also during reading only_typedfs ... write(*,122)nl,trim(line) 122 format('3E *** Warning, ignoring line ',i5,' with "',a,'"'/) endif endif endif if(keyw.eq.0) then ip=1 if(.not.eolch(line,ip)) then ! why error here?? if(ocv()) write(*,1230)nl,ip,trim(line) 1230 format('3E Ignoring line: ',i5,i7,' with "',a,'"'/) ! write(*,1230)nl,ip,trim(line) ! tdbwarning=.true. ! write(*,*)'3E tdbwarning set true 1' endif goto 100 elseif(onlyfun) then ! keyw=5 is FUNCTION if(keyw.eq.5) goto 800 goto 100 elseif(only_typedefs) then ! extract only_typdefs at first read if(keyw.ne.7) goto 100 ! write(*,*)'3E reading a TYPE_DEF' endif ! if(.not.nophase .and. keyw.ne.4) then ! after a PHASE keyword one should have a CONSTITUENT if(.not.silent) write(kou,*)'3E WARNING expeciting CONSTITUENT: ',& line(1:30) tdbwarning=.TRUE. ! write(*,*)'3E tdbwarning set true 2' endif ! check there is a ! in line, otherwise read until we find an exclamation mark ip=1 longline(ip:)=line ip=len_trim(longline)+1 ! write(*,71)'3E line 1 ',ip,trim(longline) ! write(*,*)'3E new keyword ',ip,'>',longline(1:40) do while(index(longline,'!').le.0) read(21,110,err=2200,end=2200)line nl=nl+1 if(line(1:1).ne.'$') then if(.not.(keyw.eq.11 .or. keyw.eq.9 .or. keyw.eq.8)) then ! no capson for database info and bibliography call capson(line) else ! write(*,67)trim(line) 67 format('info or bib: ',a) endif call replacetab(line,nl) longline(ip:)=line ip=len_trim(longline)+1 if(ip.ge.len(longline)-100) then if(.not.silent) write(kou,69)nl,ip,longline(1:72) 69 format('Overflow in longline ',2i8,' for line starting:'/a) gx%bmperr=4304; goto 1000 endif endif enddo ! if(keyw.eq.8 .or. keyw.eq.9) then ! no capson!! ! write(*,67)trim(longline) ! endif ! Here we have read data for the keyword up to ! ! write(*,71)'3E line 2 ',ip,trim(longline) 71 format(a,i4,1x,a) if(dodis.eq.1) then ! if dodis=1 only read data for disordred phases ! PHASE=3, CONSTITUENT=4, PARAMETER=6 ... BIBLIOGRAPHIC REFERENCES=8,9 ! if(keyw.lt.3 .or. keyw.eq.5 .or. keyw.gt.6) goto 100 if(.not.(keyw.eq.3 .or. keyw.eq.4 .or. keyw.eq.6 & .or. keyw.eq.8 .or. keyw.eq.9)) goto 100 endif ! ! we have 13 keywords ! write(*,*)'3E Reading tdb: ',keyw select case(keyw) case default if(ocv()) write(*,*)'3E default case: ',keyw,line(1:30) !--------------------------------------------------------------------- !101 format('readtdb 1: ',i3,'>',a,'<') ! if(line(2:9).eq.'ELEMENT ') then case(1) !element ------------------------------------------------ !123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678 ! ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01! ip=nextc if(eolch(longline,ip)) then if(.not.silent) & write(kou,*)'No element name after ELEMENT keyword on line ',nl gx%bmperr=4305; goto 1000 endif elsym=longline(ip:ip+1) if(elsym.eq.'/-' .or. elsym.eq.'VA') goto 100 ! allow lower case in TDB file ... call capson(elsym) if(nel.gt.0) then ! check if element among selected, if nel=0 accept all do jt=1,nel if(elsym.eq.selel(jt)) goto 76 enddo ! ignore this element as not selected if(ocv()) write(*,*)'3E Skipping database element: ',elsym ! write(*,*)'Skipping database element: ',elsym ! write(*,*)'Select: ',nel,(selel(jt),jt=1,nel) goto 100 endif ! mark we found a selected element 76 continue if(allocated(present)) then present(jt)=.TRUE. endif ! we seem to miss the first letter of the reference state below ?? ip=ip+len_trim(elsym)-1 if(eolch(longline,ip)) then name1='DUMMY' mass=one h298=zero s298=zero else ! extract the reference phase, third argument is 1 meaning until next space ! ix is the length of the reference phase (irrelevant here) ! ip is updated to character after the name extracted call getext(longline,ip,1,name1,' ',ix) ! write(*,*)'3E longline: ',ip,longline(1:ip+10) ! write(*,*)'3E element ref: ',name1 ! name1=longline(ip:) ! ip=ip+len_trim(name1) ! after the name should be mass, H298-H0 and S298, ignore errors call getrel(longline,ip,mass) if(buperr.ne.0) then mass=one; buperr=0 endif call getrel(longline,ip,h298) if(buperr.ne.0) then h298=zero; buperr=0 endif call getrel(longline,ip,s298) if(buperr.ne.0) then s298=zero; buperr=0 endif name2=elsym endif call store_element(elsym,name2,name1,mass,h298,s298) if(gx%bmperr.ne.0) goto 1000 case(2) !SPECIES ------------------------------------------------- ! elseif(line(2:9).eq.'SPECIES ') then !123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678 ! SPECIES O3PU2 O3PU2! ip=nextc if(eolch(longline,ip)) then if(.not.silent) write(kou,*)'Line after SPECIES keyword empty' gx%bmperr=4306; goto 1000 endif name1=longline(ip:) ! find first space after non-space jp=index(name1,' ') ! write(*,*)'3E longline:',trim(longline),ip,jp name1(jp:)=' ' ip=ip+jp ! handle MQMQA quads ... do I need capson? maybe ... ! write(*,*)'3E species line 3863: ',trim(name1) call capson(name1) kp=index(name1,'/') if(kp.gt.0 .and. & name1(kp+1:kp+1).ge.'A' .and. name1(kp+1:kp+1).le.'Z') then ! this is an MQMQA quad, an ion has /+ or /- or /digit kp=len_trim(longline) if(longline(kp:kp).eq.'!') longline(kp:kp)=':' ! write(*,572)trim(name1),trim(longline(ip:)) 572 format('3E Call mqmqa_species: "',a,'" "',a,'" ') call mqmqa_species(name1,longline(ip:),nend) if(gx%bmperr.ne.0) write(*,*)'3E error creating MQMQA quad',gx%bmperr goto 573 endif if(eolch(longline,ip)) then if(.not.silent) write(kou,*)'WARNING No stoichiometry for species: ',& trim(name1) tdbwarning=.TRUE. ! write(*,*)'3E tdbwarning set true 3' goto 100 endif stoiline=longline(ip:) ! write(*,'(a,a,i3,a,a)')'3E stoi:',trim(longline),ip,':',trim(stoiline) jp=index(stoiline,' ') ! write(*,'(4a,i4)')'3E >> species: ',trim(name1),' ',trim(stoiline),jp stoiline(jp:)=' ' ! write(*,'(4a,i4)')'3E >> species: ',trim(name1),' ',trim(stoiline),jp call decode_stoik(stoiline,noelx,elsyms,stoik) if(gx%bmperr.ne.0) goto 1000 ! check elements exist call enter_species(name1,noelx,elsyms,stoik) ! write(*,*)'3E: entering species error: ',gx%bmperr 573 continue if(gx%bmperr.ne.0) then ! if element not selected just skip the species if(gx%bmperr.eq.4046) then gx%bmperr=0; goto 100 else if(.not.silent) write(kou,*)'Error enter species: "',& trim(name1),'" with stoichometry: ',trim(stoiline) goto 1000 endif endif !----------------------------------------------------------------------- case(5) ! function ! see code at label 800 for functions ! elseif(line(2:10).eq.'FUNCTION ') then !123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678 ! FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T) ! name1=line(11:18) ! longline=' ' ! longline=line(20:) !300 continue ! jp=len_trim(longline) ! if(longline(jp:jp).eq.'!') then ! write(*,*)'3E Skipping function: ',name1 ! all functions entered at the end, skip until ! ! do while(index(longline,'!').le.0) if(index(longline,'!').le.0) then if(.not.silent) & write(*,*)'3E Error, terminating ! not found for function!!',nl gx%bmperr=4307; goto 1000 endif !------------------------------------------------------------------------- ! elseif(line(2:7).eq.'PHASE ') then case(3) ! PHASE !123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678 ! PHASE LIQUID:L % 1 1.0 ! if(nophase) then nophase=.false. ! give a warning if any selected element is not present if(allocated(present)) then funname=' ' kkk=1 do jt=1,nel if(.not.present(jt)) then funname(kkk:)=selel(jt) kkk=len_trim(funname)+2 endif enddo if(kkk.gt.1) then if(.not.silent) write(kou,68)funname(1:kkk) 68 format(/' *** Warning, elements not present in database: ',a/) endif deallocate(present) endif else if(.not.silent) write(kou,*) & 'Error, a PHASE keyword must be followed by its CONSTIT' gx%bmperr=4308; goto 1000 endif ! problem finding phase when line before is too long, i.e. missing the "!" ! write(*,*)'3E found PHASE ',trim(longline),' line: ',nl ! number of TYP_DEFS for this phase TDthisphase=0 ip=nextc if(eolch(longline,ip)) then if(.not.silent) write(kou,*)'line after PHASE empty' goto 100 endif name1=longline(ip:) ! convert phase name to upp case call capson(name1) jp=index(name1,' ') ip=nextc+jp if(jp.gt.0) then name1(jp:)=' ' endif jp=index(name1,':') ! write(*,*)'3E readtdb 11: ',name1,ip,jp ! phytype, a letter after the phase name separated by a :, for example GAS:G ! I2SL is :Y, MQMQA is :Q or :X for new coding if(jp.gt.0) then phtype=name1(jp+1:jp+1) name1(jp:)=' ' else phtype=' ' endif ! we must know if we have the mqmqa model before reading constituents!! ! tested below also. ! if(phtype.eq.'Q') then if(phtype.eq.'Q' .or. phtype.eq.'X') then ! Q was the original MQMQA phtype, X means maybe some new code mqmqa=.TRUE. else mqmqa=.FALSE. endif ! check if phase rejected ! write(*,*)'3E number of phases rejected: ',nphrej do jt=1,nphrej if(name1.eq.phreject(jt)) then thisphaserejected=.TRUE. ! write(*,*)'3E skipping rejected phase: ',name1 ! why is nophase set true? If I comment it away nothing read!! nophase=.true. goto 100 endif enddo ! SELECTED_PHASES ! if seltdbph is allocated check if this phase selected when dodis=0 if(dodis.eq.0 .and. allocated(seltdbph) .and. nselph.gt.0) then ! write(*,*)'3E Calling isabbr: ',trim(name1),nselph jt=isabbr(name1,seltdbph,nselph) ! write(*,*)'3E return from isabbr: ',jt if(jt.eq.0) then ! write(*,*)'3E not selected phase: ',trim(name1) thisphaserejected=.TRUE. nophase=.true. goto 100 else write(*,'(a,a,a,a)')'3E Phase ',trim(name1),' fits selection ',& trim(seltdbph(jt)) endif endif ! end elected phases thisphaserejected=.false. ! write(*,*)'3E nophase set to false, phase: ',name1 ip=ip+1 ! jp=ip ! CCI jp=index(longline,'%') ! if(jp.eq.0) then ! evidently name2 is just the % sign ... ! write(*,*)'3E missing % after phase name, continuing' ! jp=ip+1 ! endif ! I am no longer sure what name2 is used for .... name2=longline(ip:jp) ! write(*,302)trim(name2),ip,jp,trim(longline) !302 format('3E Debug: name2: ',a,2i5/a) thisdis=0 phdis: if(dodis.eq.1) then ! special when reading disordered parts, check phase name equal ! write(*,*)'3E Check if disordered part: ',dodis,name1 do jt=1,disparttc if(name1.eq.dispartph(jt)) goto 307 enddo ! not a disordered part goto 100 307 continue thisdis=jt ! write(*,'(3a)')'3E ',trim(name1),' is a disordered part' ! check if disordered phase is magnetic!, we have to step though type_defs dismag=0 if(.not.eolch(longline,jp)) then ch1=longline(jp:jp) ! write(*,312)trim(longline),jp,trim(longline(jp+1:)) 312 format('3E distypes: ',a,i3,' "',a,'"') dmag: do while(ch1.ne.' ') do jt=1,nooftypedefs if(ch1.eq.typedefchar(jt) .and. & ((typedefaction(jt).eq.-1 .or. & typedefaction(jt).eq.-3))) then dismag=typedefaction(jt) ! write(*,*)'3E disordered part is magnetic',dismag exit dmag endif enddo jp=jp+1 ch1=longline(jp:jp) enddo dmag endif ! we skip the rest of the phase line ... goto 100 elseif(dodis.eq.0 .and. ndisph.gt.0) then ! make use of initial read of TDB file to skip phases that are disordered parts ! write(*,*)'3E comparing "',trim(name1),'" with "',trim(disph(1)),'" etc' do jt=1,ndisph ! if(name1.eq.disph(jt)) then if(name1.eq.dispartph(jt)) then ! write(*,*)'3E Phase ',trim(name1),' is a disordered part of ',& ! trim(ordpartph(jt)),jt,nphrej ! if the phase ordpartph(jt) is rejected, enter the disordered phase!! do zz=1,nphrej ! write(*,*)'3E check "',trim(ordpartph(jt)),'" and "',& ! trim(phreject(zz)),'"' if(ordpartph(jt).eq.phreject(zz)) then write(*,'(a,a,a,a,a)')'3E Keeping ',trim(name1),& ' because phase ',trim(phreject(zz)),' is rejected' goto 310 endif enddo ! do not enter this phase as it is a disordered part ! all these must be set ... thisdis=-1 nophase=.true. thisphaserejected=.TRUE. goto 100 endif enddo elseif(dodis.eq.0 .and. disparttc.gt.0) then ! we must not enter phases that are disordered parts do jt=1,disparttc if(name1.eq.dispartph(jt)) then ! write(*,*)'3E Skip phase that is a disordered part: ',name1 thisdis=-1 goto 100 endif enddo endif phdis ! write(*,*)'3E Entering phase: ',name1 ! write(*,*)'3E Checking phase types for phase: ',name1,jp ! skip blanks, then read type code, finished by a blank if(eolch(longline,jp)) then if(.not.silent) & write(kou,*)'3E WARNING no phase typecode: ',trim(name1) tdbwarning=.TRUE. ! write(*,*)'3E tdbwarning set true 4' endif jp=jp-1 ! WE MUST CHECK IF TYPE_DEFS appear after phases have been entered!! ! write(*,311)'3E TDs: ',nooftypedefs,& ! (typedefchar(jt),jt=1,nooftypedefs) ! return here to check for different TYPE_DEFS 310 jp=jp+1 ! check which type_defs that has been entered ! write(*,*)'3E typedefs: ',trim(name1),': ',trim(longline(jp:)),jp ! NOTE and FIX: type code expected to be after a single space: be flexible ?? typedefcheck: if(longline(jp:jp).ne.' ') then ch1=longline(jp:jp) if(always.eq.3) then ! this code an attempt to fool -O2 compiler switch ! write(*,*)'3E typedef for ',trim(name1),': ',ch1,TDthisphase ! write(*,311)'3E TDs: ',nooftypedefs,& ! (typedefchar(jt),jt=1,nooftypedefs) 311 format(a,i3,': ',10('"',a,'", ')) always=always+1 endif do jt=1,nooftypedefs if(ch1.eq.typedefchar(jt)) goto 320 enddo ! ignore typedef % meaning sequential read ... if(ch1.eq.'%') goto 310 ! WARNING that unknown TYPE_DEF has been used!! write(kou,313)trim(name1),ch1 313 format(' *** WARNING: phase ',a,' has unknown TYPE_DEF: ',a/& ' *** Move all TYPE_DEFS before used in any phase!') tdbwarning=.TRUE. ! write(*,*)'3E tdbwarning set true 5' goto 310 320 continue if(typedefaction(jt).eq.99) then ! ignore TYPE_DEF SEQ continue elseif(typedefaction(jt).eq.-1 .or. & typedefaction(jt).eq.-3) then ! Inden magnetic addition, save for after phase created TDthisphase=TDthisphase+1 addphasetypedef(TDthisphase)=typedefaction(jt) elseif(abs(typedefaction(jt)).ge.25 .and. & abs(typedefaction(jt)).le.37) then ! ferroref replaced by negative typedefaction ... ! Qing-Xiong magnetic addition TDthisphase=TDthisphase+1 addphasetypedef(TDthisphase)=typedefaction(jt) elseif(typedefaction(jt).eq.1905) then ! Einstein TDthisphase=TDthisphase+1 addphasetypedef(TDthisphase)=typedefaction(jt) elseif(typedefaction(jt).eq.491) then ! Liquid 2-state model TDthisphase=TDthisphase+1 addphasetypedef(TDthisphase)=typedefaction(jt) elseif(typedefaction(jt).eq.777) then 778 continue ! ternary extrapolations, these should be executed at the end of reading ! some of the elements involved may not be selected. TDthisphase=TDthisphase+1 addphasetypedef(TDthisphase)=typedefaction(jt) ctxp=ctxp+1 ternaryxpol(ctxp)=trim(name1)//' '//ternaryxpol(ctxp) ! write(*,'(a,i4,": ",a)')'3E ternary around line 4137: ',& ! ctxp,trim(ternaryxpol(ctxp)) ! this ignores the type letter, just assignes in same order as phases entered ! Or one must enforce that the TYPE_DEF for ternary is right after the phase? elseif(.not.(typedefaction(jt).eq.100.or.typedefaction(jt).eq.0)) then ! give an alert if typedefaction is not 100 write(*,*)'3E Unknown typedefaction: ',typedefaction(jt) endif goto 310 endif typedefcheck ! write(*,*)'3E typedefs for ',trim(name1),': ',TDthisphase,& ! (addphasetypedef(ll),ll=1,TDthisphase) name2='TDB file model: '//name2 ! number of sublattices ! write(*,*)'3E buperr: ',buperr ,jp call getrel(longline,jp,xsl) if(buperr.ne.0) then if(.not.silent) write(kou,*)'3E tdb: "',longline(1:jp),'"',buperr gx%bmperr=buperr; goto 1000 endif ! dummy statement to fool -O2 optimization (or parallelization?) if(nsl.lt.0) jt=1 nsl=int(xsl) do ll=1,nsl call getrel(longline,jp,stoik(ll)) if(buperr.ne.0) then gx%bmperr=buperr; goto 1000 endif enddo ! write(*,*)'3E readtdb 3A: ',nsl,(stoik(ll),ll=1,nsl) !--------------------------------------------------------------------- ! The constituent line must follow PHASE before any new phase case(4) ! CONSTITUENT LIQUID:L :CR,FE,MO : ! ! the phase must have been defined if(nophase) then if(thisphaserejected) then ! write(*,*)'3E previous phase rejected ' goto 100 endif if(.not.silent) write(kou,327)nl,trim(longline) 327 format('3E A CONSTITUENT keyword not directly preceeded by PHASE!',& ' line ',i7/a) gx%bmperr=4308; goto 1000 endif nophase=.true. ! write(*,*)'3E constituents: ',trim(longline) condis1: if(dodis.eq.1) then ! searchin why sigma in TAFID does not have c disordered fraction set ! write(*,*)'3E sigma 17:',trim(longline),thisdis ! write(*,*)'3E sigma 17:',thisdis if(thisdis.eq.0) goto 100 ! we skip the constituent line and go directly to create disordered fractions goto 395 elseif(disparttc.gt.0 .and. thisdis.lt.0) then ! this is a disordered part, skip goto 100 endif condis1 !360 continue jp=len_trim(longline) ! write(*,*)'3E readtdb gas1: ',nl,jp,longline(1:jp) ! eliminate all after the exclamation mark ! longline(jp+1:)=' ' ! ip=index(longline,' :')+2 ! in TDB files MQMQA quads entered as constituents ! if(mqmqa) write(*,*)'3E skipping redundant? code for MQMQA in readtdb' goto 363 !--------------------------- redundant code below if(mqmqa) then ! this is a FactSage MQMQA model for liquids ! entering constituents as quadrupoles write(*,'(a,a,a,2i5)')'3E mqmqa const: "',trim(longline(ip:jp)),& '"',ip,jp loop=0 ! clear any old content in const const=' ' ! MQMQA constituents created "on the fly" as quadrupols using existing species ! and additional coordination numbers n1..n4. A / separate sublattices ! a , separate species in same sublattice. If any A B X Y species not entered ! the quadrupole is ignored (not an error) ! A/X n1 n2 r3 A,B/X n1 n2 n3 B/X,Y n1 n2 n3 A,B/X,Y n1 n2 n3 n4 ... ! The r3 is a FNN/SNN ratio for pairs, normally 2.4 ! nend is set to zero at first call, then incremented for each FNN endmember call mqmqa_constituents(longline(ip:jp),const,nend,loop) ! write(*,*)'3E back from entering constituents',gx%bmperr if(gx%bmperr.ne.0) then write(*,*)'3E error entering quadrupoles' goto 1000 endif call mqmqa_rearrange(const) ! write(*,*)'3E back from rearranging constituents',gx%bmperr if(gx%bmperr.ne.0) then write(*,*)'3E error rearranging quadrupoles',gx%bmperr goto 1000 endif ! skip the rest below except entering the phase ! stoik(1) is bonds/atom, just for output, never used explicitly stoik(1)=2.0D0 knr(1)=mqmqa_data%nconst ! write(*,*)'3E enter_p: ',trim(name1),' ',knr(1),stoik(1),' ',phtype name2='MQMQA ' call enter_phase(name1,1,knr,const,stoik,name2,phtype,& tdbwarning,emodel) write(*,*)'3E back from entering phase 1',gx%bmperr ! if(tdbwarning) write(*,*)'3E tdbwarning set true 6' if(gx%bmperr.ne.0) then write(*,*)'3E failed to enter the MQMQA phase',gx%bmperr endif goto 100 endif !--------------- code above redundant when MQMQA quad added as species 363 continue ! write(*,*)'3E readtdb gas2: ',jp,longline(1:jp) ll=0 nr=0 nrr=0 ! write(*,*)'3E readtdb 3E: ',ll,nr,nsl,longline(ip:jp) ! mode=1 indicates to getname that / + - are allowed in species names mode=1 370 continue if(ll.ge.1) then knr(ll)=nr if(nr.le.0) then if(ocv()) then write(*,*)'3E Skipping phase due to missing constituents: ',name1 ! write(*,378)name1,ll 378 format('Phase ',a,' has no constituents in sublattice ',i2) ! Not a fatal error when elements have been selected but skip this phase endif goto 100 endif endif ll=ll+1 ! write(*,*)'3E start sublat ',ll,nsl,nr,ip if(ll.gt.nsl) goto 390 nr=0 380 continue if(eolch(longline,ip)) then if(.not.silent) write(kou,*)'Error extracting constituents 1' gx%bmperr=4309; goto 1000 endif nr=nr+1 nrr=nrr+1 ! write(*,379)'readtdb 3EA: ',ip,nr,mqmqa,longline(ip:ip+10) 379 format(a,2i4,L2,' >',a,'< >',a,'< >',a,'<') call getname(longline,ip,name3,mode,ch1) ! write(*,379)'readtdb 3EB: ',ip,nr,longline(ip:ip+10),name3,ch1 if(buperr.ne.0) then write(*,381)'3E readtdb EC: ',ll,nr,longline(1:ip+5),ip,name3 381 format(a,2i4,' "',a,'" ',i5,1x,a,'"',a) gx%bmperr=buperr; goto 1000 endif ! write(*,381)'readtdb 3E: ',ll,nr,longline(1:ip+5),ip,name3,ch1 const(nrr)=name3 ! bypass any "major" indicator % if(ch1.eq.'%') ip=ip+1 if(eolch(longline,ip)) then if(.not.silent) write(kou,*)'Error extracting constituents 2' gx%bmperr=4309; goto 1000 endif ! check that const(nrr) among the selected elements ... if(mqmqa) then iq=len_trim(name3) ! if bot supplied in the database add -Q to quads .... if(name3(iq-1:iq).ne.'-Q') name3(iq+1:iq+2)='-Q' endif ! write(*,*)'3E Testing constituent: "',name3,'" ',nr ! call find_species_record_noabbr(name3,lp1) ! the _exact variant ignores stuff after -Q for MQMQA quads call find_species_record_exact(name3,lp1) if(gx%bmperr.ne.0) then ! this species is not present, not a fatal error, skip it and continue ! write(*,*)'3E Skipping constituent: ',name3 gx%bmperr=0; nrr=nrr-1; nr=nr-1 endif ! do not remove the -Q ! if(mqmqa) name3(iq:)=' ' ch1=longline(ip:ip) if(ch1.eq.',') then ! separator (not needed) between constituents ip=ip+1; goto 380 elseif(ch1.eq.':') then ! end of constituents in a sublattice ip=ip+1; goto 370 endif ! write(*,*)'3E we are at line 4358',gx%bmperr if(ch1.ne.'!') goto 380 ! when an ! found the list of constutents is finished. But we ! should have found a : before the ! if(.not.silent) & write(kou,*)'3E Found "!" before terminating ":" around line',nl gx%bmperr=4310; goto 1000 ! write(*,*)'Species terminator error: ',ch1,nl ! gx%bmperr=4157; goto 1000 390 continue ! name2 is model, ignored on reading TDB ionliq=.FALSE. mqmqa=.FALSE. ! write(*,*)'3E phtype: "',phtype,'"' if(phtype.eq.'Y') then ! name2='IONIC_LIQUID ' name2='I2SL ' ionliq=.TRUE. elseif(phtype.eq.'Q') then name2='MQMQA ' mqmqa=.TRUE. else name2='CEF-TDB-RKM? ' endif if(ocv()) write(*,*)'3E readtdb 9: ',name1,nsl,knr(1),knr(2),phtype ! write(*,*)'3E readtdb 9: ',name1,nsl,knr(1),knr(2),phtype 395 continue ! ! THE CODE HERE IS A MESS ! ! write(*,*)'3E sigma4 label 395 add disordered fraction set: ',dodis,nphrej condis2: if(dodis.eq.1) then ! if we have a disordered part do not enter the phase, add disordered fracs! ! the ordered phase name is ordpart(thisdis) ! write(*,*)'3E sigma19: ',trim(ordpartph(disparttc)),disparttc,& ! trim(ordpartph(thisdis)),thisdis do jt=1,nphrej ! if(ordpartph(disparttc).eq.phreject(jt)) then ! why disparttc? if(ordpartph(thisdis).eq.phreject(jt)) then write(*,'(a,a,a)')'3E ordered part ',trim(phreject(jt)),& ' is rejected, keep disordered part ' goto 100 endif enddo ! write(*,*)'3E sigma20: ',trim(ordpartph(thisdis)) call find_phase_by_name(ordpartph(thisdis),iph,ics) if(gx%bmperr.ne.0) then ! NOTE THE ORDERED PHASE MAY NOT BE ENTERED DUE TO COMPONENTS!! if(.not.silent) write(kou,396)trim(ordpartph(thisdis)) 396 format('3E and disordered part ',a,' has not been selected') tdbwarning=.TRUE. ! write(*,*)'3E tdbwarning set true 7' gx%bmperr=0 goto 100 else ! if(.not.silent) write(kou,*) & write(kou,'(a,a,3i3)')'3E Adding disordered part to ',& trim(ordpartph(thisdis)),orddistyp(thisdis),thisdis,dismag if(dismag.ne.0) then ! disordered phase magnetic, check if ordered is also ... lokph=phases(iph) nullify(addrec) addrec=>phlista(lokph)%additions write(*,1221) 1221 format('3E checking if ordered phase has magnetic model') ! type(gtp_phase_add), pointer :: addrec do while(associated(addrec)) ! write(*,*)'3E addrec: ',addrec%type,INDENMAGNETIC,XIONGMAGNETIC if(addrec%type.eq.INDENMAGNETIC) goto 798 if(addrec%type.eq.XIONGMAGNETIC) goto 798 addrec=>addrec%nextadd enddo ! write(*,*)'3E adding magnetic model to ordered phase' ! ordered not magnetic, set the same as disordered if(dismag.eq.-1) then ! Inden magnetic for BCC call add_addrecord(lokph,'Y',indenmagnetic) elseif(dismag.eq.-3) then ! Inden magnetic for FCC/HCP call add_addrecord(lokph,'N',indenmagnetic) endif endif endif 798 continue ! we are creating the phase, there is only one composition set, iph is ordered ! write(*,*)'3E sigma18: get_phase_compset' call get_phase_compset(iph,1,lokph,lokcs) if(gx%bmperr.ne.0) goto 1000 ! ch1 is suffix for disordered parameters, always D ch1='D' ! jl=0 if NDM (sigma) ! jl=1 if phase can be totally disordered (but can have interstitials) ! nd1 is the number of sublattices to sum into disordered set if(orddistyp(thisdis).eq.1) then jl=1 if(phlista(lokph)%noofsubl.le.5) nd1=4 if(phlista(lokph)%noofsubl.le.3) nd1=2 ! if(.not.silent) write(kou,397) trim(ordpartph(thisdis)),nd1 write(kou,397) trim(ordpartph(thisdis)),nd1,thisdis 397 format('3E Phase ',a,' has order/disorder partition model',& ' adding first ',i2,'; thisdis: ',i2) else jl=0 nd1=phlista(lokph)%noofsubl endif ! goto 402 402 continue if(jl.eq.0 .and. .not.silent) write(kou,398)trim(ordpartph(thisdis)) 398 format('3E The phase ',a,& ' cannot be completely disordered at equilibrium.') ! add DIS_PART from TDB ! write(*,*)'3E adding disordered fraction set',csfree,highcs call add_fraction_set(iph,ch1,nd1,jl) if(gx%bmperr.ne.0) then if(.not.silent) write(kou,*) & '3E Error entering disordered fraction set: ',gx%bmperr goto 1000 endif ! suck= newhighcs(.true.) ! write(*,*)'3E added disordered fraction set 1: ',csfree,highcs,suck if(jl.eq.0) then ! we must set the correct formula unit of the disordered phase, on the ! TDB file it is unity. Sum up the sites for the ordered phase in lokcs xxx=zero do ll=1,nd1 xxx=xxx+firsteq%phase_varres(lokcs)%sites(ll) enddo firsteq%phase_varres(lokcs)%disfra%fsites=xxx else xxx=one endif ! if(.not.silent) write(kou,601) & ! dispartph(thisdis)(1:len_trim(dispartph(thisdis))),ch1,nd1,jl,xxx 601 format('3E Add parameters from disordered part: ',a,5x,a,2x,2i3,F12.4) else ! write(*,*)'3E enter phase: ',name1 call enter_phase(name1,nsl,knr,const,stoik,name2,phtype,& tdbwarning,emodel) ! if(tdbwarning) write(*,*)'3E tdbwarning set true 8' ! no error entering an I2SL liuqid with empty first sublattice ... suck ! It is just not entered .... ! write(*,*)'3E back from enter_phase 2, error? ',gx%bmperr if(gx%bmperr.ne.0) then if(gx%bmperr.eq.4121) then if(.not.silent) write(kou,*) & '3E Phase ',trim(name1),& ' is ambiguous or short for another phase' endif goto 1000 endif ! any typedefs? only magnetic handelled at present call find_phase_by_name(name1,iph,lcs) ! write(*,*)'readtdb 9X: ',gx%bmperr if(gx%bmperr.ne.0) then if(.not.silent) write(kou,*)'Phase ',name1,' is ambiguous' goto 1000 endif lokph=phases(iph) ! write(*,*)'3E typedefs for ',trim(name1),lokph,TDthisphase phasetypes: do jt=1,TDthisphase ! write(*,*)'3E manage typedef ',jt,addphasetypedef(jt) if(addphasetypedef(jt).eq.-1) then ! Inden magnetic for BCC call add_addrecord(lokph,'Y',indenmagnetic) ! call add_magrec_inden(lokph,1,-1) elseif(addphasetypedef(jt).eq.-3) then ! Inden magnetic for FCC and other phases call add_addrecord(lokph,'N',indenmagnetic) ! call add_magrec_inden(lokph,1,-3) elseif(addphasetypedef(jt).eq.1905) then ! Einstein lowt model call add_addrecord(lokph,' ',einsteincp) elseif(addphasetypedef(jt).eq.491) then ! Liquid 2-state model call add_addrecord(lokph,' ',TWOSTATEMODEL1) else ! Assumed Xiong magnetic, the factor 0.37 (BCC) or 0.25 (FCC) needed ! write(*,*)'3E Entering Qing-Xiongmagnetic ',addphasetypedef(jt) ! in TDB files ALWAYS average bohr magenton numbers phlista(lokph)%status1=ibset(phlista(lokph)%status1,PHBMAV) more=' ' ! This is a secret way to set ferromagnetic reference state for alloys if(addphasetypedef(jt).eq.-37 .or. addphasetypedef(jt).eq.-25) & more(3:3)='R' ! if(ferroref) more(3:3)='R' ! write(*,*)'3E more: "',more,'" and ',ferroref ! write(*,*)'3E add typedef: ',lokph,jt,addphasetypedef(jt) if(abs(addphasetypedef(jt)).eq.37) then ! BCC ...... very cryptic: 2nd letter space, " ", means not idividual IBM more(1:1)='Y' ! write(*,*)'3E more: "',more,'" and ',ferroref call add_addrecord(lokph,more,xiongmagnetic) ! call add_addrecord(lokph,'Y ',xiongmagnetic) elseif(abs(addphasetypedef(jt)).eq.25) then ! FCC and others more(1:1)='N' ! write(*,*)'3E more: "',more,'" and ',ferroref call add_addrecord(lokph,more,xiongmagnetic) ! call add_addrecord(lokph,'N ',xiongmagnetic) elseif(abs(addphasetypedef(jt)).eq.777) then ! ternary extrapolations should be handled after all parameters entered ! The phase name has to be added ... we just need to add the phase name here. ! Can we have several phases with ternary extrapolation? YES!! ! write(*,'("3E ternaryxpol phase ",a,2i5)')& ! trim(phlista(lokph)%name),lokph,jt addternaryxpol=.true. ! we are never here!! else write(*,13)lokph,addphasetypedef(jt) 13 format(78('*')/'3E unknown addition: ',2i7/78('*')) endif endif if(gx%bmperr.ne.0) goto 1000 enddo phasetypes ! write(*,607)trim(name1),iph 607 format('3E Entered phase ',a,i5) endif condis2 ! write(*,*)'3E readtdb 9B:',name1,nsl,phtype !------------------------------------------------------------------- case(6) ! PARAMETER -------------------------------------------- ! elseif(line(4:13).eq.'PARAMETER ') then !123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678 ! PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T if(eolch(longline,nextc)) then if(.not.silent) write(kou,*)'Empty line after PARAMETER' gx%bmperr=4311; goto 1000 endif ! if(dodis.eq.1) write(*,*)'Reading disordered parameters' ! write(*,*)'3E found parameter: ',totalpar,dodis,nl ! count parameter only when dodis=0 ! if(dodis.eq.1) totalpar=totalpar+1 if(dodis.eq.0) totalpar=totalpar+1 ip=nextc funname=longline(ip:) ! problem with default low T limit, can be ,, directly after parameter ) kp=index(funname,' ') cbug=index(funname,'),') ! save position after parameter name in nextc if(cbug.gt.0 .and. cbug.lt.kp) then nextc=ip+cbug+1 kp=cbug+1 ! write(*,*)'3E ,,2: ',trim(longline),ip,kp else cbug=index(funname,')') if(cbug.lt.kp) then nextc=ip+kp else ! We have spaces inside constituent arrays !!! kp=cbug+1 nextc=ip+cbug ! write(*,*)'3E spaces inside constituent array ',& ! trim(funname(1:kp)),kp,nextc funname(kp:)=' ' 612 continue cbug=index(funname(1:kp),' ') if(cbug.gt.0) then funname(cbug:)=funname(cbug+1:) kp=kp-1 goto 612 endif ! write(*,*)'3E spaces removed in constituent array? ',& ! trim(funname(1:kp)),kp,nextc kp=kp+1 endif endif funname(kp:)=' ' ! extract symbol, normally G or L but TC, BMAGN and others can occur lp1=index(funname,'(') name1=funname(1:lp1-1) ! strange bug when V0 is interpreted as LPZ !!! ! write(*,*)'3E mpi: ',name1 typty=0 ! this "L " is kept for compatibility with old TDB files if(name1(1:2).eq.'G ' .or. name1(1:2).eq.'L ') then typty=1 elseif(name1(1:3).eq.'TC ') then typty=2 ! NOTE this is actually too long only 4 letters mpi should be allowed elseif(name1(1:6).eq.'BMAGN ') then typty=3 ! elseif(name1(1:3).eq.'V0 ') then ! Wow ... these not corrected when changing model_parameter_id !!! ! typty=8 ! elseif(name1(1:3).eq.'VA ') then ! typty=9 endif ! we should handle also other parameter types if(typty.eq.0) then ! find the property associated with this symbol ! write(*,*)'psym1: ',trim(name1) ! HANDLE THE ABBREVIATION BM to be accepted as BMAG if(name1(1:3).eq.'BM ') then if(bmabbr.eq.0) then write(kou,1210) 1210 format('3E *** Tdbwarning, the parameter identifier "BM"',& ' assumed to be "BMAG"'/) endif tdbwarning=.TRUE. ! write(*,*)'3E tdbwarning set true 9' bmabbr=bmabbr+1 name1='BMAG' endif ! call get_parameter_typty(name1,lokph,typty,fractyp) call get_parameter_typty(name1,lokph,typty) if(gx%bmperr.ne.0) then write(*,*)'Unknown MPID "',trim(name1),'" typty: ',typty lp2=len_trim(name1) do lp1=1,nundefmpi if(undefmpi(lp1)(1:lp2).eq.trim(name1)) goto 618 enddo if(nundefmpi.lt.mundefmpi) then nundefmpi=nundefmpi+1 undefmpi(nundefmpi)=trim(name1) else write(*,*)'3E too many model parameter identifier errors',& mundefmpi endif if(.not.silent) write(kou,*) & ' *** WARNING unknown parameter identifier, "',& trim(name1),'" on line: ',nl 618 continue gx%bmperr=0; typty=0 tdbwarning=.TRUE. ! write(*,*)'3E tdbwarning set true 10' endif ! write(*,*)'psym2: ',typty,fractyp endif ! fractyp 1 is normal or ordered part if there is a disordered part fractyp=1 ! write(*,*)'readtdb: PAR',name1,typty ! extract phase name and constituent array lp1=index(funname,'(') lp2=index(funname,',') name2=funname(lp1+1:lp2-1) dispar: if(dodis.eq.1) then ! first check if phase name is a disordered part, if not skip ! then change phase name to ordered phase and set fractyp=2 ! and add a suffix D to parameter symbol do jl=1,disparttc if(name2.eq.dispartph(jl)) goto 710 enddo ! notusedpar=notusedpar+1 ! not disordered phase, skip this parameter ! goto 100 reason=1 goto 888 !----------------------- ! This parameter was added to notusedpar at first run, correct that now 710 continue notusedpar=notusedpar-1 ! write(*,*)'Entering disordered parameter to: ',thisdis,jl thisdis=jl if(dbcheck) write(*,887)notusedpar,longline(ip:ip+55) 887 format('3E restored: ',i5,': ',a) ! write(*,*)'Entering disordered parameter to: ',ordpartph(thisdis) ! write(*,*)'3E ',longline(1:len_trim(longline)) name2=ordpartph(jl) ! fractyp is now detected inside enter_parameter ! fractyp=2 endif dispar !---------------------- check phase is entered, ! the database may contain many phases that are not selected ! if(name2(1:2).eq.'ZR') write(*,*)'3E parameter for phase: ',trim(name2) call find_phase_by_name_exact(name2,jph,kkk) ! write(*,*)'readtdb 19: ',jph,gx%bmperr,name2 if(gx%bmperr.ne.0) then ! Why is ZRTE not accepted?? ... exact match with first phase was not OK! suck if(gx%bmperr.eq.4121) & write(*,*)'3E WARNING parameter with ambiguous phase name',& ' ignored: ',trim(name2) ! this parameter is not entered as phase not entered ! notusedpar=notusedpar+1 ! gx%bmperr=0; goto 100 gx%bmperr=0; reason=2; goto 888 ! goto 1000 endif ! extract constituent array, remove final ) and decode ! constituent names can be very long .... lokph=phases(jph) if(btest(phlista(lokph)%status1,PHIONLIQ)) then ! check if ionic liquid for handling neutrals ... with or without *: ionliq=.TRUE. else ionliq=.FALSE. endif name4=funname(lp2+1:) ! find terminating ) lp1=index(name4,')') ! if(name2(1:7).eq.'FCC_L12') then ! write(*,*)'3E constituent array: ',trim(name4) ! endif if(lp1.le.0) then if(.not.silent) then ! problem with space in constituent array ... write(kou,*) & '3E WARNING missing ")" in parameter constituent array "',& trim(name2),',',trim(name4),'", line:',nl write(*,*)'3E funname: ',trim(funname(lp2+1:)) write(*,*)'3E longline: ',trim(longline) endif tdbwarning=.TRUE. ! write(*,*)'3E tdbwarning set true 11' ! notusedpar=notusedpar+1 ! goto 100 reason=3 goto 888 else name4(lp1:)=' ' endif ! Handling of ionic liquid parameters for neutrals if(ionliq) then nsl=index(name4,':') ! write(*,*)'3E ionic liquid parameter: ',trim(name4),nsl if(nsl.le.0) then name4(3:)=name4 name4(1:2)='*:' ! write(*,*)'3E Added wildcard to parameter: ',trim(name4) endif endif 297 continue ! call decode_constarr(lokph,name4,nsl,endm,nint,lint,ideg) if(ocv()) write(*,303)'readtdb 303: ',name4(1:len_trim(name4)),& nsl,endm(1),endm(2),nint,((lint(ip,jp),ip=1,2),jp=1,nint) 303 format(a,a,2i4,2x,2i3,' : ',3(2i3,2x)) if(gx%bmperr.ne.0) then ! error here can mean parameter with un-selected constituent, i.e. no error ! write(*,*)'3E: decode',ionliq,tdbv,nsl,gx%bmperr if(ionliq .and. tdbv.eq.1 .and. nsl.eq.1) then ! handle parameters in ionic liquids with only neutrals in second sublattice ! in TC one can have no constituent there or an arbitrary constituent, ! in OC the constituent in sublattice 1 must be a * nsl=2 endm(2)=endm(1) endm(1)=-99 ! shift any interaction from sublattice 1 to 2 do ip=1,nint ! write(*,*)'3E lint: ',lint(1,ip),lint(2,ip) lint(2,ip)=2 enddo if(ocv()) write(*,303)'modif endmem: ',name4(1:len_trim(name4)),& nsl,endm(1),endm(2),nint,((lint(ip,jp),ip=1,2),jp=1,nint) gx%bmperr=0 else if(ocv()) write(*,*)'Skipping parameter: ',name4(1:len_trim(name4)) ! notusedpar=notusedpar+1 ! gx%bmperr=0; goto 100 gx%bmperr=0; reason=4; goto 888 endif endif ! if(nint.gt.1) then ! lint(1,1) is species of first, lint(1,2) in second interaction ! write(*,305)'readtdb 305: ',endm(1),nint,lint(2,1),lint(2,2) ! endif 305 format(a,5i4) !---------------- encode function ! if(dodis.eq.1) write(*,*)'We are here 1' ! limit Model parameter id and phase name to 5 characters ip=index(funname,',') if(ip.gt.7) funname(7:)=funname(ip:) !------------------------ ip=0 jp=0 400 continue ip=ip+1 405 continue ! write(*,*)'3E funname: ',trim(funname) ch1=funname(ip:ip) ! accept the first 6 letters and numbers of phase name ! accept the first 8 letters and numbers of phase name if((ch1.ge.'A' .and. ch1.le.'Z') .or. & (ch1.ge.'0' .and. ch1.le.'9')) goto 400 if(ch1.ne.' ') then funname(ip:)=funname(ip+1:) jp=jp+1 if(jp.lt.8) goto 405 funname(ip+1:)=' ' endif funname='_'//funname !------------------------------------------------- ! now read the function, start from position nextc ! write(*,398)'3E ,,: ',trim(longline),nextc longline=longline(nextc:) !410 continue jp=len_trim(longline) if(longline(jp:jp).ne.'!') then if(.not.silent) write(kou,410)nl,ip,longline(1:ip) 410 format('Error, parameter line not ending with !',2i5/a) gx%bmperr=4312; goto 1000 endif ! extract bibliographic reference if any ! NOTE: a legal ending is ;,,,! refx='none' kp=jp-1 do while(longline(kp:kp).ne.';') kp=kp-1 if(kp.lt.1) then ! illegal termination of function in TDB file if(.not.silent) write(kou,417)nl 417 format('No final ; of function in TDB file, around line: ',i5) gx%bmperr=4013; goto 1000 endif enddo kp=kp+2 ! longline(kp:kp) is character after "; " or ";," ! next is upper temperature limit or , meaning default. We have a "!" at end 430 continue if(eolch(longline,kp)) continue if(longline(kp:kp).eq.',') then kp=kp+1 elseif(longline(kp:kp).eq.'!') then goto 433 else ! ; 6000 N 91DIN ! ! kp=^ => index(...,' ')=5; kp=kp+4 kp=kp+index(longline(kp:),' ')-1 endif ! next is N or , if(eolch(longline,kp)) continue if(longline(kp:kp).ne.'!') then kp=kp+1 endif if(eolch(longline,kp)) continue if(kp.lt.jp) then ! NEW feature, comment after bibliographic reference, to be suppressed online!! refx=longline(kp:jp-1) zp=index(refx,' ') if(zp.gt.0) refx(zp:)=' ' call capson(refx) else refx=' ' endif ! ------------------- we found the reference, continue with the expression 433 continue ! replace any # by ' ' 412 continue jss=index(longline(1:jp),'#') if(jss.gt.0) then longline(jss:jss)=' ' goto 412 endif ! write(*,*)'3E Entering function 2: ',funname,trim(longline) lrot=0 ! write(*,*)'3E globaldata%encrypted 1: ',globaldata%encrypted ! call store_tpfun(funname,longline,lrot,.TRUE.) call store_tpfun(funname,longline,lrot,rewindx) ! write(*,17)lokph,typty,nsl,lrot,(endm(i),i=1,nsl) 17 format('readtdb 17: ',4i3,5x,10i3) ! write(*,404)'readtdb entpar: ',refx,fractyp,nint,ideg 404 format(a,a,i3,2x,10i3) if(gx%bmperr.ne.0) then if(.not.silent) write(kou,406)gx%bmperr,lrot,trim(funname),nl 406 format(/'Fatal error: ',2i7,': ',a,' around line: ',i7) goto 1000 else ! write(*,*)'3E calling enter_parameter from 3E line 4919' call enter_parameter(lokph,typty,fractyp,nsl,endm,nint,lint,ideg,& lrot,refx) if(ocv()) write(*,407)'3E Entered parameter: ',lokph,typty,gx%bmperr ! write(*,407)'3E Entered parameter: ',lokph,typty,gx%bmperr if(gx%bmperr.ne.0) then ! error entering parameter, not fatal ! if(dodis.eq.1 .and. .not.silent) & ! write(*,408)'3E parameter warning:',gx%bmperr,nl,& ! funname(1:40) !408 format(a,i6,' line ',i5,': ',a) ! if(.not.(gx%bmperr.ne.4096 .or. gx%bmperr.ne.4066)) then ! goto 1000 ! Error 4096 means "no such constituent" and 4066 "... in a sublattice" ! Error 4154 means no reference but the parameter has been entered if(gx%bmperr.eq.4096 .or. gx%bmperr.eq.4066 .or. & gx%bmperr.eq.4154) then ! this means the user has not selected this component or forgot reference ! write(*,*)'readtdb entparerr: ',gx%bmperr,' >',& ! funname(1:len_trim(funname)) ! error 4154 means missing reference but the parameter is entered if(gx%bmperr.eq.4154 .and. .not.silent) then write(*,409)gx%bmperr,nl 409 format('3E Warning: Parameter reference missing ',i6,& ', around line:',i7,' continuing') noparref=noparref+1 tdbwarning=.TRUE. ! write(*,*)'3E tdbwarning set true 12' else write(*,4091)gx%bmperr,nl 4091 format('3E Error ',i5,' occured around line ',i6) endif else ! Other errors than 4096, 4066 and 4154 are fatal goto 1000 endif gx%bmperr=0 ! else endif enteredpar=enteredpar+1 ! write(*,407)'3E Entered parameter: ',lokph,typty,gx%bmperr,enteredpar 407 format(a,4i5) endif ! there cannot be any error when we come here ... ! if(gx%bmperr.ne.0 .and. .not.silent) & ! write(*,*)'3E parameter function error: ',gx%bmperr goto 100 !------------------------------------------------------------------ ! this is end of PARAMETER keyword 888 continue ! TAFID with 9000 parameters have about 100 unused when all selected ! reason 1= parameter not part of disordered fraction set after rewind ! reason 2= phase not entered ! reason 3= constituent array error ! reason 4= constituent array not selected if(reason.ne.1) then notusedpar=notusedpar+1 if(dbcheck) write(*,889)reason,notusedpar,longline(ip:ip+55) 889 format('3E unused: ',i2,i5,': ',a) ! else ! parameters in disordered part read after rewinding ! notusedpar=notusedpar-1 endif goto 100 !------------------------------------------------------------------ ! elseif(line(2:17).eq.'TYPE_DEFINITION ') then case(7) !TYPE_DEFINITION !123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678 ! TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! if(.not.only_typedefs) then ! skip TYPE_DEFS unless only_typdefs is TRUE ! write(*,*)'3E skipping TYPE_DEFS at later rewind',rewindx goto 100 endif nytypedef=nytypedef+1 typedefchar(nytypedef)=longline(nextc+1:nextc+1) ! in TC the same typedef "letter" can be used several times do ip=1,nooftypedefs if(typedefchar(nytypedef).eq.typedefchar(ip)) then write(*,*)'3E Same typedef again, "',& typedefchar(nytypedef),'", ignoring second or later occurance' nytypedef=nytypedef-1 goto 88 endif enddo nooftypedefs=nytypedef if(nooftypedefs.gt.maxtypedefs) then write(*,*)'3E Too many TYPE_DEFINITION, modify readtdb in gtp3E.F90' gx%bmperr=4399; goto 1000 endif ip=nextc+3 ! newtypedef: if(index(longline(ip:),' SEQ').gt.0) then newtypedef: if(index(longline,' SEQ').gt.0) then typedefaction(nytypedef)=100 else !---------------------------------------------- TYPE_DEF phase einstein km=index(longline,' EINSTEIN ') einstein: if(km.gt.0) then typedefaction(nytypedef)=1905 exit newtypedef endif einstein !---------------------------------------------- TYPE_DEF magnetic km=index(longline,' MAGNETIC ') ! write(*,*)'3E typedef: ',trim(longline),km magnetic: if(km.gt.0) then ip=km+9 !73 format(a,i3,' "',a,'"') call getrel(longline,ip,xxx) if(buperr.ne.0) then gx%bmperr=buperr; goto 1000 endif if(xxx.eq.zero) then ! this is Qing-Xiong magnetic model, next number is 0.37 for BCC or 0.25 call getrel(longline,ip,xxx) if(buperr.ne.0) then gx%bmperr=buperr; goto 1000 endif typedefaction(nytypedef)=int(1.0D2*xxx) ! write(*,*)'3E Qing-Xiong magnetic model',nytypedef,& ! typedefaction(nytypedef) ! Special for Ting, check and set if ferromagnetic reference state ! write(*,*)'3E magnetic: "',trim(longline(ip:)),'"' if(.not.eolch(longline,ip)) then ! If there is a final F on the TYPE_DEF line set ferromagnetic reference state if(longline(ip:ip).eq.'F') then ! in this way all magnetic phases will have T=0 as refernce state ... ! ferroref=.TRUE. ! Use a negative value to indicate T=0 is ferroref typedefaction(nytypedef)=-typedefaction(nytypedef) endif endif else ! this is Inden model, xxx can be -1 for BCC or -3 for FCC, HCP and other phases typedefaction(nytypedef)=int(xxx) endif else !------------------------------------------ TYPE_DEF disordered-part and others km=index(longline,' DIS_PART ') never=1 ! write(*,*)'3E sigma1: ',trim(longline),km,never addnever: if(km.eq.0) then ! Allow for NEVER_DIS ... km=index(longline,' NEVER') ! this is for disordered SIGMA etc. if(never.gt.0) then never=-1 endif endif addnever ! write(*,*)'3E sigma2: ',trim(longline),km,never dispart: if(km.gt.0) then ! disordered part, either DIS_PART or NEVER_DIS several checks disparttc=disparttc+1 ! find the ordered phase name, we have to go backwards from km ip=km-1 81 continue if(longline(ip:ip).eq.' ') then ordpartph(disparttc)=' ' ! The ordpartph is not correct ordpartph(disparttc)=longline(ip+1:km) ! if the ordered part rejected skip this TYPE_DEF else ip=ip-1 goto 81 endif orddistyp(disparttc)=never ! extract the disordered part phase name ip=index(longline(km+2:),' ') dispartph(disparttc)=longline(km+2+ip:) ! find the end of phase name, a space or a , there is always a space after , ip=index(dispartph(disparttc),' ') km=index(dispartph(disparttc),',') if(km.gt.0 .and. km.lt.ip) ip=km ! if(ip.le.0) ip=1 dispartph(disparttc)(ip:)=' ' ! if ordered part rejected all OK do jt=1,nphrej if(ordpartph(disparttc).eq.phreject(jt)) then write(*,*)'3E ordered part rejected, keep disordered' goto 84 endif enddo if(.not.silent) write(kou,82)disparttc, & trim(ordpartph(disparttc)),& trim(dispartph(disparttc)),orddistyp(disparttc) 82 format('3E Found a type_def DIS_PART:',i2,& ' with ',a,' and ',a,' type:',i2) ! THIS CODE REDUNDANT BECAUSE ALL TYPE_DEFS READ BEFORE PHASES ARE ENTERED ! if the disordered part phase already entered give warning and advice ! call find_phase_by_name(dispartph(disparttc),iph,ics) ! if(gx%bmperr.ne.0) then ! gx%bmperr=0 ! else ! if(.not.silent) write(kou,83)dispartph(disparttc) !83 format('3E *** Warning, the disordered phase is already',& ! ' entered ***'/' Please rearrange the TDB file so',& ! ' this TYPE_DEF comes before'/& ! ' the PHASE keyword for the disordered phase: ',a/& ! ' *** The disordered part ignored ***') ! disparttc=disparttc-1 ! warning=.TRUE. ! endif 84 continue else km=index(longline,' LIQUID 2-STATE ') liq2state: if(km.gt.0) then !------------------------------------------- TYPE_DEF liquid 2-state model typedefaction(nytypedef)=491 else !---------------------------------------------- TYPE-DEF TERNARY_EXTRAPOL ! write(*,*)'3E typedef: ',trim(longline) km=index(longline,' TERNARY') ! do we know which phase we have here? The command should be ! type_def z A-P-D phase TERNARY ! extract the phase name before TERNARY !!! done at label 778, line 4148!!! ! step backward to extract phase name, bypass spaces ! pz2=km-1 ! do while(longline(pz2:pz2).eq.' ') ! pz2=pz2-1 ! enddo ! pz1=pz2 ! do while(longline(pz1:pz1).ne.' ') ! pz1=pz1-1 ! enddo ! write(*,'("3E phase name: ",a)')longline(pz1+1:pz2) ! code above redundant ternaryxp: if(km.gt.0) then typedefaction(nytypedef)=777 ntxp=ntxp+1 ! write(*,86)nytypedef,ntxp,trim(longline) 86 format('3E Found ternary extrapolation',2i4/a) ! we need to save the line!! if(ntxp.gt.mtxp) then write(*,*)'3E Error, ternary_extrapolations max',mtxp gx%bmperr=4399; goto 1000 endif ! write(*,'("3E line1: ",i3,a)')km,trim(longline) ! skip from km to first space and compress multiple spaces to a single one zp=index(longline(km+1:),' ') ! write(*,'("3E line2: ",i3,a)')zp,trim(longline(km+zp:)) ! we must add the phase name first!! ! NO, that is done at label 778, line 4148 !!! double ! ternaryxpol(ntxp)=longline(pz1+1:pz2+1)//longline(km+zp:) ternaryxpol(ntxp)=longline(km+zp:) ! write(*,'("3E line3: ",a,i3)')trim(ternaryxpol(ntxp)),ntxp ! call merge_spaces(longline(km+zp:)) ! Indicate we should execute ternaryxpol addternaryxpol=.true. else !---------------------------------------------- unknown TYPE-DEF typedefaction(nytypedef)=99 if(.not.silent) & write(kou,87)nl,longline(1:min(78,len_trim(longline))) 87 format('3E WARNING ignoring TYPE_DEF on line ',i5,':'/a) tdbwarning=.TRUE. ! write(*,*)'3E tdbwarning set true 13' ! write(*,*)' WARNING SET TRUE <<<<<<<<<<<<<<<<<<<<<<<<<<<' endif ternaryxp endif liq2state endif dispart endif magnetic endif newtypedef 88 continue !--------------------------------------------------------------------- ! elseif(line(2:20).eq.'LIST_OF_REFERENCES ' .or. & ! line(2:16).eq.'ADD_REFERENCES ') then case(8,9) ! LIST_OF_REFERENCES and ADD_REFERENCES bibliography !123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678 ! LIST_OF_REFERENCES ! NUMBER SOURCE ! REF283 'Alan Dinsdale, SGTE Data for Pure Elements, ! Calphad Vol 15(1991) p 317-425, ! also in NPL Report DMA(A)195 Rev. August 1990' ! write(kou,*)'Does not handle REFERENCES' ! skip the line with "NUMBER SOURCE" ! position ip after "NUMBER SOURCE" ip=index(longline,'NUMBER SOURCE')+14 if(eolch(longline,ip)) then if(.not.silent) write(kou,*)'Empty reference line',nl gx%bmperr=4313; goto 1000 endif if(longline(ip:ip).eq.'!') then ! write(*,*)'No references at all' goto 100 endif ! write(*,*)'list_of_references text length: ',len_trim(longline),ip ! some reference lists like those from SSUB has no single quotes kp=index(longline(ip:),"'") citationmarks: if(kp.gt.0) then 775 continue ! reference symbol is refx; reference text in reftext refx=longline(ip:ip+kp-2) if(longline(ip+kp:ip+kp).eq."'") then ! two ' after each other, a dummy reference reftext=' ' ip=ip+kp+1 kkk=1 ! write(*,*)'dummy: ',refx,' next >',longline(ip:ip+20),'<' else jp=ip+kp+1+index(longline(ip+kp+1:),"'") reftext=longline(ip+kp:jp-2) ip=jp ! when all works replace multiple spaces by a single one in reftext kkk=len_trim(reftext) kp=index(reftext(1:kkk),' ') do while(kp.gt.0) reftext(kp:)=reftext(kp+1:) kkk=kkk-1 kp=index(reftext(1:kkk),' ') enddo endif ! write(*,776)refx,nrefs,ip,jp,reftext(1:kkk) 776 format('Reference: ',a,3i5/a) ! this will not create bibliographic references that has not been referenced call tdbrefs(refx,reftext(1:kkk),1,ix) nrefs=nrefs+1 ! write(*,*)'added biblio ',refx,'>',longline(ip-5:ip+5),'<' if(eolch(longline,ip)) then gx%bmperr=4313; goto 1000 endif if(longline(ip:ip).ne.'!') then kp=index(longline(ip:),"'") goto 775 endif else ! references without citation marks no capson ! ip is at the start of the reference id, look for space if(.not.silent) write(kou,*) & 'Cannot handle references without citation marks',nl gx%bmperr=4314; goto 1000 endif citationmarks 777 continue ! write(*,*)'Read ',nrefs,' references, ending at',nl !---------------------------------------------------------------- case(10) ! ASSESSED_SYSTEMS if(.not.silent) write(kou,*) & '3E cannot handle ASSESSED_SYSTEMS ending at ',nl ! warning=.TRUE. ! skip lines until ! do while(index(line,'!').le.0) read(21,110)line nl=nl+1 ! call replacetab(line,nl) enddo !------------------------------------------------------------------ case(11) ! DATABASE_INFORMATION ! skip this as checktdb2 has already presented the information ! if(.not.silent) write(kou,*)'3E Cannot handle DATABASE_INFORMATION at ',nl ! warning=.TRUE. ! skip lines until ! ! write(*,*)'3E reading database information' ! write(*,*)'3E ',trim(line) ! ll=index(line,'!') ! write(*,*)'3E value of ll: ',ll ! this loop probably meaningless as we have read up to ! already ... ! write(*,*)'3E found this line: ',nl do while(index(line,'!').le.0) read(21,110)line nl=nl+1 ! ll=index(line,'!') ! write(*,*)'3E value of ll: ',ll ! call replacetab(line,nl) enddo !------------------------------------------------------------------ case(12) ! VERSION, recognize OC1 780 continue if(eolch(line,ip)) then read(21,110)line nl=nl+1 call replacetab(line,nl) goto 780 else if(line(ip:ip).eq.'!' .and. .not.silent) then write(kou,*)'Found VERSION keyword but no specification' else if(line(ip:ip+3).eq.'OC1 ') tdbv=2 endif endif ! skip lines until ! do while(index(line,'!').le.0) read(21,110)line nl=nl+1 call replacetab(line,nl) enddo !------------------------------------------------------------------ case(13) ! DEFAULT_COMMAND, handle REJECT only ! skip lines until ! do while(index(line,'!').le.0) read(21,110)line nl=nl+1 call replacetab(line,nl) enddo ! replace - by _ ... can be dangerous for electrons /- 790 continue ip=index(line,'-') if(ip.gt.0) then line(ip:ip)='_' goto 790 endif ! here I handle only reject phase 791 continue call getext(line,nextc,1,name1,' ',ix) if(name1(1:ix).eq.'REJECT_PHASE') then 793 continue ! save phase names to be rejected in a structure call getext(line,nextc,1,name1,' ',ix) if(name1(1:1).eq.' ' .or. name1(1:1).eq.'!') then goto 794 else nphrej=nphrej+1 if(nphrej.gt.maxrejph) then write(*,*)'3E Too many phases to reject, increase maxrejph' else write(*,*)'3E rejected phase: ',name1 phreject(nphrej)=name1 endif endif goto 793 elseif(name1(1:7).eq.'DEF_SYS' .or. & name1(1:13).eq.'DEFINE_SYSTEM') then ! ignore default define_system... as, Va and /- are always entered by default continue else write(*,*)'3E WARNING: ignoring default command: ',trim(name1) endif 794 continue ! rejected phases OK ! do zz=1,nphrej ! write(*,*)'3E rejected phase: ',phreject(zz) ! enddo !--------------------------------- DEFINE case(14) !ignore without warning write(*,*)'3E ignoring DEFINE keyword' continue end select !-------------------------------------------------------- end select if(gx%bmperr.ne.0 .and. .not.silent) then write(kou,711)gx%bmperr,nl,trim(line) 711 format('3E error: ',i5,' around line ',i7,': '/a) ! this error means reference error if(gx%bmperr.eq.4154) gx%bmperr=0 endif ! look for next KEYWORD goto 100 !-------------------------------------------------------- !----- reading FUNCTIONS at the end from a TDB file, we read just functions 800 continue if(eolch(line,nextc)) then if(.not.silent) write(kou,*) & 'Function name must be on same line as FUNCTION' gx%bmperr=4315; goto 1000 endif ipp=nextc+index(line(nextc:),' ') name1=line(nextc:ipp-1) ! write(*,18)'function >',name1,'< ',nextc,ipp !18 format(a,a,a,2i4) ! old code longline=' ' longline=line(ipp:) 810 continue jp=max(len_trim(longline),1) ! write(*,811)jp,longline(jp:jp),longline(1:jp) 811 format('3E ll: ',i3,' "',a1,'" ',a) ! if(longline(jp:jp).eq.'!') then ! This is to allow comments between ! and EndOfLine if(index(longline(1:jp),'!').gt.0) then ! replace # by ' ' 820 continue jss=index(longline(1:jp),'#') if(jss.gt.0) then longline(jss:jss)=' ' goto 820 endif ! file is not encrypted call find_tpfun_by_name_exact(name1,nr,notent) if(gx%bmperr.eq.0) then if(notent) then ! write(*,*)'Entering function: ',name1 ! entering a function may add new unentered functions ... last argument TRUE ! write(*,*)'3E Entering function 3: ',name1,len_trim(longline) ! lrot=0 ! call store_tpfun(name1,longline,lrot,.TRUE.) ! we are using the version which can read encrypted files call store_tpfun(name1,longline,lrot,rewindx) if(gx%bmperr.ne.0) then ! one may have error here if(.not.silent) write(kou,*)'Failed entering function: ',name1 goto 1000 endif if(ocv()) write(*,*)'Entered function: ',name1 nofunent=nofunent+1 else ! write(*,*)'3E referenced: ',trim(name1),nr,& ! tpfuns(nr)%rewind,rewindx if(tpfuns(nr)%rewind.eq.rewindx) then ! Function entered and referenced, check if duplicate! write(*,828)trim(name1),nl,rewindx 828 format('3E WARNING duplicate function ',a,' at line: ',2i5) tdbwarning=.TRUE. ! write(*,*)'3E tdbwarning set true 14' endif endif else ! ignore the function as it is not referenced. Reset error code gx%bmperr=0 endif else 830 continue nl=nl+1 read(21,110)line ! write(kou,101)'readtdb 2: ',nl,line(1:40) ! skip lines with a $ in first position if(line(1:1).eq.'$')goto 830 call replacetab(line,nl) call capson(line) longline=longline(1:jp)//line goto 810 endif goto 100 ! endif barafun !--------------------------------------------------------- ! We have now read all !-------------------------------------------------------- 1000 continue ! write(*,1111)totalpar,totalpar-notusedpar ! write(*,1111)totalpar,enteredpar,notusedpar if(manylonglines.gt.0) & write(*,*)'3E Number of lines exceeding 80 characters: ',manylonglines if(noparref.gt.0) write(*,1117)noparref 1117 format('There are ',i7,' parameters with no reference') write(*,1111)totalpar,enteredpar 1111 format(/'Out of ',i5,' model parameters ',i5,' have been entered'/) if(tdbwarning) then 1001 continue write(*,*) ! if silent set ignore warnings if(.not.silent) then do jss=1,nundefmpi write(*,1008)undefmpi(jss) 1008 format('3E *** WARNING unused model parameter identifier ',a,& ' in some phases') enddo write(kou,1003) 1003 format(/'There were warnings, check them carefully'/& 'and press RETURN if you wish to continue.') read(kiu,1004)ch1 1004 format(a) ! if(ch1.eq.'N') stop 'warnings reading database' ! if(ch1.ne.'Y') then ! write(kou,*)'Please answer Y or N' ! goto 1001 ! endif endif endif ! write(*,*)'3E At label 1000' if(buperr.ne.0 .or. gx%bmperr.ne.0) then if(gx%bmperr.eq.0) gx%bmperr=buperr if(.not.silent) write(kou,1002)gx%bmperr,nl 1002 format('Error ',i5,', occured at TDB file line ',i7) ! write(*,*)'Do you want to continue at your own risk anyway?' ! read(*,1008)ch1 !1008 format(a) ! if(ch1.eq.'Y') then ! write(*,*)'Now any kind of error may occur .... ' ! buperr=0 ! gx%bmperr=0 ! goto 100 ! endif endif !000000000000000000000000000000000000000000000000000000 ! After entering all parameters we should take care of ternary_extrapolations if(addternaryxpol) then ! write(*,'(a)')'3E Adding extrapolation methods',ntxp do zp=1,ntxp ! write(*,*)'3E call set_database_ternary: ',trim(ternaryxpol(zp)) ! this subroutine is in gtp3H.F90 is obsolete ! call set_database_ternary(ternaryxpol(zp)) ! this subroutine is in gtp3XQ.F90 call set_ternary_asymmetry(ternaryxpol(zp)) enddo ! else ! write(*,*)'3E No ternary extrapolations' endif !000000000000000000000000000000000000000000000000000000 ! no more read(21 ... close(21) ! read numbers, value after / is maximum ! endmember, interactions, property, ! tpfuns, composition sets, equilibria ! state variable functions, references, additions if(ocv()) write(*,1007)noofel,maxel,noofsp,maxsp,noofph,maxph,& noofem,100000,noofint,100000,noofprop,100000,& notpf(),maxtpf,highcs,2*maxph,eqfree-1,maxeq,& nsvfun,maxsvfun,reffree-1,maxrefs,addrecs,csfree-1 1007 format('Created records for elements, species, phases: ',2x,& 3(i4,'/',i4,1x)/& 'end members, interactions, properties: ',10x,& 3(i4,'/',i4,1x)/& 'TP-funs, max and free composition sets, equilibria: ',10x,& 3(i4,'/',i4,1x)/& 'state variable functions, references, additions: ',& 3(i4,'/',i4,1x)/) ! a special warning message as it may be scrolled away by all references ! write(*,*)'Any warnings?',tdbwarning ! nonzero multiuse will prompt a warning in the monitor firsteq%multiuse=0 if(gx%bmperr.eq.0 .and. tdbwarning) firsteq%multiuse=-1 return !-------------------------------------------------------------------------- ! errors and rewinds 1010 continue if(.not.silent) write(kou,*)'I/O error opening file: ',gx%bmperr return !----------------------------------------------------- ! end of file found, act differently if reading functions 2000 continue rewindx=rewindx+1 if(only_typedefs) then ! new feature, read only_typdes at first run, then set it false only_typedefs=.FALSE. ! write(*,*)'3E Finished reading all TYPE_DEFS, now the rest of the file' gx%bmperr=0 rewind(21) nl=0 goto 100 endif rewindfile: if(dodis.eq.0 .and. disparttc.gt.0) then ! rewind to read disordred parts if(.not.silent) write(kou,1220) 1220 format('3E Rewinding to read disordered part of phases') rewind(21) dodis=1 nl=0 goto 100 elseif(.not.onlyfun) then ! rewind to read referenced functions and references !! dodis=2 rewind(21) onlyfun=.TRUE. nofunent=0 ! write(*,2002)gx%bmperr 2002 format('Found end-of-file, rewind to find functions',i5) nl=0 goto 100 ! elseif(encrypted.gt.0) then ! REDUNDANT CODE when testing using 2 files for encrypted TDB files ! on encrypted TDB files the FUNCTION and PARAMETER keywords are ! in a separate file. When onlyfun is TRUE then we swich to this file ! close(21) ! write(*,*)'3E closing TDB file to read encrypted part' ! call readencrypt(encryptline,nr) ! nr is missing functions ... ! if(gx%bmperr.eq.0) then ! if(nr.gt.0) then ! write(*,*)'3E read encrypted part, missing functions: ',nr ! endif ! else ! write(*,*)'3E error reading encrypted part',gx%bmperr ! endif ! return elseif(nofunent.gt.0) then ! rewind if there were functions entered last time rewind(21) norew=norew+1 ! write(*,*)'Found functions: ',nofunent,' rewinding again',norew,gx%bmperr ! if(newfun.gt.0) then ! write(*,*)'Read ',newfun+nfail,' functions, entered ',newfun,& ! ' rewinding ',norew ! newfun=0 nofunent=0 nl=0 goto 100 else ! check if there are any unentered functions call list_unentered_funs(kou,nr) if(nr.gt.0) then if(.not.silent) write(kou,*)'3E Number of missing function: ',nr gx%bmperr=4186 endif ! check if any function not entered onlyfun=.FALSE. endif rewindfile goto 1000 ! end of file while looking for ! terminating a keyword 2200 continue if(.not.silent) write(kou,2210)nl,longline(1:72) 2210 format('End of file at ',i5,' looking for end of keyword:'/a) gx%bmperr=4316 goto 1000 end subroutine readtdb !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine readtdbsilent !\begin{verbatim} subroutine readtdbsilent !\end{verbatim} %+ globaldata%status=ibset(globaldata%status,GSSILENT) return end subroutine readtdbsilent !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine any_disordered_part !\begin{verbatim} subroutine any_disordered_part(lin,ndisph,dispartph,ordpartph,orddistyp) ! reading data from a TDB/PDB file with selection of elements ! extract only TYPE_DEFS for order/disorder !------------------------------------------------------- ! Not all TYPE_DEFS implemented !------------------------------------------------------- implicit none integer lin,ndisph character dispartph(*)*(*),ordpartph(*)*(*) integer orddistyp(*) !\end{verbatim} character line*128,longline*1024,phase*24 integer ip,jp,zp ndisph=0 loop1: do while(.true.) read(lin,100,end=900)line 100 format(a) ip=1 if(eolch(line,ip)) cycle loop1 if(line(ip:ip).eq.'$') cycle loop1 typedef: if(line(ip:ip+7).eq.'TYPE_DEF') then ! search for ! meaning end of keyword longline=line(ip:) ip=len_trim(longline) loop2: do while(longline(ip:ip).ne.'!') read(lin,100,end=900)line longline(ip+1:)=line ip=len_trim(longline) enddo loop2 ! write(*,*)'3E type_def 1: ',longline(1:ip) ! the important part is "GES" followed by "A_P_D" (or AMEND_PHASE_DEFINITION) ! followed by phase name and followed by "DIS_PART" or "NEVer" and a phase name jp=index(longline,' GES ') if(jp.le.0) exit typedef ! below is a clumsy way to extract phase names for ordered/disordered parts ! skip the first item after "GES" (should be AMEND_PHASE_DESCRIPTION or abbrev zp=jp+4 if(eolch(longline,zp)) then exit typedef endif ! skip to next item, if none loop, else extract next item jp=index(longline(zp:),' ') if(zp.le.0) exit typedef zp=zp+jp ! write(*,*)'3E zp1: ',trim(longline),zp if(eolch(longline,zp)) then exit typedef endif phase=longline(zp:) jp=index(phase,' ') phase(jp:)=' ' ! this should be a phase name, maybe the ordered part ! write(*,*)'3E phase name? ',trim(phase) ! check what comes after phase name, ! the important is "DISORDERED_PART" or "NEVER_DISORDERED" or abbreviations ip=zp+jp ! write(*,*)'3E after phase: "',trim(longline(ip:)),'"' if(eolch(longline,ip)) exit typedef if(longline(ip:ip+2).eq.'NEV') then ndisph=ndisph+1 orddistyp(ndisph)=1 elseif(longline(ip:ip+2).eq.'DIS') then ndisph=ndisph+1 orddistyp(ndisph)=-1 else exit typedef endif ! write(*,'(a,a,2i3)')'3E zp2: ',trim(longline),orddistyp(ndisph),ip ! find space after NEVER or DIS_PART jp=ip+index(longline(ip:),' ') ! disordered phase name should be now ! write(*,*)'3E after dis/nev: "',trim(longline(ip:)),'"',jp if(eolch(longline,jp)) then write(*,'(a/a)')'3E no disordered phase! ',trim(longline) exit typedef endif dispartph(ndisph)=longline(jp:) ! name terminated by space, comma or ! ip=index(dispartph(ndisph),',') if(ip.gt.0) dispartph(ndisph)(ip:)=' ' ip=index(dispartph(ndisph),'!') if(ip.gt.0) dispartph(ndisph)(ip:)=' ' ! ip=index(dispartph,' ') ! dispartph(ndisph)(ip:)=' ' ordpartph(ndisph)=phase ! write(*,'(a,i2,5a,i3)')'3E ord/dis: ',ndisph,' "',& ! trim(ordpartph(ndisph)),'" + "',trim(dispartph(ndisph)),'"',& ! orddistyp(ndisph) endif typedef enddo loop1 ! eof 900 continue rewind(lin) 1000 continue return end subroutine any_disordered_part !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\addtotable subroutine checkdb2 !\begin{verbatim} subroutine checkdb2(filename,ext,nel,selel) ! checking a TDB and XTDB file exists and return the elements ! It also writes 15 lines from any "DATABASE_INFO" in the file implicit none integer nel character filename*(*),ext*(*),selel(*)*2 !\end{verbatim} character line*256,ext2*4 integer ipp,nl,kk,dbinfo logical cl ! ext2=ext dbinfo=0 call capson(ext2) ! write(*,*)'3E extract elements: "',trim(filename),'" and "',ext if(.not.(index(filename,ext).gt.0 & .or. index(filename,ext2).gt.0)) then ! no extention provided filename(len_trim(filename)+1:)=ext2 endif nel=0 #ifdef entrypopt write(*,*)'PM: no listing of elements in encrypted databases' nel=-1 goto 1000 #endif ! there is a need to extract elements also from encrypted files open(21,file=filename,access='sequential',form='formatted',& err=1010,iostat=gx%bmperr,status='old') ! if first line of file is "$OCVERSION ..." the text is displayed once read(21,110)line if(line(1:11).eq.'$OCVERSION ') then write(kou,117)trim(line(12:)) 117 format(/'TDB file id: ',a/) endif rewind(21) nl=0 write(*,*)'3E Database file extention is: "',ext,'"' if(ext.eq.'.xtdb' .or. ext.eq.'.XTDB') then write(*,*)'3E *** WOW *** Reading elements from XTDB file' ! extracting elements from XTDB file cl=.FALSE. 200 continue read(21,110,end=2000)line nl=nl+1 if(cl) then ! if cl is TRUE then skip all lines until !> if(index(line,'-->').gt.0) then cl=.FALSE. endif goto 200 elseif(index(line,'').gt.0) cl=.FALSE. goto 200 endif if(index(line,'ceq%phase_varres(lokcs) ! this is to check how the ordered phase constituents ! ip=0 ! do i2=1,phlista(lokph)%noofsubl ! write(*,*)'3EA: ',lokph,(phlista(lokph)%constitlist(ip+nn),& ! nn=1,phlista(lokph)%nooffr(i2)) ! ip=ip+phlista(lokph)%nooffr(i2) ! i3=i3*phlista(lokph)%nooffr(i2) ! enddo ! write(*,*)'3E number of endmembers 1: ',lokph,i3 disvarres=>ceq%phase_varres(varres%disfra%varreslink) ! write(*,*)'3ZZ: ',disvarres%sites(1),disvarres%sites(2) ! there must be a disfra record, ! the number of sublattices and constituents in each sublattice found there ip=0 i3=1 nsubl=varres%disfra%ndd do i2=1,varres%disfra%ndd ! write(*,*)'3ZB: ',varres%disfra%nooffr(2),& ! (varres%disfra%splink(nn+ip),& ! nn=1,varres%disfra%nooffr(i2)) ! ip=ip+varres%disfra%nooffr(i2) i3=i3*varres%disfra%nooffr(i2) enddo ! write(*,*)'3E number of endmembers 2: ',lokph,i3 disfactor=varres%disfra%fsites ! write(*,*)'3ZC factor: ',disfactor,varres%disfra%latd else nsubl=phlista(lokph)%noofsubl do i2=1,phlista(lokph)%noofsubl i3=i3*phlista(lokph)%nooffr(i2) enddo disfactor=one endif ! write(*,*)'3E nonsuspended phase constituents: ',i1,i3 ncon(i1)=i3 ! for check at the end endx(i1)=ncon(i1) endif enddo phloop1 ! now can we write the line with overall phase information ... suck ip=1 noelel=noofel+nelectrons write(text(ip:),110)noelel ip=len_trim(text)+1 ! number of mixture phases and for each mixture the number of endmembers ! if nogas is TRUE add a phase with zero endmembers first if(nogas) then write(text(ip:),109)nphmix+1,0 ip=len_trim(text)+1 109 format(2i4) else write(text(ip:),110)nphmix ip=len_trim(text)+1 110 format(i4) 112 format(i5) endif ph1: do i1=1,noofph lokph=phasetuple(i1)%lokph if(ceq%phase_varres(phlista(lokph)%linktocs(1))%phstate.eq.PHSUS) then ! write(*,*)'3E skipping phase loop 2: ',phlista(lokph)%name cycle ph1 endif ! Write the number of constituents in mixures (including gas if present) ! write(*,*)'3E mixture constituents: ',i1,ncon(i1) if(ncon(i1).gt.0) then write(text(ip:),112)ncon(i1) ip=len_trim(text)+1 if(ip.gt.72) then ! write(lut,100)trim(text) ! According to Ted write(lut,99)trim(text) ip=1 endif endif enddo ph1 ! finally the number of stoichiometric phases using i5 write(text(ip:),112)nphstoi ! NOTE format 100 adds an initial space on the line ! write(lut,100)trim(text) ! According to Ted write(lut,99)trim(text) ! write(*,*)'3E elements mm: ',trim(text) !------------------ system components including electrons for charged phases ip=1 text=' ' lcase=ichar('a')-ichar('A') do i1=1,noofel ! second letter lower case elsym=ellista(elements(i1))%symbol if(elsym(2:2).ne.' ') then elsym(2:2)=char(ichar(elsym(2:2))+lcase) endif text(ip:)=elsym ip=ip+25 if(ip.gt.51) then write(lut,100)trim(text) ip=1 text=' ' endif enddo ! electrons nnn=1 do i1=1,noofph if(estoi(i1).lt.0) then if(phchargedx(nnn).eq.i1) then text(ip:)='e('//trim(phcharged(nnn))//')' nnn=nnn+1 else lokph=phasetuple(i1)%lokph text(ip:)='e('//trim(phlista(lokph)%name)//')' endif ip=ip+25 if(ip.gt.51) then write(lut,100)trim(text) ip=1 text=' ' endif endif enddo if(ip.gt.1) then write(lut,100)trim(text) endif ! allocate an array for constituent stoichiometry ! if(noofel+nelectrons.gt.50) & if(noelel.gt.50) & write(*,*)'Allocating large constituent array: ',noelel allocate(constcomp(noelel)) !----------------------------- system component mass, electrons 0.00054858??? ip=1 text=' ' do i1=1,noofel write(text(ip:),130)ellista(elements(i1))%mass 130 format(F25.8) ip=ip+25 if(ip.gt.51) then write(lut,100)trim(text) ip=1 text=' ' endif enddo ! electrons do i1=1,nelectrons write(text(ip:),130)5.4858D-4 ip=ip+25 if(ip.gt.51) then write(lut,100)trim(text) ip=1 text=' ' endif enddo if(ip.gt.1) then write(lut,100)trim(text) endif !---------------------------------T powers, always the same line ! if(npows.eq.9) then ! 10 here are the allowed powers: 0 1 100 2 3 -1 ; 7 -9 -2 any any ! 1 2 3 4 5 6 7 8 9 10 11 ! Those after the ; are special. 100 means T*ln(T) if(npows.le.15) then ! the first 7 digits should be 9 1..6 ! write(lut,140)trim(powers(36:)) ! write(lut,140)trim(powers(36:)) !140 format(' 9 1 2 3 4 5 6',a) ! it does not seem to matter what is on these lines ... write(lut,140) write(lut,140) !140 format(' 6 1 2 3 4 5 6') ! According to Ted 140 format('6 1 2 3 4 5 6 ') else write(*,*)'3E too many different T powers: ',npows stop endif !-------------------------------------- end of header section ! SOLGASMIX phase names must start with 4 unique letters, when TDB files ! has phases with same first 4 characters add a prefix phunique='P000' ! data for mixtures ! First the endmembers mphstoi=1 phases1: do i1=1,noofph lokph=phasetuple(i1)%lokph skipfc=.false. if(ceq%phase_varres(phlista(lokph)%linktocs(1))%phstate.eq.PHSUS) then ! skip phases with suspended default composition set ! write(*,*)'3E skipping phase loop 3: ',phlista(lokph)%name cycle phases1 endif ! havemag nonzero if there are magnetic parameters ! magloop set to TRUE to list magnetic excess parameters havemag=0 magloop=.FALSE. if(phlista(lokph)%nooffs.gt.1) then ! skip first ordered fraction set skipfc=.true. endif if(i1.eq.phstoi(mphstoi)) then ! write(*,*)'3E skipping stoichiometric ',trim(phlista(lokph)%name) mphstoi=mphstoi+1 cycle phases1 ! else ! write(*,*)'3E parameters for mixture ',trim(phlista(lokph)%name) endif lokcs=phlista(lokph)%linktocs(1) varres=>ceq%phase_varres(lokcs) ! if disordered fraction set, set varres to point to disordered phase_varres if(skipfc) then varres=>ceq%phase_varres(lokcs) fedup=>varres ! write(*,*)'3E disordered part: ',varres%disfra%ndd varres=>ceq%phase_varres(varres%disfra%varreslink) endif nsubl=1 ionliq=.false. ! phase model ane expected endmembers ! we calculate the number of endmembers, end1mem is needed for DAT file ! end2mem is actual. Error is not the same end1mem=0 if(btest(phlista(lokph)%status1,PHIONLIQ)) then model='SUBI' nsubl=2 ionliq=.true. ! there can just be one ionic liquid ... ?? allocate(constcompiliq(noelel)) elseif(btest(phlista(lokph)%status1,PHID)) then model='IDMX' else ! there are phases with other bits which will not work but they are rarely set ! now for sublattices ... nsubl=phlista(lokph)%noofsubl offset=nsubl if(btest(phlista(lokph)%status1,PHFORD)) then ! NOTE varres is the disordered fraction set nsubl=size(varres%sites) ! write(*,141)trim(phlista(lokph)%name),nsubl 141 format('Phase ',a,' has FCC permutated parameters, ignore ordered',& i3) elseif(btest(phlista(lokph)%status1,PHBORD)) then nsubl=size(varres%sites) ! write(*,142)trim(phlista(lokph)%name),nsubl 142 format('Phase ',a,' has BCC permutated parameters, ignore ordered',& i3) elseif(btest(phlista(lokph)%status1,PHMFS)) then nsubl=size(varres%sites) ! write(*,143)trim(phlista(lokph)%name),nsubl 143 format('Phase ',a,' has disorded fraction sets, ignore ordered',i3) endif if(nsubl.gt.1) then model='SUBL' else model='RKMP' endif ! fill values in xnooffr if(skipfc) then xnooffr=0 do i2=1,nsubl xnooffr(i2)=xnooffr(i2-1)+fedup%disfra%nooffr(i2) enddo xnooffr(0)=1 else xnooffr=0 do i2=1,nsubl xnooffr(i2)=xnooffr(i2-1)+phlista(lokph)%nooffr(i2) enddo xnooffr(0)=1 endif ! write(*,*)'3E xnooffr: ',(xnooffr(i2),i2=0,nsubl) ! magnetism? addrec=>phlista(lokph)%additions lastadd: do while(associated(addrec)) ! no need to increment CHTD except for magnetism ! write(*,*)'3E additions?: ',phlista(lokph)%name,addrec%type if(addrec%type.eq.1) then aff=addrec%aff havemag=3 model(5:5)='M' write(*,*)'3E magnetic phase 2: ',phlista(lokph)%name elseif(addrec%type.ne.7) then ! ignore addrec%type=7 which is volume model write(*,*)'3E WARNING addition type: ',addrec%type,' ignored' endif addrec=>addrec%nextadd enddo lastadd endif ! prepare a dummy prefix phdummy=phlista(lokph)%name(1:4) jp=0 name2: do i3=1,noofph if(i3.ne.lokph .and. phdummy.eq.phlista(i3)%name(1:4)) then ! write(*,*)'Duplicate name',i3,lokph,phdummy,' ? ',& ! phlista(i3)%name(1:4) jp=1; exit name2 endif enddo name2 if(jp.gt.0) then call incunique(phunique) phdummy=phunique ! write(*,*)'3E prefixing TDB phase name ',& ! phdummy//'_'//trim(phlista(lokph)%name),i1,lokph else phdummy=' ' endif ! According to Ted if(phdummy(1:1).eq.' ') then write(*,180)trim(phlista(lokph)%name),trim(model),& nsubl,ncon(i1),disfactor 180 format('3E mixture: ',a,' with model ',a,2i4,F12.4,a) write(lut,201)phlista(lokph)%name,nsubl,trim(model) else warnings=warnings+1 write(*,180)phdummy//'_'//trim(phlista(lokph)%name),trim(model),& nsubl,ncon(i1),disfactor,' with name change' write(lut,201)phdummy//'_'//phlista(lokph)%name,nsubl,trim(model) endif 201 format(a,5x,'= MIXTURE PHASE =',i3/a) if(havemag.ne.0) then if(aff.eq.one) then ! Inden BCC magnetism write(lut,202)-aff,0.4 else ! Inden FCC, HCP and other structures write(lut,202)-one/aff,0.28 endif 202 format(F8.6,2x,F10.6) endif !-------------------- we must repeat the endmember loop below for interactions 205 continue missend(1)=1 do ip=2,nsubl missend(ip)=missend(ip-1)+phlista(lokph)%nooffr(ip-1) enddo endmember=>phlista(lokph)%ordered if(associated(phlista(lokph)%disordered)) then ! skip writing ordered part, nsubl set above!! ! if(.not.skipfc) then ! write(*,*)'3E We have disorderd fraction set but skipfc not set!' ! else ! write(*,*)'3E Skipfc set correctly',nsubl ! endif write(*,*)'BEWARE skipping ordered part of :',& trim(phlista(lokph)%name),nsubl,offset endmember=>phlista(lokph)%disordered endif ! write(*,*)'3E first the endmembers',nsubl ! endmember parameters, when they are done loop for excess parameters excessparam=.FALSE. !=========================================================================== !================================== big loop for endmembers and interactions ! when all endmembers written then set excesspara=.true. and jump back here 207 continue if(ionliq) then nextcation=>endmember%nextem cation=endmember%fraclinks(1,1) if(.not.excessparam) then ! check if there is a missing endmember, skip wildcard parameters if(cation.ne.-99 .and. anion.ne.-99) then if(cation.ne.missend(1) .or. & endmember%fraclinks(2,1).ne.missend(2)) then write(*,*)'3E first endmember missing for liquid: ',& missend(1),missend(2) stop 'Check if inonic liquid has all endmember parameters' endif endif endif ! NOTE there can be missing endmembers!! ! write(*,*)'3E firstcation: ',cation firstcation=cation iliqwild=.false. if(firstcation.eq.-99) then iliqwild=.true. else ccc=one endif endif lokcs=phlista(lokph)%linktocs(1) varres=>ceq%phase_varres(lokcs) !-------------------------------------------------------------------- ! here starts the loop for all parameters ! i1 is the index of this phase in the SOLGASMIX order allend: do while(associated(endmember)) ! we have to generate two lines by extracting the endmember and constituents ! we may have to do this loop several times for the same phase to list ! the endmembers in correct order, at least for the ionic liquid phase ! For the ionic liquid all endmembers with the same cation must come together constcomp=zero if(ionliq) constcompiliq=zero constext=' ' text=' ' ip=1 valency=zero wildcard=.false. if(.not.ionliq) then !----------------------------------------------- ! for all other mixtures except ionic liquid ... note there are some tests ! of ionliq here as this loop originally was also for ionic liquids ... sloop1: do isubl=1,nsubl ! this is the loop for the constituents in sublattices if(skipfc) then ! We should skip the ordered sublattices ! for isubl=2 we should use the constituents in the last sublattce isp=endmember%fraclinks(isubl,1) ! write(*,*)'3E constituent 1: ',isp,offset else isp=endmember%fraclinks(isubl,1) endif intconst(isubl)=isp if(isp.eq.-99) then ! this means wildcard in this sublattice wildcard=.true. constext(ip:)='*:' ip=ip+2 ! if(ionliq .and. wildcard .and. isubl.eq.1) then ! iliqwild=.true. ! wildcard=.false. ! endif ! Hm we should add stoichiometric factors for all constituents in this subl ! For ionliq this means neutrals on sublattice 2 !>> QUESTION >> the DAT format repeats all neutrals for all cations !>>>>>>>>>>>>>> with the stoichiometry of the cation !!! ! if(ionliq) valency(1)=one cycle sloop1 endif if(skipfc) then ! which index should be used to find the constituent in last sublattice ! write(*,*)'3E disordered species: ',isp ! nn=phlista(lokph)%constitlist(isp) i3=firsteq%phase_varres(lokcs)%disfra%splink(isp) ! write(*,*)'3E disordered species: ',isp,nn,i3 isp=i3 ! write(*,*)'3E species: ',splista(isp)%symbol else isp=phlista(lokph)%constitlist(isp) endif if(btest(splista(isp)%status,SPVA)) then valency(isubl)=zero ! according to the example I have the stoichiometry should be 1 for (cation:VA) if(ionliq) valency(2)=-one else valency(isubl)=splista(isp)%charge if(abs(valency(isubl)).lt.1.0D-6) valency(isubl)=zero endif ! here we cannot have ionic liquid here! ! if(ionliq .and. isubl.eq.2) then ! write(*,*)'3E we cannot have an ionic liquid here!' ! do i3=1,noofel ! constcomp(i3)=-constcomp(i3)*valency(2) ! enddo ! elseif(estoi(i1).lt.0) then if(estoi(i1).lt.0) then ! charged sublattice phase. Electronic stoichiometry should be positive! ! constcomp(-estoi(i1))=constcomp(-estoi(i1))+& constcomp(-estoi(i1))=constcomp(-estoi(i1))-& valency(isubl)*varres%sites(isubl) ! write(*,901)'3E e-stoik:',isubl,-estoi(i1),& ! valency(isubl),varres%sites(isubl),constcomp(-estoi(i1)) 901 format(a,2i3,3F10.2) endif call lower_case_species_name(constext,ip,isp) constext(ip:ip+1)=':' ip=ip+1 do i2=1,splista(isp)%noofel ! this is a loop for the components of the endmember constituents i3=ellista(splista(isp)%ellinks(i2))%alphaindex if(i3.eq.0) then ! skip vacancies continue elseif(ionliq) then write(*,*)'#C we should never be here if ionic liquid 2' if(isubl.eq.1) then constcomp(i3)=constcomp(i3)+& splista(isp)%stoichiometry(i2) else constcomp(i3)=constcomp(i3)+& splista(isp)%stoichiometry(i2)*valency(1) endif else ! ! here the stoichiometry of the endmember is added together ! if(skipfc) then constcomp(i3)=constcomp(i3)+& splista(isp)%stoichiometry(i2)*& varres%disfra%dsites(isubl) else constcomp(i3)=constcomp(i3)+& splista(isp)%stoichiometry(i2)*varres%sites(isubl) endif endif enddo enddo sloop1 ! for endmembers check that there is no missing endmember missend1: if(.not.excessparam) then www=0 donotincrement=0 miss7: do i2=1,nsubl if(intconst(i2).eq.-99) then ! if we find a wildcard endmember do not increment missend !!! www=0; goto 1814 endif thisend(i2)=missend(i2) if(intconst(i2).ne.missend(i2)) then www=77 ! this endmember is not the expected one. There can be several missing ! but we should expect the one following. That means we should reset ! constituents expected in higher sublattices .... missend(i2)=intconst(i2)+1 if(donotincrement.eq.0) donotincrement=i2 endif enddo miss7 if(www.ne.0) then write(*,48)'3E *** Phase ',trim(phlista(lokph)%name),& ' missing endmember: ',(thisend(i2),i2=1,nsubl) ! write(*,49)'3E found endmember: ',(intconst(i2),i2=1,nsubl) warnings=warnings+1 48 format(a,a,a,9(1x,i3,':')) 49 format(a,19x,9(1x,i3,':')) endif ! increment constituents from the end for next test ! To handle also disordered fraction sets use varres pointer ! xnooffr(0) initially 1, xnooffr(j) is sum of constituents to and including j if(donotincrement.ne.nsubl) missend(nsubl)=missend(nsubl)+1 do i2=nsubl,2,-1 if(missend(i2).gt.xnooffr(i2)) then missend(i2)=xnooffr(i2-1)+1 missend(i2-1)=missend(i2-1)+1 endif enddo 1814 continue ! write(*,49)'3E expecting: ',(missend(i2),i2=1,nsubl) endif missend1 else !-------------------------------------------------------------------- ! This is exclusivly for inonic liquids, loop second sublattice first ... ! this is the loop for the constituents in sublattices ! Hm we should add stoichiometric factors for all constituents in this subl ! write(*,*)'3E we are here 1 ',excessparam,firstcation if(.not.iliqwild) then isp=phlista(lokph)%constitlist(cation) intconst(1)=cation valency(1)=splista(isp)%charge cationval=valency(1) do i2=1,splista(isp)%noofel ! this is a loop for the components of the endmember constituents i3=ellista(splista(isp)%ellinks(i2))%alphaindex if(i3.eq.0) then ! skip vacancies continue else constcomp(i3)=constcomp(i3)+& splista(isp)%stoichiometry(i2) endif enddo call lower_case_species_name(constext,ip,isp) constext(ip:ip+1)=':' ip=ip+1 else valency(1)=one endif ! what about neutrals? anion=endmember%fraclinks(2,1) intconst(2)=anion isp=phlista(lokph)%constitlist(anion) missend2: if(.not.excessparam) then if(cation.ne.missend(1) .or. anion.ne.missend(2)) then write(*,47)'3E **** liquid missing endmember: ',& missend(1),missend(2) 47 format(a,2i5,5x,2i5) stop 'Missing endmember in ionic liquid' warnings=warnings+1 ! avoid having several errors due to a missing cation:anion pair missend(1)=cation endif ! Hm, cation should not be incremented here ... ! missend(1)=cation+1 missend(2)=anion+1 if(anion.eq.phlista(lokph)%tnooffr) then missend(1)=missend(1)+1 missend(2)=phlista(lokph)%nooffr(1)+1 endif endif missend2 if(btest(splista(isp)%status,SPVA)) then ! according to the example I have the stoichiometry should be 1 for (cation:VA) valency(2)=-one else valency(2)=splista(isp)%charge if(abs(valency(2)).lt.1.0D-6) valency(2)=zero endif ! This is values in the stoichiometry line .... do i3=1,noofel constcomp(i3)=-constcomp(i3)*valency(2) enddo call lower_case_species_name(constext,ip,isp) constext(ip:ip+1)=':' ip=ip+1 do i2=1,splista(isp)%noofel ! this is a loop for the components of the endmember constituents i3=ellista(splista(isp)%ellinks(i2))%alphaindex if(i3.eq.0) then ! skip vacancies continue elseif(ionliq .and. iliqwild) then ! For neutrals in ionic liquid we must multiply with ccc (the cation valency) constcomp(i3)=constcomp(i3)+& splista(isp)%stoichiometry(i2)*valency(1)*ccc else constcomp(i3)=constcomp(i3)+& splista(isp)%stoichiometry(i2)*valency(1) endif enddo ! write(*,917)'3E Ionliq endmember: ',constext(1:ip-2),iliqwild,ccc,& ! valency(2),(constcomp(i3),i3=1,noofel) 917 format(a,a,L3,2F10.2/10F7.3) !------------------ end special ionic liquid endif ! write(*,*)'3E we are here 2 ' endorexcess: if(excessparam) then ! we can have several excess parameters for each endmember intparam=>endmember%intpointer ilevel=0 ! write(*,*)'3E we are here 3 ' intree: do while(associated(intparam)) ! we must save intparam%nextlink to be able to follow the parameter tree ilevel=ilevel+1 saveint(ilevel)%intlink=>intparam%nextlink isp=intparam%fraclink(1) intconst(nsubl+ilevel)=isp isp=phlista(lokph)%constitlist(isp) property=>intparam%propointer ! Check if endmember contains wildcard if(wildcard .and. associated(property)) then write(*,903)'3E Expanding wildcard interaction: ',& trim(phlista(lokph)%name),trim(constext),& (intconst(k1),k1=1,nsubl+ilevel) 903 format(a,a,',',a,2x,6i4) ! we should make a loop fof all constituents in sublattice with wildcard ! and write the same parameter for all. There can be several wildcards!! ! like G(C1_MO2,Zr+2:*:*), where *=(O-2,Va) in both cases ! wildloop expanded constituent sets returned in iset, allocated inside call expand_wildcards(intconst,nsubl+ilevel,& wildloop,iset,lokph) ! wildloop=1 ! replace current intconst with values in iset and loop below back to 310 do k1=1,nsubl+ilevel intconsty(k1)=intconst(k1) intconst(k1)=iset(k1,wildloop) enddo ! write(*,324)'3E wildloop1: ',wildloop,& ! (intconst(k1),k1=1,nsubl+ilevel) savedproperty=>property else wildloop=0 endif ! return here with new set of constituents in intconst if wildloop not zero 310 continue maxideg=-1 extcpar=zero; exbmpar=zero intproploop: do while(associated(property)) ! Check type of excess parameter and what kind to be listed .... if(magloop) then if(property%proptype.eq.2) then ! this is Curie/Neel temperature do ideg=0,property%degree f1=property%degreelink(ideg) if(f1.gt.0) then extcpar(ideg)=tpfc(f1)%cfun%coefs(1,1) else write(*,315)' 3E zero excess TC parameter: ',& trim(tpfuns(property%degreelink(property%degree))%symbol) ! trim(phlista(lokph)%name),ideg,ilevel 315 format(a,a,5i5) extcpar(ideg)=zero endif enddo ! write(*,*)'3E excess TC: ',f1,partc paratyp=17 if(ideg.gt.maxideg) maxideg=ideg elseif(property%proptype.eq.3) then ! This is BMAGN do ideg=0,property%degree f1=property%degreelink(ideg) if(f1.gt.0) then exbmpar(ideg)=tpfc(f1)%cfun%coefs(1,1) else write(*,315)' 3E zero excess BM parameter: ',& trim(tpfuns(property%degreelink(property%degree))%symbol) exbmpar(ideg)=zero endif enddo paratyp=17 if(ideg.gt.maxideg) maxideg=ideg endif property=>property%nextpr cycle intproploop elseif(property%proptype.ne.1) then ! we should have a loop here also as G not always first parameter continue endif ! write the identification of the excess parameter .... ! The list of constituents (in intconst) arranged in ascending order call intsort(intconst,nsubl+ilevel,intconstx) ! write interaction level (2=binary, 3=ternary ...) ! Then constituent indices in acending order (maybe rearrange intconst) ! finally the degree (number of Redlich-Kister parameters) ! write(*,907)'3E solgasorder: ',nsubl+ilevel,& ! (intconstx(k1),k1=1,nsubl+ilevel),property%degree+1 ! write an excess parameter write(lut,208)nsubl+ilevel,& (intconstx(k1),k1=1,nsubl+ilevel),property%degree+1 907 format(a,10i5) 208 format(i5/10i5) ! write the expression of the excess parameter .... (Redlich-Kister ??) alldegs: do ideg=0,property%degree f1=property%degreelink(ideg) ! excess parameters has just the coefficients ! call list_tpascoef(lut,text,f1,npows,tpfc) if(f1.lt.1) then ! This means one RK parameter is zero!! L(FCC,NB:C,Va,1) is zero !!1 ! write(*,*)'3E No function?: ',f1,ideg,property%degree write(*,*)'3E zero RK paramameter: ',& tpfuns(property%degreelink(property%degree))%symbol write(lut,307)0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0 307 format(6(1x,G15.8)) cycle alldegs endif if(tpfc(f1)%nranges.gt.1) then write(*,*)'3E excess parameter with T-ranges!' stop endif ! This gave compiler error on MacOS 10.13 ??? GNU Fortran 5.2 ... ! write(lut,311)(tpfc(f1)%cfun%coefs(jj,1),jj=1,6) ! write another excess parameter. What about magnetism and paratype??? write(lut,311)tpfc(f1)%cfun%coefs(1,1),& tpfc(f1)%cfun%coefs(2,1),tpfc(f1)%cfun%coefs(3,1),& tpfc(f1)%cfun%coefs(4,1),tpfc(f1)%cfun%coefs(5,1),& tpfc(f1)%cfun%coefs(6,1) 311 format(6(1x,G15.8)) enddo alldegs property=>property%nextpr enddo intproploop ! if(wildloop.gt.0) write(*,*)'3E wildloop2: ',wildloop ! magnetic excess parameter not written above but here ! write(*,*)'3E exit intproploop',magloop,paratyp,& ! associated(property) if(magloop .and. paratyp.eq.17) then paratyp=4 call intsort(intconst,nsubl+ilevel,intconstx) ! write(*,907)'3E solgasorder: ',nsubl+ilevel,& ! (intconstx(k1),k1=1,nsubl+ilevel),1 write(lut,208)nsubl+ilevel,& (intconstx(k1),k1=1,nsubl+ilevel),maxideg write(lut,323)(extcpar(ideg),exbmpar(ideg),ideg=0,maxideg-1) 323 format(2F12.3) ! end of output of magnetic excess parameter endif ! If this is a wildcard parameter maybe it should be written several times if(wildcard) then if(wildloop.gt.1) then wildloop=wildloop-1 do k1=1,nsubl+ilevel intconst(k1)=iset(k1,wildloop) enddo ! write(*,324)'3E next expanded: ',wildloop,& ! (intconst(k1),k1=1,nsubl+ilevel) 324 format(a,i3,2x,10i4) property=>savedproperty goto 310 else ! deallocate iset and restore intconst as we may have higher interactions ... deallocate(iset) do k1=1,nsubl+ilevel intconst(k1)=intconsty(k1) enddo endif endif ! Take link to higher intparam=>intparam%highlink do while(ilevel.gt.0 .and. .not.associated(intparam)) ! go down the saved links intparam=>saveint(ilevel)%intlink ilevel=ilevel-1 enddo enddo intree else ! here we are writing endmembers, we have generated the endmember symbol, ! for the parameters follow the property link ! write(*,*)'3E We are here 4' property=>endmember%propointer if(wildcard .and. associated(property)) then write(*,*)'3E ERROR! Endmember parameter with wildcard: ',& trim(phlista(lokph)%name),',',trim(constext) endif paratyp=4 partc=zero; parbm=zero ! return here if we find a magnetic property first 333 continue propem: if(associated(property)) then ! some endmembers may not have a property record!! if(property%proptype.ne.1) then ! for magnetism we can have proptype 1 and 2 (TC and BMAGN) ! They can be before the G parameter in the TDB file. ! write(*,*)'3E magnetic 1: ',trim(phlista(lokph)%name),& ! havemag,property%proptype,paratyp if(havemag.ne.0) then if(property%proptype.eq.2) then ! this is Curie/Neel temperature f1=property%degreelink(0) partc=tpfc(f1)%cfun%coefs(1,1) ! write(*,*)'3E endmember TC: ',f1,partc paratyp=16 elseif(property%proptype.eq.3) then ! This is BMAGN f1=property%degreelink(0) parbm=tpfc(f1)%cfun%coefs(1,1) ! write(*,*)'3E endmember BMAGN: ',f1,parbm paratyp=16 else write(*,*)'3E skipping magnetic endmember property: ',& property%proptype exit propem endif else write(*,*)'3E unknown endmember property: ',& property%proptype exit propem endif if(associated(property%nextpr)) then property=>property%nextpr goto 333 endif ! else ! paratyp=4 endif ! this line with the stoichiometry of the endmember should be written ! together with the type of coefficients and number of ranges ! it may require several lines write(text,210)constcomp ! THIS IS THE STOICHIMETRY OF THE ENDMEMBER, with 6 decimal digits ! If this format is changed the output routine list_tpascoef must be changed! !210 format(60(1x,F11.6)) ! ERNESTO GEIGER complained it did not work ... this is stoichiometry format 210 format(60(1x,F7.2)) ! Check if any value in contcomp is greated than 1000, could give overflow ! Check also if two decimals not enough do i3=1,noofel if(constcomp(i3).gt.maxcc) then warnings=warnings+1 write(*,206)trim(phlista(lokph)%name),i3,constcomp(i3) 206 format('3E *** Warning stoichiometry factor >100: ',& a,i4,F10.2) endif decimals=int(1.0D5*constcomp(i3)) xxx=1.0D-5*dble(decimals) if(abs(xxx-constcomp(i3)).gt.1.0D-6) then warnings=warnings+1 write(*,203)trim(constext),i3,constcomp(i3) 203 format('3E *** Warning stoichiometry with >5 decimals: ',& a,i4,2F10.6) endif enddo ! property record has property=1 it is G; take care of magnetic properties ! write(*,*)'3E havemag: ',trim(phlista(lokph)%name),havemag magprop: if(havemag.gt.0) then nextprop=>property%nextpr 334 continue ! write(*,*)'3E magnetic 2: ',trim(phlista(lokph)%name),& ! property%proptype,associated(nextprop) if(associated(nextprop)) then if(nextprop%proptype.eq.2) then ! this is Curie/Neel temperature f1=nextprop%degreelink(0) partc=tpfc(f1)%cfun%coefs(1,1) ! write(*,*)'3E endmember TC2: ',f1,partc paratyp=16 elseif(nextprop%proptype.eq.3) then ! This is BMAGN f1=nextprop%degreelink(0) parbm=tpfc(f1)%cfun%coefs(1,1) ! write(*,*)'3E endmember BMAGN2: ',f1,parbm paratyp=16 else write(*,*)'3E ignoring endmember property: ',& nextprop%proptype endif else exit magprop endif nextprop=>nextprop%nextpr goto 334 endif magprop ! property record has still property=1 it is G f1=property%degreelink(0) if(f1.gt.0) then factor=one if(ionliq .and. iliqwild) then write(lut,211)constext(1:ip-2),ccc ! According to Ted 211 format(a,40x,' * ',F12.2) ! We must multiply tpfc(f1) with ccc, store in tpfc(jp) coefficient function! jp=ntpf+1 call tpmult(f1,jp,ccc,tpfc) call list_tpascoef(lut,text,paratyp,jp,npows,factor,tpfc) if(paratyp.eq.16) write(lut,222)partc,parbm 222 format(2G15.8) else ! according to Ted: endmember symbol ! write(*,99)constext(1:ip-2) write(lut,99)constext(1:ip-2) call list_tpascoef(lut,text,paratyp,f1,npows,factor,tpfc) if(paratyp.eq.16) write(lut,222)partc,parbm endif else write(*,*)'3 C missing function for endmember property',& constext(3:ip-2) endif endy(i1)=endy(i1)+1 endif propem endif endorexcess ! take next endmember ! write(*,*)'3E We are here 5' if(.not.ionliq) then endmember=>endmember%nextem else ! find next endmember with the same cation, liquids without cations? !! ! if none set endmember=>nextcation ! if nextcation has same cation as firstcation we have finished! 240 continue iliqwild=.false. ! write(*,241)'ionliq done: ',firstcation,cation,& ! endmember%fraclinks(1,1),endmember%fraclinks(2,1) endmember=>endmember%nextem if(associated(endmember)) then ! write(*,241)'ionliq ass: ',firstcation,cation,& ! endmember%fraclinks(1,1),endmember%fraclinks(2,1) 241 format(a,2i3,2x,2i3) if(endmember%fraclinks(1,1).eq.-99) then iliqwild=.true. ! ccc is the valency of the cation used to multiply the neutral parameter ccc=cationval elseif(endmember%fraclinks(1,1).ne.cation) then goto 240 endif else ! write(*,*)'3E we are here 6: ',associated(nextcation) endmember=>nextcation if(associated(endmember)) then nextcation=>nextcation%nextem cation=endmember%fraclinks(1,1) ! write(*,241)'ionliq notaass: ',firstcation,cation,& ! endmember%fraclinks(1,1),endmember%fraclinks(2,1) ! we have looped through all cations if(cation.eq.firstcation) exit allend ! there were just one cation but some neutrals (already listed) if(endmember%fraclinks(1,1).eq.-99) exit allend ! else ! no more cations, finished! ! write(*,*)'3E no nextcation!' endif endif endif enddo allend ! ------------------- end of endmembers, constituents and excess parameters ?? if(model(1:4).eq.'IDMX') cycle phases1 if(excessparam) goto 297 ! After endmembers for sublattice phases write number of sublattices and sites if(model(1:4).eq.'SUBL') then write(lut,250)nsubl if(skipfc) then write(lut,260)(varres%disfra%dsites(isubl),isubl=1,nsubl) else write(lut,260)(ceq%phase_varres(lokcs)%sites(isubl),isubl=1,nsubl) 250 format(1x,i4) 260 format(1x,8F9.5) endif endif ! write(*,*)'3E here 8: ',phlista(lokph)%name,model if(model(1:4).eq.'SUBL' .or. model(1:4).eq.'SUBI') then ! number of constituents in each sublattice if(skipfc) then write(lut,270)(varres%disfra%nooffr(isubl),isubl=1,nsubl) else write(lut,270)(phlista(lokph)%nooffr(isubl),isubl=1,nsubl) 270 format(9i5) endif endif ! For all phases with sublattices we should write the constituents of each ! problem here for UC2_C11A, constituent in first sublattice ignored if(nsubl.eq.1) goto 280 i3=0 ! do isubl=1,phlista(lokph)%noofsubl do isubl=1,nsubl constext=' ' ip=1 if(skipfc) then nn=varres%disfra%nooffr(isubl) else nn=phlista(lokph)%nooffr(isubl) endif do i2=1,nn i3=i3+1 if(skipfc) then isp=firsteq%phase_varres(lokcs)%disfra%splink(i3) else isp=phlista(lokph)%constitlist(i3) endif jp=ip call lower_case_species_name(constext,ip,isp) ip=jp+25 if(ip.ge.75) then write(lut,100)trim(constext) constext=' ' ip=1 endif enddo ! write(*,271)'3E constext: ',trim(constext),isubl,i2,i3,ip !271 format(a,a,4i4) ip=len_trim(constext) ! for a single component names ip=1 here ... if(ip.gt.1 .or. constext(1:1).ne.' ') then write(lut,100)trim(constext) endif enddo 280 continue if(model(1:4).eq.'SUBI') then ! There should be a line with just a "2" ??? write(lut,272) 272 format(' 2') ! for ionic liquid list abs(valencies) of constituents, one line per sublattice ip=1 isp=1 constext=' ' do i2=1,phlista(lokph)%nooffr(1) ccc=splista(phlista(lokph)%constitlist(isp))%charge write(constext(ip:),274)ccc 274 format(F10.5) ip=len_trim(constext) if(ip.gt.69) then write(lut,99)trim(constext) ip=1 constext=' ' endif isp=isp+1 enddo if(ip.gt.1) then write(lut,99)trim(constext) endif ip=1 constext=' ' do i2=1,phlista(lokph)%nooffr(2) ! Benjamin problem 1, he wants negative anion change .... ! For anions the charge as a positive value, for Va unity, for neutrals zero if(btest(splista(phlista(lokph)%constitlist(isp))%status,SPVA)) then ccc=-one else ! Benjamin correction: changed sign of ccc ! ccc=abs(splista(phlista(lokph)%constitlist(isp))%charge) ccc=splista(phlista(lokph)%constitlist(isp))%charge endif write(constext(ip:),274)ccc ip=len_trim(constext) if(ip.gt.69) then write(lut,99)trim(constext) ip=1 constext=' ' endif isp=isp+1 enddo if(ip.gt.1) then write(lut,99)trim(constext) endif endif ! if(phlista(lokph)%noofsubl.gt.1) then ! lastix=0 if(nsubl.gt.1) then ! A very strange output of integers representing endmembers jp=1 mult=1 ! do isubl=phlista(lokph)%noofsubl,1,-1 do isubl=nsubl,1,-1 mult(isubl)=jp if(skipfc) then jp=jp*varres%disfra%nooffr(isubl) else jp=jp*phlista(lokph)%nooffr(isubl) endif enddo ! write(*,278)'3E mult2: ',jp,(mult(ip),ip=1,phlista(lokph)%noofsubl) 278 format(a,10i4) do isubl=1,nsubl lastix=0 text=' ' ip=3 k1=0 i2=0 290 continue k1=k1+1 i3=0 292 continue lastix=lastix+1 exix(lastix)=k1 ! the use of text here will be made redundant call wriint(text,ip,k1) ip=ip+3 i2=i2+1 i3=i3+1 if(i3.lt.mult(isubl)) goto 292 if(skipfc) then if(k1.gt.varres%disfra%nooffr(isubl)) k1=0 if(k1.eq.varres%disfra%nooffr(isubl) .and. isubl.gt.1) k1=0 else if(k1.gt.phlista(lokph)%nooffr(isubl)) k1=0 if(k1.eq.phlista(lokph)%nooffr(isubl) .and. isubl.gt.1) k1=0 endif if(i2.lt.jp) goto 290 ! According to Markus Piro one should have 19 values per line, 18*4+3=75 ! New code using i4 format lineb=1 firstix=1 do while(lastix.gt.lineb) lineb=min(firstix+18,lastix) ! write(*,*)'3E firstix: ',firstix,lineb write(lut,'(19i4)')(exix(isp),isp=firstix,lineb) firstix=lineb+1 enddo ! output below is wrong and removed redunant ! isp=1 ! do while(len_trim(text(isp:))-76.gt.0) ! Corrected 2020-11-12 with the help from Max Poschmann and Markus Piro ! do while(len_trim(text(isp:))-76.gt.0) ! write(lut,99)trim(text(isp:isp+74)) ! isp=isp+75 ! lineb=75 ! do while(text(isp+lineb:isp+lineb).ne.' ') ! increment lineb until we find a space ! lineb=lineb+1 ! enddo ! write(*,*)'3E linebreak: "',text(isp+lineb-1:isp+lineb-1),& ! '" and "',text(isp+lineb:isp+lineb),'"',lineb ! write(lut,99)trim(text(isp:isp+lineb-1)) ! isp=isp+lineb ! enddo ! if(len_trim(text(isp:)).gt.0) write(lut,99)trim(text(isp:)) enddo endif !...................... repeat loop for excess parameters 297 continue if(.not.excessparam) then ! repeat the endmember loop again for interaction parameters (and magnetism??) ! write(*,*)'3E Now the excess parameters',nsubl excessparam=.true. ! if magnetic we have FIRST loop all excess parameters for magnetic parameters if(havemag.ne.0) magloop=.TRUE. ! and then again for the G parameters .... SUCK endmember=>phlista(lokph)%ordered if(associated(phlista(lokph)%disordered)) then endmember=>phlista(lokph)%disordered endif ! if(magloop) write(*,*)'3E First magnetic excess parameters' goto 207 elseif(magloop) then ! First finish the magetic excess parameter parameters with a zero write(lut,555) 555 format(' 0',30x,' = end of magnetic excess parameters') ! here we write the Gibbs energy excess parameters magloop=.FALSE. endmember=>phlista(lokph)%ordered if(associated(phlista(lokph)%disordered)) then endmember=>phlista(lokph)%disordered endif ! write(*,*)'3E Gibbs energy excess parameters after magnetic' goto 207 endif ! terminate the excess parameters for this phase with a line starting with 0 write(lut,300) 300 format(' 0') enddo phases1 !------------------------------------------------------- ! now data for stoichiometric phases mphstoi=1 ! write(*,*) ! write(*,*)'3E loop for compounds ',nphstoi ! phases2: do i1=1,noofph lokph=phasetuple(i1)%lokph if(ceq%phase_varres(phlista(lokph)%linktocs(1))%phstate.eq.PHSUS) then ! skip phases with suspended default composition set ! write(*,*)'3E skipping phase loop 4: ',phlista(lokph)%name cycle phases2 endif if(i1.ne.phstoi(mphstoi)) then ! write(*,*)'3E skipping mixture ',trim(phlista(lokph)%name),& ! i1,mphstoi,phstoi(mphstoi) cycle phases2 endif mphstoi=mphstoi+1 skipfc=.FALSE. factor=one if(phlista(lokph)%nooffs.gt.1) then ! skip first composition set skipfc=.true. endif ! magnetism? havemag=0 addrec=>phlista(lokph)%additions lastadd2: do while(associated(addrec)) ! no need to increment CHTD except for magnetism ! write(*,*)'3E additions?: ',phlista(lokph)%name,addrec%type if(addrec%type.eq.1) then havemag=3 write(*,*)'3E magnetic phase 1: ',phlista(lokph)%name aff=addrec%aff elseif(addrec%type.ne.7) then ! type 7 is volume write(*,*)'3E WARNING addition type: ',addrec%type,' ignored' endif addrec=>addrec%nextadd enddo lastadd2 lokcs=phlista(lokph)%linktocs(1) varres=>ceq%phase_varres(lokcs) nsubl=1 ionliq=.false. nsubl=phlista(lokph)%noofsubl if(skipfc) then factor=varres%disfra%fsites varres=>ceq%phase_varres(varres%disfra%varreslink) if(btest(phlista(lokph)%status1,PHMFS)) then nsubl=size(varres%sites) endif endmember=>phlista(lokph)%disordered else ! there is just one endmember!! endmember=>phlista(lokph)%ordered endif ! prepare a dummy prefix for compounds ... NOT NECESSARY ! phdummy=phlista(lokph)%name(1:4) ! jp=0 ! do i3=1,noofph ! if(i3.ne.lokph .and. phdummy.eq.phlista(i3)%name(1:4)) jp=1 ! enddo ! if(jp.gt.0) then ! warnings=warnings+1 ! call incunique(phunique) ! phdummy=phunique ! write(*,*)'3E prefixing TDB phase name ',& ! phdummy//'_'//trim(phlista(lokph)%name),i1 ! else ! phdummy=' ' ! endif phdummy=' ' if(phdummy(1:1).eq.' ') then write(*,477)trim(phlista(lokph)%name),nsubl,factor 477 format('3E Compound: ',a,i3,F12.3,a) ! write on file write(lut,500)phlista(lokph)%name,factor 500 format(1x,a,5x,'= COMPOUND PHASE = ',F12.4) else write(*,477)phdummy//'_'//trim(phlista(lokph)%name),nsubl,factor,& ' with name change' write(lut,500)phdummy//'_'//phlista(lokph)%name,factor endif if(havemag.ne.0) then if(aff.eq.one) then write(lut,202)-aff,0.4 else write(lut,202)-one/aff,0.28 endif endif constext=' ' ip=1 constcomp=zero sloop2: do isubl=1,nsubl ! this is the loop for the constituents in sublattices if(.not.associated(endmember)) then write(*,*)'3E no parameter!! ',phlista(lokph)%name cycle sloop2 endif isp=endmember%fraclinks(isubl,1) if(isp.eq.-99) then ! this means wildcard in this sublattice write(*,*)'3E *** ERROR! Wildcard in a stoichiometric compound!!!' constext(ip:)='*:' ip=ip+2 cycle sloop2 endif ! Hm we should add stoichiometric factors for all constituents in this subl isp=phlista(lokph)%constitlist(isp) if(btest(splista(isp)%status,SPVA)) then write(*,*)'3E Warning: vacancy in stoichiometric compound!!' endif write(constext(ip:),99)trim(splista(isp)%symbol)//':' ip=len_trim(constext)+1 do i2=1,splista(isp)%noofel ! this is a loop for the components of the endmember constituents i3=ellista(splista(isp)%ellinks(i2))%alphaindex if(i3.eq.0) then ! skip vacancies continue else constcomp(i3)=constcomp(i3)+splista(isp)%stoichiometry(i2)*& varres%sites(isubl) endif enddo enddo sloop2 ! we may come here if there are no endmembers! if(.not.associated(endmember)) then write(*,*)'3E skipping this phase' cycle phases2 endif ! for the parameters follow the property link property=>endmember%propointer if(associated(property)) then ! For a compound do not write any constituent array ! write(lut,100)constext(1:ip-2) ! this line should be written together with the type of coefficients and ranges ! it may require several lines write(text,210)constcomp ! Check if any value in contcomp is greated than 1000, could give overflow do i3=1,noofel if(constcomp(i3).gt.maxcc) then warnings=warnings+1 write(*,206)trim(phlista(lokph)%name) endif enddo paratyp=4 partc=zero; parbm=zero if(havemag.ne.0) paratyp=16 ! what about several properties?? YES 575 continue if(property%proptype.eq.1) then f1=property%degreelink(0) if(f1.gt.0) then call list_tpascoef(lut,text,paratyp,f1,npows,factor,tpfc) else write(*,*)'missing endmember parameter' endif elseif(property%proptype.eq.2) then f1=property%degreelink(0) partc=tpfc(f1)%cfun%coefs(1,1) elseif(property%proptype.eq.3) then f1=property%degreelink(0) parbm=tpfc(f1)%cfun%coefs(1,1) else write(*,*)'3E ignoring compound property ',property%proptype endif property=>property%nextpr if(associated(property)) goto 575 endif if(paratyp.eq.16) write(lut,222)partc,parbm enddo phases2 ! At the end some dummy line for the pure elements?? write(lut,602) 602 format('###################################################') goto 900 !----------------------- ??? ! At the end some dummy line for the pure elements?? do i1=1,noofel write(lut,605)ellista(elements(i1))%symbol 605 format(1x,a2,22x,'#') constcomp=zero constcomp(i1)=one write(lut,610)constcomp 610 format(' 4 1',12F7.1) write(lut,620) 620 format(' 6001.0000 0.00000000 0.00000000 0.00000000',& ' 0.00000000 '/' 0.00000000 0.00000000 '/& ' 1 0.00000000 0.00') enddo ! 900 continue do i1=1,noofph if(endx(i1).ne.endy(i1)) then lokph=phases(i1) write(*,911)trim(phlista(lokph)%name),endx(i1),endy(i1) 911 format('3E Endmembers missing for ',a,& ', should have ',i3,' endmembers, has ',i3) endif enddo write(*,700)noofph,nphmix,nphstoi 700 format('3E written data for ',i4,' phases: ',i3,' mixtures and ',& i4,' compounds') if(warnings.gt.0) write(*,701)warnings 701 format(' *** Attention: there were ',i3,' warnings!') ! 1000 continue ! Finished SOLGASMIX outpur if(allocated(tpfc)) deallocate(tpfc) if(gx%bmperr.ne.0) then write(*,1009)trim(filename),gx%bmperr 1009 format(/' *** Output terminated on ',a,' due to error ',i5/) elseif(date(1:4).ne.' ') then write(*,1010)trim(filename) 1010 format('3E Output finished on ',a/) else write(*,1020)trim(filename) 1020 format('3E no output on ',a/) endif close(lut) return end subroutine save_datformat !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine incunique !\begin{verbatim} subroutine incunique(text) character text*(*) !\end{verbatim} %+ integer j1,j2,j3 j1=len(text) ! write(*,*)'3E phunique 1: ',text loop: do while(j1.ge.1) j2=ichar(text(j1:j1))-ichar('0') ! this position is not a number, exit if(j2.lt.0) exit loop if(j2.lt.9) then ! increment the number and exit text(j1:j1)=char(j2+1+ichar('0')) exit loop elseif(j2.eq.9) then text(j1:j1)='0' j1=j1-1 else ! this position is not a number, exit exit loop endif enddo loop ! write(*,*)'3E phunique 2: ',text return end subroutine incunique !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine expand_wildcards !\begin{verbatim} subroutine expand_wildcards(intconst,nconst,wildloop,iset,lokph) ! Expand a wildcard constituent with all constituents it replaces ! There can be several wildcards ! intconst is the original set of constuents including the wildcards (-99) ! nconst is the number of constituents ! wildloop is set to the number of times the interaction is repeated ! iset is a matrix with the expanded constituents ! phrecord is the phase record where one can find the phase structure implicit none integer intconst(*) integer, allocatable, dimension(:,:) :: iset integer nconst,wildloop,lokph !\end{verbatim} %+ integer la,lb,lc,lz,ja,jb,jc,jz,ka,kb,nexp integer, allocatable, dimension(:) :: multi ! write(*,10)'3E in expand_wildcard: ',nconst,(intconst(la),la=1,nconst) 10 format(a,i3,2x,10i4) nexp=1 allocate(multi(phlista(lokph)%noofsubl)) multi=1 do la=1,phlista(lokph)%noofsubl if(intconst(la).eq.-99) then multi(la)=nexp nexp=nexp*phlista(lokph)%nooffr(la) endif enddo ! write(*,*)'3E expand: ',nconst,nexp allocate(iset(nconst,nexp)) ! initiate iset to original constituents (with wildcards) do la=1,nexp do ja=1,nconst iset(ja,la)=intconst(ja) enddo enddo ! do ja=1,nexp ! write(*,10)'3E before expanded: ',ja,(iset(la,ja),la=1,nconst) ! enddo ! loop several times expanding one sublattice with wildcard each time ja=1 lat1: do la=1,phlista(lokph)%noofsubl if(iset(la,1).eq.-99) then ka=1 do while(ka.lt.nexp) jc=ja do jb=1,phlista(lokph)%nooffr(la) do jz=1,multi(la) iset(la,ka)=jc ka=ka+1 enddo jc=jc+1 enddo enddo endif ja=ja+phlista(lokph)%nooffr(la) enddo lat1 wildloop=nexp ! do ja=1,wildloop ! write(*,10)'3E after expanded: ',ja,(iset(la,ja),la=1,nconst) ! enddo 1000 continue return end subroutine expand_wildcards !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine intsort !\begin{verbatim} subroutine intsort(intc,nint,intx) ! This is just another stupid sorting subroutine ! intc is not changed implicit none integer intc(*),intx(*),nint !\end{verbatim} %+ integer byte,jj if(nint.lt.2) then write(*,*)'*** ERROR: intsort called with too few constituents',nint stop endif do byte=1,nint intx(byte)=intc(byte) enddo do while(byte.gt.0) ! values in intx are never zero byte=0 do jj=2,nint if(intx(jj-1).gt.intx(jj)) then byte=intx(jj) intx(jj)=intx(jj-1) intx(jj-1)=byte endif enddo enddo 1000 continue return end subroutine intsort !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine lower_case_species_name !\begin{verbatim} subroutine lower_case_species_name(constext,ip,isp) ! writes a species name using lower case for second letter of element implicit none character constext*(*) integer ip,isp !\end{verbatim} integer iel,jp,lcase,kp character elsym*2,name*24 jp=1 name=' ' lcase=ichar('a')-ichar('A') do iel=1,splista(isp)%noofel elsym=ellista(splista(isp)%ellinks(iel))%symbol kp=0 if(elsym(2:2).ne.' ') then elsym(2:2)=char(ichar(elsym(2:2))+lcase) name(jp:)=elsym jp=jp+2 else name(jp:)=elsym jp=jp+1 kp=1 endif ! 3rd argument 0 means no sign if(abs(splista(isp)%stoichiometry(iel)-one).gt.1.0D-6 .or. & (iel.lt.splista(isp)%noofel .and. kp.eq.1)) then call wrinum(name,jp,6,0,splista(isp)%stoichiometry(iel)) if(buperr.ne.0) then write(*,*)'3E buperr 2: ',trim(name),buperr buperr=0 endif endif enddo ! species may have a charge if(splista(isp)%charge.eq.one) then name(jp:jp)='+' jp=jp+1 elseif(splista(isp)%charge.eq.-one) then name(jp:jp)='-' jp=jp+1 elseif(abs(splista(isp)%charge).gt.1-0D-6) then call wrinum(name,jp,6,1,splista(isp)%charge) endif ! write(*,*)'3E suck: lower case name: ',trim(name) constext(ip:)=name ip=len_trim(constext)+1 1000 continue return end subroutine lower_case_species_name !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable logical function notallowlisting !\begin{verbatim} logical function notallowlisting(privil) ! check if user is allowed to list data double precision privil !\end{verbatim} logical ok ! false means listing allowed ok=.FALSE. notallowlisting=ok return end function notallowlisting !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine get_parameter_typty !\begin{verbatim} ! subroutine get_parameter_typty(name1,lokph,typty,fractyp) subroutine get_parameter_typty(name1,lokph,typty) ! interpret parameter identifiers like MQ&C#2 in MQ&C#2(FCC_A1,FE:C) ... ! find the property associated with this symbol implicit none integer typty,fractyp,lokph character name1*(*) !\end{verbatim} integer nr,typty1,iel,isp,kel,loksp,lk3,kq,k4,kk,ll character elnam*24 ! It can be a mobility with a & inside kel=index(name1,'&') if(kel.gt.0) then ! note that elnam may contain sublattice specification like Fe+2#2 elnam=name1(kel+1:) name1=name1(1:kel-1) endif kq=len_trim(name1) ! write(*,*)'3D: fractyp: ',kq,name1(1:kq) ! if(name1(kq:kq).eq.'D') then ! No longer user suffix D for fractyp 2 ! A final "D" on the paramer symbol indicates fractyp=2 ! name1(kq:kq)=' ' ! fractyp=2 ! else ! fractyp=1 ! endif !---------------------- ! write(*,*)'Property symbol: "',propid(nr)%symbol,'" >',name1(1:4),'<' do nr=1,ndefprop if(name1(1:4).eq.propid(nr)%symbol) then goto 70 endif enddo ! no matching property identifier gx%bmperr=4292; goto 1000 ! 70 continue typty=nr typty1=nr iel=0; isp=0 if(kel.gt.0) then ! there is a specifier, check if correct element or species kel=index(elnam,'#') if(kel.gt.0) then ! extract sublattice number 1-9 specification lk3=ichar(elnam(kel+1:kel+1))-ichar('0') ! write(*,73)elnam(kel+1:kel+1),kel,elnam,lk3 !73 format('3D sublattice: "',a,'" position: ',i3,' in ',a,' : ',i3) elnam(kel:)=' ' else lk3=0 endif if(btest(propid(typty)%status,IDELSUFFIX)) then ! write(*,*)'3D: elnam: ',kel,lk3,typty,elnam call find_element_by_name(elnam,iel) if(gx%bmperr.ne.0) then write(kou,*)'3D Unknown element ',elnam,& ' in parameter type MQ, please reenter' gx%bmperr=0; goto 1000 endif typty=100*typty+iel elseif(btest(propid(typty)%status,IDCONSUFFIX)) then ! to know the constituents we must know the phase but as we do not know ! the phase name yet but check the species exists !!! call find_species_by_name(elnam,isp) if(gx%bmperr.ne.0) then ! This is not an error, the species may not be selected!!! ! write(kou,*)'Unknown species ',elnam,& ! ' in parameter type MQ, please reenter',gx%bmperr gx%bmperr=0; goto 1000 endif ! convert from index to location, loksp loksp=species(isp) ! write(*,69)'3D: conname: ',kel,lk3,typty,isp,loksp,elnam 69 format(a,5i4,a) ! extract sublattice after # else ! write(kou,*)'This property has no specifier' gx%bmperr=4168; goto 1000 endif ! this is the property type stored in property record else ! check if there should be a specifier !! if(btest(propid(typty)%status,IDELSUFFIX) .or. & btest(propid(typty)%status,IDCONSUFFIX)) then write(*,77)propid(typty)%symbol 77 format('3D Missing specifier for model parameter idenifier ',a) gx%bmperr=4169; goto 1000 endif endif ! if the parameter symbol has a constituent specification check that now if(isp.gt.0) then k4=0 do ll=1,phlista(lokph)%noofsubl if(lk3.eq.0 .or. lk3.eq.ll) then do kk=1,phlista(lokph)%nooffr(ll) k4=k4+1 if(phlista(lokph)%constitlist(k4).eq.loksp) goto 80 enddo elseif(ll.lt.lk3) then k4=k4+phlista(lokph)%nooffr(ll) endif enddo ! constituent not found write(kou,*)'No such constituent' gx%bmperr=4066; goto 1000 ! constituent found in right sublattice 80 continue typty=100*typty+k4 ! write(*,81)'3D: found: ',typty1,typty,lk3,k4,loksp 81 format(a,10i4) endif 1000 continue return end subroutine get_parameter_typty !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine merge_spaces !\begin{verbatim} ! subroutine merge_spaces(text) subroutine merge_spaces(text) ! merge multiple spaces to a single one in text implicit none character text(*) !\end{verbatim} 1000 continue return end subroutine merge_spaces !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! ================================================ FILE: src/models/gtp3EX.F90 ================================================ ! ! gtp3EX included in gtp3.F90 ! !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !> 9B. Section: read and save on files using XML bases XTDB !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine read_xtdb_dummy !\begin{verbatim} subroutine read_xtdb_dummy(filename,nel,selel) ! reading data from an XTFB file and list data on screen ! if nel<=0 then only extract elements and retutn in selel (-nel dimension) ! if nel>0 extract data for the the nel elements in selel ! implicit none integer nel character filename*(*),selel(*)*2 !\end{verbatim} ! for extracting elements, phases and data from database integer warnings,ip,jp,kp,tagno,lastp,tag,fl,taglevel ! character (len=2) :: present(78) character line*512,lline*2048 ! when reading a tag with nested tag this is the end of the tad ! up to "nestedtags" levels of nested tags allowed integer, parameter :: nestedtags=10 character(len=24), dimension(nestedtags) :: tagend character tagname*18 type(gtp_xtdbcompatibility) :: pmpid logical onlyfun,comment ! write(*,*)'3EX read_xtdb not implemented yet' ! goto 1000 if(len(xtdbtags(1)).gt.18) then write(*,*)'3EX xtdbtags longer than 18 characters, extend tagend!',& len(xtdbtags) endif ! initiating xtdbmpid call xtdbinitmpid(nxtdbmpids) ! ! if(index(filename,'.').eq.0) then ! no extention provided filename(len_trim(filename)+1:)='.XTDB' endif ! write(*,*)'Reading XTDB files not implemented' gx%bmperr=9999; goto 1000 ! open(21,file=filename,access='sequential',form='formatted',& err=2010,iostat=gx%bmperr,status='old') onlyfun=.FALSE. ! warnings=0 ! This is the current level of nexted tags taglevel=0 comment=.FALSE. ! if the tag and its attributes continue on next line lastp end of previous line lastp=0 ! this is current number of lines read from file fl=1 !------------------------- ! Reading the XTDB file: ! 1. If no elements provided just extract all the elements ! 2. If elements provides read first the Models tag and possibly modify the MPID ! 2.1 if an unknown model give a warning but no error unless used by a phase ! 3. If elements then read all species and phases that can form ! 3.1 There can be phases rejected or selected ! 3.2 If a phase have an unknown model skip it with a warning ! 4. Read the parameters for the phases and species entered ! 5. Maybe perform some conditional action (extra composition sets, ! default constituents) !------------------------- readfile: do while(.true.) ! return here to read next line from file read(21,110,end=900,err=2010)line 110 format(a) fl=fl+1 ip=1 if(taglevel.eq.0) then ! No current tag ! or ! (on several lines) with on a later line ! max nestedtags (=10) tags possible ! we expect to read the beginning of a tag or comment ! ! call gettag(line,ip,tagname) ! ! extract tag and all its attributes (can be on several lines) jp=ip ! call xtdbkey_old(line,jp,tagname) select case(tag) ! case default means keyw not understood case default write(*,*)'3EX no such XTDB tag: ',line(ip:jp) ! handle all tags here case(1) end select else ! we are reading a continuation line of a tag, can be a new tag continue end if ! ! ! end do readfile ! we have finished reading from the fil, we may need to read it agaon 900 continue close(21) ! if(warnings.ne.0) then write(*,*)'3EX warning ',warnings endif ! 1000 continue return ! error opening file 2000 continue write(*,'("3EX error opening file ",i7)')gx%bmperr goto 1000 2010 continue write(*,'("3EX error reading file ",i7,", line ",i7)')gx%bmperr,fl goto 1000 end subroutine read_xtdb_dummy !\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! subroutine xtdbinitmpid(ns) integer ns ! initiating xtdbmpid ! use the xtdbmodel records allocate(xtdbmodel(ns)) ! ! maybe one should reconsider the indexing in the result data arrays ... ! In the new models all will have a GEIN model, some a magnetic model ! Note the liquid may be magnetic ... ! these are 9 models allowed in the AmendPhase tag ! for the ocix values: 1=G, 2=LNTH, 3=BMAGN, 4=TC, 5=NT, 6=G2 ! Magnetic model 1, previously AFF=-1 ! write(*,*)'Initating xtdbmodel' xtdbmodel(1)%modelid='IHJBCC' xtdbmodel(1)%nmpid=2 allocate(xtdbmodel(1)%mpid(2)) allocate(xtdbmodel(1)%ocmpid(2)) allocate(xtdbmodel(1)%ocix(2)) xtdbmodel(1)%mpid(1)='TC' xtdbmodel(1)%mpid(2)='BMAG' xtdbmodel(1)%ocmpid(1)='TC' xtdbmodel(1)%ocmpid(2)='BMAG' ! The ocix is the location for the parameter in the result array in GTP ???? xtdbmodel(1)%ocix(1)=4 xtdbmodel(1)%ocix(2)=3 ! Magnetic model 2, previously AFF=-3 xtdbmodel(2)%modelid='IHJREST' xtdbmodel(2)%nmpid=2 allocate(xtdbmodel(2)%mpid(2)) allocate(xtdbmodel(2)%ocmpid(2)) allocate(xtdbmodel(2)%ocix(2)) xtdbmodel(2)%mpid(1)='TC' xtdbmodel(2)%mpid(2)='BMAG' xtdbmodel(2)%ocmpid(1)='TC' xtdbmodel(2)%ocmpid(2)='BMAG' xtdbmodel(2)%ocix(1)=4 xtdbmodel(2)%ocix(2)=3 ! Magnetic model 3, previously AFF=0 xtdbmodel(3)%modelid='IHJQX' xtdbmodel(3)%nmpid=3 allocate(xtdbmodel(3)%mpid(3)) allocate(xtdbmodel(3)%ocmpid(3)) allocate(xtdbmodel(3)%ocix(3)) xtdbmodel(3)%mpid(1)='TC' xtdbmodel(3)%mpid(2)='NT' xtdbmodel(3)%mpid(3)='BMAG' xtdbmodel(3)%ocmpid(1)='TC' xtdbmodel(3)%ocmpid(2)='NT' xtdbmodel(3)%ocmpid(3)='BMAG' xtdbmodel(3)%ocix(1)=4 xtdbmodel(3)%ocix(2)=5 xtdbmodel(3)%ocix(3)=3 ! Einstein xtdbmodel(4)%modelid='GEIN' xtdbmodel(4)%nmpid=1 allocate(xtdbmodel(4)%mpid(1)) allocate(xtdbmodel(4)%ocmpid(1)) allocate(xtdbmodel(4)%ocix(1)) xtdbmodel(4)%mpid(1)='LNTH' xtdbmodel(4)%ocmpid(1)='LNTH' xtdbmodel(4)%ocix(1)=2 ! Liq2State xtdbmodel(5)%modelid='LIQ2STATE' xtdbmodel(5)%nmpid=2 allocate(xtdbmodel(5)%mpid(2)) allocate(xtdbmodel(5)%ocmpid(2)) allocate(xtdbmodel(5)%ocix(2)) xtdbmodel(5)%mpid(1)='LNTH' xtdbmodel(5)%mpid(2)='G2' xtdbmodel(5)%ocmpid(1)='LNTH' xtdbmodel(5)%ocmpid(2)='G2' xtdbmodel(5)%ocix(1)=2 xtdbmodel(5)%ocix(2)=6 ! ! These models have no model parameters xtdbmodel(6)%modelid='FCC4PERM' xtdbmodel(6)%nmpid=0 xtdbmodel(7)%modelid='BCC4PERM' xtdbmodel(7)%nmpid=0 xtdbmodel(8)%modelid='EEC' xtdbmodel(8)%nmpid=0 xtdbmodel(9)%modelid='EBEF' xtdbmodel(9)%nmpid=0 ! ! The DisorderedPart is a separate tag ! return end subroutine xtdbinitmpid !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine write_xtdbformat !\begin{verbatim} subroutine write_xtdbformat(filename,ext) ! write an XTDB database !-------------------------------------------------- ! NOTE writing TDB files is in gtp3C.F90 by subroutine list_phase_data2 ! The XTDB format is defined in gtp3_xml.F90 !-------------------------------------------------- implicit none character*(*) filename,ext !\end{verbatim} integer ip,jp,kp,lut,nl,ia,ib,ic,id,nk,isp integer lokph,ics,lokcs,proptyp,lokxx ! integer, parameter :: maxint=20 integer :: freemodels=0 character date*20,tlim8*8,ch1*1,configmodel*32 ! character line*2000,text16*16,text80*80,text256*256,text512*512 ! there was a TPfun in TAFID with more than 700 characters .... BAGAS? character line*2000,text16*16,text80*80,text256*256,text512*1024 ! eventually list a short description of models used in this database character, dimension(50) :: usedmodels*24 logical lrange TYPE(gtp_phase_varres), pointer :: phvarres TYPE(gtp_phase_add), pointer :: addrec ! 10 format(a) ! ! write(*,*)'3E: in write_xtbformat: XTDB format output not yet finished ! write(*,*)'3E: filename: "',trim(filename),'" "',ext,'"' ! make sure extention is .XTDB if(index(filename,ext).le.0) then ip=index(filename,' ') filename(ip:)='.'//ext endif write(*,*)'Output on: ',trim(filename) ! open the file lut=27 open(lut,file=filename,access='sequential',form='formatted',& err=1100,iostat=gx%bmperr,status='unknown') nl=0 ! write heading ! xtdbversion is in gtp3_xml.F90? call date_and_time(date) write(lut,80)trim(xtdbversion),version(2:7),date(1:4),date(5:6),date(7:8) ! There should probably be some intial XML stuff 80 format('') nl=nl+1 ! values of lowtdef,hightdef,bibrefdef and eldef are set in gtp3_xml.F90 ! but can be changed by user or when reading an XTDB database if(eldef(1:1).eq.' ') then write(lut,90)trim(lowtdef),trim(hightdef),trim(bibrefdef) 90 format(' ') else write(lut,91)trim(lowtdef),trim(hightdef),trim(bibrefdef),trim(eldef) 91 format(' ') endif nl=nl+1 write(lut,95)ModelAppendXTDB 95 format(' '/& ' ') nl=nl+2 ! Writing in this order (option writing parameters by phase?) ! 1: Elements and species ! 2: Phases ! 3: Parameters ! 4: TPfuns ! 5: Bibliography !----------------------------- ! 1: Elements and species do ia=1,noofel ! skip /- and VA write(lut,100)trim(ellista(ia)%symbol),trim(ellista(ia)%ref_state),& ellista(ia)%mass,ellista(ia)%h298_h0,ellista(ia)%s298 100 format(2x,'') nl=nl+1 enddo ! list alse elements as species do ia=1,noofsp text80=' ' ! ip is set to 1 inside encode_stoik, text is the stoichiometry with 8 digits call encode_stoik(text80,ip,8,ia) ! if MQMQA or UNIQUAC ??????? write(lut,110)trim(splista(ia)%symbol),text80(1:ip) 110 format(2x,'') nl=nl+1 enddo write(*,*)'No check for MQMQA or UNIQUAC species' !---------------------------------------------------------------------- ! in gtp3C.F90 there is a subroutine list_phase_data2 for TDB files ! 2: Phases phaseloop: do ia=1,noofph lokph=phases(ia) ics=1 ! write(lut,*)'' ! write(*,*)'3E phase ',trim(phlista(lokph)%name),ia,lokph ! Default is CEF and solid phase, test some status bits !-Bits in PHASE record STATUS1 there are also bits in each phase_varres record! ! 0 HID phase is hidden (not implemented) ! 1 IMHID phase is implictly hidden (not implemented) ! 2 ID phase is ideal, substitutional and no interaction ! 3 NOCV phase has no concentration variation ! 4 HASP phase has at least one parameter entered ! 5 FORD phase has 4 sublattice FCC ordering with parameter permutations ! 6 BORD phase has 4 sublattice BCC ordering with parameter permutations ! 7 SORD phase has TCP type ordering (not subract ordered as disordered, NEVER) ! 8 MFS phase has a disordered fraction set (DisorderedPart) ! 9 GAS this is the gas phase (first in phase list) ! 10 LIQ phase is liquid (can be several but listed directly after gas) ! 11 IONLIQ phase has ionic liquid model (I2SL) ! 12 AQ1 phase has aqueous model (not implemented) ! 13 2STATE elemental liquid twostate model parameters (not same as I2SL!) ! 14 QCE phase has corrected quasichemical entropy (Hillerst-Selleby-Sundman) ! 15 CVMCE phase has some CVM ordering entropy (not implemented, SEE CVMTFL) ! 16 EXCB phase need explicit charge balance (has ions) ! 17 XGRID use extra dense grid in gridminimizer for this phase (not used ?) ! 18 MQMQA phase has FACT quasichem SRO model - implementation pending ! 19 NOCS not allowed to create composition sets for this phase ! 20 HELM parameters are for a Helmholz energy model (not implemented), ! 21 PHNODGDY2 phase model with no analytical 2nd derivatives (not implemented) ! 22 not used ! 23 EECLIQ this is the condensed phase (liquid) for highest entropy ! 24 PHSUBO special use testing models DO NOT USE ! 25 PALM interaction records numbered by PALMTREE NEEDED FOR PERMUTATIONS !!! ! 26 MULTI may be used with care ! 27 BMAV Xiong magnetic model with average Bohr magneton number ! 28 UNIQUAC The UNIQUAC fluid model ! 29 TISR phase has the TSIR entropy model (E Kremer) ! 30 PHSSRO phase has the tetrahedral FCC model for SRO (without LRO) ! 31 SROT phase has a tetrahedron quasichemical model -- NOT USED ! 32 CVMTFL phase has the tetrahedral FCC for LRO and SRO (not impl) ! some bits tested later for AmendPhase and DisorderedPart configmodel='CEF'; ch1='S' if(btest(phlista(lokph)%status1,PHGAS)) then configmodel='IDEAL' ch1='G' elseif(btest(phlista(lokph)%status1,PHIONLIQ)) then configmodel='I2SL' ch1='L' elseif(btest(phlista(lokph)%status1,PHMQMQA)) then configmodel='MQMQA' ch1='L' elseif(btest(phlista(lokph)%status1,PHUNIQUAC)) then configmodel='UNIQUAC' ch1='L' elseif(btest(phlista(lokph)%status1,PHLIQ)) then ch1='L' endif line=' ' write(lut,10)trim(line) nl=nl+1 ! sublattices/sublattices line=' ' write(lut,10)trim(line) nl=nl+1 ! how are constiuents stored ! write(*,70)phlista(lokph)%constitlist 70 format('3E constituents: ',20i3) ! constituents ! loop for all sublattices nk=0 do ic=1,ib line=' ' ! write(*,10)'3E check; ',trim(line) write(lut,10)trim(line) nl=nl+1 enddo ! end of sublattices write(lut,250) 250 format(' ') nl=nl+1 ! DisorderedPart, in OC the ordered and disordered parameters in same phase if(btest(phlista(lokph)%status1,PHMFS)) then write(*,*)'3EX The phase '//trim(phlista(lokph)%name)//& ' has a DisorderedPart' ! in gtp_fraction_set the data for disordered phase can be found ! write(*,*)'3E Disordere:',phvarres%disfra%latd,phvarres%disfra%totdis line=' ' else line(ip:)='" />' endif ! if(btest(phlista(lokph)%status1,PHSORD)) then ! I am not sure how this is connected with Disordered_Part in OC ! write(*,*)'3E do not subtract ordered as disordered' ! endif ! write(*,10)'3E check: ',trim(line) write(lut,10)trim(line) nl=nl+1 endif !------------------------------------ ! AmendPhase: magnetism etc as additions text512=' ' ip=1 addrec=>phlista(lokph)%additions do while(associated(addrec)) proptyp=addrec%type ! write(*,*)'3E addrec%propval: ',proptyp select case(proptyp) case default write(*,*)'3E Unknown property: ',proptyp case(1) ! INDENMAGNETIC=1, BCC and other phases if(addrec%aff.eq.-1) then text512(ip:)='IHJBCC'; ip=ip+7 elseif(addrec%aff.eq.-3) then text512(ip:)='IHJREST'; ip=ip+8 endif case(2) ! XIONGMAGNETIC=2 same for all text512(ip:)='IHJQX'; ip=ip+6 case(3)! DEBYECP=3, not implemented continue case(4) ! EINSTEINCP=4 text512(ip:)='GEIN'; ip=ip+9 case(5) ! TWOSTATEMODEL1=5 text512(ip:)='LIQ2STATE'; ip=ip+10 case(6) ! ELASTICMODEL1=6 case(7) ! VOLMOD1=7 ! OC by default set VOLMOL continue case(8) ! UNUSED_CRYSTBREAKDOWNMOD=8 case(9) ! SECONDEINSTEIN=9 case(10) ! SCHOTTKYANOMALY=10 case(11) ! DIFFCOEFS=11 end select addrec=>addrec%nextadd enddo ! these amendments/amendments are set by other bits if(btest(phlista(lokph)%status1,PHFORD)) then text512(ip:)='FCC4PERM'; ip=ip+9 elseif(btest(phlista(lokph)%status1,PHBORD)) then text512(ip:)='BCC4PERM'; ip=ip+9 endif if(ip.gt.1) then ! write(*,*)'3E additions: ',trim(text512),ip if(len_trim(text512).gt.1) write(lut,270)trim(text512) 270 format(' ') nl=nl+1 endif !------------------------------------------ suck .... ! CrystalStructure ? write(lut,290) 290 format(' ') nl=nl+1 ! ! write(*,*)'3E Finished this phase' enddo phaseloop ! goto 900 write(lut,*)' ' !----------------------------- ! 3: Parameters, phase by phase ! code here copied from gtp3C.F90 subroutine list_phase_data do ia=1,noph() ! write(*,*)'3E calling write_parametrar',lut lokph=phases(ia) call write_parameters(lokph,lut,2,nl) if(gx%bmperr.ne.0) goto 1100 ! write(*,*)'3E Finished listing parameters for this phase' enddo !----------------------------- CHANGE HERE if gtp3_xml.F90 changes ! 4: TPfuns this is the tag xmlel(26) write(lut,*)' ' write(lut,*)' ' nl=nl+2 ! write(*,*)'3E tpfuns: ',notpf(),freetpfun tpfuns: do ia=3,notpf() text512=' ' tlim8=' ' lrange=.FALSE. ! A TPfun can be very long call list_tpfun(ia,0,text512) if(text512(1:1).eq.'_') cycle tpfuns ! check that there is a " N " in text512 to indicate end of expression if(index(text512,' N ').le.0) then ip=index(text512,'= ')-1 write(*,*)text512(1:ip) 130 format('3E no end of TPfun ',a,' in text512') stop endif ! we have to format this using TPfun anda Trange tags ! we should use lowtdef and hightdef which are 8 characters ip=index(text512,'= ')+2 tlim8=text512(ip:) jp=index(tlim8,' ') tlim8(jp:)=' ' if(tlim8.ne.lowtdef) then line=' ' else line(kp:)='" HighT="'//text512(ip:ip+jp-2)//'" >' endif else if(lrange) then line(kp:)='" />' else line(kp:)='" >' endif endif lrange=.TRUE. write(lut,10)trim(line) nl=nl+1 ip=ip+jp+2 ! This is the tag xmlel(26) line=' ' else ! at the highT limit line(kp:)='" />' endif ip=ip+jp+1 kp=len_trim(line)+1 write(lut,10)line(1:kp) nl=nl+1 ! if there has been Trange tags then end the TPfun, tag xmlel(26) if(lrange) write(lut,10)' ' cycle tpfuns endif ! there are more tranges ! write(*,*)'3E next range: ',trim(text512(ip:)) enddo tranges enddo tpfuns !----------------------------- ! 5: Bibliography ! write(*,*)'3EX reffree: ',reffree if(reffree.gt.1) then write(lut,400) 400 format(' ') nl=nl+1 do ia=1,reffree-1 ! Wow, reference texts are stored using storec/loadc ... max 1024 chars ip=bibrefs(ia)%wprefspec(1) line=' ' call loadc(2,bibrefs(ia)%wprefspec,line(1:ip)) ! check to < > and & ! call check_illegal_xml(line,ip) ! write(*,*)'Bibitem: ',trim(line),ip write(lut,410)trim(bibrefs(ia)%reference),trim(line) 410 format(' ') nl=nl+1 enddo write(lut,420)trim(bibrefdef) 420 format(4x,' '/' ') nl=nl+1 else endif !----------------------------- ! Models in AppendXTDB ! Finished !! 900 continue write(lut,990) 990 format('') nl=nl+1 !---------------------------- 1000 continue close(lut) write(*,1010)nl,trim(filename) ! 1010 format('Written: ',i7,' lines on ',a) return ! error open or writing 1100 continue write(*,*)'Error during writing XTDB file',gx%bmperr goto 1000 ! end subroutine write_xtdbformat !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! ! \addtotable subroutine check_illegal_xml subroutine replace_illegal_xml(line,ip) ! replace < > & and " in references by ! [ ] | and # character*(*) line integer ip ! integer jp lt: do while(.true.) jp=index(line(1:ip),'<') if(jp.eq.0) exit lt line(jp:jp)='[' enddo lt gt: do while(.true.) jp=index(line(1:ip),'>') if(jp.eq.0) exit gt line(jp:jp)=']' enddo gt amp: do while(.true.) jp=index(line(1:ip),'&') if(jp.eq.0) exit amp line(jp:jp)='|' enddo amp quote: do while(.true.) ! this means " is replaced by a single ' jp=index(line(1:ip),'''') if(jp.eq.0) exit quote line(jp:jp)='#' enddo quote return end subroutine replace_illegal_xml !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! ! \addtotable subroutine exp2xml subroutine exp2xml(lut,expr,tag,nl) ! convert expr to TPfun/Parameter and Trange and write lines on unit lut ! tag is TPfun or Parameter and the first part of expr is the Id followd ! by the expression integer lut,nl character expr*(*),tag*(*) ! integer ip,jp,kp character tlim8*8,line*1000,bibref*16 logical lrange ! ! make sure there is a final ' N ' ip=index(expr,' N ') if(ip.le.0) then write(*,*)'3E expression has no terminating N' stop elseif(tag(1:1).eq.'P') then ! extract reference if tag is Parameter bibref=trim(expr(ip+3:)) else bibref=' ' endif ! missing default bibref?? fixed ! write(*,*)'3E exp2xml: "',trim(expr),'" "',trim(bibref) ! in tlow is after "= " ! write(*,*)'3E exp2xml: ',len_trim(expr) ! write(*,*)'3E exp2xml: ',trim(expr) lrange=.FALSE. ip=index(expr,'= ')+2 tlim8=expr(ip:) jp=index(tlim8,' ') tlim8(jp:)=' ' line=' <'//trim(tag)//' Id="'//expr(1:ip-3)//'"' kp=len_trim(line) ! write(*,*)'3E line 1A: ',line(1:kp) if(tlim8.ne.lowtdef) then line(kp+2:)=' LowT="'//trim(tlim8)//'" Expr="' else ! Default LowT line(kp+2:)=' Expr="' endif kp=len_trim(line)+2 ! write(*,*)'3E line 1B: >',line(1:kp),'<' ! find space after lowT limit ... ! write(*,*)'3E space1: ',expr(1:ip),ip ! ip=ip+index(expr(ip:),' ')-1 ip=ip+index(expr(ip:),' ') ! write(*,*)'3E after space: ',expr(ip:ip+20) ! ip is after lowT in expr and kp is after Expr=" ! there can be breakpoints in T tranges: do while(.TRUE.) jp=index(expr(ip:),';') if(jp.le.0) then write(*,*)'Missing ; at end of expression',ip,jp write(*,*)'3E expr :',trim(expr(ip:)),':' stop endif ! write(*,*)'3E line 1C: >',line(1:kp),'<' ! write(*,*)'3E exp 2: ',expr(ip:ip+20),ip ! line(kp:)=expr(ip+1:ip+jp+1) ! problem here because initial sign disappeared!!! line(kp:)=expr(ip:ip+jp-1) ! write(*,*)'3E line 2: >',trim(line),'<' kp=kp+jp ip=ip+jp+1 ! HighT limit or more ranges? jp=index(expr(ip:),' Y ') if(jp.gt.0) then ! more ranges, save end of this range do not check highT limit tlim8=expr(ip:ip+jp-2) if(tlim8.ne.hightdef) then if(lrange) then line(kp:)='" HighT="'//expr(ip:ip+jp-2)//'" />' else ! there is a seconed or more ranges, the bibref should be part of TPfun tag line(kp:)='" HighT="'//expr(ip:ip+jp-2)//'" >' if(bibref(1:1).ne.' ') then kp=len_trim(line) line(kp:)=' Bibref="'//trim(bibref)//'" >' bibref=' ' endif endif else line(kp:)='" />' endif lrange=.TRUE. ! write(*,*)'3E line: ',trim(line) write(lut,10)trim(line) 10 format(a) nl=nl+1 nl=nl+1 ip=ip+jp+2 line=' ' else ! at the highT limit line(kp:)='" />' endif ! add the Bibref if there has not been any Tranges if(bibref(1:1).ne.' ') then kp=len_trim(line)-1 line(kp:)=' Bibref="'//trim(bibref)//'" />' endif ! ip=ip+jp+1 kp=len_trim(line) ! write(*,*)'3E line 7: ',trim(line) write(lut,10)line(1:kp) nl=nl+1 ! if there has been Trange tags then end the Parameter/Tpfun tag ! write(*,*)trim(line) if(lrange) then write(lut,10)' ' nl=nl+1 endif exit tranges endif ! loop if there are more tranges enddo tranges 1000 continue return end subroutine exp2xml !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\addtotable subroutine write_parameters !\begin{verbatim} subroutine write_parameters(lokph,lut,typ,nl) ! code below same as in list_all_data ... maybe make it a subroutine ... ! lokph is phlista index, lut is output unit ! typ 1 for screen, 2 for XML, nl counts number of lines written implicit none integer lokph,lut,typ,nl !\end{verbatim} integer parlist,ll,nsl,ij,ideg,typty,typspec,kk,kkx,iel,linkcon,nz,ics integer ncsum,ip,intpq,prplink,nint,lokcs,ik,jdeg,kkk,iqhigh,iqnext,lqq ! integer ilist(9), endm(15), lint(2,3) character text*2000,prop*32,funexpr*1000,phname*24,ch1*1,toopsp(3)*24 logical mqmqa,noelin1,subref ! This is the index of PARAMETER in xtdbtags integer, parameter :: xmlpartag=17 ! TYPE(gtp_property), pointer :: proprec TYPE(gtp_endmember), pointer :: endmemrec TYPE(gtp_interaction), pointer :: intrec ! a smart way to have an array of pointers TYPE intrecarray type(gtp_interaction), pointer :: p1 end TYPE intrecarray integer, parameter :: maxstack=20 TYPE(intrecarray), dimension(maxstack) :: intrecstack TYPE(gtp_fraction_set), pointer :: disfrap type(gtp_tooprec), pointer :: tooprec ! !-------------------------------------------------- ! return here to list disordered parameters ! write(lut,*)'' ! write(*,*)'3E In write_parameters',lokph,lut,typ phname=phlista(lokph)%name parlist=1 ics=1 ! tooptop=0 mqmqa=.FALSE. 100 continue ! parlist changed below for disordered fraction set if(parlist.eq.1) then endmemrec=>phlista(lokph)%ordered nsl=phlista(lokph)%noofsubl else ! write(*,*)'3E Listing disordred parameters 1',nsl endmemrec=>phlista(lokph)%disordered disfrap=>firsteq%phase_varres(lokcs)%disfra nsl=disfrap%ndd endif ! write(*,*)'3E Listing parameters 2, nsl=',nsl endmemberlist: do while(associated(endmemrec)) do ll=1,nsl ! ilist(ll)=emlista(lokem)%fraclinks(ll,1) ilist(ll)=endmemrec%fraclinks(ll,1) if(ilist(ll).gt.0) then if(parlist.eq.2) then ! what is disfra here??!! ! write(*,*)'3E disfra?: ',disfra%splink(ilist(ll)),& ! disfrap%splink(ilist(ll)) ! endm(ll)=disfra%splink(ilist(ll)) endm(ll)=disfrap%splink(ilist(ll)) else endm(ll)=phlista(lokph)%constitlist(ilist(ll)) endif else ! wildcard, write '*' endm(ll)=-99 endif enddo nint=0 ideg=0 text=' ' call encode_constarr(text,nsl,endm,nint,lint,ideg) if(gx%bmperr.ne.0) goto 1000 proprec=>endmemrec%propointer ptyloop: do while(associated(proprec)) ij=proprec%proptype if(ij.ge.100) then typty=ij/100 typspec=mod(ij,100) else typty=ij endif if(typty.gt.0 .and. typty.le.ndefprop) then prop=propid(typty)%symbol ! if(parlist.eq.2) then ! disordered endmember parameter ! DO NOT ADD D on disordered parameter identifiers ! kk=len_trim(prop)+1 ! prop(kk:kk)='D' ! endif if(btest(propid(typty)%status,IDELSUFFIX)) then ! property like ZZ&(phase,constituent array) ! the element index should be in typsepc iel=typspec if(iel.ge.0 .and. iel.le.noofel) then ! prop=propid(typty)%symbol prop=prop(1:len_trim(prop))//'&'& //ellista(elements(iel))%symbol else gx%bmperr=4082; goto 1000 endif elseif(btest(propid(typty)%status,IDCONSUFFIX)) then ! property like mobility, MQ&(phase,constituent array) ! the suffix is a constituent iel=typspec if(iel.gt.0 .and. iel.le.phlista(lokph)%tnooffr) then if(parlist.eq.2) then ! we must consider parlist, take disordered constituent list ! we have no current equilibrium record but can use firsteq!! ! lokcs=phlista(lokph)%linktocs(1) ! write(*,*)'3E: endmember typspec 1: ',iel ! write(*,*)'3E splink: ',disfrap%splink linkcon=disfrap%splink(iel) ! write(*,*)'3E: endmember typspec 2: ',linkcon ll=0 ! ll=1 ! linkcon has nothing to do with which sublattice, ignore ll ! if(linkcon.gt.disfrap%nooffr(1)) ll=2 prop=prop(1:len_trim(prop))//'&'& //splista(linkcon)%symbol ! write(*,*)'3E We are here',linkcon,disfrap%nooffr(1),ll prop=prop(1:len_trim(prop)) ! goto 120 goto 121 else linkcon=phlista(lokph)%constitlist(iel) if(linkcon.le.0) then write(*,*)'Illegal use of wildcard 1' gx%bmperr=4286; goto 1000 endif prop=prop(1:len_trim(prop))//'&'& //splista(linkcon)%symbol ! also add the sublattice number ... ncsum=0 do ll=1,phlista(lokph)%noofsubl ncsum=ncsum+phlista(lokph)%nooffr(ll) if(iel.le.ncsum) goto 120 enddo endif ! error if sublattice not found write(*,*)'Error in constituent depended parameter id' gx%bmperr=4287; goto 1000 ! jump here to append sublattice 120 continue ! write(*,*)'property 1: ',prop(1:10),ll if(ll.gt.1) then prop=prop(1:len_trim(prop))//'#'//char(ll+ichar('0')) ! else ! prop=prop(1:len_trim(prop))//'#'//char(ll+ichar('0')) endif 121 continue else write(*,*)'lpd 7B: ',iel,typty gx%bmperr=4082; goto 1000 endif endif else ! unknown property ... write(*,*)'unknown property type xx: ',ij,typty,typspec prop='ZZ' endif ! note changes here must be repeated for interaction parameters below write(funexpr,200)prop(1:len_trim(prop)),& phname(1:len_trim(phname)),text(1:len_trim(text)) 200 format(A,'(',A,',',A,') ') ip=len_trim(funexpr)+1 ! check if FNN MQMQA parameter ... if(mqmqa) then ! ilist is index in fraction list, same as index in mqmqa_data%contyp ! intpq=ilist(1) ! write(*,*)'3E check if SNN parameter',intpq,& ! mqmqa_data%contyp(5,intpq) if(mqmqa_data%contyp(5,ilist(1)).le.0) goto 203 endif if(typ.eq.1) then ! subtract reference states if(subref .and. typty.eq.1) then call subrefstates(funexpr,ip,lokph,parlist,endm,noelin1) if(noelin1) then ! this can happen for ionic liquids with just neutrals in sublattice 2 ! replace the constituent in sublattice 1 with "*" !!! ! write(*,*)'before: ',funexpr(1:ip) kk=index(funexpr,',') ik=index(funexpr,':') funexpr(kk+1:)='*'//funexpr(ik:) ip=len_trim(funexpr)+2 ! write(*,*)'after: ',funexpr(1:ip) endif endif endif 203 continue ! this writes the expression as for a TDB file call list_tpfun(proprec%degreelink(0),1,funexpr(ip:)) ! write(*,*)' >>>> fun? ',trim(funexpr(ip:)),lut ip=len_trim(funexpr) if(len_trim(proprec%reference).le.0) then funexpr(ip+1:)=' Default ' else funexpr(ip+1:)=' '//proprec%reference endif ip=len_trim(funexpr) if(typ.eq.1) then ! nice output over several lines if needed with indentation 12 spaces call wrice2(lun,2,12,78,1,funexpr(1:ip)) else ! write(*,10)funexpr(1:ip) ! write(lut,10)funexpr(1:ip) ! this convert TDB expression to XTDB format, this is the Parameter tag ! call exp2xml(lut,funexpr,xmlel(xmlpartag),nl) call exp2xml(lut,funexpr,xtdbtags(xmlpartag),nl) endif proprec=>proprec%nextpr enddo ptyloop if(typ.eq.1) then if(btest(phlista(lokph)%status1,PHFORD).or. & btest(phlista(lokph)%status1,PHBORD)) then ! if(endmemrec%noofpermut.gt.1) then intpq=0 if(associated(endmemrec%intpointer)) then intpq=endmemrec%intpointer%antalint endif prplink=0 if(associated(endmemrec%propointer)) prplink=1 ! keep this output for the moment if(parlist.eq.1) write(*,207)endmemrec%antalem,& endmemrec%noofpermut,intpq,prplink 207 format('3E Endmember check: permut, interaction, pty: ',4i5) endif endif endmemrec=>endmemrec%nextem enddo endmemberlist ! write(*,*)'3E Finished listing endmember parameters',parlist,nsl !----------------------------------------------------------------------- ! parameters for interactions using site fractions if(parlist.eq.1) then endmemrec=>phlista(lokph)%ordered else if(.not.associated(phlista(lokph)%disordered)) & write(*,*)'3E Problems with disordered fraction set' endmemrec=>phlista(lokph)%disordered if(.not.associated(disfrap)) write(*,*)'3E disfrap problems!' nsl=disfrap%ndd ! write(*,*)'new nsl',nsl endif intlist1: do while(associated(endmemrec)) intrec=>endmemrec%intpointer if(associated(intrec)) then ! write(*,*)'intlist 1B: ',intrec%status do ll=1,nsl kkx=endmemrec%fraclinks(ll,1) if(kkx.eq.-99) then ! wildcard endm(ll)=-99 elseif(parlist.eq.2) then endm(ll)=disfrap%splink(kkx) else endm(ll)=phlista(lokph)%constitlist(kkx) endif enddo endif nint=0 intlist2: do while(associated(intrec)) nint=nint+1 if(nint.gt.maxstack) then write(*,*)'3E overflow in intrecstack 1' gx%bmperr=4399; goto 1000 endif intrecstack(nint)%p1=>intrec !-------------------------------------------------- lint(1,nint)=intrec%sublattice(1) kkk=intrec%fraclink(1) if(parlist.eq.2) then lint(2,nint)=disfrap%splink(kkk) else lint(2,nint)=phlista(lokph)%constitlist(kkk) endif proprec=>intrec%propointer ptyloop2: do while(associated(proprec)) ! typty=proprec%proptype ij=proprec%proptype if(ij.ge.100) then typty=ij/100 typspec=mod(ij,100) else typty=ij endif if(typty.gt.0 .and. typty.le.ndefprop) then prop=propid(typty)%symbol if(btest(propid(typty)%status,IDELSUFFIX)) then ! property like ZZ&(phase,constituent array) ! the element index should be in typsepc iel=typspec if(iel.ge.0 .and. iel.le.noofel) then prop=prop(1:len_trim(prop))//'&'& //ellista(elements(iel))%symbol else ! write(*,*)'lpd 7: ',iel,typty gx%bmperr=4082; goto 1000 endif elseif(btest(propid(typty)%status,IDCONSUFFIX)) then ! property like mobility MQ&(phase,constituent array) ! the suffix is a constituent iel=typspec if(iel.gt.0 .and. iel.le.phlista(lokph)%tnooffr) then if(parlist.eq.2) then ! we must consider parlist, take disordered constituent list ! we have no current equilibrium record but can use firsteq!! ! write(*,*)'3E: typspec: 3 ',typty,iel,prop(1:10) linkcon=disfrap%splink(iel) ! write(*,*)'3E: typspec: 4 ',typty,linkcon,prop(1:10) ll=1 if(iel.gt.disfrap%nooffr(1)) ll=2 prop=prop(1:len_trim(prop))//'&'& //splista(linkcon)%symbol goto 220 else linkcon=phlista(lokph)%constitlist(iel) if(linkcon.le.0) then ! write(*,*)'Illegal use of wildcard 2' gx%bmperr=4286; goto 1000 endif prop=prop(1:len_trim(prop))//'&'& //splista(linkcon)%symbol ! also add the sublattice number ... ncsum=0 do ll=1,phlista(lokph)%noofsubl ncsum=ncsum+phlista(lokph)%nooffr(ll) if(iel.le.ncsum) goto 220 enddo endif ! there cannot be any errors here .... ! write(*,*)'Never never error 2' gx%bmperr=4288; goto 1000 220 continue ! write(*,*)'property 2: ',prop(1:10),ll ! add sublattice index only if not unity if(ll.gt.1) then prop=prop(1:len_trim(prop))//'#'//char(ll+ichar('0')) endif else ! write(*,*)'lpd 7: ',iel,typty gx%bmperr=4082; goto 1000 endif endif else ! unknown property ... write(*,*)'unknown property type yy: ',typty prop='ZZ' endif ! note changes here must be repeated for endmember parameters above degree: do jdeg=0,proprec%degree if(proprec%degreelink(jdeg).eq.0) then ! write(*,*)'Ignoring function link' cycle degree endif call encode_constarr(text,nsl,endm,nint,lint,jdeg) write(funexpr,300)trim(prop),trim(phname),trim(text) 300 format(A,'(',A,',',A,') ') ip=len_trim(funexpr)+1 call list_tpfun(proprec%degreelink(jdeg),1,funexpr(ip:)) ip=len_trim(funexpr) ! default reference missing for excess parameters if(len_trim(proprec%reference).le.0) then funexpr(ip+1:)=' Default ' else funexpr(ip+1:)=' '//proprec%reference endif ! funexpr(ip+1:)=' '//proprec%reference ip=len_trim(funexpr) if(typ.eq.1) then call wrice2(lun,4,12,78,1,funexpr(1:ip)) else ! write(*,10)funexpr(1:ip) ! write(lut,10)funexpr(1:ip) ! This is the Parameter xml tag ! call exp2xml(lut,funexpr,xmlel(xmlpartag),nl) call exp2xml(lut,funexpr,xtdbtags(xmlpartag),nl) 10 format(a) endif enddo degree proprec=>proprec%nextpr enddo ptyloop2 ! list temporarily the number of permutations for FCC and BCC ordering pdebug: if(typ.eq.1) then if(btest(phlista(lokph)%status1,PHFORD).or. & btest(phlista(lokph)%status1,PHBORD)) then if(nint.eq.1) then nz=intrec%noofip(2) else nz=size(intrec%sublattice) lqq=intrec%noofip(size(intrec%noofip)) if(lqq.ne.nz) then write(*,*)'3E Not same 1: ',intrec%antalint,nz,lqq endif ! write(*,301)nz,intrec%noofip 301 format('noofip: ',10i3) ! nz=intrec%noofip(intrec%noofip(1)+2) endif iqnext=0 iqhigh=0 if(associated(intrec%highlink)) then iqhigh=intrec%highlink%antalint endif if(associated(intrec%nextlink)) then iqnext=intrec%nextlink%antalint endif prplink=0 if(associated(intrec%propointer)) prplink=1 ! keep this output for the moment if(parlist.eq.1) write(*,302)intrec%antalint,& nz,nint,iqhigh,iqnext,prplink 302 format('3E Inter check 1: id, permut, level, high, next, pty: ',& i5,i3,i3,i4,i4,i2) endif endif pdebug intrec=>intrec%highlink empty: do while(.not.associated(intrec)) if(nint.gt.0) then ! restore pointers in same clumsy way intrec=>intrecstack(nint)%p1 intrec=>intrec%nextlink ! write(*,*)'poping a pointer from intrecstack',ninit nint=nint-1 else exit intlist2 endif enddo empty enddo intlist2 endmemrec=>endmemrec%nextem enddo intlist1 ! write(*,*)'3E Finished listing interactions',parlist,nsl ! check if there are other fraction lists ! parlist=parlist+1, hm parlist can only be 1 or 2 ! write(*,*)'checking for disordered parameters' if(parlist.eq.1 .and. associated(phlista(lokph)%disordered)) then subref=.TRUE. ! lokcs=phlista(lokph)%cslink lokcs=phlista(lokph)%linktocs(ics) ! does this make a copy? Maybe it should be a pointer. IT IS A POINTER! disfrap=>firsteq%phase_varres(lokcs)%disfra if(.not.associated(disfrap)) then ! write(*,*)'disfrap OK' ! else write(*,*)'3E disfrap not set, expect segmentation fault?' endif nsl=disfrap%ndd ! write(*,810)disfrap%fsites,nsl write(lut,810)disfrap%fsites,nsl 810 format('') parlist=2 ! write(*,*)'3E Jump back to list disordered parameters',nsl,parlist goto 100 endif ! Check if there are toop/kohler ternaries tooprec=>phlista(lokph)%tooplast if(associated(tooprec)) then write(*,*)'3EX there are Toop/Kohler extrapolations' write(*,*)'There is some code in gtp3C.F90 to handle this' endif ! write(lut,*)'' ! write(*,*)'3E listing by write_parameters 1000 continue return end subroutine write_parameters !/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! !\addtotable subroutine debug_phaseparameters !\begin{verbatim} subroutine debug_phaseparameters(lokph,lut,ceq) ! code to debug a phase structure of parameters ! It follows the data structure as in calcg_internal in gtp3X.F90 ! lokph is phlista index, lut is output unit implicit none integer lokph,lut type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer lokres ! use composition set 1, phlista is protected inside GTP lokres=phlista(lokph)%linktocs(1) ! this call will eventually be replaced by call calcg_internal ! after setting a global debugpar variable. The subroutines ! debug_endmember and debug_intrec may be integrated in calcg_internal ! to ensure that any new data structures are followed write(*,*)'3EX In debug_phaseparameters',lut call list_phaseparameters(lokph,lut,ceq%phase_varres(lokres),ceq) return end subroutine debug_phaseparameters !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_phaseparameters !\begin{verbatim} subroutine list_phaseparameters(lokph,lut,cps,ceq) ! code to debug a phase structure of parameters ! It follows the data structure as in calcg_internal in gtp3X.F90 ! lokph is phlista index, lut is output unit implicit none integer lokph,lut type(gtp_equilibrium_data), pointer :: ceq type(gtp_phase_varres), target :: cps !\end{verbatim} ! Most declaration copied, some may not be needed integer fractype,epermut,maxprec,sameint,nprop,lokres,lokdiseq integer moded,nofc2,nsl,msl,qz,incffr(0:maxsubl),spmod,intlevel,ipermut ! TYPE(gtp_parcalc) :: gz TYPE(gtp_fraction_set), pointer :: fracset,dislink TYPE(gtp_phase_varres), pointer :: phres,phpart,phmain TYPE(gtp_property), pointer :: proprec TYPE(gtp_endmember), pointer :: endmemrec TYPE(gtp_interaction), pointer :: intrec ! array with intrec pointers type intstackarray TYPE(gtp_interaction), pointer :: save end type intstackarray type(intstackarray), dimension(5) :: intstack ! TYPE(gtp_pystack), pointer :: pystack ! TYPE(gtp_phase_add), pointer :: addrec ! to handle parameters with wildcard constituent and other things logical wildc,nevertwice,first,chkperm,ionicliq,iliqsave,iliqva,iliqneut integer, parameter :: permstacklimit=150 integer, dimension(permstacklimit) :: lastpmq,maxpmq integer pmq,nz ! write(*,*)'3EX in list_phaseparameters',lokph if(btest(phlista(lokph)%status1,PHMQMQA)) then write(*,*)'3EX phase has MQMQA model, no listing' goto 1000 endif spmod=0 if(btest(phlista(lokph)%status1,PHFORD) .or. & btest(phlista(lokph)%status1,PHBORD)) then ! PHPALM is needed for phases with permutations such as ordered FCC/BCC/HCP chkperm=.true. ! spmod tries to keep track of disordered/permutation of parameters? >10 permut spmod=10 if(.not.btest(phlista(lokph)%status1,PHPALM)) then ! write(*,*)'3X calling palmtree ',lokph,cps%phtupx ! This is needed only once unless parameters are changed. It numbers the ! interaction records sequ+entially for the permutations ! the subroutine palmtree is in gtp3Y.F90 for some unknown reason ... call palmtree(lokph) if(gx%bmperr.ne.0) goto 1100 write(lut,300)'Phase has parameter permutations' 300 format(a) ! this must be zeroed if a new interaction parameter is added ! phlista(lokph)%status1=ibset(phlista(lokph)%status1,PHPALM) endif endif !----------------------------------------------------------------- 50 continue ! local work arrays for products of Y and calculated parameters are allocated gz%nofc=phlista(lokph)%tnooffr ! ! dimension for number of parameter properties nprop=cps%nprop ! phres will point either to ordered or disordered results ! phmain will always point to record for ordered phase_varres phmain=>cps phres=>cps ! nsl=phlista(lokph)%noofsubl write(lut,10)trim(phlista(lokph)%name),phlista(lokph)%nooffs 10 format(a,' parameter structure with ',i3,' fraction sets') write(*,*)'3EX Inside list_phaseparameters ',phlista(lokph)%nooffs,nsl ! fractype=0 ! chkperm true if FCC/HCP or BCC permutation of ordered phases chkperm=.false. if(btest(phlista(lokph)%status1,PHFORD) .or. & btest(phlista(lokph)%status1,PHBORD)) then ! PHPALM is needed for phases with permutations such as ordered FCC/BCC/HCP chkperm=.true. if(.not.btest(phlista(lokph)%status1,PHPALM)) then ! write(*,*)'3X calling palmtree ',lokph,cps%phtupx ! This is needed only once unless parameters are changed. ! interaction records sequentially for the permutations write(*,*)'3EX parameter permutations initiated' call palmtree(lokph) if(gx%bmperr.ne.0) goto 1000 endif endif ! ! loop for different types of fractions: site fractions, mole fractions ... fractyp: do while(fractype.lt.phlista(lokph)%nooffs) ! 105 continue fractype=fractype+1 write(*,*)'3EX fraction type: ',fractype ! Jump back here for parameters in disordered fraction set (fractype>1) 110 continue fracset=>phmain%disfra ! code to handle phases with two fraction sets (Disordered_2Part and _3Part) ftype: if(fractype.eq.1) then odtest: if(btest(phlista(lokph)%status1,PHMFS)) then ! there is a disordered fraction set if(fracset%totdis.ne.0) then if(btest(phlista(lokph)%status1,PHSUBO)) then write(lut,300)'Phase has Disordered_2Part model' write(*,*)'Disordered_2Part model' goto 106 endif write(lut,300)'Phase has Disordered_3Part model' if(btest(phmain%status2,CSORDER)) then ! this is a Disordered_3Part model, the ordered part is calculated twice nevertwice=.false. ! else ! Disordered_3Part model and phase is disordered, skip ordered part (fractype=1) ! goto 105 ! When listing include the listing of ordered parameters ... endif endif endif odtest 106 continue ! initiate variables for disordered part gz%nofc=phlista(lokph)%tnooffr msl=nsl incffr(0)=0 do qz=1,nsl incffr(qz)=incffr(qz-1)+phlista(lokph)%nooffr(qz) enddo else ! parameters in disordered fraction set msl=fracset%ndd ! write(*,*)'3EX disordered fraction set',msl,associated(fracset) gz%nofc=fracset%tnoofxfr incffr(0)=0 do qz=1,msl incffr(qz)=incffr(qz-1)+fracset%nooffr(qz) enddo ! no need to handle fractions and derivatives dislink=>cps%disfra lokdiseq=dislink%varreslink phres=>ceq%phase_varres(lokdiseq) ! UNFINISHED: moded has no value here .... if(moded.gt.1) then nofc2=gz%nofc*(gz%nofc+1)/2 ! if(.not.allocated(phres%d2gval)) then ! allocate(phres%d2gval(nofc2,nprop)) ! endif ! phres%d2gval=zero endif endif ftype first=.true. ! ! HERE WE START FOLLOWING THE LINKS BETWEEN ENDMEMBERS ! ordered fraction set listed first if(fractype.eq.1) then endmemrec=>phlista(lokph)%ordered else endmemrec=>phlista(lokph)%disordered endif ! write(*,70)'3EX debug endmemberloop',nsl,msl,associated(endmemrec) !70 format(a,2i3,l3) ! write(*,*)'3EX we are here 1' ! write(*,*)'3EX number of permutations: ',endmemrec%noofpermut ! write(*,*)'3EX we are here 2' endmemloop: do while(associated(endmemrec)) ! Note all interaction are calculated inside this loop!!!! ! The array maxpmq is used for interaction permutations. It must be ! initialized to zero at the first endmember permutation. It is set to ! limits for the interacton permutations for all interaction records. maxpmq=0 maxprec=0 epermut=0 sameint=0 ! not implemented for MQMQA empermut: do while(epermut.lt.endmemrec%noofpermut) epermut=epermut+1 !---------------------------------------------------------- ! list endmembers call debug_endmemberpar(endmemrec,lut,lokph,msl,epermut,& fractype,ceq) !---------------------------------------------------------- if(gx%bmperr.ne.0) goto 1100 ! write(*,*)'Listed excess parameters ',& ! epermut,endmemrec%noofpermut ! Excess parameters based on this endmember, also permutations ... pmq=1 intlevel=0 intrec=>endmemrec%intpointer interloop: do while(associated(intrec)) ! return here if the interaction ?? maybe use cycle ? in gtp3X 200 continue ! each interaction has two pointer, to higher and to same level ! push link to same level on intstack and follow highlink intlevel=intlevel+1 intstack(intlevel)%save=>intrec%nextlink pmq=intrec%order ! write(*,*)'3EX interaction level ',intlevel ! this is label 220 also in gtp3X.F90 220 continue bford: if(chkperm) then ! complicated handling of permuted interaction parameter, see gtp3X,F90 ! copied from gtp3X.F90 setipermut: if(maxpmq(pmq).eq.0) then ipermut=1; lastpmq(pmq)=ipermut ! should I use gz%intlevel ?? maxpmq=intrec%noofip(intlevel) plimit: if(ipermut.gt.maxpmq(pmq)) then level: if(intlevel.eq.1) then maxpmq(pmq)=maxpmq(pmq)+intrec%noofip(1) elseif(intlevel.gt.2) then write(*,*)'3EX permutation max intlevel 2' gx%bmperr=4340; goto 1000 else varying: if(intrec%noofip(1).eq.1) then maxpmq(pmq)=maxpmq(pmq)+intrec%noofip(2) if(ipermut.le.maxpmq(pmq)) goto 230 else ! complicated, see gtp3X at same place .... nz=intrec%noofip(1) if(maxpmq(pmq).gt.0) then if(intrec%noofip(1).eq.2) then maxpmq(pmq)=-maxpmq(pmq) else nz=mod(ipermut-1,intrec%noofip(1)) if(nz.eq.0) then maxpmq(pmq)=maxpmq(pmq) else maxpmq(pmq)=maxpmq(pmq)+& intrec%noofip(nz+1) endif endif if(ipermut.le.maxpmq(pmq)) goto 230 else maxpmq(pmq)=intrec%noofip(2)-& maxpmq(pmq) if(ipermut.le.maxpmq(pmq)) goto 230 endif endif varying endif level if(associated(intrec%highlink)) then if(intlevel.eq.2) then write(*,*)'3EX too high interaction' gx%bmperr=4340; goto 1000 endif goto 290 endif if(intlevel.eq.0) exit interloop pmq=intrec%order nullify(intrec) goto 295 endif plimit 230 continue endif setipermut ! this value of ipermut should vary with permutations write(*,*)'3EX ipermut: ',ipermut lastpmq(pmq)=ipermut else ipermut=1 endif bford !---------------------------------------------------------- ! list excess parameters with permutationer ! subroutine debug_excesspar(intrec,lut,lokph,ipermut,intlevel,ceq) call debug_excesspar(intrec,lut,lokph,ipermut,intlevel,ceq) if(gx%bmperr.ne.0) goto 1000 !---------------------------------------------------------- ! jump to 290 take higher excess several times for same lower order permutation 290 continue ! jump to 295 take higher excess ?? 295 continue ! take highlink, if empty (not associated) pop intstack(level) intrec=>intrec%highlink nextint: do while(.not.associated(intrec)) ! write(*,*)'3EX no higher link',intlevel if(intlevel.le.0) then exit nextint endif ! intrec is set to the next interaction on same level, if empty decend furter intrec=>intstack(intlevel)%save intlevel=intlevel-1 enddo nextint enddo interloop ! loop the whole data structure for each permutation of this endmember!!! enddo empermut !----------------------------------------- ! Done all permutations and interaction of this endmember record endmemrec=>endmemrec%nextem ! write(*,*)'Next endmember',associated(endmemrec) enddo endmemloop ! ?? check how this is used in calcg_internal in gtp3X.F90 ?? write(*,*)'3EX Finished listing parameters for this phase' disord: if(fractype.eq.1 .and. btest(phlista(lokph)%status1,phmfs) & .and. btest(phmain%status2,csorder)) then ! we have traversing some of the parameter tree. returnoradd: if(first) then ! list (calculate) parameters in second (disordered) fraction set first=.false. ! in gtp3X we calculate for the first fraction set twice, now as disordered ! not needed for listing ! goto 110 ! else ! here gtp3X returns to sums the disordered and ordered results and ! maybe subtracs ordered as ordered. Not needed when listing endif returnoradd else ! Here adding the two fraction sets, skip when listing endif disord ! loop if more fraction types, fractype incremented when loop starts enddo fractyp !---------------------------------------------- ! original label ... 410 continue ! fractionsets: if(btest(phlista(lokph)%status1,phmfs)) then ! both ordered and disordered listed above ! write(*,*)'3EX Can be ignored?' ! endif fractionsets ! finished this phase 1000 continue write(lut,1010)trim(phlista(lokph)%name) 1010 format(/'End of listing for phase ',a/60('-')/) return ! if error 1100 write(*,*)'Some error: ',gx%bmperr goto 1000 end subroutine list_phaseparameters !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine debug_endmemberpar !\begin{verbatim} subroutine debug_endmemberpar(endmemrec,lut,lokph,msl,epm,fractype,ceq) ! code to write a debug list of endmembers ! lokph is phlista index, lut is output unit ! cps is phase_varres record, ceq is equilibrium record implicit none integer lut,lokph,msl,epm,fractype TYPE(gtp_property), pointer :: proprec TYPE(gtp_endmember), pointer :: endmemrec type(gtp_equilibrium_data), pointer :: ceq ! type(gtp_phase_varres), target :: cps !\end{verbatim} integer ll,idlist(9),id,ip,nsl character endmemconst*80 character props*60 TYPE(gtp_interaction), pointer :: intrec TYPE(gtp_pystack), pointer :: pystack TYPE(gtp_phase_add), pointer :: addrec ! to remember for fractset 2 save nsl ! ! write(*,*)'In debug_endmemberpar',msl endmemconst=':' ip=2 if(fractype.eq.1) then ! >>>>>>>>> to be added: special for I2SL ! save value of msl for use for fractype 2 nsl=msl pyqloop: do ll=1,msl ! id is sequatial index of constituent over all sublattices ... id=endmemrec%fraclinks(ll,epm) idlist(ll)=id if(id.lt.0) then endmemconst(ip:)="*:" ip=ip+2 else ! orderd or only fraction set has same constituents in sublattice 1 as ordered endmemconst(ip:)=& trim(splista(phlista(lokph)%constitlist(id))%symbol)//':' ip=len_trim(endmemconst)+1 endif enddo pyqloop else ! fractype 2, ! If msl=2 then constituents in first and last sublattice, else just in first ! this is SPECIES index, alphabetical order. Index in SPLISTA is SPECIES(..) idlist(1)=species(endmemrec%fraclinks(1,epm)) endmemconst=':'//trim(splista(idlist(1))%symbol)//':' if(msl.eq.2) then ip=len_trim(endmemconst)+1 ! write(*,*)'3EX 2nd disordered sublattice: ',idlist(2),species(idlist(2)) idlist(2)=species(endmemrec%fraclinks(2,epm)) endmemconst(ip:)=trim(splista(idlist(2))%symbol)//':' endif ! write(*,*)'Constituent: :',trim(endmemconst),idlist(1),idlist(2) endif ! proprec=>endmemrec%propointer write(*,*)'3EX Endmember: ',trim(endmemconst) write(lut,300,advance='no')trim(endmemconst) 300 format(5x,'Endmember ',a,i3) ! >>>>>>>> to be added: special for liquid2state if(associated(proprec)) then props=' ' id=1 do while(associated(proprec)) props(id:)=proprec%modelparamid id=len_trim(props)+2 proprec=>proprec%nextpr enddo ! this is added to the line with the constituents write(lut,310)epm,trim(props) 310 format(i3,', MPIDs: ',a) else write(lut,320)epm 320 format(i3,', none') endif 1000 continue return end subroutine debug_endmemberpar !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable debug_excesspar !\begin{verbatim} subroutine debug_excesspar(intrec,lut,lokph,ipermut,intlevel,ceq) ! code to debug list and endmember ! lokph is phlista index, lut is output unit ! cps is phase_varres record, ceq is equilibrium record implicit none integer lut,lokph,msl,epm,intlevel TYPE(gtp_property), pointer :: proprec TYPE(gtp_interaction), pointer :: intrec ! TYPE(gtp_endmember), pointer :: endmemrec type(gtp_equilibrium_data), pointer :: ceq ! type(gtp_phase_varres), target :: cps !\end{verbatim} integer nn,ll,isp,id character props*60 ! from gtp3X: integer ipermut,intlat,ic,pmq ! ! write(*,*)'3EX In debug_excesspar',intlevel,chkperm,ipermut intlat=intrec%sublattice(ipermut) ic=intrec%fraclink(ipermut) if(intlat.le.0 .or. ic.le.0) then write(*,*)'3EX illegal interaction constituent' gx%bmperr=4399; goto 1000 endif ! ic is a sequential index to constituent fractions ... not species index ! extract the species number from phmain ... ! iliqsave and iliqva used in gtp3X but not here as we do not calculate anything ! but we can have wildcards ... maybe?? isp=phlista(lokph)%constitlist(ic) ! write(*,10)'3EX excess constituent/sublattice ',isp,ic,& ! trim(splista(isp)%symbol),trim(splista(species(isp))%symbol) !10 format(a,2i4,' symbol: ',a,' or ',a) ! proprec=>intrec%propointer props='MPIDs: ' if(associated(proprec)) then id=8 do while(associated(proprec)) props(id:)=proprec%modelparamid id=len_trim(props)+2 proprec=>proprec%nextpr enddo endif if(len_trim(props).eq.6) props='none' write(*,100)intlevel,trim(splista(isp)%symbol),intlat,trim(props) write(lut,100)intlevel,trim(splista(isp)%symbol),intlat,trim(props) 100 format(10x,'Excess level ',i3,' ',a,'@',i1,', ',a) ! bford: if(chkperm) then ! internal loop for for permutations for FCC/HCP and BCC with this endmember ! write(*,*)'3EX this excess has permutations' ! endif bford 1000 continue return end subroutine debug_excesspar !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! ================================================ FILE: src/models/gtp3EY.F90 ================================================ !---------------------------- ! Reading the XTDB file with AppendXTDB: Models, parameters, TPfun and Biblio ! 1. All data on original file. It may have to be rewinded for missing TPfuns ! 2. One can select a subset of elements. All species which can form from ! this subset are entered. ! 3. An external Model file, this is read initially and never again ! 4. The original file is then read to the end and phases, parameters entered ! If TPfun missing the file may be rewinded and reread severel times ! until the number of missing TPfuns/bibitems are zero or constant. ! 5. One can have an external parameter file which will be read once. ! Needed parameters are entered and file closed. Preferably no TPfuns ! 6. One can have an external TPfuns file which is read and rewinded ! to extract missing TPfuns until no TPfun entered from this file. ! Warning of duplicates of same TPfuns. ! 7. One can have a file with biblitems which is opende if there are ! missing bibitems at the end. ! 8. If there ate missing TPfun or bibitem at the end that is reported. !---------------------------- ! ! The values for modelappy, parappy, tpfunappy, biblioappy initiates to 0 ! if there are no associated file: ! modelappy=1 if there is an AppendXTB Model file. Read once and set to zero ! parappy=1 if there is an AppendXTB parameter file. Read once and set to zero ! tpfunappy=1 if there is an AppendXTB TPfun file. Read once and ! incremented by one for each rewind. Stop rewinding and set to 0 ! when number of missing TPfuns is zero or do not decrease. ! biblioappy=1 if the is a biblogapy file. Read once and set to zero. ! allappy is 0 initially. It is set to 1 while reading parappy and tpfunappy ! files. If the masterfile is rewinded allappy is set to 2 o 3 ! to prevent reading anythng except TPfun/Trange and bibitem tags. ! !---------------------------- ! To do: ! 1. Clean up a bit, remove duplicate variables ! 2. Reread masterfile for TPfuns if no AppendXDB file ! 3. Store complete attribute for each tag in selxx temporary storage !------------------------------ ! ! Module xtdblib ! program to read an xml file, in particular XTDB ! implicit none ! this contais tags, attributes and some global variables ! #include "gtp3_xml.F90" ! ! integer nselph ! !================================================================== ! contains !================================================================== ! ! subroutines and functions ! ! xtdbread(masterfile) ! read a whole database. This may open and read other AppendXTDB files ! ! xtdbtag(unit,fline,tagname,matt,pretag,attributes) ! extract all attributes of tag from the file in sequential order. ! fline is the line number. The tag can depend om other nested tags. ! ! logical function getatt(line,ip,attname,value) ! extract sequentially the attributes and their values within "" from line ! The value should be all spaces and for the first attribute ip should be 1 ! ! - The important tags on a single XTDB file are: ! Model, Element, Species, Phase (and nested tags), Parameter, Tpfun, Trange ! but as a TPfun may use other TPfun the file may be rewinded to find all ! - A first sequential read will pick up all phases parameters selected but ! as TPfuns may call other TPfuns and it may be necessary to rewind the file. ! - The program keeps track of all needed TPfuns and may rewind to find them. ! - All bibliographic references are stored until reading the bibliography. ! - An AppendXTDB file for models is recommended if the database may be ! used by different software. ! ! For large databases the the primary XTDB file should contain all ! AppendXTDB, Element, Species, Phase (and nested tags) ! On separate AppendXTDB file one can have: ! a file sith model information ! a file with Parameter and Trange tags (which is read only once) ! a file with TPfun and Trange tags which is rewinded until all TPfuns extracted ! a file with bibliograpgic refenences (read once at the end) ! The Parameter file can contain TPfuns but it will not be rewinded ! The TPfun file may contain Parameters but it should be as short as possible ! as it may be rewinded several times. ! An AppendXTDB file should start with and end with ! ! The XTDB tags, attributes and some global data and variables ! are in gtp3_xml.F90 ! ! Some routines in this file: ! subroutine xtdbread(filename,nel,elnames) ! open filename and read an XTDB file including ApendXTDB files and ! extracts tag and data for nel elemsnte for storing in thermodynamic softaware ! if nel=0 the elements in the satabase is returned ! ! subroutine xtdbtag(unit,fline,tagname,matt,pretag,attributes) ! reads lines from unit until the end of attributes of a tag ! If matt=1 a nested tag found with tagname and attributes ! matt=0 a complete tag found with tagname and attributes ! matt=-1 the end of a nested tag found and some action needed ! Maybe pretag in not needed inside xtdbtag? ! ! logical function getatt(attributes,ip,attname,values) ! extracts sequentially from attributes the attname and its values using ip ! True if it finds and attribute ! ! logical function xeolch(line,ip) ! Skipping spaces and TAB characters in "line" from "ip". True if no data ! !* logical function check_mpid(mpid,phase) ! Check that phase has a model corresponding to the MPID of a parameter ! !-------------------------------------------------------- subroutine xtdbread(masterfile,nel,el) ! To read xtdb files and extract tags and attributes including nesting implicit none character*(*) masterfile character*2 el(*) integer nel ! if nel=0 extract all elements from database !---------------------------- ! Reading the XTDB file with AppendXTDB: Models, Parameters, TPfun and Biblio ! 1. All data on original file. It may be rewinded for missing TPfuns ! 2. If there is an external Model file it is read and closed before any data. ! 3. The original file is then read to EOF and phases, parameters and ! missing TPfuns and bibliographic refs are read. File will not be closed! ! DUPLICATE TPfuns will always be reported as errors, keeping first case. ! 4. If there is an external parameter file (WITHOUT ANY TPFUNS) this is ! opened and parameters needed are entered and the file closed at EOF. ! Any TPfuns found will be create a warning but entered if needed. ! This file will not be rewound. ! 5. If there is an external TPfuns file this is opened and read to extract ! missing TPfuns, it may be rewinded several times until no ! missing TPfun found and then it will be closed. ! 6. If there are TPfuns or biblitems missing the original XTDB file will ! be rewinded and read again until no missing TPfuns or bibitems found ! and the file closed ! 7. If TPfun or bibitem missing now that will be reported. !---------------------------- ! line is line read from file character line*256,tagname*64 ! tag attributes ! character(len=:), allocatable :: attributes ! this does not work ! character attributes*(1024) character(len=:), allocatable :: attributes ! the global character wholexpr is concatinated Expr for TPfun or Parameter ! The different files used for reading the XTDB files ! The database can be a single (primary) file or split on several files. ! All elements and phases and extra files must be in the primary file ! The extra files can define models, parameters, tpfuns and bibliography ! The model file is not needed but defines the MPIDs ! The parameter file should only have Parameter and Trange tags ! The tpfun file should only have TPfun and Trange tags ! The bibliography file should only have bibliograpgy and bibitem tags integer unit ! the current file used by xtdbget, any of those below integer, parameter :: unit1=21 ! main XTDB file, ! with everyting or just element and phases ! open the whole time, may be rewinded at the end integer, parameter :: unit2=22 ! parameter file read once and then closed integer, parameter :: unit3=23 ! tpfun file may be rewinded several times ! ! for nested tags level is current level, matt=0 if tagend missing (nesting) character pretag*24,values*256,attname*18 integer tagno,matt ! for storing data during nested tags, each at a higher level ?? needed integer, parameter :: maxatt=5 character*256, dimension(maxatt) :: saveatt ! tags with nested tagas are TPfun 1: Trange ! character phaseid*24 ! Phase sublattices, 10xconstituents, crystalstructure, amendphase, disord ...) character phid*24,phconfig*24,phmodels*128,phstate*1 ! check of missing tpfun and missingbib integer prevmisstp,prevmissbib ! extending an allocated variable ?? ! ! extending an allocatable and already allocated array (data(m)) ! data = [ data, ( 0, kk=1,n ) ] see ternary extrapolation! ! ! curent line in a database file (mater or AppendXTDB integer fline ! for tempraty storage of phase data integer phnsub,phisub character (len=:), allocatable :: lowt, default_lowt,tpfun character (len=:), allocatable :: hight,default_hight,expr character (len=:), allocatable :: parid,bibref character*16 usedtpfun ! is tpfun found in Expr of Parameter or TPfun logical listphases,add,ternaryxwarning ! handling of AppendXTDB ! The Models must be read first and only once ! The Parameters after reading the phases and only once ! The TPfun after all paramaters and maybe several times ! The Bibiliography read last and and only once ! Bibilographic references character(len=:), allocatable :: currentfile character ch1*1,spel*24,spname*24,stoichiometry*80,mqmqa*40,uniquac*12 character stoisp*40,refstate*40,phname*24 character(len=:), allocatable :: addon character(len=:), allocatable :: xpoldata ! for disorderedpart character (len=:), allocatable :: sum,disph,sub character*2 element ! ! for various purposes double precision mass, h298, s298 integer ip,iq,ir,is,it,level,prevlev,lk,kk,semicolon,lph,jp integer missbib,unknowntp,jel,skip,rewinds type(octerxpol), allocatable, target :: terxpol ! ! initiate position in arrays for storing selected information ! We automatically introdce Va ! We may have to order elements and species alphabetically!! nselel=0; nselsp=1; nselph=0; nselpar=0; nseltp=0; nselbib=0 ! software defaults default_lowt='298.15' default_hight='6000' debug=.false. rewinds=0 ternaryxwarning=.true. ! ! write(*,*)'3EY xtdbread: ',trim(masterfile),nel ! data for missing and found AppendXTDB, initiated to 0 below ! when specified set -1, while reading +1, when read 0 ! allappy initially set to 0, set to 1 when any other AppendXTDB file read if(nel.eq.0) then ! write(*,*)'Just to know which elements are in the database' ignorEOT=.true. else ignorEOT=.false. do jel=1,nel call capson(el(jel)) enddo write(*,8)(el(jel),jel=1,nel) 8 format(/'Extract data for: ',20(a,x)) ! array for bibliographic references, selbib, for selected parameter below ! allocate arrays for storing data, related to number of elements listphases=.true. maxtdbel=nel+2; maxtdbsp=10*nel*(nel-1); maxtdbph=5*nel*(nel+1); maxpar=20*nel*(nel+1)*(nel+2) maxtp=30*nel*(nel+1); maxbib=5*nel*(nel+1)*(nel+2) if(allocated(selel)) then ! deallocate all deallocate(selel) deallocate(selsp) deallocate(selph) deallocate(selpar) deallocate(seltpfun) deallocate(selbib) endif allocate(selel(-1:maxtdbel)) if(debug) write(*,9)'Dimensioning:',& maxtdbel,maxtdbsp,maxtdbph,maxpar,maxtp,maxbib 9 format(a,6i7) ! Always include Va and /- as element -1 and 0 selel(-1)%elname='/-'; selel(-1)%data=' ' selel(0)%elname='VA'; selel(0)%data=' ' allocate(selsp(maxtdbsp)) ! allocate(selspord(maxtdbsp)) allocated later selsp(1)%species='VA'; selsp(1)%data='VA'; selsp(1)%charge=0.0D0 ! needed for Va as species allocate(selsp(1)%elnames(1)); allocate(selsp(1)%stoicc(1)); selsp(1)%elnames='Va'; selsp(1)%stoicc(1)=1.0D0 ! allocate(selph(maxtdbph)) allocate(selpar(maxpar)) allocate(seltpfun(maxtp)) allocate(selbib(maxbib)) endif ! When just returning all elements jel=0 ! AppendXTB files allappy=0 modelappy=0; parappy=0; tpfunappy=0; biblioappy=0 prevmisstp=0; missingtp=0; prevmissbib=0; missingbib=0 ! nselbib=0 ! ! write(*,*)'Opening XTDB file: ',trim(masterfile) unit=unit1 fline=0 open(unit,file=masterfile,& access='sequential',form='formatted',status='old') ! zero main file line number currentfile=masterfile ! zero position in characters containing attributes attpos=0 attributes=' ' tpfun=' ' ! initiate tag nesting level=0 matt=0 pretag=' ' xtdberr=0 nomorelements=.FALSE. ! ! big loop for reading everything !============================================================== readall: do while(.true.) ! only one tag per line, attributes can be on following lines if(line(1:2).eq.'' !========================= handling end of nested tags elseif(matt.eq.-1) then !========================= nested TPfun ========= ! if matt=-1 the line is end of nested pretag, decrease level !!?? ! write(*,*)' >>>Nested tag end: "',& ! trim(tagname),'" pretag: "',trim(pretag),'" ',level,fline if(trim(pretag).eq.'' .or. trim(pretag).eq.'') then !================== end of file: or ! Here we are at the end of the primary file or an AppendXTDB file ! The ModelXTDB is read when found, the other will be opened for read here if(debug) write(*,*)'End of file for: ',trim(currentfile) prevmisstp=missingtp missingtp=0 do ntp=1,nseltp if(seltpfun(ntp)%status.lt.0) missingtp=missingtp+1 enddo prevmissbib=missingbib missingbib=0 do ntp=1,nselbib if(selbib(ntp)%status.lt.0) missingbib=missingbib+1 enddo if(debug) then write(*,*)'Number of TPfuns found and missing:',nseltp,missingtp write(*,*)'Number of bibitem found and missing:',& nselbib,missingbib ! The principal XTDB file is not closed, it may be rewinded in the end write(*,47)parappy,tpfunappy,biblioappy,allappy 47 format('Any AppendXTDB files to read?',4i3) write(*,*)'Press return to continue 1',tpfunappy read(*,'(a)')ch1 endif ! if there is an AppendXTDB for Parameters read that now! ! The Parameter file is done first (well actually the ModelAPpendXTDB) if(parappy.eq.1) then if(debug) write(*,*)'Appending Parameter file: ',trim(parappx) !---------------------------------------------------------- ! allappy set to unity indicate only parameter, tpfun and trange tags allowed allappy=1 ! parappy set to 0 as it it read only once parappy=0 unit=unit2 fline=0 open(unit,file=parappx,access='sequential',& status='old',form='formatted') if(debug) write(*,*)' *** Opened ',trim(parappx),' line',fline currentfile=parappx ! Now read parameters from appendixfile cycle readall elseif(tpfunappy.eq.1) then !----------------------------------------------- tpfuns ! if there is an AppendXTDB for Tpfuns read that, maybe including rewinds ! This file may have to be rewinded if there are unknown TPfuns ! missingtp and missingbib set to zero initially ignorEOT=.true. allappy=2 tpfunappy=tpfunappy+1 if(unit.eq.unit2) then ! We may not have opend any parameterappendix but of so, close it if(debug) write(*,*)'Closing append file: ',trim(parappx) close(unit2) endif if(debug) write(*,*)'Appending TPfun file: ',trim(tpfunappx) unit=unit3 fline=0 open(unit,file=tpfunappx,access='sequential',& status='old',form='formatted') if(debug) write(*,*)' *** Opened ',trim(tpfunappx) currentfile=tpfunappx ! Now read TPfuns from appendixfile cycle readall elseif(tpfunappy.ge.2) then !----------------------------------------- maybe rewind the TPfun file? ! we may have to rewind the TPfunappx file if there are unknown TPfuns if(debug) write(*,401)nseltp,prevmisstp,missingtp 401 format('Of ',i4,' TPfun missing changed from ',i4,' to ',i4) if(missingtp.gt.0 .and. missingtp-prevmisstp.gt.0) then prevmisstp=missingtp if(debug) then write(*,*)'Press return to Rewind ',trim(tpfunappx) read(*,'(a)')ch1 endif ! Rewind appendixfile and read again (maybe several times) ! as TPfuns may use other TPfuns fline=0 rewind(unit) cycle readall else ! The number of missing TPfuns does not decrease after rewinding ! Either all TPfuns found or the missing are not on tpfunappx if(debug) write(*,*)'Closing tpfunfile: ',trim(tpfunappx) tpfunappy=0 close(unit) endif ! if there is a biblioappy read this here ! It is also read in the following elseif but that is outside this scope if(biblioappy.gt.0) then fline=0 if(debug) write(*,410)trim(biblioappx) 410 format(/'Appending bibliography 1: ',a) ! the file is opended and read separatelym only bibitems allowed biblioappy=0 call xtdbbiblio(biblioappx) if(debug) write(*,*)'Back from reading bibliography' missingbib=0 do ntp=1,nselbib if(selbib(ntp)%status.lt.0) missingbib=missingbib+1 enddo ! if there are missing tpfuns and/or biblographics rewind and read the main file if(missingtp.gt.0 .or. missingbib.gt.0) then if(debug) write(*,491)missingtp,missingbib,masterfile 491 format('Missing data, ',2i4,' rewinding: ',a) ! allappy=3 means only Bibitem and TPfun tags read ignorEOT=.true. allappy=3 fline=0 unit=unit1 currentfile=masterfile rewind(unit) cycle readall endif elseif(missingtp.gt.0 .or. missingbib.gt.0) then ! a final try rewinding and rewind and read again from primary file rewinds=rewinds+1 ! write(*,*)'Rewinding masterfile A',rewinds unit=unit1 currentfile=masterfile rewind(unit) cycle readall endif elseif(biblioappy.eq.1) then ! We can be here if there is no AppendXTDB for TPfuns ! if there is an AppendXTDB for bibliography read that now! ! There may also be a tag in the main file? if(debug) write(*,*)'Appending bibliography: ',trim(biblioappx) biblioappy=0 call xtdbbiblio(biblioappx) if(debug) write(*,*)'Back from reading bibliography' prevmisstp=missingtp missingtp=0 do ntp=1,nseltp if(seltpfun(ntp)%status.lt.0) missingtp=missingtp+1 enddo prevmissbib=missingbib missingbib=0 do ntp=1,nselbib if(selbib(ntp)%status.lt.0) missingbib=missingbib+1 enddo if(missingtp.gt.0 .and. missingtp-prevmisstp.gt.0) then ! to avoid rewind masterfile forever prevmisstp=0 fline=0 if(debug) write(*,*)'Found missing data, rewinding: ',& masterfile,fline ! we must ignore all tags except TPfun/Trange and Bibitem allappy=3 rewinds=rewinds+1 ! write(*,*)'Rewinding masterfile B',rewinds unit=unit1 currentfile=masterfile rewind(unit) cycle readall else ! time to close when TPfuns as well as masterfile rewinded fline=0 if(debug) write(*,321)trim(masterfile) 321 format('3EY Finished reading XTDB file: ',a) unit=unit1 goto 990 endif else ! reading bibliography AppendXTB if there is no AppendXTDB for TPfuns if(debug) write(*,*)'Applied all AppendXTDB (or none)' missingtp=0 do ntp=1,nseltp if(seltpfun(ntp)%status.lt.0) missingtp=missingtp+1 enddo prevmissbib=missingbib missingbib=0 do ntp=1,nselbib if(selbib(ntp)%status.lt.0) missingbib=missingbib+1 enddo if(rewinds.gt.0.and.missingtp.eq.0) write(*,324)trim(masterfile) 324 format('All TPfuns found, closing ',a) ! if(missingtp.gt.0 .and. missingtp-prevmisstp.gt.0) then if(missingtp.gt.0 .and. rewinds.lt.3) then allappy=3 fline=0 rewinds=rewinds+1 write(*,322)missingtp-prevmisstp,trim(masterfile),rewinds 322 format('3EY Missing ',i3,' TPfuns, rewinding: ',a,i3) ! try reading the masterfile once again, ! write(*,*)'Rewinding masterfile C',rewinds currentfile=masterfile unit=unit1 rewind(unit) cycle readall else ! time to close when there is no TPfuns file and masterfile has been rewinded if(debug) then write(*,*)'Finished 2, closing: ',trim(masterfile) write(*,491)missingtp,missingbib,masterfile write(*,321)trim(masterfile) endif unit=unit1 write(*,*)'Closing file 1' goto 990 endif endif !========================= Below handling end of nested tags elseif(trim(pretag).eq.'') then ! a nested tag has the end of tag on a single line !======================== end of nested and Trange ! simple TPfun without Trange are entered below ! check if the TPfun should be add(ed) (used in a Parameter or other TPfun call xtdbentertpfun(tpfun,add) if(add) then call OCentertpfun(tpfun) ! the expression is stored in the global wholexpr endif elseif(trim(pretag).eq.'') then !======================== end of Phase, always nested ! The end of Phase tag (always nested) wholexpr=phrec%confent//' '//phrec%state//' '//phrec%clist(1)%list ! inside OCenterphase the phase may be added to selph if constituents entered call OCenterphase(phrec) ! write(*,201)fline,phrec%id,phrec%confent,phrec%state,& ! phnsub,phrec%mult 201 format(/'Collected all phase data: ',i7/& 'Phase name: ',a,5x,a,5x,a,5x,i2,5x,a) ! do ip=1,phnsub ! write(*,202)phrec%clist(ip)%subx,phrec%clist(ip)%list 202 format('Sublattice: ',a,' Constituents: ',a) ! enddo !>>>>>>> create record for phase and store data in OC <<<<<<<<<<<<< ! clear for next phase by deallocate the whole phrec deallocate(phrec) elseif(trim(pretag).eq.'') then !======================== end of Sublattices tag, part pf Phase ! Update level here for next tag, done separately here as code is messy ! Note that the ') then !========================= end of nested Parameter, may include Trange ! The end of a nested Parameter tag, non-nested parameters treated below ! A nested parameter contains Trange records ! write(*,*)'Found end of nested add ',bibref ! the ' N ' to be compatible with TDB files ... add bibref inside xtdbOCfun ! NOTE wholexpr is an allocated character wholexpr=wholexpr//' N' if(.not.allocated(bibref)) bibref=' ' call OCenterpar(parid,skip,bibref) ! if skip negative the parameter is not entered elseif(trim(pretag).eq.'') then !========================= end of nested Bibliography, nothing to do continue ! write(*,*)' End of Bibliography' else ! still with matt=-1, nested tags without special action ... ! write(*,667)trim(tagname),trim(pretag),matt,level,allappy, fline ! Probably end of file ... if(debug) write(*,*)'End of file at ',fline continue 667 format(' Unknown end of nested tag: "',a,'" "',a,'"',5i7) endif !============================ prepare to read next tag, matt=-1 ! We have to decrease the nesting level and prepare for reading a new tag level=level-1 if(level.gt.0) then ! it must be wrong to set pretag same as tagname ?? pretag='' else ! Level 0 means we have read the whole xtdb file, we should never be here ! write(*,*)'We have read past end of ' continue endif cycle readall ! Done all for end of nested tag, matt=-1 !============================ end of actions for all nested tags, matt=-1 endif ! Here matt=0 or 1, maybe we need to save attributes ! write(*,660)trim(tagname),trim(pretag),matt,fline 660 format('660 Tag: "',a,'" pretag "',a,'" ',i3,i7) ! if(matt.ge.0) then if(tagname(1:1).eq.' ') then ! This should not appear ! for rewind of masterfile it is OK if(allappy.eq.0) write(*,*)'xtdbtag found no tag on line ',& fline,matt,allappy cycle readall endif else ! we have found the end of a nested tag write(*,*)'Handle end of nested tag: ',trim(tagname),matt,level,fline endif ! check if we have reached endoffile, maybe rewind and read again? if(fline.lt.0) then ! unless there are errors one should never come here write(*,*)'Closing file 3' goto 990 endif !======================================= select case for a new tag ! The tags and attribues are defined in gtp3_xml.F90 lk=len_trim(tagname)+1 tagno=0 findtag: do kk=1,nxtdbtags ! compare ignoring trailing spaces if(tagname(1:lk).eq.xtdbtags(kk)(1:lk)) then tagno=kk; ! Abbreviated tags not allowed if(xtdbtags(kk).eq.' ') exit findtag endif enddo findtag ! write(*,99)tagname(1:lk),tagno,fline,level,matt 99 format('99 Tag: ',a,', number',i3,', line: ',i7,', level: ',2i3) ! ! ! detect tag !------------------------------------------ select case(tagno) !------------------------------------------ case default ! process the XTD tag, sometimes nested tags depend on previous attributes write(*,*)' *** Unknown tag ignored: <',trim(tagname),'>' !------------------------------------------ case(1) ! XTDB ip=1; values=' ' ! write(*,*)'XTDB: ' ! the getatt function extracts attribute name and value sequentially from ip do while(getatt(attributes,ip,attname,values)) if(debug) write(*,38)trim(attname),trim(values) 38 format(3x,'Att: ',a,' = ',a,i5) enddo !------------------------------------------ case(2) ! Defaults ip=1; values=' ' ! write(*,*)'Defaults: ' do while(getatt(attributes,ip,attname,values)) ! these should replace the software defaults such as LowT and HighT ! write(*,38)trim(attname),trim(values) if(attname(1:8).eq.'Bibref') defaultbib=values enddo ! lowT and highT should be used for parameters and TPfuns !------------------------------------------ case(3) ! DatabaseInfo ip=1; values=' ' ! write(*,*)'DatabaseInfo: ' ! do while(getatt(attributes,ip,attname,values)) ! write(*,38)trim(attname),trim(values) ! enddo !------------------------------------------ case(4) ! AppendXTDB ip=1; values=' ' ! write(*,*)'AppendTDB files: ' do while(getatt(attributes,ip,attname,values)) ! this will extract the attributes in any order ! write(*,38)trim(attname),trim(values) ! save appfiles in appropriate variables (declared in gtp3_xml ! negative *appy means it is has to be done if(attname(1:6).eq.'Models') then modelappx=trim(values) modelappy=1 endif if(attname(1:10).eq.'Parameters') then parappx=trim(values) parappy=1 endif if(attname(1:6).eq.'TPfuns') then tpfunappx=trim(values) tpfunappy=1 endif if(attname(1:12).eq.'Bibliography') then biblioappx=trim(values) biblioappy=1 endif ! Not implemented. Maybe useful for non-thermodynamic data? ! if(attname(1:13).eq.'Miscellaneous') then ! miscappx=trim(values) ! miscappy=-1 ! endif enddo ! list AppendXTDB file set ! write(*,*)'AppendXTDB: ',modelappy,parappy,tpfunappy,biblioappy ! if there is a Models appendix read that now! if(modelappy.eq.1) then call xtdbmodels(modelappx) ! setting modelappy=0 means we have read it ! The other AppendXTDB files opened after reading the primary file once modelappy=0 endif !------------------------------------------ case(5) ! Element, 5 attributes. some may be missing ... ! ip=1; values=' '; mass=1.0D0; h298=0.0D0; s298=0.0D0 ! do while(getatt(attributes,ip,attname,values)) ! write(*,38)trim(attname),trim(values) ! if(attname(1:2).eq.'Id') tpfun=trim(values) !------------------------------------------ case(6) ! Species ip=1; values=' ' ! we need to know the elements of the species mqmqa=' '; uniquac=' ' do while(getatt(attributes,ip,attname,values)) ! write(*,38)trim(attname),trim(values) if(attname(1:2).eq.'Id') spname=trim(values) if(attname(1:13).eq.'Stoichiometry') stoisp=trim(values) if(attname(1:5).eq.'MQMQA') mqmqa=trim(values) if(attname(1:7).eq.'UNIQUAC') uniquac=trim(values) enddo ! write(*,*)'Calling OCenterspecies: ',trim(spname),'" "',& ! trim(stoisp),'"' ! in OCenterspecies there is a check if species can be formed from elements call OCenterspecies(spname,stoisp,mqmqa,uniquac) !------------------------------------------ case(7) ! TPfun ip=1; values=' ' if(matt.eq.0) then ! matt=0 means no nested tags, matt=-1 is taken care of earler ! We may have to read all TPfuns several times until all used has been found ! matt=0 means there are no nested tranges lowt=default_lowt hight=default_hight do while(getatt(attributes,ip,attname,values)) ! write(*,38)trim(attname),trim(values) if(attname(1:2).eq.'Id') tpfun=trim(values) if(attname(1:4).eq.'LowT') lowt=trim(values) if(attname(1:4).eq.'Expr') expr=trim(values) if(attname(1:5).eq.'HighT') hight=trim(values) enddo ! semicolon is accepted and added if not present semicolon=len_trim(expr) if(expr(semicolon:semicolon).eq.';') then expr(semicolon:semicolon)=' ' semicolon=semicolon-1 endif ! terminate with N as in TDB files wholexpr=lowt//' '//expr(1:semicolon)//'; '//hight//' N' ! check if the TPfun is needed, tpfun is Id of selph(lph)%terxpol allocate(selph(lph)%terxpol) selph(lph)%terxpol%next=>xpol xpol=>selph(lph)%terxpol else allocate(selph(lph)%terxpol) nullify(selph(lph)%terxpol%next) xpol=>selph(lph)%terxpol endif ! no need to save the phase name, the data is linked from the phase xpol%phase=phname xpol%sps=addon(3:) xpol%xpol=xpoldata elseif(allocated(phrec)) then ! the phase is not (yet) selected (maybe the xpol tag is inside the phase tag) if(.not.associated(firstxpol)) then ! this is the first TernaryXpol without a selected phase allocate(firstxpol) nullify(firstxpol%next) xpol=>firstxpol else ! add the new Xpol record first allocate(xpol) xpol%next=>firstxpol firstxpol=>xpol endif ! enter data in xpol, we must use the phase name from current phase tag xpol%phase=trim(phrec%id) ! write(*,*)'TernaryXpol inside phasetag: "',& ! xpol%phase,'" "',addon(3:),'" "',xpoldata,'"' xpol%sps=addon(3:) xpol%xpol=xpoldata else write(*,*)'TernaryXpol for ',trim(phname),' ignored, line',fline cycle readall endif ! if we arrive here the constituents are OK but we may not have a phase (lph=0) ! write(*,*)'3EY TernaryXpol "',xpol%phase,'" ',lph !------------------------------------------ case(28) ! UnarySystem has no interest for the software write(*,*)'Found UnarySystems 28' !------------------------------------------ case(29) ! BinarySystem has no interest for the software write(*,*)'Found BinarySystem 29' !------------------------------------------ case(30) ! TernarySystem has no interest for the software write(*,*)'Found TernarySystem 30' end select !------------------------------------------ ! end of file but maybe rewind and read for some special tag? such as TPfun 900 continue ! write(*,*)'At label 900, select case: ',tagno cycle readall ! enddo readall ! errors and end of file- ignoreEOT is true if just extracting elements 990 continue ! write(*,*)'At label 990' if(.not. ignorEOT) then ! There can be TernaryXpol records not linked to a phase xpol=>firstxpol ! nullify(lastxpol) fixpol: do while(associated(xpol)) ! Either xpol will be linked to a selph(lph)%terxpol or igored ! write(*,*)'3EY There is an unlinked TernaryXpol for: ',xpol%phase ! write(*,*)'Calling findabbrphname 2: "',xpol%phase,'"' call findabbrphname(xpol%phase,lph) if(lph.le.0) then write(*,*)'Ignore TernaryXpol as ',xpol%phase,' not selected' if(.not.associated(lastxpol)) then xpol=>xpol%next endif else ! link the ternaryxpol to the phase write(*,*)'TernaryXpol included in phase ',& trim(selph(lph)%phasename) lastxpol=>xpol%next if(associated(selph(lph)%terxpol)) then xpol%next=>selph(lph)%terxpol else nullify(xpol%next) endif selph(lph)%terxpol=>xpol xpol=>lastxpol endif enddo fixpol ! if(debug) then ! write(*,*)'3Y End of file',unit write(*,993)nselel,nselsp,nselph,nselpar,nseltp,nselbib 993 format(/'3EY nselel ',i4,' nselsp ',i4,' nselph ',i4,& ' nselpar ',i4,' nseltp ',i5,' nselbib ',i4/) ! endif missingtp=0 do ntp=1,nseltp if(seltpfun(ntp)%status.lt.0) missingtp=missingtp+1 enddo prevmissbib=missingbib missingbib=0 do ntp=1,nselbib if(selbib(ntp)%status.lt.0) missingbib=missingbib+1 enddo endif if(debug .or. missingtp.gt.0 .or. missingbib.gt.0) then write(*,*)'Number of TPfuns and missing ones:',nseltp,missingtp write(*,*)'Number of bibref and missing ones:',nselbib,missingbib endif ! 999 continue close(unit) 1000 continue ! list or save all data in OC data structures if(.not.ignorEOT) then write(*,312)trim(masterfile),xtdberr 312 format(/'Listing of selected data from XTDB file: ',a,', error: ',i5) call list_selected_xtdbdata endif return 1100 continue write(*,*)'Error reading xtdbfile ',xtdberr goto 990 ! end subroutine xtdbread ! \/!\/!\/!\/!\/!/!\/!\/!\/!\/!/!\/!\/!\/!\/!/!\/!\/!\/!\/!/!\/!\/!\/!\/!/! subroutine list_selected_xtdbdata ! temporary listing from xtdb local arrays ! implicit none character line*128, charge*24, spline*24,ch1*1 integer jj,kk,ip,lk,nn type(octerxpol), pointer :: terxpol ! ! if(missingtp.gt.0) then ! write(*,491)missingtp,missingbib 491 format('Missing TPfuns, bibitems: ',2i4) ! endif ! write(*,12) 12 format(//'Finished reading the XTDB file, temporary listing') ! list all elements, species, phases with constit, parameters, tpfuns and biblio ! list all elements ------------------------------------------------- write(*,311) 311 format(//'Elements:') write(*,10)(selel(nn)%elname,nn=1,nselel) 10 format('Elements entered: ',20(a,1x)) ! ! list all species -------------------------------------------------- write(*,299) 299 format(/'Species:') if(allocated(selsp)) then do ntp=1,nselsp jj=selspord(ntp) charge=' ' if(jj.le.0) write(*,*)'3EY selspord: ',ntp,jj,selsp(ntp)%species if(selsp(jj)%charge.ne.0.0d0) & write(charge,'(F10.6)')selsp(jj)%charge spline=selsp(jj)%species if(allocated(selsp(jj)%elnames)) then nn=size(selsp(jj)%elnames) lk=27 do kk=1,nn write(line(lk:),23)selsp(jj)%elnames(kk),selsp(jj)%stoicc(kk) 23 format(a,2x,F10.7) lk=lk+15 enddo if(selsp(jj)%charge.ne.0.0D0)spline=trim(spline)//' charge '//charge else lk=len_trim(line) line(lk+3:)='MQMQA quad' endif write(*,24)ntp,trim(spline) 24 format('Species: ',i3,2x,a) enddo endif ! ! list all selected phases -------------------------------------------- write(*,*)'Press return to list selected phases' read(*,'(a)')ch1 write(*,298) 298 format(/'Phases:') do ip=1,nselph write(*,69)trim(selph(ip)%phasename),selph(ip)%confent,& selph(ip)%nsublat,trim(selph(ip)%mult),& trim(selph(ip)%const) 69 format('Phase: ',a,' cfg: ',a,' Subl: ',i2,' Mult: ',a/& ' Constituents: "',a,'"') if(allocated(selph(ip)%amendph)) write(*,76)selph(ip)%amendph 76 format(' AmendPhase: ',a) if(allocated(selph(ip)%dispar)) & write(*,'(" DisPart ",a)')selph(ip)%dispar terxpol=>selph(ip)%terxpol ! if(.not.associated(terxpol)) write(*,*)'No ternary methods' do while(associated(terxpol)) write(*,78)trim(selph(ip)%phasename),terxpol%sps,terxpol%xpol 78 format(' TernaryXpol Phase="',a,& '" Constituents="',a,'" Xpol="',a,'"') terxpol=>terxpol%next enddo enddo ! ! list all parameters selected --------------------------------------- write(*,*)'Press return to list selected parameters' read(*,'(a)')ch1 if(nselpar.gt.0) then write(*,63)nselpar 63 format(/'All ',i5,' parameters entered') do ip=1,nselpar if(len_trim(selpar(ip)%parname)+len_trim(selpar(ip)%data).gt.60) then write(*,72)ip,trim(selpar(ip)%parname),trim(selpar(ip)%data) 72 format(i4,2x,a,' ='/10x,a) else write(*,73)ip,trim(selpar(ip)%parname),trim(selpar(ip)%data) 73 format(i4,2x,a,' = ',a) endif enddo endif ! ! list asll TPfuns --------------------------------------------------- write(*,*)'Press return to list selected TPfuns' read(*,'(a)')ch1 if(nseltp.gt.0) then write(*,82)nseltp 82 format(/'All ',i5,' TPfun entered or missing (-1)') do ip=1,nseltp if(len_trim(seltpfun(ip)%data).le.50) then write(*,77)ip,seltpfun(ip)%tpfunname,seltpfun(ip)%status,& trim(seltpfun(ip)%data) 77 format(i3,2x,a,2x,i2,3x,a) else write(*,87)ip,seltpfun(ip)%tpfunname,seltpfun(ip)%status,& trim(seltpfun(ip)%data) 87 format(i3,2x,a,2x,i2/5x,a) endif enddo endif ! ! list all biteams --------------------------------------------------- write(*,*)'Press return to list selected bibilography' read(*,'(a)')ch1 if(nselbib.gt.0) then write(*,772)nselbib 772 format(/'All ',i4,' bibitems entered or missing (-1)') do ip=1,nselbib write(*,79)ip,selbib(ip)%bibitem,selbib(ip)%status,selbib(ip)%data 79 format('Bibitem ',i4,' "',a,'" ',i3/5x,a) enddo endif ! return end subroutine list_selected_xtdbdata ! \/!\/!\/!\/!\/!/!\/!\/!\/!\/!/!\/!\/!\/!\/!/!\/!\/!\/!\/!/!\/!\/!\/!\/!/! subroutine xtdbtag(unit,fline,tagname,matt,pretag,attributes) ! this subroutine extract a tag and its attributes from lines read from file. ! Tag begins with "" if no attributes, otherwise "" or "/>", the latter also means end of tag ! End of tag may be on a separate line as "/>" or if nested ! USING XEOLCH ! Attributes are one or more identifier="values" decoded in calling routine !------------------- ! character tagname*(*),pretag*(*),attributes*(*) character(len=:), allocatable :: attributes ! character attributes*(1024) character tagname*(*),pretag*(*) integer unit,fline,matt !------------- character line*512 integer ep,ip,jp,kp,tp,taglen,tagend,lines,lentagname logical comment,rewindtp ! problem initiating rewindtp? It should be false unless rewinding ! and the toggle rewind within TPfun tags save rewindtp !------- ! matt tagend meaning ! 0 -2 looking for ') then write(*,*)' *** Error, use of -- inside comment, line',fline xtdberr=4518 exit readtag endif ! we found end of multiline comment --> ! write(*,*)'End of multiline comment',fline attributes=' ' attpos=-1 comment=.false. ! skip rest of line if(len_trim(line).gt.ip+3) then write(*,103)fline 103 format('Skipping text trailing comment on line ',i7) endif ! reset line count for next tag tagend=-2 lines=0 endif cycle readtag !------- skip rest of line and cycle endif !================================================ ! use xeolch to find first character on line ip=1 if(xeolch(line,ip)) then ! if line empty read next line cycle readtag endif ! first character of a tag must be < if(line(ip:ip).eq.'<') then if(tagend.ne.-2) then write(*,*)' *** ERROR XTDB has only one tag per line,',fline xtdberr=4515; exit readtag endif if(line(ip:ip+3).eq.'').gt.0) comment=.TRUE. cycle readtag endif if(line(ip:ip+1).eq.', negative matt ! write(*,666)line(ip:ip+jp-1),trim(pretag),fline 666 format('PRETAG: "',a,'" "',a,'" ',i7) matt=-1 if(allappy.gt.1 .and. line(ip:ip+7).eq.'') then ! A TPfun with nested Trange, return as normal after clearing rewindtp rewindtp=.FALSE. endif elseif(allappy.gt.1) then ! we are rewinding file loocking only for ! write(*,*)'Ignore all endoftags except TPfun' if(line(ip:ip+7).ne.'') then cycle readtag endif elseif(allappy.le.1) then write(*,*)' *** Error, illegal end of tag, line',fline xtdberr=4514 endif ! just end of reading, maybe indicate an error? if(.not.(ignorEOT .or. (trim(line(ip:)).eq.trim(pretag)))) then if(allappy.eq.0) write(*,345)trim(line(ip:)),trim(pretag),fline 345 format('Found unexpected end of tag: "',a,'" "',a,'" ',i3,i7) endif exit readtag endif ! We have found a new tag. ! we can be after rewinding the master file. If so allappy=3 ! and only TPfuns or bibitem are accepted, ignore all other tags ! write(*,*)'Check rewinding: 1: ',allappy,rewindtp,trim(line) if(allappy.gt.1) then ! write(*,777)allappy,rewindtp,line(ip:ip+25),ip,matt,fline 777 format('Allappy ',i3,l3,' line "',a,'" ',3i5) if(line(ip:ip+7).eq.'') then ! Tag name end with > this is a tag without attributes but with nested tags ! skip any trailing text tagname=line(ip+1:ip+jp-3) ! write(*,*)'TAGNAME1: "',trim(tagname),'"' matt=1 exit readtag else tagname=line(ip+1:ip+jp-2) ! write(*,*)'TAGNAME2: "',trim(tagname),'"' endif ! we have found the tagname, tagend=-1 indicate attributes can be on next linws lentagname=len_trim(tagname) tagend=-1 ip=ip+jp endif ! we are looking for attributes in line after ip if(xeolch(line,ip)) then ! line empty and we have not found end of attributes cycle readtag else jp=index(line(ip:),'>') ! this indicate end of attributes if(jp.le.0) then ! no end of attributes, copy all to attributes and read next line if(ip.gt.0) then ! attributes(attpos+2:)=trim(line(ip:)) attributes=attributes//' '//trim(line(ip:)) attpos=len_trim(attributes) endif else ! Found > as end of attributes. maybe end of tag, matt=0 means no nested tags if(line(ip+jp-2:ip+jp-1).eq.'/>') then ! attributes(attpos+2:)=line(ip:ip+jp-3) attributes=attributes//' '//line(ip:ip+jp-3) matt=0 else ! If no end of tag nested tags may follow on next lines ! attributes(attpos+2:)=line(ip:ip+jp-2) attributes=attributes//' '//line(ip:ip+jp-2) tp=ip+jp+1 matt=1 ! check for rubbish and maybe full endoftag after rubbish if(.not.xeolch(line,tp)) then jp=index(line(tp:),'<') if(jp.gt.0) then ! The text has a <, if part of means end of tag write(*,69)line(tp+jp+1:tp+jp+lentagname),trim(tagname),tp 69 format('3EY Are "',a,'" and "',a,'" equal?',i7) if(line(tp+jp:tp+jp).eq.'/' .and. & line(tp+jp+1:tp+jp+lentagname).eq.trim(tagname)) then ! end of tag found after >, no nesting for this tag write(*,*)'3EY Trash found between > and tagend on line ',fline matt=0 else write(*,*)'3EY *** Error, new tag after > on line ',fline xtdberr=4766 exit readtag endif else ! ignore rubbish after > write(*,88)fline,trim(line) 88 format('3EY *** Rubbish after > line ',i7,& '. Quit reading.'/a/) xtdberr=4766 exit readtag endif endif endif ! we have found > or /> or exit readtag endif endif ! maybe add if(lines.gt.2) then ! check for tags with multiple lines if(tagname(1:1).eq.' ') write(*,104)fline-1 104 format('3EY *** Warning, line without tag, line ',i7) if(lines.gt.3 .and. matt.lt.0) write(*,106)fline-3 106 format('3EY *** Warning, very long list of attributes, line ',i7) endif enddo readtag ! puh................. 1000 continue ! write(*,1002)matt,fline,trim(tagname) 1002 format('Exiting xtdbtag: ',i2,i7,' ',a) return 1100 continue ! write(*,*)'End of file in xtdbtag' xtdberr=4700 fline=-1 goto 1000 end subroutine xtdbtag !\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! logical function xeolch(line,ip) ! identical to eolch in METLIB, except it can handle endofline !...End Of Line CHeck, TO SKIP SPACES/TAB FROM IP. RETURNS .TRUE. IF another character line*(*) integer ip ! integer, parameter :: itab=9 xeolch=.true. if(ip.le.0) ip=1 loop: do while(ip.le.len(line)) if(line(ip:ip).eq.' ' .or. ichar(line(ip:ip)).eq.itab) then ip=ip+1 else exit loop endif enddo loop ! with allocated characters there is maybe no space before EOL ! only when ip is larger than len(line) it returns true if(ip.le.len(line)) xeolch=.false. 900 RETURN END function xeolch !\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! logical function getatt(text,ip,attname,value) ! extract "values" of any XML "attname" in text from position ip character*(*) text,attname,value integer ip ! integer jp,kp,attlen ! getatt=.false. ! write(*,*)'3EY getatt 1',len(text) find: if(.not.xeolch(text,ip)) then if(text(ip:ip).eq.'=') exit find jp=index(text(ip+1:),'=') if(jp.gt.0) then ! the attname is terminated by a = (possibly preceeded by spaces) attname=text(ip:ip+jp-1) ! write(*,*)'3EY getatt 2 ',trim(attname) ip=ip+jp+1 if(.not.xeolch(text,ip)) then ! the values are preceeded by a " (possibly prceeded by spaces) if(text(ip:ip).eq.'"') then jp=index(text(ip+1:),'"') if(jp.gt.0) then value=text(ip+1:ip+jp-1) ip=ip+jp+1 getatt=.true. else xtdberr=4601 endif else xtdberr=4602 endif else xtdberr=4603 endif else xtdberr=4607 endif ! no error if line empty endif find return end function getatt !\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! logical function check_mpid(mpid,phase) ! check that phase has a model corresponding to the mpid of a parameter character*(*) mpid,phase ! integer np,ip ! 1. loop to find the phase ! 2. loop models for the phase to find one with the MPID ! 3. return TRUE if found, FALSE if not check_mpid=.FALSE. 1000 continue return end function check_mpid !\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! subroutine getxtdbatt(attname,text,ip,values) ! extract "values" of attribute "att" of "tag" from text at position ip character*(*) text,attname,values integer att,ip ! integer jp,kp,attlen ! seach for attribute att is the array with attributes attlen=len_trim(attname) ! write(*,*)'3EY getxtdbatt 1 >',text(ip:ip+25),'<',ip,attlen jp=index(text(ip:),attname(1:attlen)) if(jp.le.0) goto 1100 ! set jp to position after attname, the attribute must finish with =" jp=ip+jp+attlen-1 ! write(*,*)'3EY getxtdbatt 2 >',text(jp:jp+5),'<',jp if(text(jp:jp+1).ne.'="') goto 1110 kp=index(text(jp+2:),'"') ! write(*,*)'3EY getxtdbatt 3 >',text(jp:kp+5),'<',jp,kp if(kp.le.0) goto 1120 values=text(jp+2:jp+kp) ! update ip to position after " ip=jp+kp+1 ! 1000 continue ! write(*,*)'3EY exit getxtdbatt ',text(ip:ip+5),ip,xtdberr return ! cannot find attribute 1100 xtdberr=4501 goto 1000 ! attribute has no trailing =" 1110 xtdberr=4502 goto 1000 ! attribute value has no final " 1120 xtdberr=4503 goto 1000 end subroutine getxtdbatt !\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! ! xtdbinitmpid removed !\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! subroutine xtdbmodels(appfile) ! reads an AppendXTDB file with models and MPID ! may change a default MPID character*(*) appfile ! ! character(len=:), allocatable :: attributes ! character attributes*(1024) character(len=:), allocatable :: attributes character tagname*18,pretag*24,values*24,attname*24 integer unit,matt,lc,lt,ip,sm,mpid,level logical modeltag ! unit=26 write(*,5)trim(appfile) 5 format('In xtdbmodels reading: ',a) ! ! xtdbmpid is allocated in gtp3EX with 9 models ! fline=0 pretag=' ' open(unit,file=appfile,access='sequential',form='formatted',& err=1200,status='old') ! ! initiating xtdbmpid if(.not.allocated(xtdbmodel)) then ! maybe deallocate and allocate new? write(*,*)'Allocating model MPID' call xtdbinitmpid(nxtdbmpids) else write(*,*)'3EY using current model MPID' endif ! ! write(*,*)'Model file opened' level=0 modeltag=.false. pretag='' ! models: do while(.true.) if(fline.lt.0) exit models ! write(*,*)'Call with pretag "',trim(pretag),'"' call xtdbtag(unit,fline,tagname,matt,pretag,attributes) if(xtdberr.ne.0) goto 1100 ! write(*,10)trim(tagname),trim(attributes),fline,matt,modeltag 10 format('Model tag: "',a,'" att "',a,'"',i7,i3,l2) lt=len_trim(tagname)+1 ! make sure we prepare an endoftag ! This should use levels but here we have only Models and Bibliography if(matt.eq.1) then pretag='' level=level+1 elseif(matt.eq.-1) then level=level-1 ! write(*,*)'Leveling down: ',trim(tagname),' ',trim(pretag),level pretag='' ! at level 0 we close the file if(level.eq.0) goto 1000 endif if(.not.modeltag) then if(tagname(1:lt).eq.'Models ') then modeltag=.true. else ! write(*,*)'Expecting only nested modeltags' xtdberr=4700; goto 1100 endif cycle models endif if(matt.lt.0) then ! just skip the end of a model tag cycle models endif ! ! write(*,*)'Model tag "',tagname(1:lt),'" pretag "',trim(pretag),'"' ! tags expected are if(tagname(1:lt).eq.'Magnetic ') then !------------------------------------------! case(22) ! Magnetism ! write(*,40)trim(tagname),trim(attributes) 40 format('*** Addition: ',a,' "',a,'"') ip=1; values=' '; sm=0; mpid=0 do while(getatt(attributes,ip,attname,values)) lc=len_trim(values) ! write(*,38)trim(attname),trim(values),lc,ip 38 format(3x,'Att: "',a,'" = "',a,'" ',i3,i7) if(sm.eq.0) then ! first attribute must be modelid if(attname(1:2).eq.'Id') then do sm=1,3 if(values(1:lc).eq.xtdbmodel(sm)%modelid) exit enddo endif if(sm.le.0 .or. sm.gt.3) then ! write(*,*)'3EY Unknown magnetic model "',trim(values),'"' xtdberr=7777; goto 1000 endif elseif(sm.eq.1) then ! Hmmmm in this way the database can use different symbols for each phase ??? ! IHJBCC: second and third attribiures are MPD1 and MPD2 mpid=mpid+1 ! write(*,*)'Storing MPID in xtdbmodel',sm,mpid ! accept the name of the mpid in the XTDB file xtdbmodel(sm)%mpid(mpid)=trim(values) ! write(*,63)sm,mpid,xtdbmodel(sm)%mpid(mpid) 63 format('Model ',i1,', mpid',i1,' in xtdb file is: "',a,'"') elseif(sm.eq.2) then ! IHJREST: second and third attribiures are MPD1 and MPD2 mpid=mpid+1 xtdbmodel(sm)%mpid(mpid)=trim(values) ! write(*,63)sm,mpid,xtdbmodel(sm)%mpid(mpid) elseif(sm.eq.3) then ! IHJQX: second, third and forth attribiure, MPD1, MPD2 and MPD3 mpid=mpid+1 xtdbmodel(sm)%mpid(mpid)=trim(values) ! write(*,63)sm,mpid,trim(xtdbmodel(sm)%mpid(mpid)) endif ! skip bibitem if((mpid.eq.2 .and. sm.lt.3) .or. mpid.eq.3) exit enddo if(sm.eq.3) then ! write(*,67)tagname(1:lt),sm,trim(xtdbmodel(sm)%modelid),& ! trim(xtdbmodel(sm)%mpid(1)),trim(xtdbmodel(sm)%mpid(2)),& ! trim(xtdbmodel(sm)%mpid(3)) 67 format('Model tag: ',a,i3,' Id: "',a,'" MPIDs: ',3('"',a,'" ')) else ! write(*,66)tagname(1:lt),sm,trim(xtdbmodel(sm)%modelid),& ! trim(xtdbmodel(sm)%mpid(1)),trim(xtdbmodel(sm)%mpid(2)) 66 format('Model tag: ',a,i3,' Id: "',a,'" MPIDs: "',a,'" "',a,'"') endif elseif(tagname(1:lt).eq.'Einstein ') then !------------------------------------------ ! case(23) ! Einstein ! write(*,*)'Modelinfo Einstein 23' ip=1; values=' '; sm=4 do while(getatt(attributes,ip,attname,values)) ! write(*,38)trim(attname),trim(values) if(attname(1:4).eq.'MPID') xtdbmodel(sm)%mpid(1)=trim(values) enddo ! write(*,65)tagname(1:lt),sm,trim(xtdbmodel(sm)%modelid),& ! trim(xtdbmodel(sm)%mpid(1)) 65 format('Model tag: ',a,i3,' Id: "',a,'" MPIDs: "',a,'"') elseif(tagname(1:lt).eq.'Liq2State ') then !------------------------------------------ ! case(24) ! Liq2state ! write(*,*)'Modelinfo Liq2State 24' ip=1; values=' '; sm=5 do while(getatt(attributes,ip,attname,values)) ! write(*,38)trim(attname),trim(values) if(attname(1:5).eq.'MPID1') xtdbmodel(sm)%mpid(1)=trim(values) if(attname(1:5).eq.'MPID2') xtdbmodel(sm)%mpid(2)=trim(values) enddo ! write(*,66)tagname(1:lt),sm,trim(xtdbmodel(sm)%modelid),& ! trim(xtdbmodel(sm)%mpid(1)),trim(xtdbmodel(sm)%mpid(2)) elseif(tagname(1:lt).eq.'Volume ') then !------------------------------------------ ! case(25) ! Volume, not implemented ! write(*,*)'Modelinfo Volume 25' ip=1; values=' ' do while(getatt(attributes,ip,attname,values)) ! write(*,38)trim(attname),trim(values) enddo elseif(tagname(1:lt).eq.'EEC ') then !------------------------------------------ ! case(26) ! EEC ! write(*,*)'Modelinfo EEC 26' ip=1; values=' ' do while(getatt(attributes,ip,attname,values)) ! write(*,38)trim(attname),trim(values) enddo elseif(tagname(1:lt-1).eq.'Bibliography') then !------------------------------------------ ! write(*,*)' Ignoring bibliography of models, closing file' goto 1000 else !------------------------------------------ ! Models which has no MPID or is otherwise without model tag if(tagname(1:lt).eq.'DisorderedPart ') then ip=1; values=' ' do while(getatt(attributes,ip,attname,values)) ! write(*,38)trim(attname),trim(values) enddo ! write(*,*)' The DisorderedPart tag is used in the Phase tag' elseif(tagname(1:lt).eq.'Permutations ') then ip=1; values=' ' do while(getatt(attributes,ip,attname,values)) ! write(*,38)trim(attname),trim(values) enddo ! write(*,*)' The permutations Id is in AppendPhase Model attribute' elseif(tagname(1:lt).eq.'TernaryXpol ') then ip=1; values=' ' do while(getatt(attributes,ip,attname,values)) ! write(*,38)trim(attname),trim(values) enddo ! write(*,*)' TernaryXpol tags are specified for each ternary' elseif(tagname(1:lt).eq.'EBEF ') then ! write(*,*)' EBEF is indicated by the parameters of the phase' continue else ! write(*,*)'Model "',trim(tagname),'" not kown by software' continue endif endif ! enddo models !----------------- 1000 continue write(*,1005)trim(appfile),fline 1005 format('Closing model file: ',a,i7/) close(unit) 1010 continue return 1100 continue write(*,*)'Error ',xtdberr,' reset after reading ',trim(appfile) xtdberr=0 goto 1000 1200 continue write(*,*)'Error opening ',trim(appfile),' default MPID used' goto 1010 ! end subroutine xtdbmodels !\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! subroutine xtdbbiblio(appfile) ! Listing bibitems from appfile with bibitems inside a bibliography tag ! integer nselbib,maxbib character*(*) appfile character tagname*18,pretag*24 character(len=:), allocatable :: attributes ! character*1024 attributes character attname*24,values*128 ! character(len=:), allocatable :: attname,values integer unit,lc,ip,matt,nbib,lbib,found ! integer, dimension(:), allocatable :: notfound logical bibtag ! unit=25 fline=0 ignorEOT=.true. if(debug) write(*,5)nselbib,trim(appfile) 5 format(/'Trying to extract ',i5,' bibliographic references from: ',a,i7) open(unit,file=appfile,access='sequential',form='formatted',status='old') ! ! bibtag=.false. bibtag=.true. matt=0 found=0 bibitems: do while(.true.) call xtdbtag(unit,fline,tagname,matt,pretag,attributes) if(xtdberr.ne.0) goto 1100 !* write(*,10)trim(tagname),fline,matt,bibtag 10 format('Tag: "',a,'" ',i7,i3,l2) lc=len_trim(tagname)+1 if(.not.bibtag) then ! with allappy.gt.1 the bibliography will never be returned from xtdbtag!! if(tagname(1:lc).eq.'Bibliography ') then pretag='' bibtag=.true. else cycle bibitems endif else if(matt.eq.0) then ip=1; values=' ' if(getatt(attributes,ip,attname,values)) then ! extract the bibitem Id, no trailing spaces allowed !* write(*,544)trim(attname),trim(values) 544 format('Read from file: "',a,'" "',a,'"') ! Assume first attribute is "Id" ! if(attname(1:2).eq.'Id') then ! write(*,*)' *** bibitem: ',trim(values) find: do nbib=1,nselbib ! lbib=len_trim(selbib(nbib)%bibitem) ! write(*,555)values(1:lbib),trim(selbib(nbib)%bibitem),nbib 555 format('Compare "',a,'" "',a,'"',i7) ! if(values(1:lbib).eq.selbib(nbib)%bibitem) then if(values.eq.selbib(nbib)%bibitem) then ! This Id is used, extract the reference ! write(*,556)values(1:lbib),trim(selbib(nbib)%bibitem) 556 format('Found: "',a,'" "',a,'"') selbib(nbib)%status=1 found=found+1 ! We found the bibitem, extract the reference as next value, ignore attname if(getatt(attributes,ip,attname,values)) then ! write(*,50)selbib(nbib)%bibitem,values 50 format('Reference: ',a,' is ',a) selbib(nbib)%data=trim(values) exit find else write(*,60)trim(appfile),fline 60 format('3EY Formatting error file: "',a,'" line ',i7) endif endif enddo find endif endif endif ! make sure we prepare an endoftag enddo bibitems 1000 continue if(debug) write(*,*)'Found ',found,' relevant bibliographic references' close(unit) return ! errors model 1100 continue goto 1000 end subroutine xtdbbiblio !\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! subroutine addmissingtp(origin) ! extract TPfuns called inside wholexpr and add those missing to seltpfun ! with seltpfun(*)%status -1 character*(*) origin ! all variables global ! integer ip,jp,kp,ntp character symbol*16 ip=1 ! write(*,*)'Checking for new tpfuns' big: do while(ip.lt.len_trim(wholexpr)) ! istpfun extracts symbols inside wholexpr ip is updated inside istpfun call istpfun(wholexpr,ip,symbol) if(symbol(1:1).ne.' ') then do ntp=1,nseltp ! if(symbol.eq.alltpfun(ntp)) then if(symbol.eq.seltpfun(ntp)%tpfunname) then symbol=' ';cycle big endif ! write(*,55)ntp,ip,symbol,seltpfun(ntp)%tpfunname 55 format('seltpfun ',2i5,' "',a,'" and "',a,'"') enddo ! this symbol is missing ! write(*,*)' >>> addmissingtp tpfun: ',trim(symbol) nseltp=nseltp+1 ! write(*,60)trim(origin),trim(symbol),nseltp 60 format(' >>> TPfun used by "',a,'" added "',a,'" ',i4) seltpfun(nseltp)%tpfunname=symbol seltpfun(nseltp)%status=-1 endif enddo big 1000 continue return end subroutine addmissingtp !\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! subroutine istpfun(line,ip,symbol) ! extract unknown symbols (TPfuns) from an expression after position ip character line*(*),symbol*(*) integer ip !------ ! Strange error here when everyting was accepted as TPfuns .... integer jp,kp,mp character ch1*1 call capson(line) kp=0 ! write(*,*)'3EY Looking for tpfun in: "',trim(line),'"',ip,kp symbol=' ' ! write(*,*)'In istpfun',ip,trim(line),len(line) issymbol: do while(ip.lt.len_trim(line)) ! symbols must start with letter A-Z and can contain letters, digits and "_" ch1=line(ip:ip) ip=ip+1 ! write(*,*)'Testing "',ch1,'": symbol: "',trim(symbol),'" ',ip,kp if(ch1.ge.'A' .and. ch1.le.'Z') then ! first character must be a letter kp=kp+1 symbol(kp:kp)=ch1 ! write(*,*)'Acceping "',ch1,'": symbol: "',trim(symbol),'" ',ip,kp cycle issymbol elseif(kp.ge.1 .and. & ((ch1.ge.'0' .and. ch1.le.'9') .or. ch1.eq.'_')) then ! 2nd and later character can be number or "_" kp=kp+1 if(kp.gt.len(symbol)) then write(*,77)symbol,ip,kp,trim(line) 77 format('In istpfun: Too long symbol: "',a,'" ',2i4,' on line '/a) stop endif ! write(*,*)'Accept "',ch1,'": symbol: "',trim(symbol),'" ',ip,kp symbol(kp:kp)=ch1 ! write(*,*)'istpfun symbol: ',trim(symbol),kp,ip cycle issymbol elseif(kp.ge.2) then ! We found a character illegal in a symbols, check if in nottpfun if(kp.ge.2 .and. kp.le.4) then do mp=1,5 ! Skip symbols: LN LOG EXP ERF GEIN if(symbol(1:4).eq.nottpfun(mp)) goto 300 enddo ! symbol is not predefined function: LN LOG EXP ERF GEIN ! write(*,*)'reference to tpfun: ',trim(symbol),ip endif exit issymbol endif ! 300 continue symbol=' '; kp=0 enddo issymbol ! write(*,*)'istpfun found tpfun: "',trim(symbol),'" ',ip 1000 continue return end subroutine istpfun !\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! !\addtotable subroutine capson & Convert character to UPPER case !\begin{verbatim} ! SUBROUTINE capson(text) ! converts lower case ASCII a-z to upper case A-Z, no other changes ! implicit none ! character text*(*) !\end{verbatim} ! integer, parameter :: lowa=ichar('a'),lowz=ichar('z'),& ! iup=ICHAR('A')-ICHAR('a') ! integer i,ich1 ! DO i=1,len(text) ! ich1=ichar(text(i:i)) ! IF(ich1.ge.lowa .and. ich1.le.lowz) THEN ! text(i:i)=char(ich1+iup) ! ENDIF ! ENDDO ! END SUBROUTINE capson ! !\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! subroutine xtdbentertpfun(tpfun,add) ! check if TPfun is needed and of so enter it in seltpfun character*(*) tpfun logical add ! integer lentp,jj lentp=len_trim(tpfun) add=.false. do ntp=1,nseltp ! write(*,*)'3EY in xtdbentertpfun: ',& ! tpfun(1:lentp),' ? ',seltpfun(ntp)%tpfunname(1:lentp),' ',ntp if(tpfun.eq.seltpfun(ntp)%tpfunname(1:lentp)) then if(seltpfun(ntp)%status.eq.-1) then add=.true. seltpfun(ntp)%status=1 ! sometimes a final N has to be added .... ! write(*,10)1,trim(wholexpr) 10 format('In xtdbentertpfun: ',i2,' "',a,'"') jj=len_trim(wholexpr) if(wholexpr(jj:jj).ne.'N') then ! Wow, wholexpr is allocated an it must ne extended like this ... wholexpr=wholexpr(1:jj)//' N' ! write(*,10)2,trim(wholexpr) endif seltpfun(ntp)%data=trim(wholexpr) ! check if this TPfun need other TPfuns wholexpr is a global variable call addmissingtp(tpfun) goto 1000 endif endif enddo 1000 continue ! write(*,*)'exit xtdbentertpfun: ',add return end subroutine xtdbentertpfun !\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! subroutine xtdbaddbibref(bibref,selbib,nselbib,maxbib) ! adding new bibrefs to selbib if not already there integer nselbib,maxbib type(ocbib) :: selbib(*) character*(*) bibref integer nbib,lbib,kk,same lbib=len_trim(bibref) do nbib=1,nselbib if(bibref.eq.selbib(nbib)%bibitem(1:lbib)) goto 1000 enddo ! it is a new reference ! if(nselbib.gt.0) write(*,*)'Adding bibref: "',bibref,'" "',& ! trim(selbib(nselbib)),'"' if(nselbib.lt.maxbib) then nselbib=nselbib+1 selbib(nselbib)%bibitem=bibref selbib(nselbib)%status=-1 ! this is never written? write(*,*)' >>> xtdbaddbibref added: "',bibref,'"',nselbib else ! check if the same appears several times ... write(*,*)'Too many bibliographic references',nselbib same=0 do nbib=1,nselbib write(*,*)'Bibref: ',selbib(nbib)%bibitem do kk=1,nselbib if(kk.ne.nbib) then if(selbib(nbib)%bibitem.eq.selbib(kk)%bibitem) then write(*,*)'Duplicate reference',kk,nbib,selbib(kk)%bibitem same=same+1 endif endif enddo enddo write(*,*)'Duplicate references: ',same endif 1000 continue return end subroutine xtdbaddbibref !\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! ! Application (OC) dependent subroutines called by xtdbread !\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! subroutine OCenterel(spel,name,refstate,mass,h298,s298) ! subroutine OCenterel(spel,data) ! enter Element/species from the xtdb file. Name is full name in OC, ignored character spel*2,name*(*),refstate*(*) double precision mass,h298,s298 ! data is a text: Mass="5.199600E+01" H298="4.050000E+03" S298="2.354290E+01" ! /- and Va introduced automatically if(spel.eq.'/-' .or. spel.eq.'VA') goto 1000 if(nomorelements) then write(*,*)'No more elements allowed'; goto 1000 endif nselel=nselel+1 selel(nselel)%elname=spel selel(nselel)%data=' ' ! Hm alphabetical order!! later .... ! write(*,10)nselel,spel 10 format('Selected element; ',i2,2x,a) ! elements are also entered as species, except /- if(spel.ne.'/-') then nselsp=nselsp+1 selsp(nselsp)%species=spel selsp(nselsp)%data=spel allocate(selsp(nselsp)%elnames(1)) allocate(selsp(nselsp)%stoicc(1)) selsp(nselsp)%elnames(1)=spel selsp(nselsp)%stoicc(1)=1.0D0 selsp(nselsp)%charge=0.0D0 ! write(*,*)'Entering species ',spel,nselsp selsp(nselsp)%extra=' ' endif ! enter element also in OC, needed to check species and mqmqa quads ! element symbol, name, reference state, mass, h298, s298 call store_element(spel,name,refstate,mass,h298,s298) 1000 continue return end subroutine OCenterel !\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! subroutine OCenterspecies(spname,stoi,mqmqa,uniquac) ! enter Element/species in xtdb file implicit none character*(*) spname,stoi,mqmqa,uniquac ! this requires extracting the stoichiometry ... integer ia,ib,nel,kk,mel,kp character*2 el(10) double precision coef(10),qq ! this nend should be reinitiated when the NEW command integer, save :: nend=-1 ! qq=0.0D0 if(nomorelements) then write(*,*)'No more elements or species allowed'; goto 1000 endif if(mqmqa(1:1).eq.' ') then ! This is NOT MQMQA quad ! write(*,10)trim(spname),trim(stoi),nselsp 10 format('In OCenterspecies: "',a,'" stoi: "',a,'"',i4) ! check species is not a duplicate do ia=1,nselsp if(spname.eq.selsp(ia)%species) then ! write(*,*)'Species "',trim(spname),'" already entered' goto 1000 endif enddo ! extract the elements, the electron is included as /+/- here but removed below call extractstoi(stoi,nel,el,coef) if(xtdberr.ne.0) goto 1000 ! xtdberr=5000 means element not entered, this species should be ignored mel=nel ! The elements must already be entered! thissp: do ia=1,nel entered: do ib=1,nselel if(el(ia).eq.selel(ib)%elname) cycle thissp enddo entered if(el(ia).eq.'/+') then qq=coef(ia) mel=nel-1 elseif(el(ia).eq.'/-') then qq=-coef(ia) mel=nel-1 else ! this species has an unknown element, ignore it goto 1000 endif enddo thissp ! enter the species in OC call enter_species(spname, nel, el, coef) if(gx%bmperr.ne.0) goto 1000 ! enter the species in temporary here nselsp=nselsp+1 selsp(nselsp)%species=spname write(*,*)'3EY New species "',trim(selsp(nselsp)%species),'" ',nselsp ! Hm here I allocate a place for the electon, maybe use mel? allocate(selsp(nselsp)%elnames(mel)) allocate(selsp(nselsp)%stoicc(mel)) do ia=1,mel selsp(nselsp)%elnames(ia)=el(ia) selsp(nselsp)%stoicc(ia)=coef(ia) enddo ! charge if(qq.ne.0.0d0) then selsp(nselsp)%charge=qq ! Here I add charge as last constituent ! selsp(nselsp)%elnames(nel)='/-' ! selsp(nselsp)%stoicc(nel)=qq else selsp(nselsp)%charge=0.0D0 endif else !---------------------------------------------------- ! this IS AN MQMQA QUAD, code copied from gtp3E (for TDB) lines 3868-3888 call capson(spname) kp=index(spname,'/') if(kp.gt.0 .and. & spname(kp+1:kp+1).ge.'A' .and. spname(kp+1:kp+1).le.'Z') then ! this is an MQMQA quad, an ion has /+ or /- or /digit ! write(*,572)trim(spname),trim(mqmqa) 572 format('3EY Call mqmqa_species: "',a,'" "',a,'" ') ! mqmqa_species in gtp3B. It will check everything and enter the species in OC ! provided the elements are entered!!! call mqmqa_species(spname,mqmqa,nend) if(gx%bmperr.ne.0) then write(*,*)'3E error creating MQMQA quad',gx%bmperr goto 1000 endif endif ! write(*,*)'3EY spname modified? ',spname,nselsp ! modify the name nselsp=nselsp+1 selsp(nselsp)%species=spname ! if(eolch(longline,ip)) then ! if(.not.silent) write(kou,*)'WARNING No stoichiometry for species: ',& ! trim(name1) ! tdbwarning=.TRUE. ! write(*,*)'3E tdbwarning set true 3' selsp(nend)%extra=mqmqa endif ! if(uniquac(1:1).ne.' ') selsp(nselsp)%extra=mqmqa 1000 continue return end subroutine OCenterspecies !\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! subroutine extractstoi(spstoi,nel,el,coef) ! decode a species stoiciometry as element/number/ without spaces ! The element can be one or two letters and the number an integer, real ! or a quotent such as a/b: AL2O3 or ALO1.5 or ALO3/2 are the same species ! No parenthesis are allowed Al2(SO4)3 must be written Al2S2O12 ! The element names are case insensitve ! A single letter element must have a followng number (or a final space) ! A two letter element without a following number is assumbed to have unity ! A charge is /+ or /- followed by a digit ! character*(*) spstoi character*2 el(*) integer nel double precision coef(*) ! double precision stf,nom,kvot double precision, parameter :: one=1.0D0, zero=0.0D0 integer lens,kk logical ddot,slash,ion ! integer ip character ch1*1 ! debug=.false. ! debug=.true. call capson(spstoi) lens=len_trim(spstoi) ! if(lens.le.1) then ! write(*,*)'The stoichiometry must be at least 1 character!' ! xtdberr=5000; goto 1000 ! This can be a single element species with default stochiometry 1 ! coef(1)=one ! endif kvot=zero nom=one ion=.false. ! nel is incremeneter for each element, ip for each position in spstoi nel=0 ip=1 ch1=spstoi(ip:ip) ! lge and lle use ASCII character set if(.not.(LGE(CH1,'A') .AND. LLE(CH1,'Z'))) then write(*,10)trim(spstoi),ip,ch1 10 format(' *** Error in "',a,'" expected element at ',i3,' found "',a,'"') xtdberr=5001; goto 1000 endif !======================================= big extract loop extract: do while(.true.) ! The first letter of an element is in ch1 ! It can be first letter of a second element or ion / nel=nel+1 ! second character of element a space el(nel)=ch1 ! Set default stoichiometric factor to 1.0 stf=one ! default stochiometric factor coef(nel)=stf ip=ip+1 if(ip.gt.lens) exit extract ! this ch1 is the first character of el(nel), ch1 is updated below ! for ip=1 ch1 is always a letter but if(ch1.eq.'/') then if(ion) then write(*,14)trim(spstoi),ip 14 format('*** Error in "',a,'" species already charged.',i3) xtdberr=5017; goto 1000 endif ! This cannot be the first slement or a / in a factor as 1/3 ! But it can be the first letter of second element or ion "/" ! An ion, "/" must be followed by a + or - to represent an ion ! ip already incremented above if(ip.gt.lens) then write(*,11)trim(spstoi),ip 11 format('*** Error ending "',a,'" with /',i3) xtdberr=5011; goto 1000 elseif(spstoi(ip:ip).eq.'+' .or. spstoi(ip:ip).eq.'-') then ion=.true.; ddot=.true. ! This is an ion, set a default charge 1 ! write(*,300)trim(spstoi),ip,nel,(coef(kk),kk=1,nel) 300 format('Ion 1: "',a,'" ',2i3,10F8.3) el(nel)=spstoi(ip-1:ip) coef(nel)=one ! jump to extract a digit, the valence must be the end of an ion ip=ip+1 if(ip.gt.lens) exit extract ch1=spstoi(ip:ip) ! there cannot be any new elements after a /+ or /- goto 500 else write(*,13)trim(spstoi),ip 13 format('*** Error charge of "',a,'" must be "/+" or "/-" ',i3) xtdberr=5009; goto 1000 endif endif ! ip was incremented above, second letter of an element, a factor or charge ch1=spstoi(ip:ip) if(debug) write(*,*)'second letter 1: ',ch1,ip ! If second letter indicate an ion jump back to extract the whole symbol if(ch1.eq.'/') cycle extract if(lge(ch1,'A') .and. lle(ch1,'Z')) then ! this must be the second letter of the element ! Save full name, the charge taken care of above el(nel)(2:2)=ch1 ip=ip+1 if(ip.gt.lens) exit extract ch1=spstoi(ip:ip) ! if the next character is a letter cycle, otherwise coefficient if((lge(ch1,'A') .and. lle(ch1,'Z')) .or. ch1.eq.'/') cycle extract endif !------------------------------------- ! We arrive here to extract the stoichiometry or valency ! It can start with a digit or a decimal point ! reset the default stochiometry if(debug) write(*,*)'third letter 2: ',ch1,ip stf=zero; nom=1.0D0 ddot=.false.; slash=.false. ! jump here if ion 500 continue stf=zero coefficient: do while(.true.) if(debug) write(*,*)'third letter 3: ',ch1,ip if(ch1.eq.'.') then ! Handle a decimal point inside a real number if(ddot) then ! not allowed for ions either if(debug) write(*,20)trim(spstoi),ip 20 format('*** Error in "',a,'" two decimal dots ',i3) xtdberr=5002; goto 1000 ! the following numbers will be decimals endif ddot=.true. nom=1.0D-1 ip=ip+1 if(ip.gt.lens .and. stf.eq.zero) then ! stoichiometry ends with a ., if stf=0.0 no previous digit if(debug) write(*,30)trim(spstoi),ip 30 format('*** Error in "',a,'" missing stoichiometry ',i3) xtdberr=5003; goto 1000 endif ch1=spstoi(ip:ip) endif ! now there must be a number!!! if(debug) write(*,*)'third character 4: ',ch1,ip stoik: do while(lge(ch1,'0') .and. lle(ch1,'9')) ! extract stoiciometic factor digit by digit ! stf is the previous numbers in the stochiometric factor, initially 0.0 if(debug) write(*,*)'third character 5: ',ch1,ip if(ddot) then stf=stf+nom*(ichar(ch1)-ichar('0')) nom=1.0D-1*nom else stf=stf*nom+ichar(ch1)-ichar('0') nom=1.0D1*nom endif if(debug) write(*,35)'third character 6: ',ch1,ip,nel,stf,nom,kvot 35 format(1x,a,a,2i3,5F10.4) ip=ip+1 ! we have an element with a stochiometric factor, OK if no more ! the stoichometry of last element set after extract if(ip.gt.lens) exit extract ch1=spstoi(ip:ip) if(debug) write(*,36)1,ch1,ip,nel,stf,nom,kvot 36 format('fourth character ',i2,': "',a,'"',2i3,5F10.4) ! there can be a / in stoichiometry, for example in AlO3/2, This is not an ion if(ch1.eq.'/') then if(spstoi(ip+1:ip+1).eq.'+' .or. & spstoi(ip+1:ip+1).eq.'-') then ! this is not a division, it is the electone! goto 600 endif if(slash) then write(*,40)trim(spstoi),ip 40 format('**** Error in "',a,'" two slashes',i3) xtdberr=5004; goto 1000 endif slash=.true. if(ddot) then write(*,50)trim(spstoi),ip 50 format('**** Error in "',a,'" both slash and dot!',i3) xtdberr=5005; goto 1000 endif if(stf.eq.zero) then write(*,60)trim(spstoi),ip 60 format('**** Error in "',a,'" no digits before slash!',i3) xtdberr=5006; goto 1000 endif ! kvot is set to current value of stf, stf will be value to divide with kvot=stf stf=zero ip=ip+1 if(ip.gt.lens) then write(*,70)trim(spstoi),ip 70 format('**** Error in "',a,'" no digits after slash',i3) endif if(debug) write(*,16)2,ch1,ip,nel,stf,nom,kvot 16 format('Position ',i2,' letter "',a,'" ',2i3,10F8.4) ch1=spstoi(ip:ip) ! after a / there must be a digit, a "." or letter not allowed if(debug) write(*,16)3,ch1,ip,nel,stf,nom,kvot cycle stoik endif ! we have taken care of a / if(debug) write(*,16)4,ch1,ip,nel,stf,nom,kvot ! if ch1 is not a digit exit here. if(stf.eq.zero) then write(*,80)trim(spstoi),ip,ch1 80 format('*** Error in "',a,'" digit error at',i3,' "',a,'"') xtdberr=5009; goto 1000 endif enddo stoik if(debug) write(*,16)5,ch1,ip,nel,stf,nom,kvot ! there can be a . inside a stoichiometric factor followed by digits if(ch1.eq.'.') then if(slash) then write(*,50)trim(spstoi),ip xtdberr=5007; goto 1000 endif cycle coefficient endif 600 continue if(debug) write(*,16)6,ch1,ip,nel,stf,nom,kvot ! we have to calculate the stoichiometric factor ! If kvot=0.0 then coef is stf if(kvot.eq.zero) then coef(nel)=stf else coef(nel)=kvot/stf endif if(debug) write(*,16)7,ch1,ip,nel,stf,nom,kvot,coef(nel) stf=zero kvot=zero nom=one if(debug) write(*,16)8,ch1,ip,nel,stf,nom,kvot,coef(nel) cycle extract enddo coefficient ! We come here if ch1 is not a digit, it can be a letter or / or ??? if(debug) write(*,16)9,ch1,ip,nel,stf,nom,kvot,coef(nel) if(ch1.eq."/" .or. (ch1.ge.'A' .and. ch1.le.'Z')) cycle extract ! write(*,90)trim(spstoi),ip 90 format('*** Error in "',a,'" illegal character at ',i3) xtdberr=5023; goto 1000 enddo extract if(ip.gt.lens) then ! we have to calculate the stoichiometric factor ! If kvot=0.0 then coef is stf if(kvot.eq.zero) then coef(nel)=stf else coef(nel)=kvot/stf endif if(debug) write(*,16)8,ch1,ip,nel,stf,nom,kvot,coef(nel) endif ! ! write(*,*)'Leaving extractstoi: ',trim(spstoi),nel ! do ip=1,nel ! write(*,100)el(ip),coef(ip) 100 format('Element: "',a,'" Stochiomentry ',1pe16.6) ! enddo 1000 continue return end subroutine extractstoi !\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! subroutine OCenterphase(phrec) ! listing phase data to be entered in OC ! type(phnest), pointer :: phrec type(phnest) :: phrec integer ms,ns,ip,jp,js,lk character*24 constituent,ch1*1 character*1024 ccxx logical none,giveup ! if(.not.nomorelements) then ! when first phase enetered we cannot entoer more elements/species ! we should arrange elements and species in alphanetical order! nomorelements=.TRUE. call alphabetical_order endif ! ms=size(phrec%clist) ! write(*,7)trim(phrec%Id),ms,(phrec%clist(ns)%list,ns=1,ms) 7 format(/' in OCenterphase: ',a,'" ',i3/20(' "',a,'"')) ! we must check if the phase can exist, i.e. is there at least one ! entered species in each sublattice nselph=nselph+1 ! maybe not needed? ! allocate(cc(10)) ! write(*,*)'Try assigning ccxx' ccxx=' : ' ! write(*,*)'Success assigning ccxx' selph(nselph)%nsublat=ms selph(nselph)%mult=phrec%mult ! not any ternary extrapolation methods yet nullify(selph(nselph)%terxpol) sublatt: do ns=1,ms ! loop for all constituent in the phase in the database giveup=.false. none=.true. ! selph(nselph)%const(ns)=' ' ip=1 ! extract database constituents in sublattice ns from first position ! with allocated characters there are not always a space at the end!! lk=len_trim(phrec%clist(ns)%list) any: do while(.not.xeolch(phrec%clist(ns)%list,ip)) jp=index(phrec%clist(ns)%list(ip:),' ') ! write(*,*)'Loop sublattice ',ns,ip,lk,jp ! ip is start of constituent, find terminating space, if endofline ! ! big problem here because %list does not terminate with spaces ! one has to be careful with jp=0 as there are no trailing spaces .... if(jp.eq.0 .and. ip.le.lk) then constituent=phrec%clist(ns)%list(ip:lk) ! write(*,*)'Constituent ip:lk :',constituent,ip,lk ! giveup set to true here as jp=0 means it is tha last species on the line ! it would probably be safer to add a trailing space to %list giveup=.TRUE. jp=lk-ip+1 ! infinite number of problems here with C and V and character strings ! that does not terminate with spaces !!! SUCK else constituent=phrec%clist(ns)%list(ip:ip+jp-1) endif ! write(*,71)'Constituent: "',trim(constituent),'"',ip,jp,ip+jp,lk 71 format(a,a,a,5i3) ip=min(ip+jp,lk) do js=1,nselsp ! if the constituent is entered phase can exitst if(jp.gt.0) then ! write(*,*)ns,'compare: "',constituent(1:jp),& ! '" "',selsp(js)%species(1:jp),'"',ip,js ! wow V was accepted twice as it matched VA also .... if(constituent(1:jp).eq.trim(selsp(js)%species)) then ! this constituent is entered, append it to selph(nselph)%const ccxx=trim(ccxx)//' '//trim(constituent) ! write(*,*)'Saving constituent in ccxx',trim(ccxx) none=.false. endif else exit any endif enddo ! write(*,*)'Loop index ',ip,giveup if(giveup) exit any enddo any if(none) goto 1100 ccxx=trim(ccxx)//' : ' ! write(*,*)'Next sublattice: "',trim(ccxx),'" ',ns enddo sublatt ! there is at least one entered constituent in each sublattice in selph%const selph(nselph)%phasename=phrec%Id ! write(*,10)selph(nselph)%phasename,ms,trim(ccxx) 10 format('OK enter phase: ',a,i3,a) ! write(*,*)'The remaining problem is to transfer cc(1:mn) to selph%const!' selph(nselph)%const=trim(ccxx) selph(nselph)%confent=trim(phrec%confent) if(allocated(phrec%amendph)) then ! write(*,*)'Phase ',trim(phrec%id),' has models ',trim(phrec%amendph) selph(nselph)%amendph=phrec%amendph ! else ! write(*,*)'No amend phase allocated for: ',trim(phrec%Id) endif if(allocated(phrec%dispar)) then ! write(*,*)'Phase ',trim(phrec%id),' has dispart ',trim(phrec%dispar) selph(nselph)%dispar=phrec%dispar endif ! this is not needed, at the end the records in firstxpol will be searched ! xpol=>firstxpol ! nullify(lastxpol) ! look for any ternary extrapolations for this selph(nselph) ! if(associated(xpol)) then ! write(*,*)'3EY xpol: "',xpol%phase,'" and "',selph(nselph)%phasename.'"' ! if(xpol%phase.eq.selph(nselph)%phasename) then ! write(*,*)'3EY adding ternary method',xpol ! if(xpol.eq.firstxpol) then ! firstxpol=>xpol%next ! else ! xpol2=>xpol ! xpol2%next=>selph(nselph)%terxpol ! selph(nselph)%terxpol=>xpol2 ! endif ! xpol=xpol%next ! endif 1000 continue ! write(*,*)'Press return to continue' ! read(*,'(a)')ch1 ! return 1100 continue ! We arrive here there is a sublattice with no constituents entered in a subl ! The phase cannot be entered ! write(*,5)phrec%Id ! deallocate(selph(nselph)%const) 5 format('The phase ',a,' cannot exist in this system?') nselph=nselph-1 goto 1000 end subroutine OCenterphase !\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! subroutine alphabetical_order ! this should arrange elements and species in alphabetical order as in TDB integer nn,ia,ib,ic,mel,kk,jj character bytel*2,ch1*1,byt2*24 character*24, dimension(:), allocatable :: ss logical, save :: notdone=.true. integer, dimension(:), allocatable :: orig ! write(*,*)'In alphabetical order',notdone if(notdone) then ! write(*,*)'In alphabetical order to arrange elements and species'& ! ' in alphabetical order' notdone=.false. ic=1 ord1: do while(ic.gt.0) ic=0 ! element /- is -1 and Va is 0 do ia=1,nselel-1 if(selel(ia)%elname.gt.selel(ia+1)%elname) then ic=1 ! shift data in ia and ia+1, very clumsy selel(maxtdbel)%elname=selel(ia)%elname selel(maxtdbel)%data=selel(ia)%data selel(ia)%elname=selel(ia+1)%elname selel(ia)%data=selel(ia+1)%data selel(ia+1)%elname=selel(maxtdbel)%elname selel(ia+1)%data=selel(maxtdbel)%data endif enddo if(ic.eq.0) exit ord1 enddo ord1 ! write(*,10)(selel(nn)%elname,nn=1,nselel) 10 format('Elements entered: ',20(a,1x)) ! this is very clumsy ! write(*,*)'Order species alphabetically in selspord' ! allocate(selspord(nselsp+1)) ! allocate(ss(nselsp+1)) ! allocate(orig(nselsp+1)) allocate(selspord(maxtdbsp)) allocate(ss(maxtdbsp)) allocate(orig(maxtdbsp)) do ia=1,nselsp selspord(ia)=ia orig(ia)=ia ss(ia)=selsp(ia)%species enddo ! kk=0 ord2: do while(.true.) ! there is no /- species and Va is in alphabetical order ic=0 ! kk=kk+1 do ia=1,nselsp-1 ! write(*,*)'Comparing ',ia,' "',trim(ss(ia)),& ! '" and "',trim(ss(ia+1)),'"' if(ss(ia).gt.ss(ia+1)) then ic=1 byt2=ss(ia) ss(ia)=ss(ia+1) ss(ia+1)=byt2 jj=orig(ia) orig(ia)=orig(ia+1) orig(ia+1)=jj selspord(ia+1)=jj endif enddo if(ic.eq.0) exit ord2 enddo ord2 do ia=1,nselsp ! write(*,90)ia,trim(ss(ia)),orig(ia) ! selspord is in alphabetical order and has index to species selspord(ia)=orig(ia) enddo endif return end subroutine alphabetical_order !\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! subroutine OCenterpar(parname,skip,bibref) ! enter Parameter in OC if phase and constituents entered, FUNCTION IN wholexpr character*(*) parname,bibref ! bibfref can be just a space if not used integer skip ! return skip -1 or -2 if not needed ! character*24 phase, constituent character MPID*8 ! the call to addmissingtp should only be used if the parameter is entered character*24 phasename integer nn,lk,lm,ip,lph,kk ! Check that the parameter needed, i.e. phase and constituents entered ! write(*,7)trim(parname) 7 format(/'In OCenterpar: ',a) call checkifparisneeded(parname,lph) if(lph.lt.0) then ! lph=-1 means phase not entered ! if(lph.eq.-1) write(*,*)'Parameter not entered as phase not present' ! if(lph.eq.-2) write(*,*)'Parameter not entered as constituent missing' skip=lph goto 1000 endif !----------------------- ! Enter this parameter, the parameter may need new TPfuns, check wholexpr call addmissingtp(parname) ! ! enter expr with bibref and add bibref to be added wholexpr=wholexpr//' '//bibref nselpar=nselpar+1 if(nselpar.gt.maxpar) then write(*,*)'Too many parameters ',maxpar else selpar(nselpar)%parname=trim(parname) selpar(nselpar)%data=trim(wholexpr) endif ! if entered in OC then add bibref to selbibref lk=len_trim(bibref) if(lk.gt.0) then do nn=1,nselbib ! exit if already in selbib if(bibref.eq.selbib(nn)%bibitem(1:lk)) goto 300 enddo if(nselbib.ge.maxbib) then write(*,*)'Too many bibliographic references 2 ',maxbib ! check if the same appears several times ... do nn=1,nselbib write(*,*)'Bibref: ',selbib(nn)%bibitem do kk=1,nselbib if(kk.ne.nn) then if(selbib(nn)%bibitem.eq.selbib(kk)%bibitem) then write(*,*)'Duplicate reference',kk,nn,selbib(kk)%bibitem endif endif enddo enddo else nselbib=nselbib+1 selbib(nselbib)%bibitem=bibref ! mark this as missing selbib(nselbib)%status=-1 endif endif 300 continue ! exit here if parameter not needed 1000 continue return end subroutine OCenterpar !\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! subroutine checkifparisneeded(parname,lph) ! check if phase and constituents present in this parameter ! The phase name may be abbreviated between "_" characters implicit none character*(*) parname character*24 phasename,constituent character(len=:), allocatable :: mpid integer lk,lm,ln,lph,lcomma,lcolon,lsemic,lright,lend integer js,jmod,jmpid ! lph=0 lk=index(parname,'(') if(lk.le.0) then write(*,*)'3EY Missing ( in parameter: ',trim(parname) xtdberr=4544; goto 1000 endif mpid=parname(1:lk-1) ! write(*,*)'MPID: "',mpid,'"',lk ! check MPID is OK (must not be abbreviated) ! do ln=1,noofmpid ! if(mpid.eq.mpidok(ln)) goto 110 ! enddo !--------------------------------------------------------- ! VERY SPECIAL, always accept a single L as G. Even for endmembers ... if(mpid.eq.'L') mpid='G' if(mpid.eq.'G') goto 110 ! otherwise we have to find which model it belongs to ... !--------------------------------------------------------- ! There are 5 models with MPID, 3 magnetic, Einstein, liq2state do jmod=1,5 ! write(*,*)'Testing ',mpid,'. number of MPIDs for jmod ',& ! jmod,xtdbmodel(jmod)%nmpid do jmpid=1,xtdbmodel(jmod)%nmpid if(mpid.eq.xtdbmodel(jmod)%mpid(jmpid)(1:lk-1)) then ! write(*,*)'3EY Found model of MPID: "',mpid,'" is ',jmod,jmpid goto 110 endif ! write(*,108)mpid,xtdbmodel(jmod)%mpid(jmpid)(1:lk-1),jmod,jmpid 108 format('3EY MPIDs: "',a,'" and "',a,'" indices: ',2i4) enddo enddo ! now we use gtp_xtdbcompatibility: xtdbmodel ! we have an unknown MPID write(*,*)'3EY Unknown Model Parameter IDentification (MPID): "',mpid,'"' write(*,*)'Parameter: "',trim(parname),'"' xtdberr=4546 goto 1000 !--------------------------------------------------------- 110 continue ! there must be a , after the phase name lk+1 is the first letter lm=index(parname(lk+1:),',') if(lm.le.0) then write(*,*)'3EY Missing "," after phase name in parameter: ',trim(parname) write(*,*)'Parameter: "',trim(parname),'"' xtdberr=4545; goto 1000 endif ! phasename=parname(lk+1:lk+lm-1) lk=lk+lm+1 ! check this is a selected phase, allowing abbreviations ! write(*,*)'Calling findabbrphname 1: "',phasename,'"' call findabbrphname(phasename,lph) if(lph.le.0) then write(*,*)'Phase not selected "',phasename,'" parameter ignored' goto 1000 endif ! if lph>0 check also that the constituents are present in correct sublattices ! a comma deparates constituents in a sublattice, a colon in different ! the semicolon and ) is the end of constituents lcomma=index(parname(lk:),',') lcolon=index(parname(lk:),':') lsemic=index(parname(lk:),';') lright=index(parname(lk:),')') ! write(*,195)trim(parname(lk:)),lcolon,lcomma,lsemic,lright,lk 195 format('Constituent array "',a,'" ',5i5) if(lcomma.eq.0 .and. lcolon.eq.0) then ! the single constituent is terminated by ; or ) if(lsemic.eq.0) then ! there is always ) constituent=parname(lk:lk+lright-2) else ! if there is a ; that comes before ) constituent=parname(lk:lk+lsemic-2) endif ! write(*,*)'Constituent 1: ',trim(constituent) ! A wildcard * in a single sublattice phase (rare!) is accepted if(constituent(1:1).eq.'*') goto 500 do js=1,nselsp if(constituent.eq.selsp(js)%species) goto 500 enddo goto 1100 else ! we have to handle several sublattices and interacting constituents ! I do not understand the -4, I thought -2 would be correct if(lsemic.eq.0) then lend=lk+lsemic-4 else lend=lk+lright-4 endif ! write(*,*)'More: "',trim(parname(lk:)),'"',lcolon,lcomma,lend ! loop to extract all constituents terminated by , or : before lend more: do while(.true.) if(lcolon.gt.0 .and. lcomma.gt.0) then if(lcolon.lt.lcomma) then constituent=parname(lk:lk+lcolon-2) ! write(*,*)'Constituent 2: ',trim(constituent) lk=lk+lcolon lcomma=lcomma-lcolon ! lk is updated to position after the constutent found lcolon=index(parname(lk:),':') ! if(lcolon.gt.0) lcolon=lk+lcolon ! write(*,*)'Remaining: "',trim(parname(lk:)),'"',lk,lcolon,lcomma else constituent=parname(lk:lk+lcomma-2) ! write(*,*)'Constituent 3: ',trim(constituent) lk=lk+lcomma lcolon=lcolon-lcomma lcomma=index(parname(lk:),',') ! if(lcomma.gt.0) lcomma=lk+lcomma ! write(*,*)'Remaining: "',trim(parname(lk:)),'"',lk,lcolon,lcomma endif ! accept a wildcard "*" only if all other constituents selected if(constituent(1:1).ne.'*') then do js=1,nselsp if(constituent.eq.selsp(js)%species) cycle more enddo endif ! constituent is not not selected goto 1100 endif ! write(*,*)'Only comma or colon',lcolon,lcomma,lend if(lcolon.gt.0) then constituent=parname(lk:lk+lcolon-2) ! write(*,*)'Constituent 4: ',trim(constituent) lk=lk+lcolon lcolon=index(parname(lk:),':') ! if(lcolon.gt.0) lcolon=lk+lcolon ! write(*,*)'Remaining: "',trim(parname(lk:)),'"',lk,lcolon,lcomma elseif(lcomma.gt.0) then constituent=parname(lk:lk+lcomma-2) ! write(*,*)'Constituent 5: ',trim(constituent) lk=lk+lcomma lcomma=index(parname(lk:),',') ! if(lcomma.gt.0) lcomma=lk+lcomma ! write(*,*)'Remaining: "',trim(parname(lk:)),'"',lk,lcolon,lcomma else constituent=parname(lk:lend) ! write(*,*)'Constituent 6: ',trim(constituent),lk,lend,lsemic lk=lend endif ! always accept wildcard * if(constituent(1:1).eq.'*') goto 500 do js=1,nselsp if(constituent.eq.selsp(js)%species) then if(lk.eq.lend) then goto 500 else cycle more endif endif enddo ! constituent is not entered goto 1100 ! maybe there are more constituents, unless lk is lk is ge lend 200 continue if(lk.ge.lend) exit more cycle more enddo more endif ! we have the phase and species, enter parameter 500 continue ! write(*,*)'Phase and constituents OK' 1000 continue return ! parameter contain species not selected 1100 continue ! write(*,*)' *** Parameter skipped as constituent not selected ***' lph=-2 goto 1000 return end subroutine checkifparisneeded !\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! subroutine findabbrphname(phasename,lp) character phasename*(*) integer lp ! is position after phase name ?? or phase index?? !---------------- integer lpp,lpx,ok1,lenph logical debug character*1 chp,chx ! write(*,9)phasename 9 format('In findabbrphname: "',a,'"') debug=.false. lenph=len(phasename) ok1=0 ! index of any previous matching phase ! ! phase names may be abbreviated between each "_". ! It must start with A-Z ! An array with selcted phases in selph(array)%phasename ! It can be a bit complicated, the phase names are in arbitrary order lpp=0 ! position in phasename lp=1 ! array index in selph(array) lpx=0 ! position in selph(array)%phasename(lpx:lpx) bigloop: do while(.true.) lpp=lpp+1 if(lpp.gt.lenph) then ! this is lenght of provide phase and we have match up to this position, accept ! normally a phase name ends with a space but with allocated characters ... ! write(*,*)'Is "',phasename,'" same as "',selph(lp)%phasename,'"?' lph=lp; goto 1000 endif chp=phasename(lpp:lpp) lpx=lpx+1 chx=selph(lp)%phasename(lpx:lpx) ! if same character, compare next characters in lpp and lpx ! write(*,*)'Letters "',chx,'" "',chp,'" position ',lpp,lpx if(chp.eq.chx .and. chp.ne.' ') cycle bigloop ! The first character MUST be the same if(lpp.gt.1) then if(chp.eq.' ') then ! trailing characters in selph(lp)%phasename irrelevant but check ambiguous ! up to now we have found the same characters but it can be ambigous ... if(ok1.gt.0) then write(*,30)phasename,selph(ok1)%phasename,selph(lp)%phasename 30 format('Ambiguous phase name: "',a,'"'/'"',a,'" and "',a,'"') else ! save this then check the remaining phases ok1=lp; lp=lp+1; lpp=0; lpx=0 endif elseif(chp.eq.'_') then ! chx is not "_", skip in selph(lp)%ohasename up to "_". If no _ skip ! if we find a "_" continue compare the characters following this do while(chx.ne.'_') if(lpx.ge.len(selph(lp)%phasename)) then ! we have reached the end of selph(lp), skip this phase lp=lp+1; lpp=0; lpx=0 cycle bigloop endif lpx=lpx+1; chx=selph(lp)%phasename(lpx:lpx) if(chx.eq.' ') then ! we do not find any "_" but a space, skip this phase lp=lp+1; lpp=0; lpx=0 cycle bigloop endif enddo ! we found a "_" in selph(lp)%phasename. Backtrack both lpp and lpx lpx=lpx-1; lpp=lpp-1 cycle bigloop endif endif ! not the same character, compare with next phase in selph(array) lp=lp+1 if(lp.le.nselph) then lpp=0; lpx=0 cycle bigloop else ! we have compared with all phases in selph(1..nselph) if(ok1.gt.0) then ! write(*,*) 50 format('We found phase: "',a,'" and "',a,'"') lp=ok1 else lp=-1 endif exit bigloop endif enddo bigloop 1000 continue return end subroutine findabbrphname !\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! subroutine OCentertpfun(tpfuname) ! enter TPfun data in OC. MISSING check if needed. Function in wholexpr character*(*) tpfuname ! the call to addmissingtp should only be used if the parameter is entered integer nn ! check if tpfun uses other tpfun call addmissingtp(tpfuname) ! the wholexpr is a global variable ! add bibref here otherwise it may be entered as missing TPfun ! write(*,10)tpfuname,trim(wholexpr) 10 format('In xtdbOCfun: ',a,2x,a,2x,a) return end subroutine OCentertpfun !\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! subroutine OCenterbibitem(bibitem,text) ! enter referenced bibitem in OC character*(*) bibitem,text ! should only be used if the parameter is entered integer nbib,ll write(*,*)'In OCenterbibitem' ll=len_trim(bibitem) do nbib=1,nselbib if(bibitem.eq.selbib(nbib)%bibitem(1:ll)) goto 200 enddo ! bibitem not found goto 1000 ! found bibitem 200 continue nselbib=nselbib+1 selbib(nselbib)%bibitem=bibitem selbib(nselbib)%data=text selbib(nselbib)%status=1 1000 continue return end subroutine OCenterbibitem ! end module xtdblib ================================================ FILE: src/models/gtp3F.F90 ================================================ ! ! GTP3F included in gtp3.F90 ! !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !> 10. Section: state variable manipulations !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_stable_state_var_value !\begin{verbatim} subroutine get_stable_state_var_value(statevar,value,encoded,ceq) ! called with a state variable character ! If the state variable includes a phase it checks if the phase is stable ... implicit none TYPE(gtp_equilibrium_data), pointer :: ceq character statevar*(*),encoded*(*) double precision value !\end{verbatim} %+ integer lokcs,ics,ip ! type(gtp_state_variable), pointer :: svr type(gtp_state_variable), target :: svrvar type(gtp_state_variable), pointer :: svr character modstatevar*28 ! ! memory leak fix svr=>svrvar call decode_state_variable(statevar,svr,ceq) if(gx%bmperr.ne.0) goto 1000 ! check if state variable inclused a phase ! argtyp=0: no arguments ! argtyp=1: component ! argtyp=2: phase+compset ! argtyp=3: phase+compset+component ! argtyp=4: phase+compset+constituent modstatevar=statevar ! write(*,*)'3F stable: ',modstatevar,svr%argtyp,phlista(svr%phase)%noofcs if(svr%argtyp.eq.2) then ! if compset > 1 specified do nothing if(svr%compset.ne.1) goto 1000 ! svr%phase,svr%compset lokcs=phlista(svr%phase)%linktocs(svr%compset) ! write(*,*)'3F phase: ',svr%compset,phlista(svr%phase)%noofcs,& ! ceq%phase_varres(lokcs)%phstate,PHENTSTAB if(ceq%phase_varres(lokcs)%phstate.ne.PHENTSTAB) then ! phase+compset is not stable, chek if there is other stable compset loop: do ics=1,phlista(svr%phase)%noofcs lokcs=phlista(svr%phase)%linktocs(ics) ! write(*,*)'3F looping: ',ics,lokcs,ceq%phase_varres(lokcs)%phstate if(ceq%phase_varres(lokcs)%phstate.eq.PHENTSTAB) then ! add a composition set index after phase name ip=index(modstatevar,',') if(ip.eq.0) ip=index(modstatevar,')') ! maybe there is a #1 ?? if(modstatevar(ip-2:ip-2).eq.'#') then modstatevar(ip-1:ip-1)=char(ics+ichar('0')) else modstatevar(ip:)='#'//char(ics+ichar('0')) modstatevar(ip+2:)=statevar(ip:) endif ! write(*,*)'3F Modfied statevar: ',modstatevar exit loop endif enddo loop endif endif ! looking for bug ... not here ! write(*,*)'3F calling get_state_var_value' call get_state_var_value(modstatevar,value,encoded,ceq) ! write(*,*)'3F back from get_state_var_value',value,' ',trim(encoded) 1000 continue ! possible memory leak ! write(*,*)'3F exit get_stable_state_var_value' nullify(svr) return end subroutine get_stable_state_var_value !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_state_var_value !\begin{verbatim} %- subroutine get_state_var_value(statevar,value,encoded,ceq) ! called with a state variable character implicit none TYPE(gtp_equilibrium_data), pointer :: ceq character statevar*(*),encoded*(*) double precision value !\end{verbatim} ! integer indices(4) integer iunit,ip,lrot,mode ! memory leak type(gtp_state_variable), target :: svrvar type(gtp_state_variable), pointer :: svr character actual_arg(2)*16,name*16 ! ! write(*,*)'3F In get_state_variable_value: ',statevar iunit=0 svr=>svrvar !check if there is a "." (dot) neaing it is a dot derivative if(index(statevar,'.').gt.0) then write(*,*)'3F dot derivatives must be entered as symbols: ',trim(statevar) gx%bmperr=4399; goto 1000 endif call decode_state_variable(statevar,svr,ceq) ! write(*,20)statevar(1:len_trim(statevar)),svr%oldstv,svr%norm,& ! svr%argtyp,svr%component,gx%bmperr 20 format('3F gsvv 1: ',a,' : ',5i3) if(gx%bmperr.ne.0) then ! goto 1000 ! it can be a state variable symbol ... ! ! Possible problem ... this can cause nesting as a state variable will ! normally evaluate some state variables or other state variable functions ! gx%bmperr=0 name=statevar call capson(name) ! call find_svfun(name,lrot,ceq) call find_svfun(name,lrot) if(gx%bmperr.ne.0) then write(*,*)'3F Neither state variable or symbol, maybe model-param-id?' gx%bmperr=4399; goto 1000 else ! get the value of the symbol, may involve other symbols and state variablse ! The actual_arg is a facility not yet implemented and not allowed here ! if mode=0 the stored value may be used, mode=1 always evaluate ! write(*,*)'3F Found function: ',lrot actual_arg=' ' mode=1 if(btest(svflista(lrot)%status,SVFDOT)) then gx%bmperr=4399; goto 1000 endif ! this is OK if it is not a derivative ! BUT be careful!! it can be a value that must be calculated explicitly!! if(btest(svflista(lrot)%status,SVFVAL)) then value=ceq%svfunres(lrot) ! write(*,*)'3F Extracting saved value for: ',trim(name),value else ! write(*,*)'3F call svaluate_svfun_old 1' value=evaluate_svfun_old(lrot,actual_arg,mode,ceq) if(gx%bmperr.eq.4217) goto 1000 endif encoded=name endif else ! it is a real state variable ! write(*,*)'3F calling state_variable_val from get_state_var_value' call state_variable_val(svr,value,ceq) ! write(*,*)'3F back from state_variable_val',value if(gx%bmperr.ne.0) goto 1000 ip=1 encoded=' ' call encode_state_variable(encoded,ip,svr,ceq) if(gx%bmperr.ne.0) then write(*,*)'3F encode error: ',trim(encoded),gx%bmperr gx%bmperr=0; encoded='dummy' endif ! write(*,*)'3F get_state_var_value encoded: ',trim(encoded) endif 1000 continue ! possible memory leak nullify(svr) return end subroutine get_state_var_value !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_many_svar !\begin{verbatim} subroutine get_many_svar(statevar,values,mjj,kjj,encoded,ceq) ! called with a state variable name with wildcards allowed like NP(*), X(*,CR) ! mjj is dimension of values, kjj is number of values returned ! encoded used to specify if phase data in phasetuple order ('Z') ! >>>> BIG question: How to do with phases that are note stable? ! If I ask for w(*,Cr) I only want the fraction in stable phases ! but when this is used for GNUPLOT the values are written in a matix ! and the same column in that phase must be the same phase ... ! so I have to have the same number of phases from each equilibria. ! tentative added feature: # instead of * means also metastable phases ! BEWHERE # is used also for composition set and sublattice index! ! ! CURRENTLY if x(*,*) and x(*,A) mole fractions only in stable phases ! ! >>>>>>>>>>>>>>>> there is a segmentation fault in this subroutine when ! called from ocplot2 in the map11.OCM ! for the second plot as part of all.OCM ! but not when called by itself. SUCK ! probably caused by the fact that the number of composition sets are different ! >>>>>>>>>>>>>>>> ! A new segmentation fault for map2 when plotting with 2 maptops and the ! first does not have a new composition set LIQUID_AUTO#2 created in the ! second map. I do not understand how that has ever worked?? ! >>>>>>>>>>>>>>>> ! implicit none TYPE(gtp_equilibrium_data), pointer :: ceq character statevar*(*),encoded*(*) double precision values(*) integer mjj,kjj !\end{verbatim} integer indices(4),modind(4) double precision xnan,xxx integer jj,lokph,lokcs,k1,k2,k3,iref,jl,iunit,istv,enpos,maxen logical onlystable ! memory leak type(gtp_state_variable), target :: svrvar type(gtp_state_variable), pointer :: svr ! logical phtupord ! check for character overflow, leave at least 100 at end maxen=len(encoded)-30 ! calculate the NaN bit pattern xnan=0.0d0 ! xnan=0.0d0/xnan encoded=' ' enpos=1 if(gx%bmperr.ne.0) then write(*,*)'3F Error entering get_many_svar ',gx%bmperr,xnan endif !------------------------ iunit=0 modind=0 ! phtupord=.FALSE. ! if(encoded(1:1).eq.'Z') then ! when called from TQ interface the phase order should be as for phase tuples ! phtupord=.TRUE. ! endif ! called from minimizer for testing svr=>svrvar call decode_state_variable(statevar,svr,ceq) if(gx%bmperr.ne.0) then write(*,*)'3F Failed decode statevar in get_many_svar',gx%bmperr goto 1000 endif ! write(*,*)'3F get_many_svar 1: ',trim(statevar),svr%argtyp,svr%phase ! translate svr data to old indices etc istv=svr%oldstv iref=svr%phref iunit=svr%unit ! svr%argtyp specifies values in indices: ! svr%argtyp: 0=no arguments; 1=comp; 2=ph+cs; 3=ph+cs+comp; 4=ph+cs+const indices=0 if(svr%argtyp.eq.1) then indices(1)=svr%component elseif(svr%argtyp.eq.2) then indices(1)=svr%phase indices(2)=svr%compset elseif(svr%argtyp.eq.3) then indices(1)=svr%phase indices(2)=svr%compset indices(3)=svr%component elseif(svr%argtyp.eq.4) then indices(1)=svr%phase indices(2)=svr%compset indices(3)=svr%constituent endif ! write(*,*)'3F get_many_svar 2: ',trim(statevar),svr%argtyp,indices ! ! write(*,20)istv,indices,iref,iunit,gx%bmperr 20 format('3F many 1: ',i5,4i4,3i7) ! ----------------------------------------- ! Indices 1: one or all components (-1) ! Indices 2+3: 0 or phase+set ! Indices 1+2: phase+set ! Indices 3: 0 or component (-1) or constituent (-2) ! indices 4 never used ! ----------------------------------------- ! -1 means element or component ! -2 species or constituent ! -3 phase ! -4 composition set ! indices(1)=-10 phase & compset means all phases also metastable "#" jj=0 onlystable=.true. if(indices(1).ge.0) then if(indices(2).ge.0) then if(indices(3).ge.0) then ! all indices given, a single value jj=jj+1 if(jj.gt.mjj) goto 1100 call encode_state_variable3(encoded,enpos,istv,indices,& iunit,iref,ceq) if(gx%bmperr.ne.0) goto 1000 enpos=enpos+1 ! check for overflow in encoded if(enpos.gt.maxen) goto 1100 call state_variable_val3(istv,indices,iref,& iunit,values(jj),ceq) if(gx%bmperr.ne.0) goto 1000 elseif(indices(3).eq.-1) then ! loop for components, indices 1+2 must be phase+compset do k3=1,noofel indices(3)=k3 jj=jj+1 if(jj.gt.mjj) goto 1100 call encode_state_variable3(encoded,enpos,istv,indices,& iunit,iref,ceq) if(gx%bmperr.ne.0) goto 1000 enpos=enpos+1 ! check for overflow in encoded if(enpos.gt.maxen) goto 1100 call state_variable_val3(istv,indices,iref,& iunit,values(jj),ceq) if(gx%bmperr.ne.0) goto 1000 enddo elseif(indices(3).eq.-2) then ! loop for constituents, indices 1+2 must be phase+compset call get_phase_record(indices(1),lokph) do k3=1,phlista(lokph)%tnooffr indices(3)=k3 jj=jj+1 if(jj.gt.mjj) goto 1100 call encode_state_variable3(encoded,enpos,istv,indices,& iunit,iref,ceq) if(gx%bmperr.ne.0) goto 1000 enpos=enpos+1 ! check for overflow in encoded if(enpos.gt.maxen) goto 1100 call state_variable_val3(istv,indices,iref,& iunit,values(jj),ceq) if(gx%bmperr.ne.0) goto 1000 enddo else ! indices(3) must be -2, -1 or >=0 so if we are here there is an error write(*,17)'3F Illegal set of indices 1',(indices(jl),jl=1,4) 17 format(a,4i4) gx%bmperr=4317; goto 1000 endif elseif(indices(2).eq.-3 .or. indices(2).eq.-10) then ! if indices(1)>=0 then indices(2)<0 must means a loop for all phase+compset ! write(*,*)'3F seg.fault ',noofph do k2=1,noofph indices(2)=k2 call get_phase_record(indices(2),lokph) do k3=1,phlista(lokph)%noofcs indices(3)=k3 jj=jj+1 if(jj.gt.mjj) goto 1100 call get_phase_compset(indices(2),indices(3),lokph,lokcs) call encode_state_variable3(encoded,enpos,istv,indices,& iunit,iref,ceq) if(gx%bmperr.ne.0) goto 1000 enpos=enpos+1 ! check for overflow in encoded if(enpos.gt.maxen) goto 1100 ! if composition set not stable so return NaN (in xnan) if(test_phase_status(indices(2),indices(3),xxx,ceq).le. & PHENTUNST) then values(jj)=xnan elseif(ceq%phase_varres(lokcs)%dgm.lt.zero) then ! the phase must not have negative driving force values(jj)=xnan else ! problem that get_many returns values for unstable phases call state_variable_val3(istv,indices,iref,& iunit,values(jj),ceq) if(gx%bmperr.ne.0) goto 1000 23 format(a,2i3,2(1pe14.6)) endif enddo enddo else ! if indices(1)>=0 then indices(2) must be -3 or >=0, so if here it is error write(*,17)'3F Illegal set of indices 2',(indices(jl),jl=1,4) gx%bmperr=4317; goto 1000 endif elseif(indices(1).eq.-1) then ! loop for component as first indices, 2+3 can be fix phase+compset ! NOTE: loop for x(*,*) is below with indices(1).eq.-3 ! write(*,*)'3F indices: ',indices if(indices(2).ge.0) then do k1=1,noofel indices(1)=k1 jj=jj+1 if(jj.gt.mjj) goto 1100 call encode_state_variable3(encoded,enpos,istv,indices,& iunit,iref,ceq) if(gx%bmperr.ne.0) goto 1000 enpos=enpos+1 ! check for overflow in encoded if(enpos.gt.maxen) goto 1100 call state_variable_val3(istv,indices,iref,& iunit,values(jj),ceq) if(gx%bmperr.ne.0) goto 1000 enddo elseif(indices(2).eq.-3) then ! loop for components and phase+compset do k1=1,noofel indices(1)=k1 do k2=1,noofph indices(2)=k2 call get_phase_record(indices(2),lokph) do k3=1,phlista(lokph)%noofcs indices(3)=k3 jj=jj+1 if(jj.gt.mjj) goto 1100 call get_phase_compset(indices(2),indices(3),lokph,lokcs) ! if composition not stable so return NaN call encode_state_variable3(encoded,enpos,istv,indices,& iunit,iref,ceq) if(gx%bmperr.ne.0) goto 1000 enpos=enpos+1 ! check for overflow in encoded if(enpos.gt.maxen) goto 1100 if(test_phase_status(indices(2),indices(3),xxx,ceq).le. & PHENTSTAB) then ! xnan means "no value" values(jj)=xnan elseif(ceq%phase_varres(lokcs)%dgm.lt.zero) then ! the phase must not have negative driving force values(jj)=xnan else ! here the value is extracted call state_variable_val3(istv,indices,iref,& iunit,values(jj),ceq) if(gx%bmperr.ne.0) goto 1000 endif enddo enddo enddo else ! if we come here it must be an error write(*,17)'3F Illegal set of indices 3',(indices(jl),jl=1,4) gx%bmperr=4317; goto 1000 endif ! elseif(indices(1).eq.-3) then elseif(indices(1).eq.-3 .or. indices(1).eq.-10) then ! loop for phase+compset as indices(1+2) ! here we must be careful not to destroy original indices, use modind if(indices(1).eq.-10) onlystable=.FALSE. ! write(*,*)'3F get_many NP(*) etc 1: ',gx%bmperr,indices(1),indices(3),& ! onlystable,noofph phloop: do k1=1,noofph modind(1)=k1 modind(2)=0 call get_phase_record(modind(1),lokph) ! write(*,19)'3F test 17',modind,gx%bmperr,xnan if(gx%bmperr.ne.0) goto 1000 csloop: do k2=1,phlista(lokph)%noofcs modind(2)=k2 call get_phase_compset(modind(1),modind(2),lokph,lokcs) if(gx%bmperr.ne.0) goto 1000 ! skip if phase+compset suspended ! if(ceq%phase_varres(lokcs)%phstate.le.PHSUS) ! if(indices(3).eq.0) then if(indices(3).le.0) then ! This is typically listing of NP(*) for all phases modind(3)=0 call encode_state_variable3(encoded,enpos,istv,modind,& iunit,iref,ceq) if(gx%bmperr.ne.0) then write(*,*)'3F error encoding state variable'; goto 1000 endif enpos=enpos+1 ! check for overflow in encoded if(enpos.gt.maxen) goto 1100 jj=jj+1 if(jj.gt.mjj) goto 1100 ! if the wildcard is # include also metastable if(onlystable .and. & ceq%phase_varres(lokcs)%phstate.lt.PHENTSTAB) then values(jj)=xnan else call state_variable_val3(istv,modind,iref,& iunit,values(jj),ceq) if(gx%bmperr.ne.0) then write(*,*)'3F error calling __val3'; goto 1000 endif endif ! elseif(ceq%phase_varres(lokcs)%phstate.lt.PHENTSTAB) then ! call encode_state_variable3(encoded,enpos,istv,modind,& ! iunit,iref,ceq) ! if(gx%bmperr.ne.0) goto 1000 ! enpos=enpos+1 ! check for overflow in encoded if(enpos.gt.maxen) goto 1100 ! values(jj)=xnan elseif(indices(3).gt.0) then ! This is typically listing of w(*,cr), only in stable range of phases modind(3)=indices(3) ! write(*,*)'3F statevar 1A: ',modind(1),modind(2),modind(3) call get_phase_compset(modind(1),modind(2),lokph,lokcs) if(gx%bmperr.ne.0) goto 1000 call encode_state_variable3(encoded,enpos,istv,modind,& iunit,iref,ceq) if(gx%bmperr.ne.0) goto 1000 enpos=enpos+1 ! check for overflow in encoded if(enpos.gt.maxen) goto 1100 jj=jj+1 ! write(*,*)'3F statevar 1B: ',trim(encoded),jj,& ! lokph,ceq%phase_varres(lokcs)%phlink ! write(*,*)'3F statevar 1B: ',jj,& ! lokph,ceq%phase_varres(lokcs)%phlink if(jj.gt.mjj) goto 1100 !-------------------------------------------------------------- ! Beware of segmentation faults at next call to state_variable_val3 !!! ! This code should take care of the problem when new composition sets ! have been created in different step/map commands and we then try ! to extract wildcard state variables from these to plot. ! ceq here can be a previous local ceq used for the step/map ! without a compset created later. ! write(*,333)'3F this composition set may not exist',& ! lokcs,ceq%phase_varres(lokcs)%phstate,PHENTSTAB,& ! ceq%phase_varres(lokcs)%phlink,lokph 333 format(a,i4,2x,2i3,2x,2i4) if(.not.allocated(ceq%phase_varres(lokcs)%yfr)) then ! if yfr is not allocated the composition set does not exist, skip this phase ! write(*,*)'3F this composition set does not exist',& ! ceq%phase_varres(lokcs)%phstate,PHENTSTAB values(jj)=xnan; goto 600 endif !-------------------------------------------------------------- if(ceq%phase_varres(lokcs)%phstate.lt.PHENTSTAB) then ! if phase is not stable (phstate= -2, -1 or 0)set dummy value values(jj)=xnan else call state_variable_val3(istv,modind,iref,& iunit,values(jj),ceq) endif ! write(*,*)'3F statevar 1C: ',jj,values(jj) ! write(*,*)'3F statevar 1C: ',trim(encoded),jj,values(jj) ! write(*,73)'3F listing w(*,A): ',istv,modind,iref,iunit,& ! ceq%phase_varres(lokcs)%phstate,jj,values(jj) 73 format(a,i5,2x,4i3,2x,2i4,2i5,1pe12.4) if(gx%bmperr.ne.0) goto 1000 elseif(ceq%phase_varres(lokcs)%phstate.lt.PHENTSTAB) then ! loop for all components or constitunets of stable phases ! Maybe it should be included to have same number of values in all ranges? cycle csloop elseif(indices(3).eq.-1) then ! loop for all components of all phases, skip unstable phases elloop: do k3=1,noofel modind(3)=k3 call encode_state_variable3(encoded,enpos,istv,modind,& iunit,iref,ceq) if(gx%bmperr.ne.0) goto 1000 enpos=enpos+1 ! check for overflow in encoded if(enpos.gt.maxen) goto 1100 jj=jj+1 if(jj.gt.mjj) goto 1100 call state_variable_val3(istv,modind,iref,& iunit,values(jj),ceq) if(gx%bmperr.ne.0) goto 1000 enddo elloop elseif(indices(3).eq.-2) then ! loop for constituents of all phases conloop: do k3=1,phlista(lokph)%tnooffr modind(3)=k3 call encode_state_variable3(encoded,enpos,istv,modind,& iunit,iref,ceq) if(gx%bmperr.ne.0) goto 1000 enpos=enpos+1 ! check for overflow in encoded if(enpos.gt.maxen) goto 1100 jj=jj+1 if(jj.gt.mjj) goto 1100 call state_variable_val3(istv,modind,iref,& iunit,values(jj),ceq) if(gx%bmperr.ne.0) goto 1000 enddo conloop else ! error if here write(*,17)'3F Illegal set of indices 4',(indices(jl),jl=1,4) gx%bmperr=4317; goto 1000 endif 600 continue if(gx%bmperr.ne.0) then write(*,19)'3F error 3',modind,gx%bmperr 19 format(a,4i4,i7) goto 1000 endif enddo csloop enddo phloop ! write(*,*)'3F jj: ',jj else ! error if here write(*,17)'3F Illegal set of indices 5',(indices(jl),jl=1,4) gx%bmperr=4317; goto 1000 endif 1000 continue ! possible memory leak, BUT nullify does not release memory nullify(svr) kjj=jj return 1100 continue write(*,1102)enpos,maxen,jj,mjj 1102 format('3F Overflow using get_many_svar: ',2i6,5x,2i6) gx%bmperr=4317; goto 1000 end subroutine get_many_svar !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine decode_state_variable !\begin{verbatim} subroutine decode_state_variable(statevar,svr,ceq) ! converts a state variable character to state variable record character statevar*(*) type(gtp_state_variable), pointer :: svr type(gtp_equilibrium_data), pointer :: ceq ! this subroutine using state variable records is a front end of the next: !\end{verbatim} %+ ! type(gtp_state_variable) :: svrec integer istv,indices(4),iref,iunit call decode_state_variable3(statevar,istv,indices,iref,iunit,svr,ceq) 1000 continue return end subroutine decode_state_variable !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine decode_state_variable3 !\begin{verbatim} %- subroutine decode_state_variable3(statevar,istv,indices,iref,iunit,svr,ceq) ! converts an old state variable character to indices ! Typically: T, x(fe), x(fcc,fe), np(fcc), y(fcc,c#2), ac(h2,bcc), ac(fe) ! NOTE! model properties like TC(FCC),MQ&FE(FCC,CR) must be detected ! NOTE: added storing information in a gtp_state_variable record svrec !! ! ! this routine became as messy as I tried to avoid ! but I leave it to someone else to clean it up ... ! ! state variable and indices ! Symbol no index1 index2 index3 index4 ! T 1 - ! P 2 - ! MU 3 component or phase,component ! AC 4 component or phase,component ! LNAC 5 component or phase,component ! index (in svid array) ! U 10 (phase#set) 6 Internal energy (J) ! UM 11 " 6 per mole components ! UW 12 " 6 per kg ! UV 13 " 6 per m3 ! UF 14 " 6 per formula unit ! S 2x " 7 entropy ! V 3x " 8 volume ! H 4x " 9 enthalpy ! A 5x " 10 Helmholtz energy ! G 6x " 11 Gibbs energy ! NP 7x " 12 moles of phase ! BP 8x " 13 mass of moles ! DG 9x " 15 Driving force ! Q 10x " 14 Internal stability ! N 11x (component/phase#set,component) 16 moles of components ! X 111 " 17 mole fraction of components ! B 12x " 18 mass of components ! W 122 " 19 mass fraction of components ! Y 13 phase#set,constituent#subl 20 constituent fraction !----- model variables <<<< these now treated differently ! TC - phase#set - Magnetic ordering T ! BMAG - phase#set - Aver. Bohr magneton number ! MQ& - element, phase#set - Mobility ! LNTH - phase#set - LN(Einstein temperature) ! implicit none integer, parameter :: noos=20 character*4, dimension(noos), parameter :: svid = & ['T ','P ','MU ','AC ','LNAC','U ','S ','V ',& 'H ','A ','G ','NP ','BP ','DG ','Q ','N ',& 'X ','B ','W ','Y '] ! 1 2 3 4 5? 6 7 8 ! 9 10 11 12 13 14 15 16 ! 17 18 19 20 character statevar*(*) integer istv,iref,iunit integer, dimension(4) :: indices type(gtp_equilibrium_data), pointer :: ceq ! I shall try to use this record type instead of separate arguments: !! ! type(gtp_state_variable), pointer :: svrec type(gtp_state_variable), pointer :: svr !\end{verbatim} ! type(gtp_state_variable), allocatable, target :: svr integer is,jp,kp,iph,ics,icon,icomp,norm,narg,icc double precision cmass,asum ! character argument*60,arg1*24,arg2*24,ch1*1,lstate*60,propsym*60 integer typty logical deblist istv=0 ! write(*,*)'3F in decode3 "',trim(statevar),'" ',istv ! initiate svr internal variables deblist=.FALSE. ! deblist=.TRUE. if(ocv()) deblist=.TRUE. if(deblist) write(*,*)'3F entering decode_statevariable: ',& statevar(1:len_trim(statevar)) ! write(*,*)'3F svr allocated' ! memory leak ! allocate(svr) ! write(*,*)'3F svr assignment start' svr%oldstv=0 svr%norm=0 svr%unit=0 ! svr%argtyp: 0=no arguments; 1=comp; 2=ph+cs; 3=ph+cs+comp; 4=ph+cs+const svr%argtyp=0 svr%phref=0 svr%phase=0 svr%compset=0 svr%component=0 svr%constituent=0 ! write(*,*)'3F svr assignment end' ! ! For wildcard argument "*" return: ! -1 for element or component ! -2 for species or constituent ! -3 for phase ! -4 for composition set ! -10 for also metastable phases and composition sets, using hash # istv=-1 indices=0 ! iref=0 means user defined reference state iref=0 ! unit is not implemented (can apply to T, P, V, mass, etc) iunit=0 iph=0 ics=0 norm=0 ! local character for state variable lstate=statevar call capson(lstate) if(deblist) write(*,*)'3F decode_state_var 1: ',lstate(1:20) ! write(*,*)'3F decode_state_var 1: "',trim(lstate),'"' ! compare first character ch1=lstate(1:1) ! write(*,*)'3F decoding: ',trim(statevar),is,' ',ch1 do is=1,noos if(ch1.eq.svid(is)(1:1)) goto 50 enddo ! it may be a property, parameter identifier if(deblist) write(*,*)'3F jump to 600!' goto 600 !------------------------------------------------------------ 50 continue ! There is an ambiguous case with first letter: "AC" and "A" ! If is=4 it means we found an A, check if second letter is "C" if(is.eq.4) then if(lstate(2:2).ne.'C') then is=10 endif endif ! write(*,*)'3F we are here statevar ',trim(statevar),', ch1: ',ch1 if(deblist) write(*,*)'3F dsv 1: ',ch1,is if(is.eq.1) then if(lstate(2:2).ne.' ') then ! it must be a property like TC or THET goto 600 endif ! T istv=1; svr%oldstv=1; svr%statevarid=1; goto 1000 elseif(is.eq.2) then ! P if(lstate(2:2).ne.' ') goto 600 istv=2; svr%oldstv=2; svr%statevarid=2; goto 1000 elseif(is.gt.5) then goto 100 endif !------------------------------------------------------------ ! MU 3 component, possible suffix S for SER reference chemp: if(is.eq.3) then if(lstate(1:2).ne.'MU') then goto 600 endif istv=3 jp=3 elseif(is.eq.4) then ! AC is 4 but just A or AM, AV etc can mean Helmholtz Energy or a property if(lstate(1:2).ne.'AC') then is=8; goto 100 endif istv=4 jp=3 elseif(is.eq.5) then ! LNAC 5 component if(lstate(1:4).ne.'LNAC') goto 600 istv=5 jp=5 endif chemp ! MU, AC and LNAC can have a suffix 'S', reference state, iref=0 is default if(lstate(jp:jp).eq.'S') then ! This iref has not been treated correctly so far. The idea is now that ! iref=0 means user defined reference state, if the user has not defined any ! reference state it means SER. If the user specifies a suffix S it means ! always SER even if the user has defined another reference state. ! Maybe iref>0 will have some other meaing in the future ... iref=-1 jp=jp+1 endif ! extract the argument, can be one or two indices svr%oldstv=istv; svr%statevarid=istv if(lstate(jp:jp).ne.'(') goto 1130 kp=index(lstate,')') if(kp.lt.jp) then ! write(*,*)'3F cannot find )',trim(lstate),jp,kp goto 1140 endif argument=lstate(jp+1:kp-1) kp=index(argument,',') if(kp.gt.0) then ! >>> if two arguments first is phase ??? different from TC arg1=argument(1:kp-1) arg2=argument(kp+1:) if(arg1(1:2).eq.'* ') then iph=-3 else call find_phase_by_name(arg1,iph,ics) if(gx%bmperr.ne.0) goto 1150 endif if(arg2(1:2).eq.'* ') then icon=-2 else call find_constituent(iph,arg2,cmass,icon) if(gx%bmperr.ne.0) goto 1160 call set_constituent_reference_state(iph,icon,asum) ! write(*,*)'3F findconst for ref: ',arg2,cmass,icc if(gx%bmperr.ne.0) then gx%bmperr=4112; goto 1000 endif endif ! composition set irrelevant as chempot depend only on species stoichiometry indices(1)=iph indices(2)=icon svr%phase=iph svr%compset=1 svr%constituent=icon svr%argtyp=4 else if(argument(1:2).eq.'* ') then icomp=-1 else call find_component_by_name(argument,icomp,ceq) if(gx%bmperr.ne.0) goto 1170 endif indices(1)=icomp svr%component=icomp svr%argtyp=1 endif goto 1000 !================================================================= ! extensive variable, is=6..20 or a model property 100 continue jp=2 ! check second letter for some state variables if(deblist) write(*,105)is,norm,jp 105 format('3F dsv 4: ',3i4) letter2: if(is.eq.12 .and. lstate(jp:jp).ne.'P') then ! This is for Nx or a property is=16 elseif(is.eq.13) then ! this can be Bx for component, BP for phase or BMAG for Bohr magnetons if(lstate(jp-1:jp).eq.'BP') then jp=jp+1 else ! this is Bx or a property is=18 endif elseif(is.eq.14 .and. lstate(jp-1:jp).ne.'DG') then ! this is for Dx, can be a property ! gx%bmperr=4107; goto 1000 goto 600 elseif(is.eq.12 .or. is.eq.14) then ! This is NP or DG, increment jp to check the second character jp=jp+1 elseif(is.eq.17 .or. is.eq.19) then ! X and W can have a suffix % to indicate percentage if(lstate(jp:jp).eq.'%') then iunit=100 jp=jp+1 svr%unit=iunit endif endif letter2 !--------------------------------------------------------------------- ! All this is for extensive properties ! If we come here the first (and sometimes second) letter must have been: ! A, B, BP, D, G, H, N, NP, Q, S, U, W, X, Y ! and "is" is 10, 18, 13, 14, 11, 9, 16, 12, 15, 7, 6, 19, 17, 20 ! NOTE: for N and B the second character has been checked and jp incremented ! if equal to P. The third (for NP and BP forth) character must ! be normallizing (MWVF), a space or a (, otherwise it is a property if(deblist) write(*,*)'3F lstate: ',lstate(1:20),jp,is ! these have no normalizing: Q, X, W, Y nomalize: if(is.le.14 .or. is.eq.16 .or. is.eq.18) then ! ZM x1 (phase) per mole components ! ZW x2 (phase) per kg ! ZV x3 (phase) per m3 ! ZF x4 phase must be specified per formula unit ch1=lstate(jp:jp) jp=jp+1 if(ch1.eq.'M') then norm=1 elseif(ch1.eq.'W') then norm=2 elseif(ch1.eq.'V') then norm=3 elseif(ch1.eq.'F') then norm=4 else ! no or default normalization, backspace jp=jp-1 endif svr%norm=norm if(deblist) write(*,*)'3F Normalize 1: ',is,jp,ch1,norm endif nomalize !--------------------------------------------------------------------- ! reference state can be specified by an S for SER ! If no S the user specified reference states applies ! UNLESS MIXED REFERENCE STATES FOR THE ELEMENTS if(lstate(jp:jp).eq.'S') then jp=jp+1 iref=-1 elseif(lstate(jp:jp+1).eq.'R(') then write(*,*)'3F Ignoring suffix "R" on ',trim(statevar),& ', user reference is default' jp=jp+1 endif if(btest(ceq%status,EQMIXED)) then ! user has different phases as reference state for the elements use SER ! write(*,*)'3F Mixed reference state for the elements, SER used' ! This is only set for integral U(6), S(7), H(9), A(10), G(11) (not V(8)) if(is.ge.6 .and. is.le.11) iref=-1 endif !--------------------------------------------------------------------- ! extract arguments if any. If arguments then lstate(jp:jp) should be ( ! Typically H(fcc#2), N(Cr), BP(fcc), Y(sigma#2,cr#3), TC(BCC#2) !300 continue if(deblist) write(*,*)'3F args: ',jp,lstate(1:jp+10) narg=0 args: if(lstate(jp:jp).eq.'(') then kp=index(lstate,')') if(kp.le.0) then if(deblist) write(*,110)'3F dsv 5: ',is,jp,kp,lstate(1:20) write(*,110)'3F dsv 5: ',is,jp,kp,lstate(1:20) 110 format(a,3i3,a) gx%bmperr=4103; goto 1000 endif argument=lstate(jp+1:kp-1) kp=index(argument,',') arg: if(kp.gt.0) then arg1=argument(1:kp-1) arg2=argument(kp+1:) narg=2 kp=index(arg2,',') if(kp.gt.0) then ! too many arguments to a state variable gx%bmperr=4097; goto 1000 endif else !no arg narg=1 arg1=argument endif arg elseif(lstate(jp:jp).ne.' ') then ! if additional character then it must be a property goto 600 endif args !------------------ ! transform arguments to indices, different arguments for 6- ! Handle arguments: U, S, V, H, A, G, NP, BP,DG, Q, N, X, B, W, Y ! 6, 7, 8, 9,10, 11,12, 13,14,15,16,17,18,19,20 if(narg.eq.1) then if(is.le.15 .or. is.ge.21) then ! single argument is phase+composition set if(arg1(1:2).eq.'* ') then iph=-3 ics=-4 elseif(arg1(1:2).eq.'# ') then ! include also values for metastable phases, only for single argument variables iph=-10 ics=-10 else call find_phase_by_name(arg1,iph,ics) if(gx%bmperr.ne.0) goto 1000 endif indices(1)=iph indices(2)=ics svr%phase=iph svr%compset=ics svr%argtyp=2 elseif(is.eq.20) then ! state variable Y must have 2 arguments gx%bmperr=4098; goto 1000 else ! single argument is component for is=16-19 if(arg1(1:2).eq.'* ') then icomp=-1 else call find_component_by_name(arg1,icomp,ceq) if(gx%bmperr.ne.0) goto 1000 endif indices(1)=icomp svr%component=icomp svr%argtyp=1 endif elseif(narg.eq.2) then ! two arguments only for is=16-20, first phase, second component or constit if(is.le.15 .or. is.ge.21) then gx%bmperr=4110; goto 1000 endif if(arg1(1:2).eq.'* ') then iph=-3 ics=-4 else call find_phase_by_name(arg1,iph,ics) if(gx%bmperr.ne.0) goto 1000 endif indices(1)=iph indices(2)=ics svr%phase=iph svr%compset=ics if(is.eq.20) then if(arg2(1:2).eq.'* ') then icc=-2 else call find_constituent(iph,arg2,cmass,icc) ! write(*,*)'3F findconst 2: ',trim(arg2),cmass,icc if(gx%bmperr.ne.0) goto 1000 endif svr%component=0 svr%constituent=icc svr%argtyp=4 else if(arg2(1:2).eq.'* ') then icc=-1 else call find_component_by_name(arg2,icc,ceq) if(gx%bmperr.ne.0) goto 1000 endif svr%component=icc svr%argtyp=3 endif ! note indices(4) never used as icc is constituent index, arg2 must have ! a #sublattice to find the correct, otherwise always the first occurence ! In a sigma (Fe)(Cr)(Cr,Fe) y(sigma,cr)=1 but y(sigma,cr#3) gives Cr in third indices(3)=icc elseif((is.ge.12 .and. is.le.15) .or. is.eq.17 .or. is.ge.19) then ! There must be an argument for NP, BP, DG, Q, X, W, Y, TC and BMAG gx%bmperr=4111; goto 1000 elseif(norm.eq.4) then ! there must be a phase specification for a quantity per formula unit gx%bmperr=4115; goto 1000 endif ! if(is.eq.17 .or. is.eq.19) then ! is=is-1 ! svr%norm=1 if(is.eq.16) svr%norm=1 if(is.eq.18) svr%norm=2 ! endif !----------------------- 500 continue !----------------------------------------------------------------------- ! U 1x (phase,composition set) Internal energy (J) ! S 2x entropy ! V 3x volume ! H 4x enthalpy ! A 5x Helmholtz energy ! G 6x Gibbs energy ! NP 7x phase moles of phase ! BP 8x phase mass of phase ! N 9x (component/phase,component) moles >>14 ! X 9x component/phase,component mole fraction >>15 ! B 10x (component/phase,component) mass >>16 ! W 10x mass fraction >>17 ! Y 11 phase,constituent#sublattice constituent fraction >>18 ! Q 12 Internal stability >>19 ! DG 13x Driving force ! TC, BM, MQ& etc (model variables) svr%statevarid=is extensive: if(is.eq.6) then ! U 1x (phase) Internal energy (J) istv=10+norm elseif(is.eq.7) then ! S 2x entropy istv=20+norm elseif(is.eq.8) then ! V 3x volume istv=30+norm elseif(is.eq.9) then ! H 4x enthalpy istv=40+norm elseif(is.eq.10) then ! A 5x Helmholtz energy istv=50+norm elseif(is.eq.11) then ! G 6x Gibbs energy istv=60+norm elseif(is.eq.12) then ! NP 7x phase moles of phase istv=70+norm elseif(is.eq.13) then ! BP 8x phase mass of phase istv=80+norm elseif(is.eq.14) then ! DG 9x Driving force istv=90+norm elseif(is.eq.15) then ! Q 10x Internal stability istv=100+norm elseif(is.eq.16 .or. is.eq.17) then ! N 11x (component/phase,component) moles ! X=NM 111 mole fraction ! X% 111, iunit=100 mole percent if(is.eq.16) then istv=110+norm else istv=111 endif elseif(is.eq.18 .or. is.eq.19) then ! B 12x (component/phase,component) mass ! W=BW 122 mass fraction ! W% 122, iunit=100 mass percent if(is.eq.18) then istv=120+norm else istv=122 endif elseif(is.eq.20) then ! Y 130 phase#comp.set,constituent#sublat constituent fraction istv=130 ! write(*,'(a,5i5)')'3F Y: ',istv,icc,indices(1),indices(2),svr%constituent else ! the symbol may be a property if(deblist) write(*,*)'3F maybe a property ',is goto 600 endif extensive goto 1000 !------------------------------------------------ ! handling of properties like TC, BMAGN, MQ etc 600 continue ! the symbol may be a property symbol propsym=statevar ! second argument 0 means a symbol call find_defined_property(propsym,0,typty,iph,ics) if(deblist) write(*,*)'3F at 600: ',propsym(1:len_trim(propsym)),typty if(gx%bmperr.ne.0) then svr%oldstv=-1; goto 1000 endif indices(1)=iph indices(2)=ics svr%phase=iph svr%compset=ics !----------------------------- unfinished ????? ! typty>100 means a model-parameter-id with associated component such as MQ&FE if(typty.gt.100) then ! typty: third argument is constituent (or component??) istv=-typty/100 indices(3)=typty+100*istv svr%argtyp=4 elseif(typty.gt.1) then istv=-typty svr%argtyp=3 svr%argtyp=2 else ! unknown propery write(*,*)'3F Unknown state variable or property',typty gx%bmperr=4318; goto 1000 endif svr%oldstv=istv svr%statevarid=istv svr%constituent=indices(3) if(deblist) write(*,611)'3F Property: ',is,istv,typty,indices 611 format(a,10i4) !------------------------------------------------ 1000 continue ! accept the current istv as svr%oldstv, store a suffix S on MU as phref<0 svr%oldstv=istv svr%phref=iref if(deblist) write(*,1001)'3F exit decode: ',istv,(indices(is),is=1,4),& norm,iref,iunit,svr%oldstv,svr%phase,svr%compset,svr%component,& svr%constituent,svr%norm,svr%phref,svr%unit,svr%argtyp,& svr%statevarid,gx%bmperr 1001 format(a,i5,4i3,2x,3i5/17x,i5,4i3,2x,6i5) return !---------------- errors ------------------------------- ! Wrong first character of state variable 1100 continue gx%bmperr=4099; goto 1000 ! M not followed by U !1110 continue ! gx%bmperr=4100; goto 1000 ! L not followed by NAC !1120 continue ! gx%bmperr=4101; goto 1000 ! No opening ( for arguments 1130 continue gx%bmperr=4102; goto 1000 ! No closing ) for arguments 1140 continue gx%bmperr=4103; goto 1000 ! Unknown phase used as argument in state variable 1150 continue gx%bmperr=4104; goto 1000 ! No such constituent 1160 continue gx%bmperr=4105; goto 1000 ! No such component 1170 continue gx%bmperr=4106; goto 1000 ! end subroutine decode_state_variable3 !allocate !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_phase_molmass !\begin{verbatim} subroutine calc_phase_molmass(iph,ics,xmol,wmass,totmol,totmass,amount,ceq) ! calculates mole fractions and mass fractions for a phase#set ! xmol and wmass are fractions of components in mol or mass ! totmol is total number of moles and totmass total mass of components. ! amount is number of moles of components per formula unit. implicit none TYPE(gtp_equilibrium_data), pointer :: ceq integer iph,ics double precision, dimension(*) :: xmol,wmass double precision amount,totmol,totmass !\end{verbatim} integer ic,jc,lokph,lokcs,ll,iel,lokel,ie,kk,loksp,nspel integer compnos(maxspel) double precision as,yz,xsum,wsum,stoi(maxspel),smass,qsp double precision, dimension(maxel) :: x2mol,w2mass ! do ic=1,noofel xmol(ic)=zero wmass(ic)=zero enddo call get_phase_compset(iph,ics,lokph,lokcs) if(gx%bmperr.ne.0) goto 1000 ic=0 ! ! bug here when calculating MAP11 because we create new composition sets ! when we map the different lines if(ocv()) write(*,14)'3F cpm: ',iph,ics,lokph,lokcs 14 format(a,10i5) allsubl: do ll=1,phlista(lokph)%noofsubl ! an error here in MAP11.OCM as the number of composition sets varied ! in the different map commands if(.not.allocated(ceq%phase_varres(lokcs)%sites)) then if(ics.eq.2) then ! fix to allow list and amend lines from mapping when a phase ! may have added composition sets ... call get_phase_compset(iph,1,lokph,lokcs) else write(*,*)'phase ',trim(phlista(lokph)%name),& ' has no composition set ',ics endif amount=zero; gx%bmperr=4072; goto 700 endif as=ceq%phase_varres(lokcs)%sites(ll) allcons: do kk=1,phlista(lokph)%nooffr(ll) ic=ic+1 if(.not.btest(ceq%phase_varres(lokcs)%constat(ic),CONSUS)) then yz=ceq%phase_varres(lokcs)%yfr(ic) loksp=phlista(lokph)%constitlist(ic) if(.not.btest(globaldata%status,GSNOTELCOMP)) then ! the elements are the components do iel=1,splista(loksp)%noofel lokel=splista(loksp)%ellinks(iel) ie=ellista(lokel)%alphaindex if(ie.ne.0) then xmol(ie)=xmol(ie)+& as*yz*splista(loksp)%stoichiometry(iel) endif enddo else ! when we have other components than the elements ! we must convert the element stoichiometry to component stoichiometry ! write(*,*)'3F other components than elements' call get_species_component_data(loksp,nspel,compnos,stoi,& smass,qsp,ceq) do iel=1,nspel xmol(compnos(iel))=xmol(compnos(iel))+as*yz*stoi(iel) enddo endif endif enddo allcons enddo allsubl ! normallize, All ok here ! write(*,713)'A',noofel,(xmol(iq),iq=1,noofel) 713 format('3F x:',a,i2,10f8.4) !800 continue xsum=zero wsum=zero ! here xmol(i) is equal to the number of moles of element i per formula unit ! set wmass(i) to the mass of of element i per mole formula unit and sum do ic=1,noofel ! wmass(ic)=xmol(ic)*ellista(elements(ic))%mass wmass(ic)=xmol(ic)*ceq%complist(ic)%mass xsum=xsum+xmol(ic) wsum=wsum+wmass(ic) enddo ! write(*,713)'3F cpmm: ',noofel,xsum,(xmol(ic),ic=1,noofel) do ic=1,noofel xmol(ic)=xmol(ic)/xsum wmass(ic)=wmass(ic)/wsum enddo ! write(*,713)'3F cpmm: ',noofel,xsum,(xmol(ic),ic=1,noofel) ! This is the current number of formula unit of the phase, ! It is zero if not stable amount=ceq%phase_varres(lokcs)%amfu ! ceq%phase_varres(lokcs)%abnorm(1) is moles atoms for one formula unit ! ceq%phase_varres(lokcs)%abnorm(2) is mass for one formula unit 700 continue totmol=amount*xsum totmass=amount*wsum ! write(*,717)'3F z:',noofel,lokcs,totmol,totmass,amount,& ! wsum,ceq%phase_varres(lokcs)%abnorm(2) 717 format(a,i3,i6,6(1pe12.4)) ! all seems OK here ! write(*,811)xsum,ceq%phase_varres(lokcs)%abnorm(1),& ! wsum,ceq%phase_varres(lokcs)%abnorm(2),amount,totmass ! write(*,811)xsum,ceq%phase_varres(lokcs)%abnorm(1),& ! wsum,ceq%phase_varres(lokcs)%abnorm(2),amount,totmass 811 format('cphmm: ',6(1pe12.4)) ! write(*,*)'cpmm: ',totmol,totmass ! all calculation so far in elements, convert to current components ! NOTE: sum of mole fractions can be zero or negative with other ! components than elements 76 format(a,10F7.4) 78 format(a,2i3,3(1PE12.4)) ! do ic=1,noofel ! write(*,298)(ceq%invcompstoi(jc,ic),jc=1,noofel) ! enddo !298 format('3F: ',6(1pe12.4)) goto 1000 !--------------------------------------------- ! what is this ... converting to user defined components ... (not implemented) x2mol=zero w2mass=zero do ic=1,noofel do jc=1,noofel x2mol(ic)=x2mol(ic)+ceq%invcompstoi(jc,ic)*xmol(jc) ! write(*,78)'addon: ',ic,jc,x2mol(ic),ceq%invcompstoi(jc,ic),xmol(jc) w2mass(ic)=w2mass(ic)+ceq%invcompstoi(ic,jc)*wmass(jc) enddo enddo ! do ic=1,noofel ! write(*,99)'ci: ',(ceq%invcompstoi(jc,ic),jc=1,noofel) ! enddo 99 format(a,7e11.3) ! write(*,76)'cmm2: ',(x2mol(ic),ic=1,noofel) do ic=1,noofel xmol(ic)=x2mol(ic) wmass(ic)=w2mass(ic) enddo ! something wrong between writing label 713 above and here !!!!!!!!!!!!! ! write(*,713)'B',noofel,(xmol(iq),iq=1,noofel) 1000 continue return end subroutine calc_phase_molmass !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_phase_mol !\begin{verbatim} subroutine calc_phase_mol(iph,xmol,ceq) ! calculates mole fractions for phase iph, compset 1 in equilibrium ceq ! used for grid generation and some other things ! returns current constitution in xmol equal to mole fractions of components implicit none integer iph double precision xmol(*) TYPE(gtp_equilibrium_data),pointer :: ceq !\end{verbatim} integer ic,lokph,lokcs,ll,kk,loksp,lokel,iel,ie,compnos(maxspel),nspel double precision as,yz,xsum,smass,qsp,stoi(maxspel) do ic=1,noofel xmol(ic)=zero enddo lokph=phases(iph) lokcs=phlista(lokph)%linktocs(1) ic=0 allsubl: do ll=1,phlista(lokph)%noofsubl as=ceq%phase_varres(lokcs)%sites(ll) allcons: do kk=1,phlista(lokph)%nooffr(ll) ic=ic+1 if(.not.btest(ceq%phase_varres(lokcs)%constat(ic),CONSUS)) then yz=ceq%phase_varres(lokcs)%yfr(ic) loksp=phlista(lokph)%constitlist(ic) if(.not.btest(globaldata%status,GSNOTELCOMP)) then ! the elements are the components do iel=1,splista(loksp)%noofel lokel=splista(loksp)%ellinks(iel) ie=ellista(lokel)%alphaindex if(ie.ne.0) then xmol(ie)=xmol(ie)+& as*yz*splista(loksp)%stoichiometry(iel) endif enddo else ! when we have other components than the elements ! we must convert the element stoichiometry to component stoichiometry ! write(*,*)'3F other components than elements' call get_species_component_data(loksp,nspel,compnos,stoi,& smass,qsp,ceq) do iel=1,nspel xmol(compnos(iel))=xmol(compnos(iel))+as*yz*stoi(iel) enddo endif endif enddo allcons enddo allsubl ! normallize xsum=zero do ic=1,noofel xsum=xsum+xmol(ic) enddo do ic=1,noofel xmol(ic)=xmol(ic)/xsum enddo 1000 continue return end subroutine calc_phase_mol !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_molmass !\begin{verbatim} subroutine calc_molmass(xmol,wmass,totmol,totmass,ceq) ! summing up N and B for each component over all phases with positive amount ! Check that totmol and totmass are correct .... implicit none double precision, dimension(*) :: xmol,wmass double precision totmol,totmass TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} double precision am,amult,tmol,tmass double precision, dimension(maxel) :: xph,wph integer ic,iph,lokph,ics,lokcs do ic=1,noofel xmol(ic)=zero wmass(ic)=zero enddo totmol=zero totmass=zero allph: do iph=1,noofph lokph=phases(iph) if(.not.btest(phlista(lokph)%status1,phhid)) then allcs: do ics=1,phlista(lokph)%noofcs lokcs=phlista(lokph)%linktocs(ics) ! ceq%phase_varres(lokcs)%amfu is current number of formula units ! ceq%phase_varres(lokcs)%abnorm(1) is number of real atoms in a formula unit am=ceq%phase_varres(lokcs)%amfu*& ceq%phase_varres(lokcs)%abnorm(1) if(am.gt.zero) then call calc_phase_molmass(iph,ics,xph,wph,tmol,tmass,amult,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,17)'3F amult:',iph,ics,am,amult,tmol,tmass ! write(*,18)'3F x0: ',(xph(ic),ic=1,noofel) ! write(*,18)'3F w0: ',(wph(ic),ic=1,noofel) 17 format(a,2i4,6(1pe14.6)) 18 format(a,8(F9.5)) do ic=1,noofel xmol(ic)=xmol(ic)+am*xph(ic) wmass(ic)=wmass(ic)+tmass*wph(ic) enddo totmass=totmass+tmass totmol=totmol+tmol endif enddo allcs endif enddo allph ! we have summed the number of moles and mass of all elements in all phases ! xsum=zero ! wsum=zero ! do ic=1,noofel ! xsum=xsum+xmol(ic) ! wsum=wsum+wmass(ic) ! enddo if(totmass.gt.zero) then do ic=1,noofel xmol(ic)=xmol(ic)/totmol wmass(ic)=wmass(ic)/totmass enddo ! write(*,21)'3F x1: ',totmol,(xmol(ic),ic=1,noofel) ! write(*,21)'3F w2: ',totmass,(wmass(ic),ic=1,noofel) 21 format(a,1pe12.4,8(0pF9.5)) ! else ! write(*,*)'There is no mass at all in the system!' ! gx%bmperr=4185; goto 1000 endif ! write(*,21)'3F x1: ',totmol,(xmol(ic),ic=1,noofel) ! write(*,21)'3F w1: ',totmass,(wmass(ic),ic=1,noofel) ! else ! this is not an error if no calculation has been made ! write(*,28)'3F: calc_molmass: No mole fractions',totmol,totmass,xsum,& ! (xmol(ic),ic=1,noofel) 28 format(a,3(1pe12.4)/'3F. ',10f7.4) ! gx%bmperr=4185; goto 1000 ! endif ! wsum=zero ! do ic=1,noofel ! wmass(ic)=xmol(ic)*ellista(elements(ic))%mass ! wsum=wsum+wmass(ic) ! write(*,44)'3F cmm4: ',ic,xmol(ic),wmass(ic),& ! ellista(elements(ic))%mass,wsum,totmass 44 format(a,i3,6(1pe12.4)) ! enddo ! if(wsum.gt.zero) then ! do ic=1,noofel ! wmass(ic)=wmass(ic)/wsum ! enddo ! endif 1000 continue return end subroutine calc_molmass !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine sumprops !\begin{verbatim} subroutine sumprops(props,ceq) ! summing up G, S, V, N and B for all phases with positive amount ! Check if this is correct implicit none TYPE(gtp_equilibrium_data), pointer :: ceq double precision props(5) !\end{verbatim} integer lokph,lokcs,ics double precision am if(gx%bmperr.ne.0) write(*,*)'3F error entering sumprops ',gx%bmperr props=zero allph: do lokph=1,noofph ! write(*,*)'3F sumprops: ',lokph if(.not.btest(phlista(lokph)%status1,phhid)) then ! lokcs=phlista(lokph)%cslink allcs: do ics=1,phlista(lokph)%noofcs ! phase_varres(lokcs)%amfu is the amount formula units of the phase ! phase_varres(lokcs)%abnorm(1) is the moles of real atoms/formula unit ! am is the number of moles of real atoms of the phase lokcs=phlista(lokph)%linktocs(ics) ! skip phases that are not entered if(ceq%phase_varres(lokcs)%phstate.eq.phdorm) cycle allcs ! segmentation fault here ?? during plotting using several STEP/MAP ! when new comp.sets may be allocated ! skip composition sets with no allocated yfr .... if(.not.allocated(ceq%phase_varres(lokcs)%yfr)) then ! write(*,*)'3F skipping unallocated comp.set.',lokcs cycle allcs endif am=ceq%phase_varres(lokcs)%amfu*& ceq%phase_varres(lokcs)%abnorm(1) ! write(*,7)'3F sumprops 2: ',lokph,lokcs,am,& ! ceq%phase_varres(lokcs)%abnorm(1),& ! ceq%phase_varres(lokcs)%abnorm(2),props(5) 7 format(a,2i5,6(1pe12.4)) ! valgrind complains this jump if for an uninitiallized valiable ?? if(am.gt.zero) then ! properties are G, G.T=-S, G.P=V and moles and mass of real atoms ! Note gval(*,1) is per mole formula unit and ceq%phase_varres(lokcs)%abnorm(1) ! is the number of real atoms per formula unit ! write(*,13)'3F props1:',lokcs,props(1),props(2),props(3),am,& ! ceq%phase_varres(lokcs)%abnorm(1) props(1)=props(1)+am*ceq%phase_varres(lokcs)%gval(1,1)/& ceq%phase_varres(lokcs)%abnorm(1) ! write(*,10)props(1),am,ceq%phase_varres(lokcs)%gval(1,1),& ! ceq%phase_varres(lokcs)%abnorm(1) 10 format('3F props: ',6(1pe12.4)) props(2)=props(2)+am*ceq%phase_varres(lokcs)%gval(2,1)/& ceq%phase_varres(lokcs)%abnorm(1) props(3)=props(3)+am*ceq%phase_varres(lokcs)%gval(3,1)/& ceq%phase_varres(lokcs)%abnorm(1) props(4)=props(4)+am ! write(*,13)'3F props2:',lokcs,props(1),props(2),props(3),& ! props(4),ceq%phase_varres(lokcs)%gval(3,1) 13 format(a,i3,6(1pe12.4)) ! ceq%phase_varres(lokcs)%abnorm(2) should be the current mass ! %abnorm(2) is actual mass, its should be multiplied with %amfu, not am!! ! This value is calculated in set_constitution ... check there if problems props(5)=props(5)+ceq%phase_varres(lokcs)%amfu*& ceq%phase_varres(lokcs)%abnorm(2) ! write(*,75)'3F sumprops: ',lokcs,am,& ! ceq%phase_varres(lokcs)%abnorm(2),props(5) 75 format(a,i4,6(1pe12.4)) ! write(*,11)'3F sumprops: ',lokcs,props(1),props(4),props(5),& ! ceq%phase_varres(lokcs)%abnorm(2) ! write(*,11)'3F sumprops ',lokcs,am,props(4),& ! ceq%phase_varres(lokcs)%abnorm(1) 11 format(a,i4,6(1pe12.4)) endif enddo allcs endif enddo allph 1000 continue if(gx%bmperr.ne.0) write(*,*)'3F error exiting sumprops ',gx%bmperr return end subroutine sumprops !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine encode_state_variable !\begin{verbatim} subroutine encode_state_variable(text,ip,svr,ceq) ! writes a state variable in text form position ip. ip is updated character text*(*) integer ip type(gtp_state_variable), pointer :: svr type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer istv,indices(4),iunit,iref ! write(*,*)'3F ************* encode: ' iref=svr%phref iunit=svr%unit ! if svr%oldstv>=10 then istv should be 10*(svr%oldstv-5)+svr%norm ! if(svr%oldstv.ge.10) then ! istv=10*(svr%oldstv-5)+svr%norm ! write(*,*)'3F encode: ',svr%oldstv,svr%norm,istv ! else istv=svr%oldstv ! endif ! svr%argtyp specifies values in indices: ! svr%argtyp: 0=no arguments; 1=comp; 2=ph+cs; 3=ph+cs+comp; 4=ph+cs+const indices=0 if(svr%argtyp.eq.1) then indices(1)=svr%component elseif(svr%argtyp.eq.2) then indices(1)=svr%phase indices(2)=svr%compset elseif(svr%argtyp.eq.3) then indices(1)=svr%phase indices(2)=svr%compset indices(3)=svr%component elseif(svr%argtyp.eq.4) then indices(1)=svr%phase indices(2)=svr%compset indices(3)=svr%constituent endif call encode_state_variable3(text,ip,istv,indices,iunit,iref,ceq) 1000 continue return end subroutine encode_state_variable !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine encode_state_variable3 !\begin{verbatim} %- subroutine encode_state_variable3(text,ip,istv,indices,iunit,iref,ceq) ! writes a state variable in text form position ip. ip is updated ! the internal coding provides in istv, indices, iunit and iref ! ceq is needed as compopnents can be different in different equilibria ?? ! >>>> unfinished as iunit and iref not really cared for implicit none integer, parameter :: noos=20 character*4, dimension(noos), parameter :: svid = & ['T ','P ','MU ','AC ','LNAC','U ','S ','V ',& 'H ','A ','G ','NP ','BP ','DG ','Q ','N ',& 'X ','B ','W ','Y '] character*(*) text integer, dimension(4) :: indices integer istv,ip,iunit,iref type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer jp,ics,kstv,iph,norm,sublat double precision mass ! character stsymb*60 character*1, dimension(4), parameter :: cnorm=['M','W','V','F'] ! sublat=0 ! write(*,*)'3F encode: ',istv if(istv.le.0) then ! this is a parameter property symbol: TC (-2), BM (-3), MQ&FE(FCC) (-4) etc ! translate to 21, 22, 23 ... kstv=19-istv goto 200 endif ! T or P if(istv.le.2) then text(ip:ip)=svid(istv) ip=ip+1 goto 1000 endif stsymb=' ' ! potential: if(istv.le.6) then potential: if(istv.le.5) then ! Potential, MU, AC or LNAC, possible suffix 'S' for SER stsymb=svid(istv) jp=len_trim(stsymb)+1 if(iref.lt.0) then ! New use of svr%phref and iref, <0 means use SER as reference state stsymb(jp:jp)='S' jp=jp+1 endif stsymb(jp:jp)='(' jp=jp+1 if(indices(2).eq.0) then ! problem ... component names can be different in different equilibria .... call get_component_name(indices(1),stsymb(jp:),ceq) if(gx%bmperr.ne.0) goto 1000 jp=len_trim(stsymb)+1 stsymb(jp:jp)=')' jp=jp+1 else ! always use composition set 1 ics=1 call get_phase_name(indices(1),ics,stsymb(jp:)) if(gx%bmperr.ne.0) goto 1000 jp=len_trim(stsymb)+1 stsymb(jp:jp)=','; jp=jp+1 call findsublattice(indices(1),indices(3),sublat) if(gx%bmperr.ne.0) goto 1000 ! call get_phase_constituent_name(indices(1),indices(2),& ! stsymb(jp:),sublat) ! I am not sure if indices(2) is constituent numbered for each sublattice ! or numbered from the beginning, assume the latter !! ! call get_constituent_name(indices(1),indices(2),& ! stsymb(jp:),mass) ! modified 190710/BoS as constituent index is in 3 call get_constituent_name(indices(1),indices(3),& stsymb(jp:),mass) if(gx%bmperr.ne.0) goto 1000 jp=len_trim(stsymb)+1 if(sublat.gt.1) then stsymb(jp:)='#'//char(ichar('0')+sublat)//')' jp=jp+3 else stsymb(jp:jp)=')' jp=jp+1 endif endif goto 800 endif potential if(istv.lt.10) then ! write(*,*)'3F unknown potential' gx%bmperr=4158; goto 1000 endif ! Extensive property has istv>=10 norm=mod(istv,10) kstv=(istv+1)/10+5 ! write(*,3)'3F encode 3: ',kstv,indices !3 format(a,5i5) if(kstv.eq.16 .and. norm.eq.1) then ! NM should be X if(indices(1).ne.0) kstv=17 elseif(kstv.eq.17) then ! BW should be W if(norm.eq.2 .and. indices(1).ne.0) then kstv=19 else kstv=18 endif elseif(kstv.ge.18) then ! Y ! kstv=kstv+2 kstv=20 endif ! write(*,11)'3F esv 7: ',istv,kstv,indices 11 format(a,10i4) stsymb=svid(kstv) jp=len_trim(stsymb)+1 ! write(*,*)'3F norm 1A: ',kstv,norm if(kstv.le.16 .or. kstv.eq.18) then if(norm.gt.0 .and. norm.le.4) then ! write(*,*)'3F norm 1B: ',kstv,norm stsymb(jp:jp)=cnorm(norm) jp=jp+1 elseif(norm.ne.0) then ! write(*,*)'3F norm 1C: ',kstv,norm gx%bmperr=4118; goto 1000 endif endif if(iref.lt.0) then ! we can have reference states for G H etc. stsymb(jp:jp)='S' jp=jp+1 endif goto 500 !----------------- ! parameter property symbols 200 continue iph=indices(1) ics=indices(2) if(indices(3).ne.0) then kstv=-100*istv+indices(3) else kstv=-istv endif ! this call creates the symbol or gives an error ! write(*,*)'3F parameter property symbol: ',kstv,iph,ics call find_defined_property(stsymb,1,kstv,iph,ics) if(gx%bmperr.ne.0) goto 1000 jp=len_trim(stsymb)+1 goto 800 !------------------ ! handle indices 500 continue noind: if(indices(3).gt.0) then ! 3 indices, phase, comp.set and constituent allowed for Y ! or phase, comp.set and component, allowed for N, X, B and W ! or phase, comp.set and constituent allowed for MQ& if(kstv.eq.20) then ! this is Y stsymb(jp:jp)='(' jp=jp+1 call get_phase_name(indices(1),indices(2),stsymb(jp:)) if(gx%bmperr.ne.0) goto 1000 jp=len_trim(stsymb)+1 stsymb(jp:jp)=',' jp=jp+1 call findsublattice(indices(1),indices(3),sublat) if(gx%bmperr.ne.0) goto 1000 ! call get_phase_constituent_name(indices(1),indices(3),& ! stsymb(jp:),sublat) call get_constituent_name(indices(1),indices(3),& stsymb(jp:),mass) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'3F encode y:',indices,sublat ! sublattice is the last argument jp=len_trim(stsymb)+1 if(sublat.gt.1) then stsymb(jp:)='#'//char(ichar('0')+sublat)//')' jp=jp+3 else stsymb(jp:jp)=')' jp=jp+1 endif ! write(*,*)'3F encode: "',trim(stsymb),'"' elseif(kstv.ge.16 .and. kstv.le.19) then ! allow for percent or % if(iunit.eq.100) then stsymb(jp:jp+1)='%(' jp=jp+2 else stsymb(jp:jp)='(' jp=jp+1 endif call get_phase_name(indices(1),indices(2),stsymb(jp:)) if(gx%bmperr.ne.0) goto 1000 jp=len_trim(stsymb)+1 stsymb(jp:jp)=',' jp=jp+1 call get_component_name(indices(3),stsymb(jp:),ceq) if(gx%bmperr.ne.0) goto 1000 jp=len_trim(stsymb)+1 stsymb(jp:jp)=')' jp=jp+1 else gx%bmperr=4117; goto 1000 endif elseif(indices(2).gt.0) then ! 2 indices, can only be phase and comp.set stsymb(jp:jp)='(' jp=jp+1 call get_phase_name(indices(1),indices(2),stsymb(jp:)) if(gx%bmperr.ne.0) goto 1000 jp=len_trim(stsymb)+1 stsymb(jp:jp)=')' jp=jp+1 elseif(indices(1).gt.0) then ! 1 index, can only be component ! allow for percent or % if(iunit.eq.100) then stsymb(jp:jp+1)='%(' jp=jp+2 else stsymb(jp:jp)='(' jp=jp+1 endif call get_component_name(indices(1),stsymb(jp:),ceq) if(gx%bmperr.ne.0) goto 1000 jp=len_trim(stsymb)+1 stsymb(jp:jp)=')' jp=jp+1 ! >>>> unfinished endif noind ! 800 continue if(ip+jp.gt.len(text)) then write(*,*)'State variable value output exceed character variable length' gx%bmperr=4319; goto 1000 endif text(ip:ip+jp-1)=stsymb ip=ip+jp if(text(ip:ip).eq.' ') then ! remove a trailing space occuring in some cases ip=ip-1 endif 1000 continue return end subroutine encode_state_variable3 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine encode_state_variable_record !\begin{verbatim} subroutine encode_state_variable_record(text,ip,svr,ceq) ! writes a state variable in text form position ip. ip is updated ! the svr record provide istv, indices, iunit and iref ! ceq is needed as compopnents can be different in different equilibria ?? ! >>>> unfinished as iunit and iref not really cared for implicit none integer, parameter :: noos=20 character*4, dimension(noos), parameter :: svid = & ['T ','P ','MU ','AC ','LNAC','U ','S ','V ',& 'H ','A ','G ','NP ','BP ','DG ','Q ','N ',& 'X ','B ','W ','Y '] character*(*) text type(gtp_state_variable) :: svr type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer jp,ics,kstv,iph,norm,sublat integer, dimension(4) :: indices integer istv,ip,iunit,iref double precision mass ! character stsymb*60 character*1, dimension(4), parameter :: cnorm=['M','W','V','F'] ! istv=svr%oldstv norm=svr%norm iunit=svr%unit indices=0 if(svr%argtyp.eq.1) then indices(1)=svr%component elseif(svr%argtyp.eq.2) then indices(1)=svr%phase indices(2)=svr%compset elseif(svr%argtyp.eq.3) then indices(1)=svr%phase indices(2)=svr%compset indices(3)=svr%component elseif(svr%argtyp.eq.4) then indices(1)=svr%phase indices(2)=svr%compset indices(3)=svr%constituent endif ! there is some cloudy thinking here. If the user has defined his own ! reference state that should be used. The information is stored in the ! component record (ceq%complist(i)%phlink ! But if the user specifies MUS(i) one should use SER ... how to transfer that ! information to the calculating routines? ! By default svr%phref=0, then use user defined. If phref<0 use SER ?? iref=svr%phref ! if(istv.le.0) then ! this is a parameter property symbol: TC (-2), BM (-3), MQ&FE(FCC) (-4) etc ! translate to 21, 22, 23 ... kstv=19-istv goto 200 ! gx%bmperr=4116; goto 1000 endif ! T or P if(istv.le.2) then text(ip:ip)=svid(istv) ip=ip+1 goto 1000 endif stsymb=' ' ! potential: if(istv.le.6) then potential: if(istv.le.5) then ! Potential, MU, AC or LNAC, possible suffix 'S' for SER stsymb=svid(istv) jp=len_trim(stsymb)+1 ! if(iref.ne.0) then if(iref.lt.0) then ! new use of phref and iref, <0 means use SER and suffix S stsymb(jp:jp)='S' jp=jp+1 endif stsymb(jp:jp)='(' jp=jp+1 if(indices(2).eq.0) then ! problem ... component names can be different in different equilibria .... call get_component_name(indices(1),stsymb(jp:),ceq) if(gx%bmperr.ne.0) goto 1000 jp=len_trim(stsymb)+1 else ! always use composition set 1 and assume sublattice 1 ?? ics=1 sublat=1 call get_phase_name(indices(1),ics,stsymb(jp:)) if(gx%bmperr.ne.0) goto 1000 jp=len_trim(stsymb)+1 stsymb(jp:jp)=','; jp=jp+1 call findsublattice(indices(1),indices(3),sublat) if(gx%bmperr.ne.0) goto 1000 ! call get_phase_constituent_name(indices(1),indices(2),& ! stsymb(jp:),sublat) call get_constituent_name(indices(1),indices(2),& stsymb(jp:),mass) if(gx%bmperr.ne.0) goto 1000 jp=len_trim(stsymb)+1 if(sublat.gt.1) then stsymb(jp:)='#'//char(ichar('0')+sublat)//')' jp=jp+3 else stsymb(jp:jp)=')' jp=jp+1 endif endif stsymb(jp:jp)=')' goto 800 endif potential if(istv.lt.10) then ! write(*,*)'3F unknown potential' gx%bmperr=4158; goto 1000 endif ! Extensive property has istv>=10 norm=mod(istv,10) kstv=(istv+1)/10+5 ! write(*,3)'3F encode 3: ',kstv,indices !3 format(a,5i5) if(kstv.eq.16 .and. norm.eq.1) then ! NM should be X if(indices(1).ne.0) kstv=17 elseif(kstv.eq.17) then ! BW should be W if(norm.eq.2 .and. indices(1).ne.0) then kstv=19 else kstv=18 endif elseif(kstv.ge.18) then ! Y ! kstv=kstv+2 kstv=20 endif ! write(*,11)'3F esv 7: ',istv,kstv,indices 11 format(a,10i4) stsymb=svid(kstv) jp=len_trim(stsymb)+1 ! write(*,*)'3F norm 2: ',kstv,norm if(kstv.le.16 .or. kstv.eq.18) then if(norm.gt.0 .and. norm.le.4) then stsymb(jp:jp)=cnorm(norm) jp=jp+1 elseif(norm.ne.0) then gx%bmperr=4118; goto 1000 endif endif goto 500 !----------------- ! parameter property symbols 200 continue iph=indices(1) ics=indices(2) if(indices(3).ne.0) then kstv=-100*istv+indices(3) else kstv=-istv endif ! this call creates the symbol or gives an error call find_defined_property(stsymb,1,kstv,iph,ics) if(gx%bmperr.ne.0) goto 1000 jp=len_trim(stsymb)+1 goto 800 !------------------ ! handle indices 500 continue noind: if(indices(3).gt.0) then ! 3 indices, phase, comp.set and constituent allowed for Y ! or phase, comp.set and component, allowed for N, X, B and W ! or phase, comp.set and constituent allowed for MQ& if(kstv.eq.20) then ! this is Y stsymb(jp:jp)='(' jp=jp+1 call get_phase_name(indices(1),indices(2),stsymb(jp:)) if(gx%bmperr.ne.0) goto 1000 jp=len_trim(stsymb)+1 stsymb(jp:jp)=',' jp=jp+1 call findsublattice(indices(1),indices(3),sublat) if(gx%bmperr.ne.0) goto 1000 ! call get_phase_constituent_name(indices(1),indices(3),& ! stsymb(jp:),sublat) call get_constituent_name(indices(1),indices(3),& stsymb(jp:),mass) if(gx%bmperr.ne.0) goto 1000 jp=len_trim(stsymb)+1 if(sublat.gt.1) then stsymb(jp:)='#'//char(ichar('0')+sublat)//')' jp=jp+3 else stsymb(jp:jp)=')' jp=jp+1 endif elseif(kstv.ge.16 .and. kstv.le.19) then ! allow for percent or % if(iunit.eq.100) then stsymb(jp:jp+1)='%(' jp=jp+2 else stsymb(jp:jp)='(' jp=jp+1 endif call get_phase_name(indices(1),indices(2),stsymb(jp:)) if(gx%bmperr.ne.0) goto 1000 jp=len_trim(stsymb)+1 stsymb(jp:jp)=',' jp=jp+1 call get_component_name(indices(3),stsymb(jp:),ceq) if(gx%bmperr.ne.0) goto 1000 jp=len_trim(stsymb)+1 stsymb(jp:jp)=')' jp=jp+1 else gx%bmperr=4117; goto 1000 endif elseif(indices(2).gt.0) then ! 2 indices, can only be phase and comp.set stsymb(jp:jp)='(' jp=jp+1 call get_phase_name(indices(1),indices(2),stsymb(jp:)) if(gx%bmperr.ne.0) goto 1000 jp=len_trim(stsymb)+1 stsymb(jp:jp)=')' jp=jp+1 elseif(indices(1).gt.0) then ! 1 index, can only be component ! allow for percent or % if(iunit.eq.100) then stsymb(jp:jp+1)='%(' jp=jp+2 else stsymb(jp:jp)='(' jp=jp+1 endif call get_component_name(indices(1),stsymb(jp:),ceq) if(gx%bmperr.ne.0) goto 1000 jp=len_trim(stsymb)+1 stsymb(jp:jp)=')' jp=jp+1 ! >>>> unfinished endif noind ! 800 continue text(ip:ip+jp-1)=stsymb ip=ip+jp if(text(ip:ip).eq.' ') then ! remove a trailing space occuring in some cases ip=ip-1 endif 1000 continue return end subroutine encode_state_variable_record !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine findsublattice !\begin{verbatim} subroutine findsublattice(iph,constix,sublat) ! find sublattice of constituent constix in phase lokph ! is lokph index to gtp_phaserecord or gtp_phase_varres?? ! constix is constituent index implicit none integer iph,constix,sublat !\end{verbatim} integer ix,lokph,nn if(iph.gt.0 .and. iph.le.noofph) then lokph=phases(iph) else gx%bmperr=4050; goto 1000 endif ! write(*,*)'3F args: ',iph,lokph,constix ! write(*,*)'3F phase: ',phlista(lokph)%name if(constix.le.0) then write(*,*)'3F no such constituent in this phase',constix gx%bmperr=4399; goto 1000 endif ! nn=1 ! BUG!! found 21.03.18 after 5 years !! nn=0 loop: do sublat=1,phlista(lokph)%noofsubl nn=nn+phlista(lokph)%nooffr(sublat) if(constix.le.nn) exit loop enddo loop if(constix.gt.nn) then write(*,*)'3F no such constituent in this phase',constix gx%bmperr=4399 endif 1000 continue return end subroutine findsublattice !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine state_variable_val !\begin{verbatim} subroutine state_variable_val(svr,value,ceq) ! calculate the value of a state variable in equilibrium record ceq ! It transforms svr data to old format and calls state_variable_val3 type(gtp_state_variable), pointer :: svr double precision value TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer istv, indices(4),iref,iunit ! iref=svr%phref iunit=svr%unit ! searching for experimental bug ! write(*,*)'3F state_variable_val: ',svr%statevarid,iref,iunit ! if(svr%oldstv.gt.10) then ! istv=10*(svr%oldstv-5)+svr%norm ! else istv=svr%oldstv ! endif ! svr%argtyp specifies values in indices: ! svr%argtyp: 0=no arguments; 1=comp; 2=ph+cs; 3=ph+cs+comp; 4=ph+cs+const indices=0 if(svr%argtyp.eq.1) then indices(1)=svr%component elseif(svr%argtyp.eq.2) then indices(1)=svr%phase indices(2)=svr%compset elseif(svr%argtyp.eq.3) then indices(1)=svr%phase indices(2)=svr%compset indices(3)=svr%component elseif(svr%argtyp.eq.4) then indices(1)=svr%phase indices(2)=svr%compset indices(3)=svr%constituent elseif(svr%argtyp.ne.0) then write(*,*)'3F state variable has illegal argtyp: ',svr%argtyp gx%bmperr=4320; goto 1000 endif ! write(*,910)'3F svv: ',istv,indices,iref,iunit,value 910 format(a,i3,2x,4i3,2i3,1pe14.6) ! write(*,*)'3F calling state_variable_val3: ' call state_variable_val3(istv,indices,iref,iunit,value,ceq) if(gx%bmperr.ne.0) then ! write(*,920)'3F error 7: ',gx%bmperr,istv,svr%oldstv,svr%argtyp !920 format(a,i5,2x,2i15,i2) ! else ! write(*,*)'3F value: ',value endif ! write(*,*)'3F back from state_variable_val3: ',value 1000 continue return end subroutine state_variable_val !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine state_variable_val3 !\begin{verbatim} %- subroutine state_variable_val3(istv,indices,iref,iunit,value,ceq) ! calculate the value of a state variable in equilibrium record ceq ! istv is state variable type (integer) ! indices are possible specifiers ! iref indicates use of possible reference state, 0 current, -1 SER ! iunit is unit, (K, oC, J, cal etc). For % it is 100 ! value is the calculated values. for state variables with wildcards use ! get_many_svar implicit none integer, dimension(4) :: indices TYPE(gtp_equilibrium_data), pointer :: ceq integer istv,iref,iunit double precision value !\end{verbatim} double precision props(5),xmol(maxel),wmass(maxel),stoi(10) double precision, allocatable :: cmpstoi(:) double precision vt,vp,amult,vg,vs,vv,div,aref,vn,bmult,tmass,tmol double precision qsp,gref,spmass,rmult,tsave,rtn,spextra(10) integer kstv,norm,lokph,lokcs,icx,jp,ncmp,ic,iprop,loksp,nspel,iq,nspx integer endmember(maxsubl),ielno(maxspel) value=zero ceq%rtn=globaldata%rgas*ceq%tpval(1) ! write(*,10)'3F svval3: ',istv,indices,iref,iunit,gx%bmperr,value 10 format(a,i4,4i4,3i5,1PE17.6) potentials: if(istv.lt.0) then ! negative istv indicate parameter property symbols kstv=-istv goto 200 ! gx%bmperr=4097; goto 1000 elseif(istv.ge.10) then goto 50 elseif(istv.eq.1) then ! this is T value=ceq%tpval(1) elseif(istv.eq.2) then ! this is P value=ceq%tpval(2) elseif(istv.le.5) then ! the check of reference state state is made at label 500 if(istv.eq.3) then ! MUx(component) or MU(phase,constituent), x can be S for SER goto 500 elseif(istv.eq.4) then ! ACx(component) or AC(phase,constituent) goto 500 elseif(istv.eq.5) then ! LNACx(component) or LNAC(phase,constituent) goto 500 endif ! wrong or state variable not implemented write(*,10)'3F not impl 1: ',istv,indices,iref,iunit,gx%bmperr,value goto 1100 else ! wrong or state variable not implemented ! write(*,10)'3F not impl 2: ',istv,indices,iref,iunit,gx%bmperr,value goto 1100 endif potentials ! normal return goto 1000 !---------------------------------------------------------- ! extensive variable (N, X, G ...) or model variable (TC, BMAG) 50 continue norm=mod(istv,10) kstv=istv/10 ! this may not be necessary in all cases but do it anyway: ! sum over all stable phases, props(1..3) are G, G.T and G.P, ! props(4) is amount of moles of components, props(5) is mass of components call sumprops(props,ceq) if(gx%bmperr.ne.0) goto 1000 ! if verbose on if(ocv()) write(*,51)'3F stv A: ',props 51 format(a,5(1PE12.3)) ! kstv can be 1 to 15 for different properties ! norm can be 1, 2, 3 or 4 for normalizing. 0 for not normallizing ! M W V F ! OLD: iref can be 0 or 1 for reference state ! iref can be 0 for using current referennce state ! iref <0 for default reference state (SER) le10: if(kstv.le.10) then ! kstv= 1 2 3 4 5 6 7 8 9 10 ! state var; U, S, V, H, A, G, NP, BP, DG and Q vt=ceq%tpval(1) vp=ceq%tpval(2) ! ceq%rtn=globaldata%rgas*ceq%tpval(1) amult=ceq%rtn ! write(*,*)'3F stv B: ',norm,kstv,indices(1),vt,vp,amult if(indices(1).eq.0) then ! global value for the whole system vg=props(1) vs=-props(2) vv=props(3) ! normalizing: 0 none,1=M (moles), 2=W (mass), 3=W(volume), 4=F(formula unit) ! write(*,*)'3F norm: ',norm,props(1) if(norm.eq.1) then ! props(4) is total number of moldes div=props(4) elseif(norm.eq.2) then ! props(5) is total mass div=props(5) elseif(norm.eq.3) then ! Normalizing per volume, there frequently no volume data div=props(3) if(div.eq.zero) then gx%bmperr=4114; goto 1000 endif elseif(norm.eq.4) then gx%bmperr=4115; goto 1000 else div=one endif ! for phase specific the aref should be independent of amult and div ?? ! for system wide these are unity rmult=one ! write(*,555)'3F pp: ',vg,props 555 format(a,6(1pe12.4)) else ! phase specific, indices are phase and composition set call get_phase_compset(indices(1),indices(2),lokph,lokcs) if(gx%bmperr.ne.0) goto 1000 vg=ceq%phase_varres(lokcs)%gval(1,1) vs=-ceq%phase_varres(lokcs)%gval(2,1) vv=ceq%phase_varres(lokcs)%gval(3,1) ! normalizing: 0 none,1=M (moles), 2=W (mass), 3=W(volume), 4=F(formula unit) ! I have to think more here should normalizing be per phase or for total? ! GM(BCC) is for one mole BCC, M refer per mole of phase even if not stable ! NPM(BCC) is more fraction of BCC relative to total amount in system ! write(*,*)'3F norm 2: ',norm,props(1),div if(norm.eq.1) then ! phase property normalized per phase like HM or SM div=ceq%phase_varres(lokcs)%abnorm(1) ! phase property normalized for whole system as NPM if(kstv.eq.7) div=props(4) rmult=div elseif(norm.eq.2) then ! abnorm(2) should be the mass per formulat unit div=ceq%phase_varres(lokcs)%abnorm(2) ! phase property normalized for whole system as NPM if(kstv.eq.8) div=props(5) rmult=div elseif(norm.eq.3) then div=ceq%phase_varres(lokcs)%gval(3,1) if(div.eq.zero) then gx%bmperr=4114; goto 1000 endif rmult=div elseif(norm.eq.4) then ! per formula unit of a particular phase ! div=ceq%phase_varres(lokcs)%abnorm(1) ! write(*,*)'3F normalize F:',div ! rmult=one div=one rmult=div else ! no normalizing for a specific phase, value for current amount ! NOTE amult is already RT amult=amult*ceq%phase_varres(lokcs)%amfu rmult=ceq%phase_varres(lokcs)%amfu div=one ! div=ceq%phase_varres(lokcs)%abnorm(1) endif ! for phase specific the aref is for one mole of atoms and should ! be independent of amult and div ?? ! if(amult.eq.zero) then ! rmult=zero ! else ! rmult=div/amult ! endif endif ! here the reference state should be considered ! aref=zero if(iref.eq.0) then ! iref=0 means user defined reference state >>>> unfinished !?????????????????????????????????? ! UNFINISHED ! If O has reference state but no other elements then ignore refstate ! for integral quantities UNLESS all components has the same reference ! state .... ! write(*,52)'3F Ref state:',iref,kstv,indices(1),indices(2),rmult 52 format(a,4i4,1pe12.4) ! IMPORTANT !!! calculate reference state may destroy valies in %gval call calculate_reference_state(kstv,indices(1),indices(2),aref,ceq) if(gx%bmperr.ne.0) goto 1000 ! value here seems OK ! write(*,53)'3F Reference state:',iref,aref,rmult elseif(iref.lt.0) then aref=zero else ! positive value of iref is undefined write(*,*)'3F Reference state undefined: ',iref aref=zero endif ! if phase specific the scaling for phase specific must be compensated aref=rmult*aref ! write(*,53)'3F at kstv1: ',kstv,props,aref,div ! write(*,53)'3F more:',0,amult,vg,vp,vv,amult*(vg-vp*vv-aref)/div 53 format(a,i3,7(1PE11.3)) kstv1: if(kstv.eq.1) then ! 1: U = G + TS - PV = G - T*G.T - P*G.P value=amult*(vg+vt*vs-vp*vv-aref)/div elseif(kstv.eq.2) then ! 2: S = -G.T value=amult*(vs-aref)/div ! write(*,54)value,amult,vs,aref,div 54 format('3F svv: ',5(1pe12.4)) elseif(kstv.eq.3) then ! 3: V = G.P value=amult*(vv-aref)/div ! write(*,54)amult,vv,aref,div,value elseif(kstv.eq.4) then ! 4: H = G + TS = G - T*G.T ! Problem with vg here when reference state is set if(ocv()) write(*,177)'3F H:',vg+vt*vs,aref,amult,div,rmult 177 format(a,6(1pe12.4)) value=amult*(vg+vt*vs-aref)/div elseif(kstv.eq.5) then ! 5: A = G - PV = G - P*G.P value=amult*(vg-vp*vv-aref)/div ! write(*,53)'3F more:',0,amult,vg,vp,vv,value elseif(kstv.eq.6) then ! 6: G ! write(*,177)'3F G:',vg,aref,amult,div value=amult*(vg-aref)/div elseif(kstv.eq.7) then ! 7: NP ! write(*,*)'3F npm:',norm,div ! div is normalizing, can be 1.0 or total volume value=ceq%phase_varres(lokcs)%abnorm(1)* & ceq%phase_varres(lokcs)%amfu/div elseif(kstv.eq.8) then ! 8: BP ! abnorm(2) should be the mass per formula unit value=ceq%phase_varres(lokcs)%abnorm(2)* & ceq%phase_varres(lokcs)%amfu/div elseif(kstv.eq.9) then ! 9: DG (driving force) ! write(*,202)'3F svval DG:',lokcs,ceq%phase_varres(lokcs)%dgm,div 202 format(a,i5,2(1pe12.4)) value=ceq%phase_varres(lokcs)%dgm/div elseif(kstv.eq.10) then ! 10: Q (stability, thermodynamic factor) ! gx%bmperr=4081; goto 1000 call calc_qf(lokcs,value,ceq) ! else ! write(*,*)'3F svval after 10:',kstv endif kstv1 ! write(*,53)'3F more:',-1,amult,vg,vp,vv,value goto 1000 endif le10 !---------------------------------------------------------------------- ! here with kstv>10 ! kstv= 11 12 13 ! state var: N B Y le12: if(kstv.le.12) then ! normallizing for N (kstv=11) and B (kstv=12) ! write(*,88)'3F svv 12: ',indices(1),norm,props(4),props(5) 88 format(a,2i3,6(1pe12.4)) if(indices(1).eq.0) then ! no first index means the sum over all phases ! props(4) is amount of moles of components, props(5) is mass of components if(kstv.eq.11) then vn=props(4) else vn=props(5) endif ! normalizing if(norm.eq.1) then div=props(4) elseif(norm.eq.2) then div=props(5) elseif(norm.eq.3) then ! we may not have any volume data ... div=props(3) if(div.eq.zero) then gx%bmperr=4114; goto 1000 endif elseif(norm.eq.4) then gx%bmperr=4115; goto 1000 else div=one endif ! This is N or B without index but possibly normallized ! write(*,89)'3F svv, N or B: ',vn,div 89 format(a,5(1pe12.4)) value=vn/div else ! one or two indices, overall of phase specific component amount if(indices(2).eq.0) then ! one index is component specific, N(comp.), B(CR) etc. Sum over all phases ! props(4) is amount of moles of components, props(5) is mass of components call calc_molmass(xmol,wmass,tmol,tmass,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,89)'3F mm: ',tmol,tmass ! write(*,93)'3F x: ',(xmol(icx),icx=1,noofel) ! write(*,93)'3F w: ',(wmass(icx),icx=1,noofel) 93 format(a,9F7.4) icx=1 if(kstv.eq.11) then bmult=props(4) else bmult=props(5) endif else ! two indices is phase and component specific. bmult is amount of phase call calc_phase_molmass(indices(1),indices(2),& xmol,wmass,tmol,tmass,bmult,ceq) icx=3 ! write(*,92)'3F cpmm: ',indices(icx),tmol,tmass,bmult,& ! wmass(1),wmass(2),wmass(3) 92 format(a,i3,3(1pe12.4),3(0pF8.5)) endif if(gx%bmperr.ne.0) goto 1000 ! write(*,13)'3F gsvv 19: ',norm,(xmol(iq),iq=1,noofel) 777 format('gsvv 77: ',10(f7.4)) if(kstv.eq.11) then ! total moles of component vn=xmol(indices(icx)) amult=tmol ! added next line 2015-08-20 to get correct N(sigma,mo) bmult=tmol ! write(*,777)kstv,icx,indices(icx),norm,vn,amult,bmult !777 format('3F N(i): ',4i4,3(1pe12.4)) else ! total mass of component vn=wmass(indices(icx)) amult=tmass ! added next line 2015-08-20 to get correct N(sigma,mo) bmult=tmass endif ! write(*,13)'3F gsvv 8: ',norm,vn,amult,bmult,tmol,tmass 13 format(a,i3,7(1PE10.2)) norm3: if(norm.eq.1) then ! NM or X if(tmol.ne.zero) then value=amult*vn/tmol ! write(*,'(a,5F8.4)')'3F MQMQA: ',amult,vn,tmol else ! problem at x(phase,component) was zero when phase fix with zero amount ! value=zero value=vn endif ! percent % ! write(*,*)'3F x%: ',iunit,value if(iunit.eq.100) value=1.0D2*value elseif(norm.eq.2) then ! NW or W if(tmass.gt.zero) then value=amult*vn/tmass else value=zero endif ! problem when plotting w(*,C) for phase fix with 0 amount ! value=wmass(indices(icx)) value=vn ! percent % if(iunit.eq.100) value=1.0D2*value elseif(norm.eq.3) then ! NV if(props(3).gt.zero) then value=amult*vn/props(3) else gx%bmperr=4114 endif elseif(norm.eq.4) then ! NF or BF with one or two indices if(indices(2).eq.0) then gx%bmperr=4115; goto 1000 else value=vn endif else ! N(comp), N(phase,comp), B(comp) or B(phase,comp) value=bmult*vn endif norm3 endif goto 1000 endif le12 !----------------------------------------------------------------- ! special for Y if(kstv.eq.13) then ! 13: Y call get_phase_compset(indices(1),indices(2),lokph,lokcs) if(gx%bmperr.ne.0) goto 1000 value=ceq%phase_varres(lokcs)%yfr(indices(3)) else ! wrong state variable specification value=zero gx%bmperr=4113 endif goto 1000 !----------------------------------------------------------------- ! values of parameter property symbols ! >>> this can easily be generallized ... next time around ... ! here with state variable <0, system and user defined properties 200 continue ! write(*,*)'3F svv3 at 200:',kstv,ndefprop ! if(ndefprop.ne.33) then ! THIS IS A VERY CRUDE CHECK! Please check also the SELECT below !!! ! it may need to be modified !!! ! if(ndefprop.ne.31) then modified to 32 to include VS ! if(ndefprop.ne.33) then if(ndefprop.ne.36) then write(*,*)'3F The model parameter identifiers has been changed!',36 write(*,*)'3F You must correct state_variable_val3 in GTP3F.F90!' ! you may also have to change the case indices!! stop endif ! write(*,*)'3F kstv: ',kstv select case(kstv) case default write(kou,*)'Unknown parameter identifier: ',kstv ! I need to separate out mpi's that have constituent index ... ! updated 2019.12.14 !------------------------------------------------------------------- ! These are model_parameter_ident in June 2018: ! 1 G T P 0 Energy ! 2 TC - P 2 Combined Curie/Neel T ! 3 BMAG - - 1 Average Bohr magneton numb ! 4 CTA - P 2 Curie temperature ! 5 NTA - P 2 Neel temperature ! 6 IBM - P &; 12 Individual Bohr magneton num ! 7 THET - P 2 Debye or Einstein temp ! 8 V0 - - 1 Volume at T0, P0 ! 9 VA T - 4 Thermal expansion ! 10 VB T P 0 Bulk modulus ! 11 VC T P 0 Extra volume parameter ! 12 VS - - 1 Diffusion volume ! 13 MQ T P &; 10 Mobility activation energy ! 14 MF T P &; 10 RT*ln(mobility freq.fact.) ! 15 MG T P &; 10 Magnetic mobility factor ! 16 G2 T P 0 Liquid two state parameter ! 17 THT2 - P 2 Smooth slope function T ! 18 DCP2 - P 2 Smooth slope funtion step ! 19 LPX T P 0 Lattice param X axis ! 20 LPY T P 0 Lattice param Y axis ! 21 LPZ T P 0 Lattice param Z axis ! 22 LPTH T P 0 Lattice angle TH ! 23 EC11 T P 0 Elastic const C11 ! 24 EC12 T P 0 Elastic const C12 ! 25 EC44 T P 0 Elastic const C44 ! 26 UQT T P &; 0 UNIQUAC residual parameter ! 27 RHO T P 0 Electric resistivity ! 28 VISC T P 0 Viscosity ! 29 LAMB T P 0 Thermal conductivity ! 30 HMVA T P 0 Enthalpy of vacancy form. ! 31 TSCH - P 2 Schottky anomality T ! 32 CSCH - P 2 Schottky anomality Cp/R. ! 33 QCZ - - 1 MQMQA coordination factor ! I am not sure how to handle changes ... !------------------------------------------------------------------- !...................................... without constituent index ! case(1:5,7:12,16:25,27:31) OLD ! case(1:5,7:12,16:25,27:32) case(1:5,7:12,16:25,27:33) ! not with constituent index: 6: individual Bohr magneton number ! not with constituent index: 13:15: Mobilities ! not with constituent index: 26: UNIQUAC call get_phase_compset(indices(1),indices(2),lokph,lokcs) if(gx%bmperr.ne.0) goto 1000 ! nprop is number of properties calculated. Property 1 is always G find1: do jp=2,ceq%phase_varres(lokcs)%nprop ! the listprop array contain identification of the property stored there if(ceq%phase_varres(lokcs)%listprop(jp).eq.kstv) then value=ceq%phase_varres(lokcs)%gval(1,jp) goto 1000 endif enddo find1 !....................................... with constituent index ! These have a constituent index case(6,13:15,26) ! 6: IBM& Individual Bohr magneton number ! 13-15: MQ& etc mobility values ! 26: UNIQUAC parameter tau ! write(*,*)'3F svv3 mob1: ',indices(1),indices(2) call get_phase_compset(indices(1),indices(2),lokph,lokcs) if(gx%bmperr.ne.0) goto 1000 ! property is kstv*100+indices(3) (constituent index) iprop=100*kstv+indices(3) ! write(*,485)'3F svv3 mob2: ',indices(1),indices(2),iprop,& ! ceq%phase_varres(lokcs)%nprop 485 format(a,2i3,10i5) find2: do jp=2,ceq%phase_varres(lokcs)%nprop ! write(*,485)'3F calcprop: ',ceq%phase_varres(lokcs)%listprop(jp) if(ceq%phase_varres(lokcs)%listprop(jp).eq.iprop) then value=ceq%phase_varres(lokcs)%gval(1,jp) goto 1000 endif enddo find2 write(*,*)'3F model parameter value has not been calculated' gx%bmperr=4361 end select !....................................... ! all legal case values goto somewhere else ! gx%bmperr=4113; goto 1000 goto 1000 !----------------------------------------------------------------- ! chemical potentials, activites etc, istv is 3, 4 or 5 for MU, AC and LNAC ! there can be a reference state 500 continue ! ceq%rtn=globaldata%rgas*ceq%tpval(1) ! if one argument that is a component, if two these are phase and constituent ! here indices(2) is considered to specify a reference state ...??? ! write(*,502)'3F refstate 500: ',iref,indices(1),indices(3) 502 format(a,10i4) ! if(indices(2).ne.0) then ! species index is in indices(3) !!!! if(indices(3).ne.0) then ! This has nothing to do with reference state ... ??? see else link for that ! I wonder if this code is ever used ... ! write(*,502)'3F species: ',iref,indices(1),indices(3) lokph=phases(indices(1)) loksp=phlista(lokph)%constitlist(indices(3)) ! split the species in elements, convert to components, add chemical potentials call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp,nspx,spextra) if(gx%bmperr.ne.0) goto 1000 if(qsp.ne.zero) then ! write(*,*)'3F Cannot calculate potential of charged species' gx%bmperr=4159; goto 1000 endif allocate(cmpstoi(noofel)) cmpstoi=zero ! get_species_data gives only elements with non-zero stoiciometry do ic=1,nspel cmpstoi(ielno(ic))=stoi(ic) enddo ! write(*,507)'3F elstoi:',loksp,nspel,indices(3),(cmpstoi(ic),ic=1,noofel) 507 format(a,3i3,10(1pe12.4)) ! elements2components1 is in gtp3G ! ncmp returned as number of elements, cmpstoi is stoichiometry of ALL elements ! stoi is no longer used ... call elements2components1(nspel,stoi,ncmp,cmpstoi,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,508)'3F el2comp:',loksp,nspel,(cmpstoi(ic),ic=1,noofel) 508 format(a,2i3,10(1pe12.4)) value=zero do ic=1,ncmp value=value+cmpstoi(ic)*ceq%complist(ic)%chempot(1) enddo ! >>>> subtract reference state: i.e. calculate G for the phase with ! just this constituent. Note indices(1) is phase record, change to index ! write(*,*)'3F refphase: ',indices(1),value ic=phlista(indices(1))%alphaindex ! set endmember=0 to allow vacancies ... ! HM, here I think it can only be a single species .... 190710/BoS endmember=0 ! changed from indices(2) which is composition set number endmember(1)=indices(3) ! This routine returns G for current number of atoms call calcg_endmemberx(indices(1),endmember,gref,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,'(a,i3,2x,10i3)')'3F callcg_endmember 1: ',indices(1),endmember value=value-gref*ceq%rtn ! write(*,511)'3F refstate: ',indices(1),indices(3),gref*ceq%rtn,value 511 format(a,2i3,6(1pe12.4)) ! possibly convert to AC or LNAC goto 700 else ! write(*,*)'3F elselink: ',indices if(indices(1).le.0 .or. indices(1).gt.noofel) then ! write(*,*)'3F Asking for nonexisting chemical potential' gx%bmperr=4171; goto 1000 endif ! iref=0 is default meaning user defined reference state, ! if iref<0 use SER as reference state, ignoring user defined reference state ! ! If a component has a defined reference state that is in complist(indices(1)) if(iref.eq.0 .and. ceq%complist(indices(1))%phlink.ne.0) then ! write(*,*)'3F Reference state: ',indices(1),indices(2),& ! ceq%complist(indices(1))%phlink ! phlink is phase, endmember is enmember, tpref<0 means current T ! we should also have a stoichiometry factor ?? ! endmember(1)=indices(2) tsave=ceq%tpval(1) if(ceq%complist(indices(1))%tpref(1).gt.zero) then ! reference state is at a fixed T, negative tpref(1) means current T ceq%tpval(1)=ceq%complist(indices(1))%tpref(1) endif ! write(*,*)'3F calling calcg_endmember: ',& ! ceq%complist(indices(1))%phlink,& ! ceq%complist(indices(1))%endmember ic=ceq%complist(indices(1))%phlink ! ic=phlista(ic)%alphaindex ! write(*,*)'3F refphase: ',indices(1),ic,phlista(indices(1))%alphaindex ! ic=phlista(indices(1))%alphaindex ! the first index should be phase index, not location ! We may have to restore gval after this!!! ! write(*,*)'3F callcg_endmember 2: ',-ic call calcg_endmember(-ic,ceq%complist(indices(1))%endmember,gref,ceq) if(gx%bmperr.ne.0) then write(*,*)'3F Error calculating refstate for chemical pot' goto 1000 endif ! RT for current T rtn=globaldata%rgas*ceq%tpval(1) ceq%tpval(1)=tsave aref=ceq%complist(indices(1))%chempot(1) ! value=ceq%complist(indices(1))%chempot(1)-gref*rtn value=aref-gref*rtn ! write(*,513)'3F gref: ',indices(1),value/rtn,aref/rtn,gref,rtn 513 format(a,i3,5(1pe14.6)) ceq%complist(indices(1))%chempot(2)=value else ! the value in chempot(1) should always be referenced to SER ! the value in chempot(2) should always be for the user reference value=ceq%complist(indices(1))%chempot(1) endif ! write(*,*)'3F chempot: ',indices(1),& ! ceq%complist(indices(1))%chempot(1),& ! ceq%complist(indices(1))%chempot(2) goto 700 endif ! convert from MU to AC or LNAC if necessary 700 continue ! ceq%rtn=globaldata%rgas*ceq%tpval(1) if(istv.eq.4) then ! AC = exp(mu/RT) value=exp(value/ceq%rtn) elseif(istv.eq.5) then ! LNAC = mu/RT value=value/ceq%rtn endif !----------------------------------------------------------------- 1000 continue ! write(*,53)'3F more:',-1,amult,vg,vp,vv,value if(allocated(cmpstoi)) deallocate(cmpstoi) return 1100 continue gx%bmperr=4078 ! write(*,*)'3F State variable value not implemented yet' goto 1000 end subroutine state_variable_val3 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_qf !\begin{verbatim} subroutine calc_qf(lokcs,value,ceq) ! calculates eigenvalues of the second derivative matrix, stability function ! using the Darken matrix with second derivatives: OK FOR SUBSTITUTIONAL ! lokcs is index of phase_varres ! value calculated value returned ! ceq is current equilibrium ! For ionic liquid and charged crystalline phases one should ! calculate eigenvectors to find neutral directions. implicit none TYPE(gtp_equilibrium_data), pointer :: ceq integer :: lokcs double precision value !\end{verbatim} ! integer lokph,nsl ! lokph=ceq%phase_varres(lokcs)%phlink ! nsl=phlista(lokph)%noofsubl ! write(*,*)'3F calc_qf: ',lokph,lokcs,nsl ! if(nsl.eq.1) then ! For substitutional solutions ! write(*,*)'3F nsl 1: ',nsl ! call calc_qf_old(lokcs,value,ceq) ! else ! For any onther model ! write(*,*)'3F nsl 2: ',nsl call calc_qf_romain(lokcs,value,ceq) ! endif end subroutine calc_qf !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ subroutine calc_qf_romain(lokcs,value,ceq) ! calculates eigenvalues of the second derivative matrix, stability function ! using Romain Le Tellier proposal eliminating one dependent fraction in ! each sublattice and also one ion if charge balance. Also ignore sublattices ! with a single constituent ! lokcs is index of phase_varres ! value calculated value returned ! ceq is current equilibrium implicit none TYPE(gtp_equilibrium_data), pointer :: ceq integer :: lokcs double precision value !\end{verbatim} ! Algorithm: use the Hessian modified by eliminating one constituent "k_n" ! in each sublattice and one ionic constituent (if any) ! The terms of this "redused" Hessaian will be ! \sum_i\ne k_n \sum_j\ne k_n d2G/dy_idy_j - ! \sum_k_n( d2G/dy_idy_kn+ d2G/dy_jdy_kn - \sum_k_m d2G/dy_kndy_km) ! integer lokph,ii,jj,nsl,ncol,jrow,lrow,subrow,jcol,lcol,subcol,tnfr,nn,info ! skip the last constituent in each sublattice, ! skip sublattices with a single constituent ! skip one charged constituent ... NOT IMPLEMENTED ! The reduced Hessian (symmetric) double precision, allocatable, dimension(:) :: hessian ! work and result arrays. mm is needed when external charge balance double precision, allocatable, dimension(:) :: work,eigenval,ionfact,mm ! this is needed as argument but never used double precision eigenvect(1) type(gtp_phase_varres), pointer :: varres logical debug,excb ! ! debug=.true. debug=.false. varres=>ceq%phase_varres(lokcs) lokph=varres%phlink nsl=phlista(lokph)%noofsubl tnfr=phlista(lokph)%tnooffr ncol=tnfr-nsl if(ncol.eq.0) then ! fixed composition value=one; goto 1000 endif if(btest(phlista(lokph)%status1,PHEXCB)) then ! external charge balance, we need mm ! allocate(mm(phlista(lokph)%tnooffr) ! excb=.TRUE. write(*,*)'Stability check of charged phases not implemented' value=1.0D2 goto 1000 else excb=.FALSE. endif ! write(*,*)'3F allocate: ',ncol*(ncol+1)/2,tnfr,nsl allocate(hessian(ncol*(ncol+1)/2)) ! loop for all rows ii=0 subrow=1 lrow=phlista(lokph)%nooffr(subrow) jrow=0 nn=0 row: do while(ii.lt.tnfr) ii=ii+1 if(ii.eq.lrow) then subrow=subrow+1 if(subrow.gt.nsl) exit row lrow=lrow+phlista(lokph)%nooffr(subrow) if(phlista(lokph)%nooffr(subrow).eq.1) then ii=ii+1; subrow=subrow+1 if(subrow.gt.nsl) exit row lrow=lrow+phlista(lokph)%nooffr(subrow) endif cycle row endif ! loop for all columns jcol=jrow jrow=jrow+1 jj=ii-1 subcol=subrow lcol=lrow col: do while(jj.lt.tnfr) jj=jj+1 if(jj.eq.lcol) then subcol=subcol+1 if(subcol.gt.nsl) exit col lcol=lcol+phlista(lokph)%nooffr(subcol) if(phlista(lokph)%nooffr(subcol).eq.1) then jj=jj+1 subcol=subcol+1 if(subcol.gt.nsl) exit col lcol=lcol+phlista(lokph)%nooffr(subcol) endif cycle col endif nn=nn+1 jcol=jcol+1 ! write(*,'(a,3(2i4,2x))')'3F hessian: ',jrow,jcol,ii,jj,lrow,lcol hessian(ixsym(jrow,jcol))=varres%d2gval(ixsym(ii,jj),1)-& varres%d2gval(ixsym(ii,lrow),1)-& varres%d2gval(ixsym(jj,lcol),1)+& varres%d2gval(ixsym(lrow,lcol),1) enddo col enddo row if(debug) then do ii=1,ncol write(*,'("3F H: ",5(1pe12.4))')(hessian(ixsym(jj,ii)),jj=1,ncol) enddo endif if(ncol.eq.1) then value=hessian(1) goto 1000 endif ! use LAPACK routine, note Hessian is destroyed inside dspev allocate(eigenval(ncol)) ! work is work array at least 2*ncol, info is return code allocate(work(2*ncol)) info=0 ! 'N' means only eigenvalues, 'U' means Hessian is upper triangle ! ncol is dimension of Hessian, eigenval is calculated, ! dummy values for eigenvect, 1 call dspev('N','U',ncol,hessian,eigenval,eigenvect,1,work,info) if(info.eq.0) then if(debug) write(*,120)(eigenval(ii),ii=1,ncol) 120 format('Eigenvalues: ',6(1pe10.2)) ! return the first value, negative if unstable value=eigenval(1) else ! <0 the "info" argument has illegal value ! >0 "info" off-diagonal elements if intermediate tridiagonal did not converge value=zero write(*,*)'Error calculating eigenvalues of phase matrix',info gx%bmperr=4321 endif ! 1000 continue ! basically we are only interested if value is <0 or >0 ... if(value.gt.1.0D2) then value=1.0D2 elseif(value.lt.-1.0D2) then value=-1.0D2 endif return end subroutine calc_qf_romain !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ subroutine calc_qf_romain_old(lokcs,value,ceq) ! calculates eigenvalues of the second derivative matrix, stability function ! using Romain Le Tellier proposal eliminating one dependent fraction in ! each sublattice and also one ion if charge balance. Also ignore sublattices ! with a single constituent ! lokcs is index of phase_varres ! value calculated value returned ! ceq is current equilibrium implicit none TYPE(gtp_equilibrium_data), pointer :: ceq integer :: lokcs double precision value !\end{verbatim} ! Algorithm: use the Hessian modified by eliminating one constituent "k_n" ! in each sublattice and one ionic constituent (if any) ! The terms of this "redused" Hessaian will be ! \sum_i\ne k_n \sum_j\ne k_n d2G/dy_idy_j - ! \sum_k_n( d2G/dy_idy_kn+ d2G/dy_jdy_kn - \sum_k_m d2G/dy_kndy_km) ! integer ncol,nsl,nion,ii,jj,ll,lokph,iy,nf,kk,info,iskip,jskip,tnfr ! kskip needed when external charge balance as one may have two skipped ! constituents in same sublattice integer icol,jrow,kskip ! constituents that should be skipped, one per sublattice and charge, max 10 integer skipped(10) ! The reduced Hessian (symmetric) double precision, allocatable, dimension(:) :: hessian ! work and result arrays. mm is needed when external charge balance double precision, allocatable, dimension(:) :: work,eigenval,ionfact,mm ! this is needed as argument but never used double precision eigenvect(1) type(gtp_phase_varres), pointer :: varres double precision xxx,backstop,yyy logical excb,debug character phname*24 ! write(*,*)'3F entering calc_gf_romain',lokcs value=zero varres=>ceq%phase_varres(lokcs) lokph=phasetuple(varres%phtupx)%ixphase if(btest(phlista(lokph)%status1,PHEXCB)) then ! external charge balance, we need mm ! allocate(mm(phlista(lokph)%tnooffr) ! excb=.TRUE. write(*,*)'Stability check of charged phases not implemented' value=1.0D2 goto 1000 else excb=.FALSE. endif ! Step 1: eliminate one constituent per sublattice (highest fraction) ! if external charge balance we need to eliminate one ion (the first) ! NOTE ionic liquid does not have external charge balance and d2G/dyidyj ! include the variation of sites(?) skipped=0 nsl=phlista(lokph)%noofsubl iy=1 kskip=1 do ll=1,nsl ! write(*,'(a,3i3,2x,10i3)')'3F debug ',lokph,nsl,ll,skipped if(phlista(lokph)%nooffr(ll).gt.1) then xxx=zero do nf=1,phlista(lokph)%nooffr(ll) if(varres%yfr(iy).gt.xxx) then ! skip constituent with largest fraction in each sublattice ! this gives sometimes a cusp in the middle for binaries ... not nice xxx=varres%yfr(iy) if(excb) then skipped(kskip)=iy else skipped(ll)=iy endif endif iy=iy+1 enddo else ! totally skip sublattices with a sngle constituent ! negative value means second derivative wrt this fraction totally skipped skipped(ll)=-iy iy=iy+1 endif enddo ! dimension of the Hessian. One more should be added if ionic (not now!) tnfr=phlista(lokph)%tnooffr ncol=tnfr-nsl if(ncol.gt.1) then call get_phase_name(lokph,1,phname) write(*,*)'3F Q for ',trim(phname),' with ',ncol,' Hessian' debug=.true. else debug=.false. endif allocate(hessian((ncol*(ncol+1))/2)) ! write(*,*)'3F allocated Hessian',lokcs,ncol*(ncol+1)/2 nf=nsl ! write(*,'(a,10i4)')'3F skipped: ',skipped ! in all terms of the Hessian we have to add the sum of all pairs of ! fractions that are skipped ! PROBABLY WRONG, WE MUST HAVE SEVERAL BACKSTOPS DEPENDING ON SUBLATTICES ... backstop=zero ! if we have ionic constituents nf is larger than nsl one more ... back1: do ii=1,nf if(skipped(ii).lt.0) cycle back1 back2: do jj=ii,nf if(skipped(jj).lt.0) cycle back2 ! this is sum_k1 \sum_k2 d2G/dy_k1dy_k2 backstop=backstop+varres%d2gval(ixsym(skipped(ii),skipped(jj)),1) ! write(*,*)'3F backstop 1: ',skipped(ii),skipped(jj),backstop enddo back2 enddo back1 ! write(*,*)'3F backstop 2: ',0,0,backstop ! do ii=1,tnfr ! write(*,'(a,5(1pe12.4))')'3F d2G/dyidyj: ',& ! (varres%d2gval(ixsym(ii,jj),1),jj=1,phlista(lokph)%tnooffr) ! enddo ! The terms of this "reduced" Hessaian will be ! \sum_i\ne k_n \sum_j\ne k_n d2G/dy_idy_j - ! \sum_k_n( d2G/dy_idy_kn+ d2G/dy_jdy_kn - \sum_k_m d2G/dy_kndy_km) iskip=1 jskip=1 icol=1 jrow=1 loop1: do ii=1,tnfr if(ii.eq.abs(skipped(iskip))) then ! write(*,*)'3F Skipping ii: ',ii,skipped(ii) iskip=iskip+1 jskip=iskip cycle loop1 endif xxx=zero ! write(*,'(a,2i4,2x,10i3)')'3F bug 1: ',ii,nf,skipped do kk=1,nf ! PROBABLY WRONG, INCLUDE ONLY THOSE IN CURRENT SUBLATTICE ... if(skipped(kk).gt.0) then xxx=xxx+varres%d2gval(ixsym(ii,skipped(kk)),1) endif enddo ! write(*,*)'3F Calculate xxx for ii: ',ii,xxx ! here the big loop to calculate the Hessian loop2: do jj=ii,tnfr if(jj.eq.abs(skipped(jskip))) then ! PROBABLY WRONG, INCLUDE ONLY THOSE IN CURRENT SUBLATTICE ... ! write(*,*)'3F Skipping jj: ',jj,skipped(jj) jskip=jskip+1 cycle loop2 endif yyy=xxx ! write(*,'(a,2i4,2x,10i3)')'3F bug 2: ',ii,nf,skipped do kk=1,nf if(skipped(kk).gt.0) then yyy=yyy+varres%d2gval(ixsym(jj,skipped(kk)),1) endif enddo ! write(*,*)'3F calculate term',ii,jj ! write(*,*)'3F Calculate yyy for ii and jj: ',ii,jj,yyy ! kxysm is indexing a symmetrix matrix when jj >= ii ! ixsym is indexing a symmetrix matrix whatever values of ii and jj ! multiply with the fractions to avoid extrapolation to infinity ! at low fractions ... meaningless xxx=varres%d2gval(ixsym(ii,jj),1)-yyy+backstop ! if(xxx.gt.1.0d2) xxx=1.0d2 ! write(*,*)'3F index Hessian: ',icol,jrow,ixsym(icol,jrow) hessian(ixsym(icol,jrow))=xxx ! varres%yfr(ii)*varres%yfr(jj)*(varres%d2gval(ixsym(ii,jj),1)-& ! yyy+backstop) ! write(*,'(a,4i3,4(1pe12.4))')'3F hessian ',icol,jrow,ii,jj,& ! hessian(ixsym(icol,jrow)),varres%d2gval(ixsym(ii,jj),1),& ! -yyy,backstop ! limit the terms in the Hession ... icol=icol+1 enddo loop2 jrow=jrow+1 icol=jrow enddo loop1 ! if ncol > 1 calculate eigenvalues if(ncol.eq.1) then value=hessian(1) goto 1000 endif if(debug) then do ii=1,ncol write(*,'("3F Hessian: ",5(1pe12.4))')(hessian(ixsym(jj,ii)),jj=1,ncol) enddo endif ! use LAPACK routine, note Hessian is destroyed inside dspev allocate(eigenval(ncol)) ! work is work array at least 2*ncol, info is return code allocate(work(2*ncol)) info=0 ! 'N' means only eigenvalues, 'U' means Hessian is upper triangle ! ncol is dimension of Hessian, eigenval is calculated, ! dummy values for eigenvect, 1 call dspev('N','U',ncol,hessian,eigenval,eigenvect,1,work,info) if(info.eq.0) then if(debug) write(*,120)(eigenval(ii),ii=1,ncol) 120 format('Eigenvalues: ',6(1pe10.2)) ! return the first value, negative if unstable value=eigenval(1) else value=zero write(*,*)'Error calculating eigenvalues of phase matrix',info gx%bmperr=4321 endif ! 1000 continue ! basically we are only interested if value is <0 or >0 ... if(value.gt.1.0D2) then value=1.0D2 elseif(value.lt.-1.0D2) then value=-1.0D2 endif return end subroutine calc_qf_romain_old !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_qf_otis !\begin{verbatim} subroutine calc_qf_otis(lokcs,value,ceq) ! NOT USED ----------------------------- ! calculates eigenvalues of the second derivative matrix, stability function ! using Otis reduced Hessian method. Should work indpent of model!! ! lokcs is index of phase_varres ! value calculated value returned ! ceq is current equilibrium implicit none TYPE(gtp_equilibrium_data), pointer :: ceq integer :: lokcs double precision value !\end{verbatim} ! Algorithm: ! 1. Create a Jacobian matrix with massbalance and constraint n columns, m rows ! 2. Use an QR factorization of this, select the first n-m columns as Z ! 3. Calculate F = Z^T H Z where H is all second derivatives of G wrt fractions ! 4. Calculate eigenvalues of F. If all positive no problem! ! integer ncol,mrow,lda,info,ll,nsl,lokph,ii,jj double precision, allocatable, dimension(:,:) :: jac,zeta,fff double precision, allocatable, dimension(:) :: tau,work,eigenv double precision dummy(1,1) type(gtp_phase_varres), pointer :: varres ! write(*,*)'G3 Subroutine calc_qf_otis not implemented' gx%bmperr=4499; goto 1000 ! varres=>ceq%phase_varres(lokcs) ! Step 1: Jacobian: ncol columns, mrow rows value=zero ncol=1 mrow=1 allocate(jac(ncol,mrow)) jac=zero ! ! Step 2: QR factorisation, n>m allocate(tau(ncol)) allocate(work(ncol)) lda=ncol info=0 call dgeqr2(mrow,ncol,jac,lda,tau,work,info) if(info.ne.0) then write(*,*)'Error return from DGEGR2: ',info,lokph goto 1000 endif ! How to extract Q?? Documentation of DGEQR2: !> The matrix Q is represented as a product of elementary reflectors !> !> Q = H(1) H(2) . . . H(k), where k = min(m,n). !> !> Each H(i) has the form !> !> H(i) = I - tau * v * v**T !> !> where tau is a real scalar, and v is a real vector with !> v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), !> and tau in TAU(i). ! zeta should be a matrix with the first ncol x ncol-mrow part of Q allocate(zeta(ncol,ncol-mrow)) zeta=zero ! ! Step 3: multiply Z^T * H * Z allocate(fff(ncol,ncol)) fff=zero do ii=1,ncol do jj=1,ncol fff(ii,jj)=fff(ii,jj)+zeta(ii,jj)*varres%d2gval(ixsym(ii,jj),1) enddo enddo jac=zero do ii=1,ncol do jj=1,ncol jac(ii,jj)=jac(ii,jj)+fff(ii,jj)*zeta(ii,jj) enddo enddo ! ! Step 4: calculate eigenvalues ! use LAPACK routine, note d2g is destroyed inside dspev ! write(*,*)'LAPACK routine DSPEV not implemented' allocate(eigenv(ncol)) info=0 call dspev('N','U',ncol,fff,eigenv,dummy,1,work,info) if(info.eq.0) then ! write(*,120)(eigenv(ii),ii=1,ncol) 120 format('Eigenvalues: ',6(1pe10.2)) ! return the most negative value value=eigenv(1) else write(*,*)'Error calculating eigenvalues of phase matrix',info gx%bmperr=4321 endif ! 1000 continue return end subroutine calc_qf_otis !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_qf_sub !\begin{verbatim} subroutine calc_qf_sub(lokcs,value,ceq) ! NOT USED ----------------------------- ! calculates eigenvalues of the second derivative matrix, stability function ! using the Darken matrix with second derivatives: OK FOR SUBSTITUTIONAL ! lokcs is index of phase_varres ! value calculated value returned ! ceq is current equilibrium ! For ionic liquid and charged crystalline phases one should ! calculate eigenvectors to find neutral directions. implicit none TYPE(gtp_equilibrium_data), pointer :: ceq integer :: lokcs double precision value !\end{verbatim} integer info,nofc,nofc2,nmax,ii,jj,lokph,nsl,cc,rr,zz,pp,qq double precision, allocatable :: d2g(:),eigenv(:),work(:) double precision dummy(1,1),dmuidyii integer, allocatable :: skip(:) type(gtp_phase_varres), pointer :: varres ! number of constituents ! ignore sublattices with single constituents .... varres=>ceq%phase_varres(lokcs) nofc=size(varres%yfr) lokph=varres%phlink ! nofc=size(ceq%phase_varres(lokcs)%yfr) ! lokph=ceq%phase_varres(lokcs)%phlink nsl=phlista(lokph)%noofsubl allocate(skip(nsl+1)) info=1 nmax=0 do ii=1,nsl if(phlista(lokph)%nooffr(ii).eq.1) then nmax=nmax+1 skip(nmax)=info ! write(*,*)'3F QF skipping column/row ',info endif info=info+phlista(lokph)%nooffr(ii) enddo if(nmax.eq.nsl) then ! phase has no variable composition value=one goto 1000 endif skip(nmax+1)=phlista(lokph)%tnooffr+1 ! write(*,*)'QF dimension: ',nofc,nmax nofc=nofc-nmax nofc2=nofc*(nofc+1)/2 allocate(d2g(nofc2)) allocate(eigenv(nofc)) allocate(work(3*nofc)) nsl=1 cc=0 rr=0 ! Calculation of matrix elements modeified 2019.11.01/BoS ! See documentation for Darken stability in minimizer documentation ! dGA/dxB = d2GM/dxAdxB - ! \sum_C x_C (d2GM/dxAdxC+d2GM/dxBdxC + \sum_D x_D d2GM/dxCdxD) ! This may not work when sublattices ?... but difficult to calculate dG_I/dn_I ! PROBLMES WHEN USER DEFINED REFERENCE STATES !! ?? ! For Cr-Fe when plot of gm(bcc) before q(bcc) then q(bcc) is rubbish ! row: do ii=1,nofc+nmax if(ii.eq.skip(nsl)) then ! skip this row. A clumsy way to skip sublattices with a single constituent nsl=nsl+1 cycle row endif cc=cc+1 rr=cc-1 column: do jj=ii,nofc+nmax do zz=1,nmax ! skip this column. A clumsy way to skip sublattices with a single constituent if(jj.eq.skip(zz)) cycle column enddo rr=rr+1 ! write(*,17)'QF calc: ',ii,jj,' to ',cc,rr 17 format(a,2i4,a,2i4) dmuidyii=varres%d2gval(ixsym(ii,jj),1) ! write(*,33)'3F start: ',ii,jj,0,dmuidyii 33 format(a,3i3,3(1pe12.4)) ! d2g(ixsym(cc,rr))=ceq%phase_varres(lokcs)%d2gval(ixsym(ii,jj),1) ! extra summation over all constituents (except those alone in a sublattice) extra1: do qq=1,nofc+nmax do zz=1,nmax ! skip this term. A clumsy way to skip sublattices with a single constituent if(qq.eq.skip(zz)) cycle extra1 enddo dmuidyii=dmuidyii-varres%yfr(qq)*(varres%d2gval(ixsym(ii,qq),1)+& varres%d2gval(ixsym(jj,qq),1)) ! write(*,33)'3F minus: ',ii,jj,qq,dmuidyii,& ! varres%yfr(qq)*varres%d2gval(ixsym(ii,qq),1),& ! varres%yfr(qq)*varres%d2gval(ixsym(jj,qq),1) extra2: do pp=1,nofc+nmax do zz=1,nmax ! skip this term. A clumsy way to skip sublattices with a single constituent if(pp.eq.skip(zz)) cycle extra2 enddo dmuidyii=dmuidyii+varres%yfr(qq)*varres%yfr(pp)*& varres%d2gval(ixsym(pp,qq),1) ! write(*,33)'3F adding: ',0,pp,qq,dmuidyii,& ! varres%yfr(qq)*varres%yfr(pp)*varres%d2gval(ixsym(pp,qq),1) enddo extra2 enddo extra1 ! write(*,33)'3F result: ',cc,rr,0,dmuidyii d2g(ixsym(cc,rr))=dmuidyii enddo column enddo row ! do ii=1,nofc ! write(*,21)'3F d2Gdy2: ',(varres%d2gval(ixsym(ii,jj),1),jj=1,nofc) ! enddo ! do ii=1,nofc ! write(*,21)'3F dmudy: ',(d2g(ixsym(ii,jj)),jj=1,nofc) ! enddo 21 format(a,6(1pe12.4)) ! !------------------------------------------------------------------- ! uncomment the call to dspev in order to make Q work ! AND link to LAPACK !------------------------------------------------------------------- ! use LAPACK routine, note d2g is destroyed inside dspev ! write(*,*)'LAPACK routine DSPEV not implemented' call dspev('N','U',nofc,d2g,eigenv,dummy,1,work,info) ! info=-1000 if(info.eq.0) then ! write(*,120)(eigenv(ii),ii=1,nofc) 120 format('3F Eigenvalues: ',6(1pe10.2)) ! return the most negative value value=eigenv(1) else write(*,*)'Error calculating eigenvalues of phase matrix',info gx%bmperr=4321 endif 1000 continue return end subroutine calc_qf_sub !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_qf_old !\begin{verbatim} subroutine calc_qf_old(lokcs,value,ceq) ! NOT USED ----------------------------- ! calculates eigenvalues of the second derivative matrix, stability function ! this old version that seems to work for Ag-Cu ... ! lokcs is index of phase_varres ! value calculated value returned ! ceq is current equilibrium ! For ionic liquid and charged crystalline phases one should ! calculate eigenvectors to find neutral directions. implicit none TYPE(gtp_equilibrium_data), pointer :: ceq integer :: lokcs double precision value !\end{verbatim} integer info,nofc,nofc2,nmax,ii,jj,lokph,nsl,cc,rr,zz double precision, allocatable :: d2g(:),eigenv(:),work(:) double precision dummy(1,1) integer, allocatable :: skip(:) ! number of constituents ! ignore sublattices with single constituents .... ! write(*,*)'3F in calc_qf_old: ' nofc=size(ceq%phase_varres(lokcs)%yfr) lokph=ceq%phase_varres(lokcs)%phlink nsl=phlista(lokph)%noofsubl allocate(skip(nsl+1)) info=1 nmax=0 do ii=1,nsl if(phlista(lokph)%nooffr(ii).eq.1) then nmax=nmax+1 skip(nmax)=info ! write(*,*)'QF skipping column/row ',info endif info=info+phlista(lokph)%nooffr(ii) enddo if(nmax.eq.nsl) then ! phase has no variable composition value=one goto 1000 endif skip(nmax+1)=phlista(lokph)%tnooffr+1 ! write(*,*)'QF dimension: ',nofc,nmax nofc=nofc-nmax nofc2=nofc*(nofc+1)/2 allocate(d2g(nofc2)) allocate(eigenv(nofc)) allocate(work(3*nofc)) nsl=1 cc=0 rr=0 row: do ii=1,nofc+nmax if(ii.eq.skip(nsl)) then ! skip this column nsl=nsl+1 cycle row endif cc=cc+1 rr=cc-1 column: do jj=ii,nofc+nmax do zz=1,nmax if(jj.eq.skip(zz)) cycle column enddo rr=rr+1 ! write(*,17)'QF assigning ',ii,jj,' to ',cc,rr !17 format(a,2i4,a,2i4) d2g(ixsym(cc,rr))=ceq%phase_varres(lokcs)%d2gval(ixsym(ii,jj),1) enddo column enddo row ! !------------------------------------------------------------------- ! uncomment the call to dspev in order to make Q work ! AND link to LAPACK !------------------------------------------------------------------- ! use LAPACK routine, note d2g is destroyed inside dspev ! write(*,*)'LAPACK routine DSPEV not implemented' call dspev('N','U',nofc,d2g,eigenv,dummy,1,work,info) ! info=-1000 if(info.eq.0) then ! write(*,120)(eigenv(ii),ii=1,nofc) 120 format('Eigenvalues: ',6(1pe10.2)) ! return the most negative value value=eigenv(1) else write(*,*)'Error calculating eigenvalues of phase matrix',info gx%bmperr=4321 endif 1000 continue return end subroutine calc_qf_old !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calculate_reference_state !\begin{verbatim} subroutine calculate_reference_state(kstv,iph,ics,aref,ceq) ! Calculate the user defined reference state for extensive properties ! kstv is the typde of property: 1 U, 2 S, 3 V, 4 H, 5 A, 6 G ! It can be phase specific (iph.ne.0) or global (iph=0) ! IMPORTANT ! For integral quantitites (like calculated here) the reference state ! is ignored unless all components have the same phase as reference (like Hmix) implicit none integer kstv,iph,ics double precision aref type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ ! BIG BUG, the values of %gval is not restored!! ! kstv=1 2 3 4 5 6 other values cared for elsewhere ! U S V H A G integer iel,phref,allcomp double precision gref(6),bref(6),xmol(maxel),wmass(maxel),xxx(6) double precision tmol,tmass,bmult ! ! write(*,*)'Reference states not implemented yet'; goto 1000 ! write(*,*)'3F reference state:',kstv,iph,ics if(kstv.lt.1 .or. kstv.gt.6) then ! write(*,*)'3F No reference state for kstv: ',kstv goto 1000 endif aref=zero bref=zero gref=zero xxx=zero allcomp=0 ! loop for all components to extract the value of their reference states ! Multiply that with the overall composition (iph=0) or the phase composition xmol=zero do iel=1,noofel ! this is the reference phase for component iel phref=ceq%complist(iel)%phlink if(kstv.eq.3) then ! added when starting to handle P as variable. V should not depend ! on a reference state unless all have the same phase as reference ! write(*,*)'3F Reference for: ',iel,phref ! removed as we should allow different reference stated for G and H if(allcomp.eq.0) then if(phref.gt.0) then allcomp=phref else ! at least one component has no reference phase, ignore all refernce states aref=zero goto 900 endif elseif(phref.ne.allcomp) then ! different reference phases for the components, ignore the reference state ! write(*,*)'3F Ignoring reference state as not same for all' aref=zero goto 900 ! phref is same, continue the loop ! ignore any user defined reference state for the other components endif endif ! UNFINISHED ?? For integral properties, kstv=1.. 100 continue if(phref.gt.0) then ! we should use the phase index, not location in call below ! write(*,*)'3F ref.ph: ',phref,phlista(phref)%alphaindex phref=phlista(phref)%alphaindex ! special endmember call that returns G, G.T, G.P, G.T.T, G.T.P and G.P.P ! write(*,73)'3F R state: ',iel,phref,ceq%complist(iel)%endmember 73 format(a,2i3,2x,10i4) ! write(*,*)'3F callcg_endmember 3: ',phref call calcg_endmember6(phref,ceq%complist(iel)%endmember,gref,ceq) if(gx%bmperr.ne.0) then write(*,*)'3F Error return: ',gx%bmperr goto 1000 endif if(iph.gt.0) then ! multiply with mole fractions of phase iph,ics call calc_phase_molmass(iph,ics,xmol,wmass,tmol,tmass,bmult,ceq) else ! multiply with overall mole fractions call calc_molmass(xmol,wmass,tmol,tmass,ceq) endif ! note xxx, bref and gref are arrays xxx=bref+xmol(iel)*gref ! write(*,70)'3F rs: ',bref,gref,xxx,(xmol(ij),ij=1,noofel) 70 format(a,6(1pe12.4)/,2(7x,6e12.4/),8(0pF8.4)) bref=xxx else ! this is not really needed, it is bref that is used below gref=zero endif enddo ! calculate the correct correction depending on kstv if(kstv.eq.1) then ! U = G - T*G.T - P*G.P aref=bref(1)-ceq%tpval(1)*bref(2)-ceq%tpval(2)*bref(3) elseif(kstv.eq.2) then ! S = - G.T aref=-bref(2) elseif(kstv.eq.3) then ! V aref=bref(3) elseif(kstv.eq.4) then ! H = G - T*G.T aref=bref(1)-ceq%tpval(1)*bref(2) elseif(kstv.eq.5) then ! A = G - P*G.P aref=bref(1)-ceq%tpval(2)*bref(3) elseif(kstv.eq.6) then ! G aref=bref(1) endif 900 continue ! write(*,75)kstv,aref 75 format('3F ref:',i3,6(1pe12.4)) 1000 continue return end subroutine calculate_reference_state !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calculate_reference_state_old !\begin{verbatim} subroutine calculate_reference_state_old(kstv,iph,ics,aref,ceq) ! Calculate the user defined reference state for extensive properties ! kstv is the typde of property: 1 U, 2 S, 3 V, 4 H, 5 A, 6 G ! It can be phase specific (iph.ne.0) or global (iph=0) ! IMPORTANT ! For integral quantitites (like calculated here) the reference state ! is ignored unless all components have the same phase as reference (like Hmix) implicit none integer kstv,iph,ics double precision aref type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} ! BIG BUG, the values of %gval is not restored!! ! kstv=1 2 3 4 5 6 other values cared for elsewhere ! U S V H A G integer iel,phref,allcomp double precision gref(6),bref(6),xmol(maxel),wmass(maxel),xxx(6) double precision tmol,tmass,bmult ! ! write(*,*)'Reference states not implemented yet'; goto 1000 ! write(*,*)'3F reference state:',kstv,iph,ics if(kstv.lt.1 .or. kstv.gt.6) then ! write(*,*)'3F No reference state for kstv: ',kstv goto 1000 endif aref=zero bref=zero gref=zero xxx=zero allcomp=0 ! loop for all components to extract the value of their reference states ! Multiply that with the overall composition (iph=0) or the phase composition xmol=zero do iel=1,noofel ! this is the reference phase for component iel phref=ceq%complist(iel)%phlink ! write(*,*)'3F Reference for: ',iel,phref ! added when starting to handle P as variable. V should not depend ! on a reference state unless all have the same phase as reference if(allcomp.eq.0) then if(phref.gt.0) then allcomp=phref ! write(*,*)'3F Setting allcomp: ',allcomp else ! at least one component has no reference phase, ignore all refernce states aref=zero goto 900 endif elseif(phref.ne.allcomp) then ! different reference phases for the components, ignore the reference state ! writing(*,*)'3F Ignoring reference state as not same for all' aref=zero goto 900 ! else ! phref is same, continue the loop ! ignore any user defined reference state for the other components endif ! UNFINISHED ?? For integral properties, kstv=1.. if(phref.gt.0) then ! we should use the phase index, not location in call below ! write(*,*)'3F ref.ph: ',phref,phlista(phref)%alphaindex phref=phlista(phref)%alphaindex ! special endmember call that returns G, G.T, G.P, G.T.T, G.T.P and G.P.P ! write(*,73)'3F R state: ',iel,phref,ceq%complist(iel)%endmember 73 format(a,2i3,2x,10i4) ! write(*,*)'3F callcg_endmember 3: ',phref call calcg_endmember6(phref,ceq%complist(iel)%endmember,gref,ceq) if(gx%bmperr.ne.0) then write(*,*)'3F Error return: ',gx%bmperr goto 1000 endif if(iph.gt.0) then ! multiply with mole fractions of phase iph,ics call calc_phase_molmass(iph,ics,xmol,wmass,tmol,tmass,bmult,ceq) else ! multiply with overall mole fractions call calc_molmass(xmol,wmass,tmol,tmass,ceq) endif ! note xxx, bref and gref are arrays xxx=bref+xmol(iel)*gref ! write(*,70)'3F rs: ',bref,gref,xxx,(xmol(ij),ij=1,noofel) 70 format(a,6(1pe12.4)/,2(7x,6e12.4/),8(0pF8.4)) bref=xxx else ! this is not really needed, it is bref that is used below gref=zero endif enddo ! calculate the correct correction depending on kstv if(kstv.eq.1) then ! U = G - T*G.T - P*G.P aref=bref(1)-ceq%tpval(1)*bref(2)-ceq%tpval(2)*bref(3) elseif(kstv.eq.2) then ! S = - G.T aref=-bref(2) elseif(kstv.eq.3) then ! V aref=bref(3) elseif(kstv.eq.4) then ! H = G - T*G.T aref=bref(1)-ceq%tpval(1)*bref(2) elseif(kstv.eq.5) then ! A = G - P*G.P aref=bref(1)-ceq%tpval(2)*bref(3) elseif(kstv.eq.6) then ! G aref=bref(1) endif 900 continue ! write(*,75)kstv,aref 75 format('3F ref:',i3,6(1pe12.4)) 1000 continue return end subroutine calculate_reference_state_old !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine enter_svfun !\begin{verbatim} subroutine enter_svfun(cline,last,ceq) ! enter a state variable function implicit none integer last character cline*(*) type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer, parameter :: npfs=20 integer ks,maxsym,ipos,jt,js,kdot,nsymb,allowch,lbuf character name2*16,pfsym(npfs)*60,string*128,pfsymdenom*60,fbuff*256 ! integer istv(npfs),indstv(4,npfs),iref(npfs),iunit(npfs),lokv(npfs) integer iarr(10,npfs),lokv(npfs) ! memory leak type(gtp_state_variable), target :: svrvar type(gtp_state_variable), pointer :: svr type(putfun_node), pointer :: lrot,datanod ! ! maxsym is negative to allow the user to enter abs(maxs) symbols ! pfsym are the entered symbols ! lokv is only internal strage in putfun ! lrot is the root node of expression ! nsymb is the number of user entered symbols ! write(kou,17)'enter svgun ',last,cline(1:20),nsvfun 17 format(a,i3,2x,a,i3) call gparcx('Symbol name: ',cline,last,ichar('='),name2,' ','?Enter symbol') call capson(name2) if(name2(1:1).eq.' ') then gx%bmperr=4137; goto 1000 endif ! write(*,*)'3F enter_svfun: ',last,name2,':',trim(cline) if(.not.proper_symbol_name(name2,0)) goto 1000 ! nsvfun is a global variable giving current number of state variable functions do ks=1,nsvfun if(name2.eq.svflista(ks)%name) then gx%bmperr=4136; goto 1000 endif enddo kdot=0 lbuf=0 fbuff=' ' ! added allowch to handle symbols including & and # allowch=1 ! TO BE IMPLEMENTED: enter symbols with dummy arguments like CP(@P1)=HM(@P1).T ! where @Pi is a phase, @Ci is a component and @Si is a species ! these dummy variables must be defined in symbol name ?? why ?? maybe not ! write(*,*)'3F symbol: "',trim(cline),'"',last 77 continue call gparcx('Expression, end with ";" :',cline,last,6,string,';',& '?Enter symbol') ! there can be multiple lines, last end by ; or empty line if(index(string,';').le.0) then fbuff(lbuf+1:)=string lbuf=len_trim(fbuff) string=' ' write(*,*)'3F Continue: ' goto 77 elseif(lbuf.gt.0) then string=fbuff endif if(index(string,';').eq.1) then write(*,*)'3F empty expression, maybe forgotten =?' gx%bmperr=4134; goto 1000 endif ! write(*,*)'3F expression: ',trim(string) maxsym=-npfs ipos=1 call putfun(string,ipos,maxsym,pfsym,lokv,lrot,allowch,nsymb) if(pfnerr.ne.0 .or. .not.associated(lrot)) then write(*,*)'3F error in putfun: ',pfnerr,associated(lrot) pfnerr=0; gx%bmperr=4134; goto 1000 endif ! on return nsymb is the number of external symbols used in the function ! these can be other functions or state variables or used defined identifiers ! like Curie temperature etc. The symbols are in pfsym(1..nsymb) ! ! write(*,11)nsymb,(pfsym(js)(1:len_trim(pfsym(js))),js=1,nsymb) 11 format('3F args: ',i2,': ',10(1x,a,',')) ! identify symbols as state variables, if derivative there is a dot iarr=0 jt=0 svr=>svrvar do js=1,nsymb kdot=index(pfsym(js),'.') if(kdot.gt.0) then ! derivatives must be stored as two state variables ! write(*,*)'3F Found dot derivative: ',kdot,pfsym(js) ! Only allow a single symbol in this case!!! if(nsymb.gt.1) then ! write(*,*)'3F Only a single symbol allowed!' gx%bmperr=4320; goto 1000 endif jt=1 ! denominator, variable after . for with the derivative is taken pfsymdenom=pfsym(js)(kdot+1:) pfsym(js)(kdot:)=' ' call decode_state_variable(pfsym(js),svr,ceq) if(gx%bmperr.ne.0) goto 1000 ! store in the old way in iarr for two state variables iarr(1,js)=svr%oldstv iarr(2,js)=svr%norm iarr(3,js)=svr%unit iarr(4,js)=svr%phref iarr(5,js)=svr%argtyp iarr(6,js)=svr%phase iarr(7,js)=svr%compset iarr(8,js)=svr%component iarr(9,js)=svr%constituent iarr(10,js)=jt call decode_state_variable(pfsymdenom,svr,ceq) if(gx%bmperr.ne.0) goto 1000 ! store in the old way in iarr for two state variables iarr(1,js+1)=svr%oldstv iarr(2,js+1)=svr%norm iarr(3,js+1)=svr%unit iarr(4,js+1)=svr%phref iarr(5,js+1)=svr%argtyp iarr(6,js+1)=svr%phase iarr(7,js+1)=svr%compset iarr(8,js+1)=svr%component iarr(9,js+1)=svr%constituent else ! NOT a derivative call decode_state_variable(pfsym(js),svr,ceq) if(gx%bmperr.ne.0) then ! symbol not a state variable, may be another function ! write(*,*)'3F not state variable: ',gx%bmperr,' "',& ! pfsym(js)(1:len_trim(pfsym(js))),'"' do ks=1,nsvfun if(pfsym(js).eq.svflista(ks)%name) then ! write(*,*)'3F found another function: ',trim(pfsym(js)) iarr(1,js)=-ks gx%bmperr=0 goto 390 endif enddo ! here it can be a model parameter id such as THET(BCC) or MQ&FE(BCC) write(*,*)'3F argument not understood: "',& pfsym(js)(1:len_trim(pfsym(js))),'"',gx%bmperr gx%bmperr=4135; goto 1000 else ! It is a state variable or a model parameter identifier ! to avoid confusing this with another function index subtract 1000 ! write(*,*)'3F state variable or model parameter id: "',& ! pfsym(js)(1:len_trim(pfsym(js))),'"',gx%bmperr ! write(*,'(a,10i5)')'3F svr: ',svr%oldstv,svr%norm,svr%unit,& ! svr%phref,svr%argtyp,svr%phase,svr%compset,svr%component,& ! svr%constituent ! Store in the old way in iarr ! iarr(1,js)=svr%oldstv-1000 ! write(*,*)'3F state variable or model parameter id',svr%oldstv if(svr%oldstv.lt.0) then iarr(1,js)=svr%oldstv-1000 else iarr(1,js)=svr%oldstv endif iarr(2,js)=svr%norm iarr(3,js)=svr%unit iarr(4,js)=svr%phref iarr(5,js)=svr%argtyp iarr(6,js)=svr%phase iarr(7,js)=svr%compset iarr(8,js)=svr%component iarr(9,js)=svr%constituent endif endif 390 continue enddo ! for derivatives two iarr arrays ! Found bug in store_putfun if just a variable entered, coefficient set to 0.0 call store_putfun(name2,lrot,nsymb+jt,iarr) ! The call above updates the global value of nsvfun so it means the new symbol if(nsymb.eq.0) then ! this is just a constant numeric value ... store it locally. Why .and. ?? if(.not.associated(lrot%left) .and. .not.associated(lrot%left)) then ! write(*,*)'3F just a constant!!' ! set bit to allow change the value but do not allow R to be changed if(nsvfun.gt.3) then svflista(nsvfun)%status=ibset(svflista(nsvfun)%status,SVCONST) endif endif endif if(kdot.gt.0) then ! this is a dot derivative, set bits svflista(nsvfun)%status=ibset(svflista(nsvfun)%status,SVFVAL) svflista(nsvfun)%status=ibset(svflista(nsvfun)%status,SVFDOT) ! write(*,*)'3F setting explicit bit: ',SVFDOT ! endif else ! this created a crash when entering a dot derivative, only notmal functions ! there seems to be a problem that already existing state variable functions ! are not evaluated so they give a correct value call evaluate_all_svfun_old(-1,ceq) if(gx%bmperr.ne.0) then ! ignore any errors ! write(*,*)' Error calculating the state variable functions!',gx%bmperr gx%bmperr=0 endif endif ! If a function is entered that cannot be calculated we get values such as NaN ! ceq%svfunres(nsvfun)=zero ! write(*,*)'3F store zero in svfunres',nsvfun,ceq%svfunres(nsvfun) 1000 continue ! NOTE eqnoval should be zeroed ! NOTE svfval should be set if only calculated when explicitly referenced ! possible memory leak nullify(svr) ! write(*,*)'3F exit enter_svfun' return end subroutine enter_svfun !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine set_putfun_constant !\begin{verbatim} %- subroutine set_putfun_constant(svfix,value) ! changes the value of a putfun constant ! svfix is index, value is new value ! THIS CAN BE A FUNCTION WITH SVFVAL bit set, ! in that case change it to a constant implicit none integer svfix double precision value !\end{verbatim} %+ type(putfun_node), pointer :: lrot ! write(*,*)'We are in set_putfun_constant 1' if(btest(svflista(svfix)%status,SVFVAL)) then ! converting a symbol from an expression to a constant ! this means some loss of memory used for the expression svflista(svfix)%status=ibset(svflista(svfix)%status,SVCONST) svflista(svfix)%status=ibclr(svflista(svfix)%status,SVFVAL) ! set number of arguments to zero ... this will make a mess ... ! svflista(svfix)%narg=0 ! remove link to expression in in linkpnode ?? ! lrot=>svflista(svfix)%linkpnode ! do we have to delete the expression? memory loss negligable ... endif if(.not.btest(svflista(svfix)%status,SVCONST)) then write(*,*)'Symbol is not a constant' gx%bmperr=4323 else lrot=>svflista(svfix)%linkpnode ! write(*,*)'3F constant: ',lrot%value,value svflista(svfix)%svfv=value ! duplicate value, I am not sure where ... lrot%value=value endif 1000 continue return end subroutine set_putfun_constant !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine store_putfun !\begin{verbatim} %- subroutine store_putfun(name,lrot,nsymb,iarr) ! enter an expression of state variables with name name with address lrot ! nsymb is number of formal arguments ! iarr identifies these implicit none character name*(*) type(putfun_node), pointer :: lrot integer nsymb integer iarr(10,*) !\end{verbatim} %+ ! idot set if if derivative integer jf,jg,idot ! write(*,*)'3F: store_putfun ',nsvfun nsvfun=nsvfun+1 svflista(nsvfun)%status=0 svflista(nsvfun)%tplink=0 svflista(nsvfun)%eqnoval=0 if(nsymb.gt.0) then allocate(svflista(nsvfun)%formal_arguments(10,nsymb)) idot=10 ! dot derivatives have two consequtive symbols for the variable before/after do jf=1,nsymb ! the order is: 1: state variable (negative means index to another symbol) ! 2-5: norm, unit, phref, argtyp, ! 6-10: phase, compset, component, constituent, derivative do jg=1,idot svflista(nsvfun)%formal_arguments(jg,jf)=iarr(jg,jf) enddo ! write(*,77)(iarr(jg,jf),jg=1,idot) 77 format('3F: store_putfun: ',20i3) enddo endif svflista(nsvfun)%name=name svflista(nsvfun)%linkpnode=>lrot svflista(nsvfun)%narg=nsymb ! this is the number of actual argument needed (like @P, @C and @S) svflista(nsvfun)%nactarg=0 ! eqnoval indicate which equilibrium to use to get its value. ! default is 0 meaning any equilibria, can be changed by AMEND SYMBOL svflista(nsvfun)%eqnoval=0 1000 continue return end subroutine store_putfun !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine store_putfun_old !\begin{verbatim} %- subroutine store_putfun_old(name,lrot,nsymb,& istv,indstv,iref,iunit,idot) ! enter an expression of state variables ! name: character, name of state variable function ! lrot: pointer, to a putfun_node that is the root of the stored expression ! nsymb: integer, number of formal arguments ! istv: integer array, formal argument state variables typ ! indstv: 2D integer array, indices for the formal state variables ! iref: integer array, reference for the formal state variables ! iunit: integer array, unit of the formal state variables implicit none type(putfun_node), pointer :: lrot integer nsymb integer, dimension(*) :: istv,iref,iunit,idot integer, dimension(4,*) :: indstv character name*(*) !\end{verbatim} integer jf ! write(*,*)'3F store_putfun ',nsvfun nsvfun=nsvfun+1 if(nsymb.gt.0) then allocate(svflista(nsvfun)%formal_arguments(10,nsymb)) do jf=1,nsymb svflista(nsvfun)%formal_arguments(1,jf)=istv(jf) svflista(nsvfun)%formal_arguments(2,jf)=indstv(1,jf) svflista(nsvfun)%formal_arguments(3,jf)=indstv(2,jf) svflista(nsvfun)%formal_arguments(4,jf)=indstv(3,jf) svflista(nsvfun)%formal_arguments(5,jf)=indstv(4,jf) svflista(nsvfun)%formal_arguments(6,jf)=iref(jf) svflista(nsvfun)%formal_arguments(7,jf)=iunit(jf) svflista(nsvfun)%formal_arguments(8,jf)=idot(jf) enddo endif svflista(nsvfun)%name=name svflista(nsvfun)%linkpnode=>lrot svflista(nsvfun)%status=0 svflista(nsvfun)%narg=nsymb ! this is the number of actual argument needed (like @P, @C and @S) svflista(nsvfun)%nactarg=0 ! eqnoval indicate which equilibrium to use to get its value. ! default is 0 meaning current equilibria, can be changed by AMEND SYMBOL svflista(nsvfun)%eqnoval=0 1000 continue return end subroutine store_putfun_old !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine find_svfun !\begin{verbatim} subroutine find_svfun(name,lrot) ! finds a state variable function called name (no abbreviations) ! ceq not needed!!?? implicit none character name*(*) integer lrot ! type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ ! name must be in UPPER CASE and exact match required do lrot=1,nsvfun ! write(*,*)'3F find_svfun: ',name,svflista(lrot)%name,lrot if(name.eq.svflista(lrot)%name) goto 500 enddo write(*,*)'3F No such state variable function: ',name gx%bmperr=4188; goto 1000 ! 500 continue ! nothing more to do! 1000 continue return end subroutine find_svfun !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine find_symbol_with_equilno !\begin{verbatim} subroutine find_symbol_with_equilno(lrot,eqno) ! finds a state variable function with equilibrium index implicit none integer lrot,eqno !\end{verbatim} %+ ! skip the first 3 functions, R, RT and TC if(lrot.lt.0) lrot=3 eqno=0 ! write(*,*)'3F find_sweq 1: ',lrot,nsvfun allfun: do while(lrot.lt.nsvfun) lrot=lrot+1 if(svflista(lrot)%eqnoval.gt.0) then eqno=svflista(lrot)%eqnoval ! for debugging ! write(*,*)'3F symbol ',svflista(lrot)%name,' at equilibrium ',eqno goto 1000 endif enddo allfun lrot=0 1000 continue return end subroutine find_symbol_with_equilno !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine list_svfun !\begin{verbatim} %- subroutine list_svfun(text,ipos,lrot,ceq) ! list a state variable function implicit none character text*(*) integer ipos,lrot type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} ! copied svflista(lrot)%formal_arguments(2..5,jt) to indices as gfortran error ! integer indstv(4) type(gtp_state_variable), target :: svr2 type(gtp_state_variable), pointer :: svr character symbols(20)*32,afterdot*32 integer js,jt,ip,istv,kl,mm ! write(*,*)'3F list_svfun 1:',svflista(lrot)%narg if(lrot.le.0 .or. lrot.gt.nsvfun) then gx%bmperr=4140; goto 1000 endif if(svflista(lrot)%narg.eq.0) goto 500 js=0 jt=0 100 continue jt=jt+1 js=js+1 ip=1 symbols(js)=' ' istv=svflista(lrot)%formal_arguments(1,jt) ! write(*,*)'3F list_svfun: ',istv,js,jt if(istv.gt.-1000 .and. istv.lt.0) then ! istv<-1000 means this is a model_parameter_identifier ! function refer to another function (assuming never to have 1000 symbols ... symbols(js)=svflista(-istv)%name else ! the 1:10 was a new bug discovered in GNU fortran 4.7 and later ! PROBABLE MY BUG 2020-08-31/BOS, not declared allocatable ... SUCK svr=>svr2 call make_stvrec(svr,svflista(lrot)%formal_arguments(1:10,jt)) if(gx%bmperr.ne.0) then write(*,*)'3F failed creating state variable record' goto 1000 endif call encode_state_variable(symbols(js),ip,svr,ceq) if(gx%bmperr.ne.0) then write(*,*)'3F failed encode state variable' goto 1000 endif ! write(*,*)'3F list_svfun: ',trim(symbols(js)),js,jt if(svflista(lrot)%formal_arguments(10,jt).ne.0) then ! a derivative!!! ! write(*,111)'3F A dot derivative of ',js,jt,symbols(js) 111 format(a,2i3,': ',a) jt=jt+1 afterdot=' ' ip=1 svr=>svr2 call make_stvrec(svr,svflista(lrot)%formal_arguments(1:10,jt)) call encode_state_variable(afterdot,ip,svr,ceq) ! write(*,111)'3F wrt state variable ',js,jt,afterdot ! symbols(js)=symbols(js)(1:len_trim(symbols(js)))//'.'//afterdot symbols(js)=trim(symbols(js))//'.'//afterdot ! write(*,111)'3F alltogether ',js,jt,symbols(js) endif endif if(jt.lt.svflista(lrot)%narg) goto 100 500 continue ! add special information, first fill with blanks text(ipos:)=' ' if(svflista(lrot)%eqnoval.gt.0) then ! symbol should only be evaluated in equilibrium EQNOVAL write(text(ipos:ipos+3),470)svflista(lrot)%eqnoval 470 format(i4) elseif(svflista(lrot)%tplink.gt.0) then ! symbol is imported from or exported to TP function write(text(ipos:ipos+3),470)svflista(lrot)%tplink endif js=ipos+4 ipos=ipos+7 ! Mark with a letter in position 5! if(btest(svflista(lrot)%status,SVNOAM)) then ! symbol must not be amended (for R, RT and T_C) text(js:js)='N' elseif(btest(svflista(lrot)%status,SVCONST)) then ! symbol is a constant (can be amended) text(js:js)='C' elseif(btest(svflista(lrot)%status,SVFDOT)) then ! symbol is a dot derivative calculated only when explicitly referenced text(js:js)='D' elseif(btest(svflista(lrot)%status,SVFVAL)) then ! symbol calculated only when explicitly referenced text(js:js)='V' elseif(btest(svflista(lrot)%status,SVFEXT)) then ! symbol evaluated for an equilibrium, the equilibrium number already written text(js:js)='X' elseif(btest(svflista(lrot)%status,SVEXPORT)) then ! symbol imported from TP function, function index is specified text(js:js)='E' elseif(btest(svflista(lrot)%status,SVIMPORT)) then ! symbol exported to a TP function (assess coeff), function index is specified text(js:js)='I' endif ! name and expression ! kl=len_trim(svflista(lrot)%name) ! text(ipos:ipos+kl+1)=svflista(lrot)%name(1:kl)//'= ' text(ipos:)=trim(svflista(lrot)%name)//'=' ipos=len_trim(text)+2 ! svflista(lrot)%linkpode is a pointer to a pufun_node record if(.not.associated(svflista(lrot)%linkpnode)) then text(ipos:)=' = no expression; ' else ! write(*,502)'3F wrtfun: ',jt,(trim(symbols(mm)),mm=1,jt) 502 format(a,i3,10(' "',a,'", ')) call wrtfun(text,ipos,svflista(lrot)%linkpnode,symbols) ! where is pfnerr defined?? if(pfnerr.ne.0) then write(kou,*)'Putfun error listing funtion ',pfnerr gx%bmperr=4142; goto 1000 endif endif 1000 continue return end subroutine list_svfun !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine make_stvrec !\begin{verbatim} subroutine make_stvrec(svr,iarr) ! stores appropriate values from a formal argument list to a state variable ! function in a state variable record implicit none type(gtp_state_variable), pointer :: svr integer iarr(10) !\end{verbatim} integer jt,norm,currid ! ! memory leak ! allocate(svr) currid=0 if(iarr(1).lt.-1000) then ! Handling of parameter property symbols like TC, BMAGN etc ! NOTE inside symbols -1000 used to separate from other symbols currid=iarr(1)+1000 svr%statevarid=currid elseif(iarr(1).le.0) then write(*,*)'3F illegal argument to make_stvrec: ',iarr(1) elseif(iarr(1).lt.10) then ! This is T, P, MU, AC, LNAC ! 1 2 3 4 5 svr%statevarid=iarr(1) currid=iarr(1) else ! This is U, S, V, H, A, G, NP, BP, DG, Q, N, X, B, W, Y symbol ! 6 7 8 9 10, 11, 12, 13, 14, 15, 16, 17, 18, 19. 20 new code ! 10 20 30 40 50 60 70 80 90 100 110 111 120 122 130 old code ! dvs iarr()=10 means U etc. jt=iarr(1)/10+5 norm=mod(iarr(1),10) ! special for x and w, note norm is set to normallizing if(jt.eq.16 .and. norm.eq.1) jt=17 if(jt.eq.18 .and. norm.eq.2) jt=19 svr%statevarid=jt currid=iarr(1) ! write(*,*)'3F make: ',iarr(1),jt endif ! write(*,11)iarr 11 format('3F Arguments: ',10i5) ! svr%oldstv=iarr(1) svr%oldstv=currid svr%norm=iarr(2) svr%unit=iarr(3) svr%phref=iarr(4) svr%argtyp=iarr(5) svr%phase=iarr(6) svr%compset=iarr(7) svr%component=iarr(8) svr%constituent=iarr(9) 1000 continue return end subroutine make_stvrec !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine list_all_svfun !\begin{verbatim} subroutine list_all_svfun(kou,ceq) ! list all state variable funtions implicit none integer kou type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} character text*256 integer ks,ipos write(kou,17) 17 format('List of all state variable symbols'/' No Special Name= expression ;') !17 format('List of all state variable symbols'/' No Name= expression ;') do ks=1,nsvfun ipos=1 call list_svfun(text,ipos,ks,ceq) if(pfnerr.ne.0) then gx%bmperr=4142; pfnerr=0; goto 1000 endif write(kou,76)ks,text(1:ipos-1) 76 format(i3,2x,a) enddo 1000 continue return end subroutine list_all_svfun !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine evaluate_all_svfun_old !\begin{verbatim} subroutine evaluate_all_svfun_old(kou,ceq) ! THIS SUBROUTINE MOVED TO MINIMIZER but kept for initiallizing ! cannot be used for state variable functions that are derivatives ... ! evaluate and list values of all functions but it is still used somewhere implicit none integer kou TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ character actual_arg(10)*24 integer kf double precision val if(kou.gt.0) write(kou,75) 75 format('No Name ',12x,'Value') do kf=1,nsvfun ! actual arguments needed if svflista(kf)%nactarg>0 ! write(*,*)'3F call svaluate_svfun_old 2' val=evaluate_svfun_old(kf,actual_arg,0,ceq) if(gx%bmperr.ne.0) goto 1000 if(kou.gt.0) write(kou,77)kf,svflista(kf)%name,val 77 format(i3,1x,a,1x,1PE15.8) enddo 1000 continue return end subroutine evaluate_all_svfun_old !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable double precision function evaluate_svfun_old !\begin{verbatim} %- double precision function evaluate_svfun_old(lrot,actual_arg,mode,ceq) ! THIS SUBROUTINE MOVED TO MINIMIZER ! but needed in some cases in this module ... ??? ! envaluate all funtions as they may depend on each other ! actual_arg are names of phases, components or species as @Pi, @Ci and @Si ! needed in some deferred formal parameters (NOT IMPLEMENTED YET) ! if mode=1 always evaluate implicit none integer lrot,mode character actual_arg(*)*(*) TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} double precision argval(20) type(gtp_state_variable), target :: svr2 type(gtp_state_variable), pointer :: svr integer jv,jt,istv,ieq ! added to handle symbols that are model parameter id integer indices(4),iref,iunit double precision value argval=zero value=zero ! calculate symbol * does not come here for H298 ... ! write(*,*)'3F evaluate_svfun ',lrot,svflista(lrot)%narg,svflista(lrot)%name ! locate function if(lrot.le.0 .or. lrot.gt.nsvfun) then gx%bmperr=4140; goto 1000 endif if(btest(svflista(lrot)%status,SVFDOT)) then ! write(*,*)'3F Warning has SVFDOT set, return error ',lrot gx%bmperr=4399; goto 1000 elseif(btest(svflista(lrot)%status,SVFVAL) .and. mode.ne.1) then ! this symbol is keeps it value unless evaluated explicitly (mode=1) ! write(*,*)'3F Warning has SVFVAL set: ',lrot,svflista(lrot)%name,value value=ceq%svfunres(lrot) goto 1000 elseif(btest(svflista(lrot)%status,SVFEXT)) then ! the symbol is associated with a specific equilibrium we must fetch ! its value from that equilibrium unless that is ceq!! ieq=svflista(lrot)%eqnoval ! write(*,*)'3F SVFEXT set: ',lrot,ieq,svflista(lrot)%name if(ieq.gt.0 .and. ieq.ne.ceq%eqno) then value=eqlista(ieq)%svfunres(lrot) ! save its value also in this equilibrium goto 900 endif endif if(svflista(lrot)%narg.eq.0) goto 300 !-------------------------------------------------------------------- ! get values of arguments ... THIS IS NOT IMPLEMENTED ... I think ?? jv=0 jt=0 100 continue jt=jt+1 istv=svflista(lrot)%formal_arguments(1,jt) ! write(*,*)'3F get argument: ',istv,lrot,svflista(lrot)%eqnoval if(istv.lt.0) then ! evidently istv<1 can also mean this is a model parameter identifier ! how to know? Here only when entering the symbol? if(istv.lt.-1000) then ieq=-istv-1000 ! write(*,*)'3F model parameter identifier: ',ieq ! write(*,*)'3F allocated: ',size(svflista(lrot)%formal_arguments) ! write(*,'(a,10i5)')'3F svflista: ',& ! svflista(lrot)%formal_arguments(5,jt),& ! svflista(lrot)%formal_arguments(6,jt),& ! svflista(lrot)%formal_arguments(7,jt) ! VERY VERY CLUMSY, must be changes to use svr state variable record ! indices are PHASE, COMPSET, COMPONENT, indices(1)=svflista(lrot)%formal_arguments(5,jt) indices(2)=svflista(lrot)%formal_arguments(6,jt) indices(3)=svflista(lrot)%formal_arguments(7,jt) indices(4)=0 iref=0 iunit=0 call state_variable_val3(-ieq,indices,iref,iunit,value,ceq) ! value=zero else ! if eqnoval nonzero it indicates from which equilibrium to get its value ieq=svflista(lrot)%eqnoval if(ieq.eq.0) then value=ceq%svfunres(-istv) else value=eqlista(ieq)%svfunres(-istv) endif endif else ! the 1:10 was a new bug discovered in GNU fortran 4.7 and later ! FOUND PROBABLE BUG 2020-08-31/BOS %formal_arguments never allocated ??? svr=>svr2 call make_stvrec(svr,svflista(lrot)%formal_arguments(1:10,jt)) if(gx%bmperr.ne.0) goto 1000 if(svflista(lrot)%formal_arguments(10,jt).eq.0) then ! get state variable value call state_variable_val(svr,value,ceq) else ! state variable derivative, error code set above, it must be handelled ! by calling other routine and use meq_evaluate_svfun ! write(*,*)'3F In evaluate_svfun_old!!!' ! write(*,*)'Use "calculate symbol" for state variable derivatives!' gx%bmperr=4217 ! call make_stvrec(svr2,svflista(lrot)%formal_arguments(1:10,jt)) ! call state_var_value_derivative(svr,svr2,value,ceq) ! call meq_state_var_value_derivative(svr,svr2,value,ceq) endif if(gx%bmperr.ne.0) goto 1000 endif jv=jv+1 argval(jv)=value if(jt.lt.svflista(lrot)%narg) goto 100 ! all (if any) arguments evaluated (or no arguments needed) !-------------------------------------------------------------------- 300 continue ! write(*,333)'evaluate_svfun ',svflista(lrot)%name,argval(1),argval(2) !333 format(a,a,2(1PE15.6)) ! write(*,340)'3F evaluate svfun 1: ',mode,lrot 340 format(a,5i4) modeval: if(mode.eq.0 .and. btest(svflista(lrot)%status,SVFVAL)) then ! If mode=0 and SVFVAL set return the stored value value=ceq%svfunres(lrot) ! write(*,350)'3F evaluate svfun 2: ',0,lrot,value elseif(mode.eq.0 .and. btest(svflista(lrot)%status,SVFEXT)) then ! if mode=0 and SVFEXT set use value from equilibrium eqno ieq=svflista(lrot)%eqnoval if(ceq%eqno.eq.ieq) then value=evalf(svflista(lrot)%linkpnode,argval) if(pfnerr.ne.0) then write(*,*)'3F evaluate_svfun putfunerror 1',pfnerr gx%bmperr=4141; pfnerr=0; buperr=0; goto 1000 endif ceq%svfunres(lrot)=value ! write(*,350)'3F evaluate svfun 3: ',ieq,lrot,value else ! Hm, we already did this earlier ... redundant? value=eqlista(ieq)%svfunres(lrot) endif ! write(*,350)'3F evaluate svfun 4: ',ieq,lrot,value 350 format(a,2i3,1pe12.4) else ! if mode=1 always evaluate unless another equilibrium, we jumped to 900 above value=evalf(svflista(lrot)%linkpnode,argval) if(pfnerr.ne.0) then write(*,*)'3F evaluate_svfun putfunerror 2',pfnerr gx%bmperr=4141; pfnerr=0; buperr=0; goto 1000 endif endif modeval ! if(btest(svflista(lrot)%status,SVFVAL)) then ! if(lrot.gt.4) write(*,*)'3F evaluated symbol: ',lrot,value ! endif ! save value in current equilibrium 900 continue if(lrot.gt.0) then ceq%svfunres(lrot)=value ! if(lrot.gt.4) write(*,*)'Saved symbol ',lrot,' in equil ',ceq%eqno,value endif 1000 continue ! write(*,*)'3F eval_svfun: ',lrot,value,size(ceq%svfunres) evaluate_svfun_old=value return end function evaluate_svfun_old !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! ================================================ FILE: src/models/gtp3G.F90 ================================================ ! ! gtp3G included in gtp3.F90 ! !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !> 11. Section: status for things !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine change_element_status !\begin{verbatim} subroutine change_element_status(elname,nystat,ceq) ! change the status of an element, can affect species and phase status ! nystat:0=entered, 1=suspended, -1 special (exclude from sum of mole fraction) ! ! suspending elements for each equilibrium separately not yet implemented ! implicit none character elname*(*) integer nystat TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer iel,lokel call find_element_by_name(elname,iel) if(gx%bmperr.ne.0) goto 1000 lokel=elements(iel) write(*,*)'3G Changing element status not yet implemented' goto 1000 if(btest(ellista(iel)%status,elsus)) then ! element already suspended, quit it should be suspended again .... if(nystat.eq.1) goto 1000 ! element status should be changed from suspended to entered ellista(iel)%status=ibclr(ellista(iel)%status,elsus) call restore_species_implicitly_suspended call restore_phases_implicitly_suspended elseif(nystat.eq.1) then ! element should be changed from entered to suspended ellista(iel)%status=ibset(ellista(iel)%status,elsus) call suspend_species_implicitly(ceq) call suspend_phases_implicitly(ceq) endif 1000 continue return end subroutine change_element_status !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable logical function testelstat !\begin{verbatim} logical function testelstat(iel,status) ! return value of element status bit implicit none integer iel,status !\end{verbatim} integer lokel if(iel.gt.0 .and. iel.lt.noofel) then lokel=elements(iel) if(btest(ellista(lokel)%status,status)) then ! btest(iword,bit) .true. if bit set in iword ! iword=ibclr(iword,bit) to clear bit bit in iword ! iword=ibset(iword,bit) to set bit bit in iword testelstat=.true. else testelstat=.false. endif else gx%bmperr=4042 endif end function testelstat !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine change_species_status !\begin{verbatim} subroutine change_species_status(spname,nystat,ceq) ! change the status of a species, can affect phase status ! nystat:0=entered, 1=suspended implicit none integer nystat character spname*(*) TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer loksp call find_species_record(spname,loksp) if(gx%bmperr.ne.0) goto 1000 write(*,*)'3G Changing species status not yet implemented' goto 1000 if(btest(splista(loksp)%status,spsus)) then ! species already suspended, quit if it should be suspended again .... if(nystat.eq.1) goto 1000 ! restore the species (and phases) unless implicitly suspended if(btest(splista(loksp)%status,spimsus)) then ! species cannot be entered as it is implicitly suspended (some element susp) gx%bmperr=4085; goto 1000 endif splista(loksp)%status=ibclr(splista(loksp)%status,spsus) call restore_phases_implicitly_suspended elseif(nystat.eq.1) then ! suspend the species and possibly some phases splista(loksp)%status=ibset(splista(loksp)%status,spsus) call suspend_phases_implicitly(ceq) endif 1000 continue return end subroutine change_species_status !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable logical function testspstat !\begin{verbatim} logical function testspstat(isp,status) ! return value of species status bit implicit none integer isp,status !\end{verbatim} integer loksp if(isp.gt.0 .and. isp.le.noofsp) then loksp=species(isp) if(btest(splista(loksp)%status,status)) then ! btest(iword,bit) .true. if bit set in iword ! iword=ibclr(iword,bit) to clear bit bit in iword ! iword=ibset(iword,bit) to set bit bit in iword testspstat=.true. else testspstat=.false. endif else gx%bmperr=4051 endif end function testspstat !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable integer function get_phase_status !\begin{verbatim} integer function get_phase_status(iph,ics,text,ip,val,ceq) ! return phase status as text and amount formula units in val ! for entered and fix phases also phase amounts. ! OLD Function value: 1=entered, 2=fix, 3=dormant, 4=suspended, 5=hidden implicit none character text*(*) integer iph,ics,ip TYPE(gtp_equilibrium_data), pointer :: ceq double precision val !\end{verbatim} %+ integer ists,lokph,lokcs,j ! write current status ists=0 val=-one if(iph.gt.0 .and. iph.le.noph()) then call get_phase_compset(iph,ics,lokph,lokcs) !old if(btest(phlista(lokph)%status1,phhid)) then !old text='HIDDEN'; ip=6 !old ists=5 !old elseif(btest(ceq%phase_varres(lokcs)%status2,CSSUS)) then ! entered, fix, suspended, dormant ! bit setting: 00 01 , 10 11 !old if(btest(ceq%phase_varres(lokcs)%status2,CSFIXDORM)) then !old text='DORMANT'; ip=7 !old ists=3 !old else !old text='SUSPENDED'; ip=9 !old ists=4 !old endif !old elseif(btest(ceq%phase_varres(lokcs)%status2,CSFIXDORM)) then !old text='FIXED'; ip=5 ! val=ceq%phase_varres(lokcs)%amount(1) !old val=ceq%phase_varres(lokcs)%amfu !old ists=2 !old else !old text='ENTERED'; ip=7 !old val=ceq%phase_varres(lokcs)%amfu !old ists=1 !old endif ! new way, test PHSTATE j=ceq%phase_varres(lokcs)%phstate !z if(j.lt.-4 .or. j.gt.2) then ! I had an erroor here when plotting map2 macro because after the second ! map command I had 2 liquid compsets and during the first mapping I had ! only one liquid so I think !z ip=j !z j=0 !z if(btest(ceq%phase_varres(lokcs)%status2,CSSUS)) then !z if(btest(ceq%phase_varres(lokcs)%status2,CSFIXDORM)) then !z j=-2 !z else ! suspended !z j=3 !z endif !z elseif(btest(ceq%phase_varres(lokcs)%status2,CSFIXDORM)) then ! fix !z j=2 !z else ! entered !z j=0 !z endif ! save this status .... ??? !z write(*,16)'3G PHSTATE wrong, fixing ...',iph,ics,j,ip,& !z ceq%phase_varres(lokcs)%status2 !z ceq%phase_varres(lokcs)%phstate=j !z endif select case(j) case default write(*,16)'3G: PHSTATE not correct: ',iph,ics,j,ip,& ceq%phase_varres(lokcs)%status2 16 format(a,4i3,2x,z16) gx%bmperr=4324 case(phfixed) ! fix 2 text='FIXED' ip=5 val=ceq%phase_varres(lokcs)%amfu ists=phfixed case(-1,0,1) ! entered (unstable, unknown, stable) text='ENTERED' ip=7 val=ceq%phase_varres(lokcs)%amfu ists=phentered case(phdorm) ! dormant -2 text='DORMANT' ip=7 ists=phdorm case(phsus) ! suspended -3 text='SUSPENDED' ip=9 ists=phsus case(phhidden) ! hidden -4 text='HIDDEN' ip=6 ists=phhidden end select else ! write(*,*)'No such phase' gx%bmperr=4050; goto 1000 endif get_phase_status=ists ! write(*,*)'3G: PHSTAT value: ',ists ! write(*,*)'3G: gps: ',ip 1000 continue return end function get_phase_status !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable integer function test_phase_status !\begin{verbatim} integer function test_phase_status(iph,ics,val,ceq) ! Almost same as get_..., returns phase status as function value but no text ! value is amfu ! nystat:-4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fix ! this is different from in change_phase .... one has to make up one's mind implicit none TYPE(gtp_equilibrium_data), pointer :: ceq integer iph,ics double precision val !\end{verbatim} integer ists,lokph,lokcs,j,ip character text*24 ! new code ists=0 call get_phase_compset(iph,ics,lokph,lokcs) if(gx%bmperr.ne.0) goto 900 ists=ceq%phase_varres(lokcs)%phstate val=ceq%phase_varres(lokcs)%amfu goto 900 !============================================= code below redundant? ists=0 ip=1 val=-one ists=get_phase_status(iph,ics,text,ip,val,ceq) goto 900 !------------------ if(iph.gt.0 .and. iph.le.noph()) then call get_phase_compset(iph,ics,lokph,lokcs) ! biet set means false .... !z if(btest(phlista(lokph)%status1,phhid)) then ! hidden !z ists=5 !z elseif(btest(ceq%phase_varres(lokcs)%status2,CSSUS)) then ! entered, fix, suspended, dormant ! bit setting: 00 01 , 10 11 !z if(btest(ceq%phase_varres(lokcs)%status2,CSFIXDORM)) then !z ists=3 !z else !z ists=4 !z endif !z elseif(btest(ceq%phase_varres(lokcs)%status2,CSFIXDORM)) then !z val=ceq%phase_varres(lokcs)%amfu !z ists=2 !z else !z ists=1 !z val=ceq%phase_varres(lokcs)%amfu !z endif ! new way, test PHSTATE j=ceq%phase_varres(lokcs)%phstate select case(ceq%phase_varres(lokcs)%phstate) case default write(*,*)'PHSTAT outside range -4:2: ',j case(phfixed) ! fix +2 if(ists.ne.2) write(*,*)'wrong PHSTAT',ists,j case(-1,0,1) ! entered (unstable, unknown, stable) if(ists.ne.1) write(*,*)'wrong PHSTAT',ists,j case(phdorm) ! dormant -2 if(ists.ne.3) write(*,*)'wrong PHSTAT',ists,j case(phsus) ! suspended -3 if(ists.ne.4) write(*,*)'wrong PHSTAT',ists,j case(phhidden) ! hidden -4 if(ists.ne.5) write(*,*)'wrong PHSTAT',ists,j end select else ! write(*,*)'No such phase' gx%bmperr=4050; goto 1000 endif 900 continue test_phase_status=ists 1000 continue return end function test_phase_status !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine set_phase_status_bit !\begin{verbatim} subroutine set_phase_status_bit(lokph,bit) ! set the status bit "bit" in status1, cannot be done outside this module ! as the phlista is private ! These bits do not depend on the composition set implicit none integer lokph,bit !\end{verbatim} %+ integer lokcs,j if(bit.lt.0 .or. bit.gt.31) then write(*,*)'Illegal phase bit number' gx%bmperr=4325; goto 1000 elseif(lokph.le.0 .or. lokph.gt.noofph) then write(*,*)'Illegal phase in call to set_phase_status_bit' gx%bmperr=4326; goto 1000 endif ! write(*,99)'sphs1bit: ',lokph,bit,phlista(lokph)%status1 99 format(a,2i3,z8) phlista(lokph)%status1=ibset(phlista(lokph)%status1,bit) if(bit.eq.PHHID) then ! if bit is PHHID, i.e. hidden, set PHSTATE in all phase_varres record to -4 do j=1,phlista(lokph)%noofcs lokcs=phlista(lokph)%linktocs(j) ! eventually, this must be set in all equilibrium records now just firsteq ?? firsteq%phase_varres(lokcs)%phstate=-4 enddo endif 1000 continue return end subroutine set_phase_status_bit !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine clear_phase_status_bit !\begin{verbatim} %- subroutine clear_phase_status_bit(lokph,bit) ! clear the status bit "bit" in status1, cannot be done outside this module ! as the phlista is private implicit none integer lokph,bit !\end{verbatim} %+ integer lokcs,j if(bit.lt.0 .or. bit.gt.31) then write(*,*)'Illegal phase bit number' gx%bmperr=4325; goto 1000 endif phlista(lokph)%status1=ibclr(phlista(lokph)%status1,bit) if(bit.eq.PHHID) then write(*,*)'clear_bit: Not implemented to change PHSTATE' ! if bit is PHHID, i.e. hidden, set PHSTATE in all phase_varres record to 0 do j=1,phlista(lokph)%noofcs lokcs=phlista(lokph)%linktocs(j) ! eventually, this must be set in all equilibrium records now just firsteq ?? firsteq%phase_varres(lokcs)%phstate=phentered enddo endif 1000 continue return end subroutine clear_phase_status_bit !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable logical function test_phase_status_bit !\begin{verbatim} %- logical function test_phase_status_bit(iph,ibit) ! return TRUE is status bit ibit for phase iph, is set ! because phlista is private. Needed to test for gas, ideal etc, ! DOES NOT TEST STATUS like entered/fixed/dormant/suspended implicit none integer iph,ibit !\end{verbatim} integer lokph if(iph.gt.0 .and. iph.le.noofph) then lokph=phases(iph) else gx%bmperr=4050; goto 1000 endif if(btest(phlista(lokph)%status1,ibit)) then test_phase_status_bit=.true. else test_phase_status_bit=.false. endif 1000 continue return end function test_phase_status_bit !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine change_many_phase_status !\begin{verbatim} subroutine change_many_phase_status(phnames,nystat,val,ceq) ! change the status of many phases. ! nystat:-4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fix ! phnames is a list of phase names or *S (all suspeded) *D (all dormant) or ! *E (all entered (stable, unknown, unstable), *U all unstable ! If just * then change_phase_status is called directly ! It calls change_phase_status for each phase implicit none character phnames*(*) integer nystat double precision val TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer qph,ics,oldstat,ipos,slen,lokph,lokcs,phcsx character name*24 ! CCI correted size of phnames ! write(*,*)'3G phnames: ',trim(phnames),' >',phnames(1:1),'<' if(phnames(1:1).eq.'*') then ! write(*,*)'3G star' if(phnames(2:2).eq.'S') then oldstat=-3 elseif(phnames(2:2).eq.'D') then oldstat=-2 elseif(phnames(2:2).eq.'E') then ! all entered (stable, unstable, unknown) oldstat=0 elseif(phnames(2:2).eq.'U') then ! all unstable phases (not those which ar efix!) oldstat=1 elseif(phnames(2:2).eq.' ') then qph=-1 ! write(*,*)'3G star',qph,ics,nystat,val call change_phase_status(qph,ics,nystat,val,ceq) goto 1000 else write(*,*)'Illegal selection of old phase status after *' gx%bmperr=4327; goto 1000 endif ! loop for all phases to find those with correct old status do qph=1,noofph ! we cannot loop for ics as we do not know lokph ics=1 call get_phase_compset(qph,ics,lokph,lokcs) 200 continue ! stable phases has ceq%phase_varres(lokcs)%phstate = 1 ! fix phases =2 ipos=oldstat-ceq%phase_varres(lokcs)%phstate ! write(*,*)'3G entered: ',qph,ics,oldstat,ipos if((oldstat.ne.1 .and. ipos.eq.0) .or. & (oldstat.eq.0 .and. abs(ipos).eq.1) .or.& (oldstat.eq.1 .and. ipos.gt.0)) then ! *U=nystat means all all with phstate <=0 that means ipos=1-0; 1-(-1)=2 etc ! (oldstat.eq.1 .and. abs(ipos).gt.0)) then ! this comp.set has correct old phase status call change_phase_status(qph,ics,nystat,val,ceq) if(gx%bmperr.ne.0) goto 1000 endif ! take next composition set if any, else next phase if(ics.lt.phlista(lokph)%noofcs) then ics=ics+1 lokcs=phlista(lokph)%linktocs(ics) goto 200 endif enddo else ! we have one or more specific phase names separated by space or comma ! ipos is updated inside getext, The 3rd argument of getext is JTYP ! JTYP DEFINES THE TERMINATION OF A STRING ! 1 TEXT TERMINATED BY SPACE OR "," ! 2 TEXT TERMINATED BY SPACE ! 3 TEXT TERMINATED BY ";" OR "." ! 4 TEXT TERMINATED BY ";" ! 5 TEXT UP TO END-OF-LINE ! 6 TEXT UP TO AND INCLUDING ";" ! >31, THE CHAR(JTYP) IS USED AS TERMINATING CHARACTER ipos=0 500 continue call getext(phnames,ipos,1,name,' ',slen) ! write(*,*)'3G phase1: ',slen,' ',name if(name(1:1).eq.' ') goto 1000 ! write(*,*)'3G phase2: ',name ! call find_phase_by_name(name,qph,ics) ! phcsx=-1 means that all composition sets should have new status phcsx=-1 call find_phasex_by_name(name,phcsx,qph,ics) if(gx%bmperr.ne.0) then write(*,*)' *** Warning no phase "',trim(name),'", phase ignored' ! write(*,*)'No phase called "',name(1:len_trim(name)),'"' gx%bmperr=0 else ! we may have to make a loop for all composition sets ! A phase without composition set specification but with several composition ! sets should have all composition sets changed to the new status ! UNLESS the status is FIX if(ics.lt.0) then ! we should never loop to set all composition sets to FIXED ! if another composition set than 1 was to be set fixed ics is not negative if(nystat.eq.PHFIXED) then slen=1 else slen=-ics endif ! write(*,*)'3G Status changed for several composition sets: ',slen do ics=1,slen call change_phase_status(qph,ics,nystat,val,ceq) if(gx%bmperr.ne.0) goto 1000 enddo else ! write(*,*)'3G changing status for a single phase',nystat call change_phase_status(qph,ics,nystat,val,ceq) if(gx%bmperr.ne.0) goto 1000 endif endif goto 500 endif 1000 continue return end subroutine change_many_phase_status !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ ! !\addtotable subroutine get_phtup_status !\begin{verbatim} %- ! subroutine get_phtup_status(phtupx,status,ceq) ! return the status of a phase tuple. Also used when setting phase fix etc. ! nystat:-4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fix ! ! implicit none ! integer phtupx,status ! TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ ! the status is in phase_varres record, THIS IS NOT PRIVATE ! 2 fix, 1,0,-1 entered, -2 dormant, -3 suspended ! status=ceq%phase_varres(phasetuple(phtupx)%lokvares)%status2 !1000 continue ! return ! end subroutine get_phtup_status ! !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine change_phtup_status !\begin{verbatim} %- subroutine change_phtup_status(phtupx,nystat,val,ceq) ! change the status of a phase tuple. Also used when setting phase fix etc. ! nystat:-4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fix ! qph can be -1 meaning all or a specifix phase index. ics compset ! implicit none integer phtupx,nystat double precision val TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer lokph,iph,ics if(phtupx.lt.0) then ! change status for all phases to nystat call change_many_phase_status('* ',nystat,val,ceq) else ! lokph=phasetuple(phtupx)%phaseix lokph=phasetuple(phtupx)%lokph iph=phlista(lokph)%alphaindex ics=phasetuple(phtupx)%compset ! write(*,77)'3G Test: ',phlista(lokph)%name,phtupx,lokph,iph,phases(iph) !77 format(a,a,10i5) call change_phase_status(iph,ics,nystat,val,ceq) endif 1000 continue return end subroutine change_phtup_status !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine change_phase_status !\begin{verbatim} %- subroutine change_phase_status(qph,ics,nystat,val,ceq) ! change the status of a phase. Also used when setting phase fix etc. ! nystat:-4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fix ! qph can be -1 meaning all or a specifix phase index. ics compset ! implicit none integer qph,ics,nystat double precision val TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer lokph,lokcs,iph,ip,mcs character line*80,phname*32 ! write(*,11)'3G in change_phase_status: ',qph,ics,nystat,val 11 format(a,3i5,1pe14.6) if(qph.eq.-1) then ! this means all phases. All phases cannot be set fix if(nystat.eq.3) then gx%bmperr=4152; goto 1000 endif iph=1 ics=1 else ! a specific phase iph=qph endif ! return here for next phase 100 continue call get_phase_compset(iph,ics,lokph,lokcs) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'3G: Phase and status: ',iph,ceq%phase_varres(lokcs)%phstate if(ceq%phase_varres(lokcs)%phstate.eq.phfixed) then ! this phase and composition set is fix, remove condition ! unless the new status is also FIX if(nystat.ne.phfixed) then call get_phase_name(iph,ics,phname) line=' NOFIX='//phname(1:len_trim(phname)) ip=1 ! write(*,*)'Remove fix phase: ',line(1:len_trim(line)) call set_condition(line,ip,ceq) if(gx%bmperr.ne.0) then ! write(*,*)'Failed to remove fix phase as condition' goto 1000 endif endif endif bigif: if(ceq%phase_varres(lokcs)%phstate.eq.phhidden) then ! phase is hidden, quit if it should be hidden again ! bigif: if(btest(phlista(lokph)%status1,phhid)) then if(nystat.eq.phhidden) goto 900 ! phlista(lokph)%status1=ibclr(phlista(lokph)%status1,phhid) !??? this phase must be added in phlista ??? no it is already there ??? write(*,*)'Unifished handling of hide/not hide ...' gx%bmperr=4095; goto 900 elseif(nystat.eq.phhidden) then ! phase is not hidden but should be set as hidden, ! Always applies to all composition sets ! clear all entered/suspended/dormant/fix for all composition sets phlista(lokph)%status1=ibset(phlista(lokph)%status1,phhid) do mcs=1,phlista(lokph)%noofcs lokcs=phlista(lokph)%linktocs(mcs) ceq%phase_varres(lokcs)%phstate=phhidden ! also set amounts and dgm to zero ceq%phase_varres(lokcs)%amfu=zero ceq%phase_varres(lokcs)%netcharge=zero ceq%phase_varres(lokcs)%dgm=zero enddo else !bigif lokcs=phlista(lokph)%linktocs(ics) ! changing FIX/ENTERED/SUSPENDED/DORMANT for a composition set ! input nystat:0=entered, 3=fix, 1=suspended, 2=dormant ! bit setting: 00 01 , 10 11 !! BITS NO LONGER USED ! write(*,71)'3G new status: ',iph,ics,lokph,lokcs,nystat,phentered,val 71 format(a,6i5,1pe14.6) if(nystat.eq.phentered .or. nystat.eq.phentunst .or. & nystat.eq.phentstab) then ! set enterered with amount val and dgm zero ! write(*,*)'Setting phase as entered',nystat ! ceq%phase_varres(lokcs)%phstate=phentered ceq%phase_varres(lokcs)%phstate=nystat ceq%phase_varres(lokcs)%amfu=val ceq%phase_varres(lokcs)%netcharge=zero ceq%phase_varres(lokcs)%dgm=zero elseif(nystat.eq.phsus) then ! set suspended with amount and dgm zero ceq%phase_varres(lokcs)%phstate=phsus ceq%phase_varres(lokcs)%amfu=zero ceq%phase_varres(lokcs)%netcharge=zero ceq%phase_varres(lokcs)%dgm=zero elseif(nystat.eq.phdorm) then ! set dormant with amount and dgm zero ceq%phase_varres(lokcs)%phstate=phdorm ceq%phase_varres(lokcs)%amfu=zero ceq%phase_varres(lokcs)%netcharge=zero ceq%phase_varres(lokcs)%dgm=zero elseif(nystat.eq.phfixed) then ! to allow MAPPHASEFIX=3 ceq%phase_varres(lokcs)%phstate=phfixed ceq%phase_varres(lokcs)%amfu=val ceq%phase_varres(lokcs)%netcharge=zero ceq%phase_varres(lokcs)%dgm=zero ! also set as condition call get_phase_name(iph,ics,phname) line=' FIX='//phname(1:len_trim(phname))//' ==' ip=len_trim(line)+2 call wrinum(line,ip,6,0,val) if(buperr.ne.0) goto 1000 ip=1 ! write(*,*)'phase fix condition: ',line(1:40) call set_condition(line,ip,ceq) endif endif bigif 900 continue ! check if loop if(qph.eq.-1) then lokph=phases(iph) if(ics.lt.phlista(lokph)%noofcs) then ics=ics+1 elseif(iph.lt.noofph) then iph=iph+1 ics=1 else goto 1000 endif goto 100 endif 1000 continue ! write(*,*)'error code: ',gx%bmperr return end subroutine change_phase_status !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine mark_stable_phase !\begin{verbatim} &- subroutine mark_stable_phase(iph,ics,ceq) ! change the status of a phase. Does not change fix status ! called from meq_sameset to indicate stable phases (nystat=1) ! nystat:-4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fix ! implicit none integer iph,ics TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer lokph,lokcs ! write(*,11)'3G mark as stable: ',iph,ics,phentstab 11 format(a,3i5,1pe14.6) call get_phase_compset(iph,ics,lokph,lokcs) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'3G: Phase and status: ',iph,ceq%phase_varres(lokcs)%phstate if(ceq%phase_varres(lokcs)%phstate.eq.phhidden) then write(*,*)'Error calling mark_stable for hidden phase' gx%bmperr=4095; goto 1000 elseif(ceq%phase_varres(lokcs)%phstate.le.phdorm) then write(*,*)'Cannot make suspended or doremant phases as stable' gx%bmperr=4095; goto 1000 elseif(ceq%phase_varres(lokcs)%phstate.eq.phfixed) then ! do nothing goto 1000 else ceq%phase_varres(lokcs)%phstate=phentstab endif 1000 continue ! write(*,*)'error code: ',gx%bmperr return end subroutine mark_stable_phase !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !> 12. Section: unfinished things !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine set_unit !\begin{verbatim} subroutine set_unit(property,unit) ! set the unit for a property, like K, F or C for temperature ! >>>> unfinished implicit none character*(*) property,unit !\end{verbatim} write(*,*)'Not implemented yet' gx%bmperr=4078 1000 continue return end subroutine set_unit !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine set_constituent_reference_state !\begin{verbatim} subroutine set_constituent_reference_state(iph,icon,asum) ! determine the end member to calculate as reference state for this constituent ! Used when giving a chemical potential for a constituent like MU(GAS,H2O) implicit none integer iph,icon double precision asum !\end{verbatim} type(gtp_endmember), pointer :: endmemrec integer lokph,nsl,ll,jcon,loksp,loksp2,lokcs ! lokph=phases(iph) loksp=phlista(lokph)%constitlist(icon) nsl=phlista(lokph)%noofsubl endmemrec=>phlista(lokph)%ordered asum=one lokcs=phlista(lokph)%linktocs(1) if(nsl.eq.1) then asum=firsteq%phase_varres(lokcs)%sites(1) emlist1: do while(associated(endmemrec)) if(endmemrec%fraclinks(nsl,1).eq.icon) goto 300 endmemrec=>endmemrec%nextem enddo emlist1 else ! several sublattices OK if same species or vacancies in other sublattices asum=zero emlist2: do while(associated(endmemrec)) do ll=1,nsl jcon=endmemrec%fraclinks(ll,1) if(jcon.ne.icon) then loksp2=phlista(lokph)%constitlist(jcon) if(loksp2.eq.loksp) then ! same species in this sublattice, add sites to asum asum=asum+firsteq%phase_varres(lokcs)%sites(ll) elseif(.not.btest(splista(loksp2)%status,spva)) then ! other species (not vacancies) in this sublattice, skip this end member goto 200 endif else asum=asum+firsteq%phase_varres(lokcs)%sites(ll) endif enddo ! this endmember OK goto 300 ! not this end member 200 continue endmemrec=>endmemrec%nextem enddo emlist2 endif ! this phase cannot exist for species icon as pure gx%bmperr=4112; goto 1000 300 continue 1000 continue return end subroutine set_constituent_reference_state !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine elements2components1 !\begin{verbatim} subroutine elements2components1(nspel,dum,ncmp,cmpstoi,ceq) ! converts a stoichiometry array for a species from elements to components ! This subroutine, is it used to get activity for a constituent in gtp3F ! dum is is no longer used implicit none integer nspel,ncmp ! cmpstoi is stoichiometry as element, changed to be as components double precision cmpstoi(*),dum(*) double precision, allocatable :: stoi(:) type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} double precision, parameter :: small=1.0d-30 integer ic,jc,ns allocate(stoi(noofel)) do ic=1,noofel stoi(ic)=cmpstoi(ic) cmpstoi(ic)=zero enddo ! use the ceq%complist(ic)%invcompstoi ! do ic=1,noofel ! cmpstoi(ic)=zero ! enddo ! not sure about the indices here .... ???? ! write(*,*)'e2c: ',noofel,nspel,stoi(1),ceq%invcompstoi(1,1) do ic=1,noofel ! convert elements to components, if the elements are components no problem do jc=1,noofel cmpstoi(ic)=cmpstoi(ic)+ceq%invcompstoi(ic,jc)*stoi(ic) enddo enddo ! write(*,7)'3G 1: ',(stoi(ic),ic=1,noofel) ! write(*,7)'3G 2: ',(stoi(ic),ic=1,noofel) 7 format(a,10(1pe12.4)) ! MODIFIED HERE 190710/BoS, return stoichiometry for ALL components ncmp=noofel goto 1000 !--------------------- ! skip code below ... ncmp=0 ic=0 ns=0 200 continue ic=ic+1 if(ic.lt.noofel) then if(abs(cmpstoi(ic)).lt.small) then do jc=ic,noofel cmpstoi(jc)=cmpstoi(jc+1) enddo else ncmp=ncmp+1 ! write(*,*)'c2c1: ',ic,ncmp endif goto 200 elseif(abs(cmpstoi(ic)).gt.small) then ! write(*,*)'c2c2: ',ic,ncmp,cmpstoi(ic) ncmp=ncmp+1 endif ! write(*,190)ic,(cmpstoi(i),i=1,ncmp) !190 format('e2c3: ',i3,10F7.3) 1000 continue return end subroutine elements2components1 !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\! !> 13. Section: internal stuff !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine termterm !\begin{verbatim} subroutine termterm(string,ich,kpos,lpos,value) ! search for first occurance of + - = > or < ! if + or - then also extract possible value after sign ! value is coefficient for NEXT term (if any) ! IF WE FIND A ( accept all characters up to ), constitunets can have + or - ! kpos is last character in THIS state variable, lpos where NEXT may start implicit none character string*(*) integer kpos,ich,lpos double precision value !\end{verbatim} integer ipos,jpos,i1 logical afterlp character ch1*1 character (len=1), dimension(6), parameter :: chterm=& ['+','-','=','<','>',':'] ! afterlp=.FALSE. ich=0 sloop: do ipos=1,len_trim(string) ch1=string(ipos:ipos) ! I do not check for nested ( ) or ... if(ch1.eq.'(') then afterlp=.TRUE. elseif(ch1.eq.')') then afterlp=.FALSE. endif ! accept all characters between ( ) if(afterlp) cycle sloop do i1=1,6 if(ch1.eq.chterm(i1)) then kpos=ipos; ich=i1; exit sloop endif enddo enddo sloop ! different actions depending on ich ! write(*,17)'3G termterm: ',trim(string),string(1:kpos),ich,kpos 17 format(a,' "',a,'" >',a,'< ',2i3) select case(ich) case default write(*,*)'3G wrong ich case: ',ich case(0) ! no terminator, just return with position pointer after the text continue kpos=len_trim(string)+1 case(1,2) ! there is a - or + sign, collect value in front of next term lpos=kpos+1 call getrel(string,lpos,value) if(buperr.ne.0) then ! a sign not followed by number means unity buperr=0; value=one else ! lpos first character after number, a number must be followed by a "*" if(string(lpos:lpos).ne.'*') then write(*,*)'3G syntax error missing *: ',string(1:lpos+5),lpos gx%bmperr=4130 else lpos=lpos+1 endif endif if(ich.eq.2) value=-value case(3,4,5) ! there is an = sign, or > or <, just set back the pointer kpos=ipos lpos=0 case(6) ! there is an : sign, meaning a condition number, must be followed by = if(string(kpos+1:kpos+1).ne.'=') then gx%bmperr=4328; goto 1000 endif kpos=ipos+1 lpos=0 end select 1000 continue ! write(*,17)'3G termterm: ',trim(string),string(1:lpos),ich,lpos return end subroutine termterm !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine alphaelorder !\begin{verbatim} subroutine alphaelorder ! arrange new element in alphabetical order ! also make alphaindex give alphabetical order implicit none !\end{verbatim} %+ character symb1*2 integer i,j symb1=ellista(noofel)%symbol ! write(6,*)'alphaelorder 1: ',symb1,noofel loop1: do i=1,noofel-1 if(symb1.lt.ellista(elements(i))%symbol) then loop2: do j=noofel,i+1,-1 elements(j)=elements(j-1) ellista(elements(j))%alphaindex=j enddo loop2 ! write(6,*)'alphaelorder 3: ',i elements(i)=noofel ellista(elements(i))%alphaindex=i exit endif enddo loop1 ! write(6,*)'alphaelorder 4: ',(elements(k),k=1,noofel) END subroutine alphaelorder !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine alphasporder !\begin{verbatim} subroutine alphasporder ! arrange new species in alphabetical order ! also make alphaindex give alphabetical order implicit none !\end{verbatim} %+ character symb1*24 integer i,j symb1=splista(noofsp)%symbol ! write(6,*)'alphasporder 1: ',symb1(1:6),noofsp loop1: do i=1,noofsp-1 if(symb1.lt.splista(species(i))%symbol) then ! write(6,*)'alphasporder 2; ',symb1,splista(species(i))%symbol loop2: do j=noofsp,i+1,-1 species(j)=species(j-1) splista(species(j))%alphaindex=j enddo loop2 species(i)=noofsp ! write(6,*)'alphasporder 3:',i splista(species(i))%alphaindex=i exit endif enddo loop1 ! write(6,*)'alphasporder 4: ',(species(k),k=1,noofsp) END subroutine alphasporder !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine alphaphorder !\begin{verbatim} subroutine alphaphorder(tuple) ! arrange last added phase in alphabetical order ! also make alphaindex give alphabetical order ! phletter G and L and I have priority ! phletter F and B meaning FCC or BCC permutations(?) ignored ! tuple is returned as position in phase tuple implicit none integer tuple !\end{verbatim} character symb1*24,ch1*1,ch2*1 integer iph,lokph,j,lokcs ! symb1=phlista(noofph)%name ch1=phlista(noofph)%phletter ! special care for F or B meaning with permutations ... if(ch1.eq.'F' .or. ch1.eq.'B') ch1='S' if(btest(phlista(noofph)%status1,PHLIQ)) ch1='L' ! for some reason the MQMQA model does not have letter L if(btest(phlista(noofph)%status1,PHMQMQA)) then ch1='L' ! write(*,*)'3G enter phase with MQMQA model' endif ! one more phase in "phases" array phases(noofph)=noofph ! write(6,75)'3G alphaphorder 1: ',noofph,ch1,symb1(1:6) 75 format(A,I3,1x,A,1x,A) loop1: do iph=1,noofph-1 lokph=phases(iph) ch2=phlista(lokph)%phletter ! special care for F or B meaning with permutations ... if(ch2.eq.'F' .or. ch1.eq.'B') ch2='S' ! we must test if MQMQA is any of the phases already sorted if(btest(phlista(lokph)%status1,PHMQMQA)) then ch2='L' ! write(*,*)'3G phletter for phases: ',ch1,ch2 endif ! write(6,76)'alphaphorder 2A: ',iph,lokph,ch1,ch2 76 format(A,2I3,1x,A,1x,A) ! phaseletter different, if ch1=G insert it here if(ch1.eq.'G') goto 300 if(ch2.eq.'G') goto 200 liquid: if(ch1.eq.'L') then if(ch2.eq.'G') goto 200 if(ch2.eq.'L') goto 100 goto 300 endif liquid if(ch2.eq.'L') goto 200 solution: if(ch1.eq.'S') then if(ch2.eq.'G' .or. ch2.eq.'L') goto 200 if(ch2.eq.'S') goto 100 goto 300 endif solution if(ch2.eq.'S') goto 200 compound: if(ch1.eq.'C') then if(ch2.eq.'C') goto 100 goto 200 endif compound ! here phletter of lokph and the new phase are the same 100 continue ! write(6,*)'alphaphorder 2B: ',symb1,phlista(lokph)%name if(symb1.lt.phlista(lokph)%name) goto 300 200 continue enddo loop1 ! exit loop, add new phase last ! lokph=phases(noofph) iph=phases(noofph) 300 continue ! write(*,*)'3G new phase position: ',iph ! write(6,77)'alphaphorder 2C: ',iph,lokph,phlista(lokph)%name !77 format(A,2I3,1X,A) ! insert phase here at iph, shift down trailing phase indices ! also OK if new phase should be last loop2: do j=noofph,iph+1,-1 ! update index of trailing phases, loop from the end not to overwrite phases(j)=phases(j-1) phlista(phases(j))%alphaindex=j enddo loop2 ! index of new phase ! write(6,*)'alphaphorder 4: ',lokph,iph,noofph phases(iph)=noofph phlista(noofph)%alphaindex=iph nooftuples=nooftuples+1 tuple=iph ! write(*,771)iph,phasetuple(iph),phlista(noofph)%name 771 format('3G tuple: ',i5,': ',4(i8,1x),2x,a) ! link to first compset set when phase_varres record connected ! write(*,777)'3G phase tuple position: ',iph,noofph,lokph,lokcs,tuple 777 format(a,10i5) return END subroutine alphaphorder !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine alphaphorder_old !\begin{verbatim} subroutine alphaphorder_old(tuple) ! arrange last added phase in alphabetical order ! also make alphaindex give alphabetical order ! phletter G and L and I have priority ! tuple is returned as position in phase tuple implicit none integer tuple !\end{verbatim} character symb1*24,ch1*1,ch2*1 integer iph,lokph,j,lokcs ! symb1=phlista(noofph)%name ch1=phlista(noofph)%phletter if(btest(phlista(noofph)%status1,PHLIQ)) ch1='L' ! one more phase in "phases" array phases(noofph)=noofph ! write(6,75)'3G alphaphorder 1: ',noofph,ch1,symb1(1:6) 75 format(A,I3,1x,A,1x,A) loop1: do iph=1,noofph-1 lokph=phases(iph) ch2=phlista(lokph)%phletter ! write(6,76)'alphaphorder 2A: ',iph,lokph,ch1,ch2 76 format(A,2I3,1x,A,1x,A) ! phaseletter different, if ch1=G insert it here if(ch1.eq.'G') goto 300 if(ch2.eq.'G') goto 200 liquid: if(ch1.eq.'L') then if(ch2.eq.'G') goto 200 if(ch2.eq.'L') goto 100 goto 300 endif liquid if(ch2.eq.'L') goto 200 solution: if(ch1.eq.'S') then if(ch2.eq.'G' .or. ch2.eq.'L') goto 200 if(ch2.eq.'S') goto 100 goto 300 endif solution if(ch2.eq.'S') goto 200 compound: if(ch1.eq.'C') then if(ch2.eq.'C') goto 100 goto 200 endif compound ! here phletter of lokph and the new phase are the same 100 continue ! write(6,*)'alphaphorder 2B: ',symb1,phlista(lokph)%name if(symb1.lt.phlista(lokph)%name) goto 300 200 continue enddo loop1 ! exit loop, add new phase last ! lokph=phases(noofph) iph=phases(noofph) 300 continue ! write(*,*)'3G new phase position: ',iph ! write(6,77)'alphaphorder 2C: ',iph,lokph,phlista(lokph)%name !77 format(A,2I3,1X,A) ! insert phase here at iph, shift down trailing phase indices ! also OK if new phase should be last loop2: do j=noofph,iph+1,-1 ! update index of trailing phases, loop from the end not to overwrite phases(j)=phases(j-1) phlista(phases(j))%alphaindex=j enddo loop2 ! index of new phase ! write(6,*)'alphaphorder 4: ',lokph,iph,noofph phases(iph)=noofph phlista(noofph)%alphaindex=iph nooftuples=nooftuples+1 tuple=iph ! write(*,771)iph,phasetuple(iph),phlista(noofph)%name 771 format('3G tuple: ',i5,': ',4(i8,1x),2x,a) ! link to first compset set when phase_varres record connected ! write(*,777)'3G phase tuple position: ',iph,noofph,lokph,lokcs,tuple 777 format(a,10i5) return END subroutine alphaphorder_old !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine check_alphaindex !\begin{verbatim} subroutine check_alphaindex ! just for debugging, check that ellist(i)%alphaindex etc is correct implicit none !\end{verbatim} integer i,j,k,l write(kou,*) write(6,77)(ellista(elements(i))%symbol,i=1,noofel) 77 format(20(1x,A2)) write(6,78)(splista(species(i))%symbol,i=1,noofsp) 78 format(20(1x,a6)) write(6,*)'element alphaindex' check1: do i=1,noofel j=ellista(elements(i))%alphaindex write(6,*)i,j,elements(i),ellista(i)%symbol enddo check1 write(6,*)'species alphaindex' check2: do i=1,noofsp j=species(i) k=splista(j)%alphaindex l=splista(species(j))%alphaindex write(6,79)i,k,j,l,splista(j)%symbol enddo check2 79 format(4i4,1x,A) check3: do i=1,noofsp write(6,*)i,splista(i)%alphaindex,splista(i)%symbol enddo check3 END subroutine check_alphaindex !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine create_constitlist !\begin{verbatim} subroutine create_constitlist(constitlist,nc,klist) ! creates a constituent list ... implicit none integer, dimension(*) :: klist integer, dimension(:), allocatable :: constitlist integer nc !\end{verbatim} integer ic ALLOCATE(constitlist(nc)) DO ic=1,nc constitlist(ic)=klist(ic) enddo return END subroutine create_constitlist !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine create_parrecords !\begin{verbatim} subroutine create_parrecords(lokph,lokcs,nsl,nc,nprop,iva,ceq) ! fractions and results arrays for a phase for parallel calculations ! location is returned in lokcs ! nsl is sublattices, nc number of constituents, nprop max number if propert, ! iva is an array which is set as constituent status word (to indicate VA) ! ceq is always firsteq ??? ! ! BEWARE not adopted for threads ! ! >>> changed all firsteq below to ceq???? ! implicit none TYPE(gtp_equilibrium_data), pointer :: ceq integer, dimension(*) :: iva integer lokph,lokcs, nsl, nc, nprop !\end{verbatim} integer ic,nnc ! find free record, free list csfree maintained in FIRSTEQ only! ! write(*,*)'3G maxcalcprop: ',nprop lokcs=csfree if(csfree.le.0) then ! This means no free phase_varres records. ! csfree is set to -1 by the statement csfree=phase_varres(lokcs)%next below ! when reserving the last free record. The same for the other free lists gx%bmperr=4094; goto 1000 endif ! the free list of phase_varres record is only maintained in firsteq ! but all equilibria have identical allocation of phase_varres records ! the free list is created when starting OC, each record points to the next ! After composition sets has been entered and deleted it may be different ! highcs should always be the index of the highest used record csfree=firsteq%phase_varres(lokcs)%nextfree ! write(*,*)'3G looking for free varres record 1:',lokcs,csfree ! wrong ... if(csfree.gt.highcs) highcs=csfree ! The varres record used will be, csfree is updated ! write(*,*)'3G looking for free varres record 2:',lokcs,csfree firsteq%phase_varres(lokcs)%nextfree=0 firsteq%phase_varres(lokcs)%status2=0 ic=newhighcs(.true.) if(lokcs.gt.highcs) highcs=lokcs ! added integer status array constat. Set CONVA bit from iva array ! write(*,*)'Allocate constat 2: ',nc,lokcs if(.not.allocated(ceq%phase_varres(lokcs)%constat)) then ! remove CSDEL if set firsteq%phase_varres(lokcs)%status2=& ibclr(firsteq%phase_varres(lokcs)%status2,CSDEL) ! already allocated error for the Al-Ni case, why? ! Maybe if composition set has been deleted without releasing allocated arrays? allocate(ceq%phase_varres(lokcs)%constat(nc)) endif ! write(*,*)'3G compset: ',trim(phlista(lokph)%name),nc,lokcs,& ! size(ceq%phase_varres(lokcs)%constat) ! write(*,33)nc,(iva(i),i=1,nc) do ic=1,nc ceq%phase_varres(lokcs)%constat(ic)=iva(ic) enddo ! allocate fraction and default fraction arrays allocate(ceq%phase_varres(lokcs)%yfr(nc)) allocate(ceq%phase_varres(lokcs)%mmyfr(nc)) do ic=1,nc ceq%phase_varres(lokcs)%yfr(ic)=one ceq%phase_varres(lokcs)%mmyfr(ic)=zero enddo ! write(*,*)'Allocated mmyfr: ',lokcs,nc,nprop ! abnorm initiated to unity to avoid trouble at first calculation ceq%phase_varres(lokcs)%abnorm=one allocate(ceq%phase_varres(lokcs)%sites(nsl)) ! if(btest(phlista(lokph)%status1,PHIONLIQ)) then ! for ionic liquid the sites may depend on composition ! I get error these already allocated. Why ?? if(.not.allocated(ceq%phase_varres(lokcs)%dpqdy)) then allocate(ceq%phase_varres(lokcs)%dpqdy(nc)) allocate(ceq%phase_varres(lokcs)%d2pqdvay(nc)) endif endif ! ! result arrays for a phase for use in parallel processing ceq%phase_varres(lokcs)%nprop=nprop allocate(ceq%phase_varres(lokcs)%listprop(nprop)) allocate(ceq%phase_varres(lokcs)%gval(6,nprop)) ! write(*,*)'Allocated gval: ',nprop,nc allocate(ceq%phase_varres(lokcs)%dgval(3,nc,nprop)) nnc=nc*(nc+1)/2 ! write(*,*)'Allocated dgval: ',nprop,nc,nnc allocate(ceq%phase_varres(lokcs)%d2gval(nnc,nprop)) ! write(*,*)'Allocated d2gval: ',nprop,nc,nnc ! zero everything ceq%phase_varres(lokcs)%listprop=0 ! ceq%phase_varres(lokcs)%amount=zero ceq%phase_varres(lokcs)%amfu=zero ceq%phase_varres(lokcs)%netcharge=zero ceq%phase_varres(lokcs)%dgm=zero ceq%phase_varres(lokcs)%gval=zero ceq%phase_varres(lokcs)%dgval=zero ceq%phase_varres(lokcs)%d2gval=zero ! Mark there is no disordered phase_varres record ceq%phase_varres(lokcs)%disfra%varreslink=0 ! write(*,*)'parrecords: ',lokcs,nsl,nc 1000 continue return end subroutine create_parrecords !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine create_interaction !\begin{verbatim} subroutine create_interaction(intrec,mint,lint,intperm,intlinks) ! creates a parameter interaction record ! with permutations if intperm(1)>0 implicit none type(gtp_interaction), pointer :: intrec integer, dimension(2,*) :: lint,intlinks integer, dimension(*) :: intperm integer mint !\end{verbatim} integer permut,emperm,nz,nq,lqq,ii,ll ! ! write(*,5)'create interaction:',mint,lint(1,mint),lint(2,mint),& ! (intperm(ii),ii=1,6) 5 format(a,i5,2x,2i3,2x,6i3) allocate(intrec) ! note that the order of values in intperm here is not the same in ! fccpermuts or bccpermuts ?? Intlinks is the same permut=intperm(1) if(permut.le.0) then ! This is a default for no permutations, store 1's permut=0 allocate(intrec%noofip(2)) intrec%noofip(1)=1 intrec%noofip(2)=1 allocate(intrec%sublattice(1)) allocate(intrec%fraclink(1)) elseif(mint.eq.1) then ! Intperm contains information as created by fccpermut or bccpermut ! intperm(1) and 2 are related to mint=1 (level 1 interaction), ! intperm(3) to mint=2 ! The values are stored in noofip(1) and intperm(2..) in noofip(2..) ! For mint=1 intperm(1..2) are stored in noofipermt(1..2) ! intperm(1) is the number of interaction permutations for each ! endmember permutation. ! intperm(2) are the number total number of permutations on level 1 ! The number of endmember permutations is thus intperm(2)/intperm(1) ! write(*,17)'intrec: ',mint,intperm(1),intperm(2) permut=intperm(2) nz=intperm(2) allocate(intrec%noofip(2)) intrec%noofip(1)=intperm(1) intrec%noofip(2)=intperm(2) allocate(intrec%sublattice(nz)) allocate(intrec%fraclink(nz)) nq=0 elseif(mint.eq.2) then ! For mint=2 intperm(3) is stored in noofip(1) and intperm(4..) after that ! if intperm(3)>1 then there are intperm(3) number of limits in ! intperm(2..) for each lower order interaction. ! Example endmember A:A:A:A; no permutations ! 1st level intperm(1)=1, intperm(2)=4; permutations AX:A:A:A, A:AX:A:A etc ! 2nd level intperm(1)=4, inteprm(2..4)=(3, 2, 1, 0) ! 3 permutations for AX:A:A:A: AX:AX:A:A; AX:A:AX:A; AX:A:A:AX ! 2 permutations for A:AX:A:A: A:AX:AX:A A:AX:A:AX; ! 1 permutation for A:A:AX:A: A:A:AX:AX; ! 0 permutations for A:A:A:AX: none ! If noofpermut>1 the index selected of noofip is by the permutation of ! the lower order interaction ! the value in intpermut(4+intperm(3)) is total number of permutations lqq=intperm(4+intperm(3)) ! write(*,17)'intrec: ',mint,intperm(3),(intperm(3+ii),ii=1,intperm(3)) 17 format(a,2i4,2x,10i4) permut=intperm(3) emperm=intperm(2)/intperm(1) allocate(intrec%noofip(permut+2)) nz=0 intrec%noofip(1)=intperm(3) do ii=1,permut intrec%noofip(1+ii)=intperm(3+ii) nz=nz+intperm(3+ii) enddo ! write(*,19)'ci: ',nz,emperm,permut,(intrec%noofip(j),j=1,permut+2) 19 format(a,10i4) ! AX:AX:A:A; 1 endmember permutation, 4 1st level permutations; 6 2nd level ! emperm=1; intperm(3)=4, intparm(4..6)=(3,2,1,0), nz=1*6=6 ! AX:AX:B:B; 6 endmember permutation, 6 1st level permutations; 6 2nd level ! emperm=6; nz=1; nz=1*6=6 ! number of permutations is related to the previous level ! nz=nz*emperm nz=lqq ! write(*,*)'Level 2 permutations: ',nz allocate(intrec%sublattice(nz)) allocate(intrec%fraclink(nz)) ! Save at the end the total number of permutations stored intrec%noofip(permut+2)=nz nq=intperm(2) ! write(*,19)'c2: ',nz,emperm,permut,(intrec%noofip(j),j=1,permut+2) ! write(*,17)'level 2 permutations: ',nz,emperm,nq,lqq else write(*,*)'Create_interaction called with too many permutations' gx%bmperr=4329; goto 1000 endif if(permut.eq.0) then ! this is again a default when there are no permutations intrec%sublattice(1)=lint(1,mint) intrec%fraclink(1)=lint(2,mint) else ! We can have cases like noofiperumt(1)=1; noofip(2)=4 or ! noofip(1)=4; noofip(2..5)=(4, 3, 2, 1) ! nq is 0 for first level, intperm(2) for second level do ll=1,nz intrec%sublattice(ll)=intlinks(1,nq+ll) intrec%fraclink(ll)=intlinks(2,nq+ll) enddo ! write(*,99)'isp: ',mint,& ! (intrec%sublattice(ll),intrec%fraclink(ll),ll=1,nz) 99 format(a,i2,8(2x,2i3)) endif nullify(intrec%propointer) nullify(intrec%nextlink) nullify(intrec%highlink) ! nullify Kohler-Toop link ! write(*,*)'3G nullifying tooprec pointer' nullify(intrec%tooprec) intrec%status=0 noofint=noofint+1 intrec%antalint=noofint 1000 continue return end subroutine create_interaction !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine create_endmember !\begin{verbatim} subroutine create_endmember(lokph,newem,noperm,nsl,endm,elinks) ! create endmember record with nsl sublattices with endm as constituents ! noperm is number of permutations ! endm is the basic endmember (if there are permutations) ! elinks are the links to constituents for all permutations implicit none integer endm(*) integer lokph,noperm,nsl type(gtp_endmember), pointer :: newem integer, dimension(nsl,noperm) :: elinks !\end{verbatim} integer is,ndemr,noemr,nn allocate(newem) nullify(newem%nextem) allocate(newem%fraclinks(nsl,noperm)) if(noperm.eq.1) then do is=1,nsl newem%fraclinks(is,1)=endm(is) enddo else ! write(*,*)'3G permutations: ',noperm,nsl ! write(*,7)((elinks(is,nn),is=1,4),nn=1,noperm) 7 format('3G ce1: ',4(4i3,2x)) newem%fraclinks=elinks endif ! zero or set values newem%noofpermut=noperm newem%phaselink=lokph noofem=noofem+1 newem%antalem=noofem nullify(newem%propointer) nullify(newem%intpointer) ! indicate that oendmemarr and denmemarr must be renewed ??? noemr=0 ndemr=0 1000 continue return end subroutine create_endmember !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine create_proprec !\begin{verbatim} subroutine create_proprec(proprec,proptype,degree,lfun,refx) ! reservs a property record from free list and insert data ! it is called from enter_parameter in gtp3B.F90 ! if there is already a property record (magnetic, MQMQA etc) for the parameter ! this record is automatically linked at the end implicit none TYPE(gtp_property), pointer :: proprec integer proptype,degree,lfun character refx*(*) !\end{verbatim} %+ type(gtp_asymprop) :: asymdata integer j,iref,typty,powers,ppow,qpow character notext*32 logical mqmqa ! mqmqa=.false. if(proptype.ge.1000) then ! this an MQMQA parameter write(*,*)'3G use special create_mqmqa_proprec' stop mqmqa=.true. ! an MQMQA model parameters have special asymmetric composition dependence write(*,*)'3G special MQMQA excess parameter',proptype,degree typty=proptype/1000 ! this proptype is probably not needed nor useful if(typty.eq.1) then powers=proptype-1000 proptype=34 ! GG elseif(typty.eq.2) then powers=proptype-2000 proptype=35 !GQ elseif(typty.eq.3) then powers=proptype-3000 proptype=36 !GB endif allocate(proprec) ! MQMQA has a single function but it can be asymmetric allocate(proprec%degreelink(0:0)) nullify(proprec%nextpr) ! proptype for MQMQA is 34, 35, 36, the modelparameter i just G proprec%proptype=proptype ! the typty 34, 35 and 36 is kept but changed to G when listing? ! this typty is used to provide information after the ; in listing ! 34 is ;G,p,q,r), 35 is ;Q,p,q,r) and 26 is ;B,p,q,r) proprec%modelparamid=propid(1)%symbol ! proprec%modelparamid=propid(proptype)%symbol ! write(*,*)'3G MQMQA parameter ',typty,proprec%proptype,powers ! the proprec%extra should contains 3 powers, as 100*p + 10*q + r ! for the equation \varkappa_ij**p * \varkappa_ji**q in Max eq. 23/24 ! The r is for a ternary parameter in eqs. 25/26. There is just one degree 0 ! NOW THERE IS A MQMQA property record for this proprec%extra=powers proprec%degree=0 proprec%degreelink(0)=lfun ! write(*,2)proptype,powers,degree,refx 2 format('3G in create_proprec ',i2,i7,i3,' refx: ',a) ! create an addition asymprop record for extra information ! some of the information in this will be added from the calling routine ! powers is for example 321 where 3 is ppow, 2 is qpow and 1 is rpow ! very clumsy but I am tired of this model allocate(proprec%asymdata) proprec%asymdata%ppow=powers/100 proprec%asymdata%qpow=(powers-100*proprec%asymdata%ppow)/10 ! proprec%proprec%asymdata%ppow=ppow ! proprec%proprec%asymdata%qpow=qpow proprec%asymdata%rpow=powers-100*proprec%asymdata%ppow-& 10*proprec%asymdata%qpow ! write(*,*)'3G value of rpow: ',proprec%asymdata%rpow ! write(*,7)powers,proprec%asymdata%ppow,proprec%asymdata%qpow,& ! proprec%asymdata%rpow 7 format('3G allocated asymdata: ',i7,5x,3i3) ! indices in proprec%asymdata%quad_ij _ii, _jj and _33 will be set by ! calling routine proprec%reference=adjustl(refx) ! index of asymdata%quad, %alpha, %beta and %ternary should be set <<<<<< goto 900 !------------ end of MQMQA specific elseif(degree.lt.0 .or. degree.gt.9) then write(*,10)degree 10 format('*** Error, degree of a parameter ',i2,'must be between 0 and 9') gx%bmperr=4063 goto 1000 endif ! this is for all parameters EXCEPT the MQMQA excess allocate(proprec) ! enter data in reserved record allocate(proprec%degreelink(0:degree)) nullify(proprec%nextpr) ! if(proptype.ge.100) write(*,*)'property type: ',proptype proprec%proptype=proptype ! also save %modelparamid for unformatted files ... ! this causes problems with the MQMQA ... if(proptype.gt.100) then ! this is a property with a constituent suffix like MQ&FE proprec%modelparamid=propid(proptype/100)%symbol ! write(*,*)'3G proptype ',propid(proptype/100)%symbol,proptype else proprec%modelparamid=propid(proptype)%symbol ! write(*,*)'3G proptype ',propid(proptype)%symbol,proptype endif proprec%degree=degree do j=0,degree proprec%degreelink(j)=0 enddo proprec%degreelink(degree)=lfun proprec%reference=adjustl(refx) proprec%extra=0 ! create reference record if new, can be amended later !------global counter noofprop=noofprop+1 proprec%antalprop=noofprop ! write(*,11)refx,noofprop 11 format('create proprec: ',a,i7) ! save the reference index 900 continue call capson(refx) ! write(*,*)'3G reference: ',refx notext='*** Not set by database or user ' call tdbrefs(refx,notext,0,iref) 1000 continue return end subroutine create_proprec !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine create_mqmqa_proprec !\begin{verbatim} subroutine create_mqmqa_proprec(proprec,proptype,degree,lfun,refx) ! reservs a property record from free list and insert data MQMQA version ! it is called from enter_parameter in gtp3B.F90 ! if there is already a property record (magnetic, MQMQA etc) for the parameter ! this record is automatically linked at the end implicit none TYPE(gtp_property), pointer :: proprec integer proptype,degree,lfun character refx*(*) !\end{verbatim} %+ type(gtp_asymprop) :: asymdata integer j,iref,typty,powers,ppow,qpow character notext*32 logical mqmqa ! ! write(*,*)'3G using special MQMQA create_proprec' mqmqa=.false. if(proptype.ge.1000) then ! this an MQMQA parameter mqmqa=.true. ! an MQMQA model parameters have special asymmetric composition dependence if(mqmqtdb) write(*,*)'3G special MQMQA excess parameter',proptype,degree typty=proptype/1000 ! this proptype is probably not needed nor useful if(typty.eq.1) then powers=proptype-1000 proptype=34 ! GG elseif(typty.eq.2) then powers=proptype-2000 proptype=35 !GQ elseif(typty.eq.3) then powers=proptype-3000 proptype=36 !GB endif !-------------------------- ! modifying the create_proprec for MQMQA crased reading some normal database ! and I do not really understand how it work any longer ! so I created a new version for MQMQA databases allocate(proprec) ! MQMQA has a single function but it can be asymmetric allocate(proprec%degreelink(0:0)) nullify(proprec%nextpr) ! proptype for MQMQA is 34, 35, 36, the modelparameter i just G proprec%proptype=proptype ! the typty 34, 35 and 36 is kept but changed to G when listing? ! this typty is used to provide information after the ; in listing ! 34 is ;G,p,q,r), 35 is ;Q,p,q,r) and 26 is ;B,p,q,r) proprec%modelparamid=propid(1)%symbol ! proprec%modelparamid=propid(proptype)%symbol ! write(*,*)'3G MQMQA parameter ',typty,proprec%proptype,powers ! the proprec%extra should contains 3 powers, as 100*p + 10*q + r ! for the equation \varkappa_ij**p * \varkappa_ji**q in Max eq. 23/24 ! The r is for a ternary parameter in eqs. 25/26. There is just one degree 0 ! NOW THERE IS A MQMQA property record for this proprec%extra=powers proprec%degree=0 proprec%degreelink(0)=lfun ! write(*,2)proptype,powers,degree,refx 2 format('3G in create_proprec ',i2,i7,i3,' refx: ',a) ! create an addition asymprop record for extra information ! some of the information in this will be added from the calling routine ! powers is for example 321 where 3 is ppow, 2 is qpow and 1 is rpow ! very clumsy but I am tired of this model allocate(proprec%asymdata) proprec%asymdata%ppow=powers/100 proprec%asymdata%qpow=(powers-100*proprec%asymdata%ppow)/10 ! proprec%proprec%asymdata%ppow=ppow ! proprec%proprec%asymdata%qpow=qpow proprec%asymdata%rpow=powers-100*proprec%asymdata%ppow-& 10*proprec%asymdata%qpow ! write(*,*)'3G value of rpow: ',proprec%asymdata%rpow ! write(*,7)powers,proprec%asymdata%ppow,proprec%asymdata%qpow,& ! proprec%asymdata%rpow 7 format('3G allocated asymdata: ',i7,5x,3i3) ! indices in proprec%asymdata%quad_ij _ii, _jj and _33 will be set by ! calling routine proprec%reference=adjustl(refx) ! index of asymdata%quad, %alpha, %beta and %ternary should be set <<<<<< noofprop=noofprop+1 proprec%antalprop=noofprop ! write(*,11)refx,noofprop 11 format('3G create proprec: ',a,i7) goto 900 !------------ end of MQMQA specific elseif(degree.lt.0 .or. degree.gt.9) then write(*,10)degree 10 format('*** Error, degree of a parameter ',i2,'must be between 0 and 9') gx%bmperr=4063 goto 1000 endif ! this is for all parameters EXCEPT the MQMQA excess allocate(proprec) ! enter data in reserved record allocate(proprec%degreelink(0:degree)) nullify(proprec%nextpr) ! if(proptype.ge.100) write(*,*)'property type: ',proptype proprec%proptype=proptype ! also save %modelparamid for unformatted files ... ! this causes problems with the MQMQA ... if(proptype.gt.100) then ! this is a property with a constituent suffix like MQ&FE proprec%modelparamid=propid(proptype/100)%symbol ! write(*,*)'3G proptype ',propid(proptype/100)%symbol,proptype else proprec%modelparamid=propid(proptype)%symbol ! write(*,*)'3G proptype ',propid(proptype)%symbol,proptype endif proprec%degree=degree do j=0,degree proprec%degreelink(j)=0 enddo proprec%degreelink(degree)=lfun proprec%reference=adjustl(refx) proprec%extra=0 ! create reference record if new, can be amended later !------global counter noofprop=noofprop+1 proprec%antalprop=noofprop ! save the reference index 900 continue call capson(refx) ! write(*,*)'3G reference: ',refx notext='*** Not set by database or user ' call tdbrefs(refx,notext,0,iref) 1000 continue return end subroutine create_mqmqa_proprec !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine extend_proprec !\begin{verbatim} subroutine extend_proprec(current,degree,lfun) ! extends a property record and insert new data implicit none integer degree,lfun type(gtp_property), pointer :: current !\end{verbatim} integer oldeg,j integer :: savedegs(0:9) ! save degreelinks ... maybe not necessary .... oldeg=current%degree ! write(*,*)'extend_proprec 1: ',current,degree,lfun,oldeg do j=0,9 savedegs(j)=0 enddo do j=0,oldeg savedegs(j)=current%degreelink(j) enddo ! important to get it correct here deallocate(current%degreelink) allocate(current%degreelink(0:degree)) current%degree=degree do j=0,current%degree current%degreelink(j)=0 enddo do j=0,oldeg current%degreelink(j)=savedegs(j) enddo current%degreelink(degree)=lfun 1000 continue return end subroutine extend_proprec !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine add_fraction_set !\begin{verbatim} subroutine add_fraction_set(iph,id,ndl,totdis) ! add a new set of fractions to a phase, usually to describe a disordered state ! like the "partitioning" in old TC ! ! BEWARE this is only done for firsteq, illegal when having more equilibria ! ! id is a letter used as suffix to identify the parameters of this set ! ndl is the last original sublattice included in the (first) disordered set ! ndl can be 1 meaning sublattice 2..nsl are disordered, or nsl meaning all are ! disordered ! totdis=0 if phase never disorder totally (like sigma) ! ! For a phase like (Al,Fe,Ni)3(Al,Fe,Ni)1(C,Va)4 to add (Al,Fe,Ni)4(C,Va)4 ! icon=1 2 3 1 2 3 4 5 with ndl=2 ! For a phase like (Fe,Ni)10(Cr,Mo)4(Cr,Fe,Mo,Ni)16 then ! icon=2 4 1 3 1 2 3 4 with ndl=3 ! This subroutine will create the necessary data to calculate the ! disordered fraction set from the site fractions. ! ! IMPORTANT (done): for each composition set this must be repeated ! if new composition sets are created it must be repeated for these ! ! IMPORTANT (not done): order the constituents alphabetically in each disorderd ! sublattice otherwise it will not be possible to enter parameters correctly ! implicit none integer iph,ndl,totdis character id*1 !\end{verbatim} ! ceq probably not needed as firsteq is declared as pointer ! TYPE(gtp_equilibrium_data), target :: ceq TYPE(gtp_fraction_set), target :: fsdata ! jsp(i) contains species locations of disordered constituent i ! jy2x(i) is the disordered fraction to which site fraction i should be added ! y2x(i) is the site ration factor for multiplying sitefraction i when added ! ispord and ispold are needed to sort disordered constituents integer jsp(maxconst,2),jy2x(maxconst),iva(maxconst) integer ispord(maxconst),ispold(maxconst),nrj3(2),nrj4(2) integer lokph,lokcs,nsl,ii,nrj1,nrj2,nlat,lokx,l2 integer ll,kk,jall,nnn,mmm,ioff,koff,jl,j1,j2,ix,is,jj,k,ijcs,nydis,nyttcs double precision sum,div ! if(.not.allowenter(2)) then gx%bmperr=4125 goto 1000 endif ! this subroutine can only be called when there is only one equilibrium lokph=phases(iph) ! phase must not have any suspended constituents nor any composition sets if(phlista(lokph)%noofcs.gt.1) then gx%bmperr=4029; goto 1000 else lokcs=phlista(lokph)%linktocs(1) if(btest(firsteq%phase_varres(lokcs)%status2,CSCONSUS)) then gx%bmperr=4030; goto 1000 endif endif nsl=phlista(lokph)%noofsubl if(ndl.le.1 .or. ndl.gt.nsl) then ! ndl must be larger than 2 and lesser or equal to nsl gx%bmperr=4076; goto 1000 endif ! location of first composition set, there may be more if(btest(phlista(lokph)%status1,phmfs)) then ! disordered fractions already set gx%bmperr=4077; goto 1000 endif ! write(*,*)'3G in add_fr: ',iph,id,ndl,totdis ! we must organise a constituent list for the disordered fractions by ! scanning the constituents in the current phlista(lokph)%constitlist ! we must also contruct the way site fractions should be added ii=0 nrj1=1 nrj2=0 nlat=0 lokx=0 l2=1 iva=0 subloop: do ll=1,nsl constloop: do kk=1,phlista(lokph)%nooffr(ll) ii=ii+1 if(nrj2.lt.nrj1) then nrj2=nrj2+1 lokx=lokx+1 jy2x(ii)=lokx jsp(nrj2,l2)=phlista(lokph)%constitlist(ii) ! write(*,46)'new 1: ',nrj2,l2,ii,nlat,jsp(nrj2,l2),jy2x(ii) else do jall=nrj1,nrj2 if(phlista(lokph)%constitlist(ii).eq.jsp(jall,l2)) then ! this constituent already found in another sublattice to be merged ! write(*,*)'same: ',jall,nlat,jall+nlat,ii,jy2x(jall+nlat) jy2x(ii)=jy2x(jall+nlat); goto 50 endif enddo ! new constituent nrj2=nrj2+1 lokx=lokx+1 jy2x(ii)=lokx jsp(nrj2,l2)=phlista(lokph)%constitlist(ii) ! write(*,46)'new 2: ',nrj2,l2,ii,nlat,jsp(nrj2,l2),jy2x(ii) 46 format(a,10i3) ! if vacancy set that bit in iva if(btest(firsteq%phase_varres(lokcs)%constat(ii),conva)) then iva(nrj2)=ibset(iva(nrj2),conva) endif ! write(*,*)'addfs 7B: ',ll,ii,nrj2 50 continue endif enddo constloop if(ll.eq.ndl) then ! next sublattices (if any) will be summed to second disordered sublattice nrj3(1)=nrj2 nrj3(2)=0 ! bug?? nlat=ii nrj1=1 nrj2=0 ! nrj4 is the number of constituents in ordered phase thst is summed ! to first disordered sublattice. Needed below to rearrange jy2x nrj4(1)=ii nrj4(2)=0 if(ndl.lt.nsl) l2=2 ! write(*,*)'addfs 7C: ',ll,ndl,nrj1,nrj2,nrj3 elseif(ll.eq.nsl) then ! this may never be executed if ndl=nsl but we set nrj3(2)=0 above nrj3(2)=nrj2 nrj4(2)=ii-nrj4(1) endif enddo subloop ! write(*,53)'add_fraction_set 2: ',(jy2x(i),i=1,ii) 53 format(a,20i3) ! added fsites to handle the case when reading sigma etc from a TDB file ! as the TDB file format assumes 1 site. Default is 1.0, changed externally fsdata%fsites=one ! write(*,*)'3G Set fsites: ',fsdata%fsites,ndl,totdis,nnn ! ! write(*,53)'add_fraction_set 3: ',nrj1,nrj2,nrj3,nrj4 fsdata%latd=ndl fsdata%tnoofyfr=phlista(lokph)%tnooffr fsdata%varreslink=lokcs ! totdis=1 means disordered fcc, bcc, ncp. totdis=0 means sigma fsdata%totdis=totdis fsdata%id=id ! one or 2 disordered sublattices nnn=1 if(ndl.lt.nsl) nnn=2 ! try to allow more than one interstitial sublattice ... NO if(nsl-ndl.gt.1) then write(*,*)'3G *** Error max one sublattices outside the disordered set' gx%bmperr=4399 goto 1000 endif ! write(*,'(a,10i5)')'3G disordered sublattices:',nsl,ndl,nnn,fsdata%latd allocate(fsdata%dsites(nnn)) fsdata%ndd=nnn allocate(fsdata%nooffr(nnn)) fsdata%nooffr(1)=nrj3(1) if(nnn.eq.2) fsdata%nooffr(2)=nrj3(2) ! nrj3(1) are the number of constituents on first sublattice, nrj3(2) on 2nd mmm=nrj3(1)+nrj3(2) fsdata%tnoofxfr=mmm allocate(fsdata%splink(mmm)) allocate(fsdata%y2x(phlista(lokph)%tnooffr)) allocate(fsdata%dxidyj(phlista(lokph)%tnooffr)) ! write(*,*)'add_fs dxidyj: ',phlista(lokph)%tnooffr ! the constituents in jsp(i..n,subl) must be ordered alphabetically!!! ! get the species number in alphadetical order ioff=0 koff=0 do l2=1,nnn do jl=1,nrj3(l2) ! write(*,*)'l2 loop: ',jsp(i,l2) ispord(jl)=splista(jsp(jl,l2))%alphaindex enddo ! write(*,47)1,(ispord(i),i=1,nrj3(l2)) 47 format('add_fs ',i1,': ',20i3) ! species, noofsp, origonal order call sortin(ispord,nrj3(l2),ispold) if(buperr.ne.0) then gx%bmperr=buperr; goto 1000 endif ! when rearranging jsp(1..n,l2) we must also rearrange y2x ! for 2nd sublattice add nrj3(1) to ispold if(l2.eq.2) then ioff=nrj4(1) koff=nrj3(1) endif ! write(*,47)2,(jy2x(ioff+i),i=1,nrj4(l2)) ! this must be possible to do smarter ..... do j2=1,nrj4(l2) do j1=1,nrj3(l2) if(jy2x(ioff+j2).eq.ispold(j1)+koff) then jy2x(ioff+j2)=j1+koff; goto 77 endif enddo 77 continue enddo do j1=1,nrj3(l2) ispord(j1)=jsp(ispold(j1),l2) enddo do j1=1,nrj3(l2) jsp(j1,l2)=ispord(j1) enddo ! write(*,47)5,(jsp(i,l2),i=1,nrj3(l2)) enddo fsdata%splink=0 ! do jl=1,phlista(lokph)%tnooffr fsdata%y2x(jl)=jy2x(jl) enddo ix=0 do l2=1,nnn do jl=1,nrj3(l2) ix=ix+1 fsdata%splink(ix)=jsp(jl,l2) enddo enddo ! write(*,*)'addfs splink: ',fsdata%splink ! is=0 sum=zero do ll=1,ndl ! sum=sum+phlista(lokph)%sites(ll) sum=sum+firsteq%phase_varres(lokcs)%sites(ll) enddo fsdata%dsites(1)=sum if(ndl.lt.nsl) then sum=zero do ll=ndl+1,nsl ! sum=sum+phlista(lokph)%sites(ll) sum=sum+firsteq%phase_varres(lokcs)%sites(ll) enddo fsdata%dsites(2)=sum endif ! jj=0 sum=fsdata%dsites(1) ! write(*,*)'3G sum: ',ndl,sum,fsdata%dsites do ll=1,nsl if(ll.gt.ndl) sum=fsdata%dsites(2) ! div=phlista(lokph)%sites(ll)/sum div=firsteq%phase_varres(lokcs)%sites(ll)/sum ! write(*,78)'add_fs 5A ',div,phlista(lokph)%sites(ll),sum !78 format(a,6F10.7) do k=1,phlista(lokph)%nooffr(ll) jj=jj+1 fsdata%dxidyj(jj)=div enddo enddo ! write(*,99)'add_fs 5B ',fsdata%dxidyj 99 format(a,6(F10.7)) firsteq%phase_varres(lokcs)%disfra=fsdata firsteq%phase_varres(lokcs)%status2=& ibset(firsteq%phase_varres(lokcs)%status2,CSDLNK) ! we have to reserve a phase_varres record for calculations ! ... det galler att halla tungan ratt i mun ... ! nprop=10 ! call create_parrecords(nyttcs,nnn,mmm,nprop,iva,firsteq) call create_parrecords(lokph,nyttcs,nnn,mmm,maxcalcprop,iva,firsteq) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'3G created disordered phase_varres: ',csfree,highcs,nyttcs fsdata%varreslink=nyttcs ! note ceq is firsteq but declared target ! write(*,*)'3G disordered fraction set',nyttcs !*? fsdata%phdapointer=>ceq%phase_varres(nyttcs) firsteq%phase_varres(nyttcs)%phlink=lokph firsteq%phase_varres(nyttcs)%prefix=' ' firsteq%phase_varres(nyttcs)%suffix=' ' do ll=1,nnn firsteq%phase_varres(nyttcs)%sites(ll)=fsdata%dsites(ll) enddo firsteq%phase_varres(nyttcs)%status2=0 firsteq%phase_varres(nyttcs)%status2=& ibset(firsteq%phase_varres(nyttcs)%status2,CSDFS) ! finally copy fsdata to the link in lokcs call copy_fracset_record(lokcs,fsdata,firsteq) if(gx%bmperr.ne.0) goto 1000 ! if there are several composition sets create fracset records for each 200 continue ! if(firsteq%phase_varres(lokcs)%next.gt.0) then ! lokcs=firsteq%phase_varres(lokcs)%next do ijcs=2,phlista(lokph)%noofcs lokcs=phlista(lokph)%linktocs(ijcs) ! one must also create parrecords for these !!! ! call create_parrecords(nydis,nnn,mmm,nprop,iva,firsteq) call create_parrecords(lokph,nydis,nnn,mmm,maxcalcprop,iva,firsteq) if(gx%bmperr.ne.0) goto 1000 fsdata%varreslink=nydis ! set pointer also !*? fsdata%phdapointer=firsteq%phase_varres(nydis) firsteq%phase_varres(nydis)%phlink=lokph firsteq%phase_varres(nydis)%prefix=' ' firsteq%phase_varres(nydis)%suffix=' ' do ll=1,nnn firsteq%phase_varres(nydis)%sites(ll)=fsdata%dsites(ll) enddo firsteq%phase_varres(nydis)%status2=0 firsteq%phase_varres(nydis)%status2=& ibset(firsteq%phase_varres(nyttcs)%status2,CSDFS) ! This does not create a new record ! firsteq%phase_varres(lokcs)%disfra=fsdata ! but this seems to work call copy_fracset_record(lokcs,fsdata,firsteq) if(gx%bmperr.ne.0) goto 1000 firsteq%phase_varres(lokcs)%status2=& ibset(firsteq%phase_varres(lokcs)%status2,CSDLNK) goto 200 enddo ! set status bit for multiple/disordered fraction sets and no of fraction sets phlista(lokph)%status1=ibset(phlista(lokph)%status1,PHMFS) phlista(lokph)%nooffs=2 1000 continue ! write(*,*)'3G exit add_fraction_set: ',fsdata%fsites,nnn ! NOTE fsdata&fsites updated in calling routine. A bit strange but ... return ! nydis end subroutine add_fraction_set ! no ceq !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine copyfracs(fromeq,ceq) !\begin{verbatim} subroutine copyfracs(fromeq,ceq) ! Copy phase amounts and constitution from equilibrim fromceq to ceq ! Useful to set start constitutions for miscibility gaps during assessments ! implicit none integer fromeq type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer toph,fromph type(gtp_equilibrium_data), pointer :: fromceq type(gtp_phase_varres), pointer :: fromvar,tovar fromceq=>eqlista(fromeq) if(.not.allocated(fromceq%phase_varres)) then ! if phase_varres not allocated this equilibrium has no data write(*,*)'No such equilibrium' goto 1000 endif ! each equilbrium have the same phases and same number of compstes !!! ! thus the phase_varres correspond! ! copy only to those nonsuspended in ceq which exist in fromceq ! write(*,*)'gtp3A allocated: ',size(ceq%phase_varres) ! phase_varres(1) is for the unused REFERENCE_STATE allnonsus: do toph=2,size(ceq%phase_varres) ! there are more phase_varres allocated than used, but yfr no allocated tovar=>ceq%phase_varres(toph) if(.not.allocated(tovar%yfr)) exit allnonsus if(tovar%phstate.le.PHSUS) cycle allnonsus ! write(*,*)'3A copy phasetuple ',tovar%phtupx ! copy phase amounts and fractions from the same phase_varres record fromvar=>fromceq%phase_varres(toph) tovar%abnorm=fromvar%abnorm tovar%yfr=fromvar%yfr ! these are calculated values but copy anyway tovar%sites=fromvar%sites tovar%amfu=fromvar%amfu tovar%dgm=fromvar%dgm enddo allnonsus 1000 continue return end subroutine copyfracs !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine copy_fracset_record !\begin{verbatim} subroutine copy_fracset_record(lokcs,disrec,ceq) ! attempt to create a new disordered record ??? this can probably be done ! with just one statement .. but as it works I am not changing right now implicit none TYPE(gtp_equilibrium_data), pointer :: ceq TYPE(gtp_fraction_set) :: disrec integer lokcs !\end{verbatim} TYPE(gtp_fraction_set) :: discopy ! the hard way ?? discopy%fsites=disrec%fsites discopy%latd=disrec%latd discopy%ndd=disrec%ndd discopy%tnoofxfr=disrec%tnoofxfr discopy%tnoofyfr=disrec%tnoofyfr discopy%varreslink=disrec%varreslink !*? discopy%phdapointer=>disrec%phdapointer discopy%totdis=disrec%totdis discopy%id=disrec%id allocate(discopy%dsites(disrec%ndd)) allocate(discopy%nooffr(disrec%ndd)) allocate(discopy%splink(disrec%tnoofxfr)) allocate(discopy%y2x(disrec%tnoofyfr)) allocate(discopy%dxidyj(disrec%tnoofyfr)) ! discopy%dsites=disrec%dsites discopy%nooffr=disrec%nooffr discopy%splink=disrec%splink discopy%y2x=disrec%y2x discopy%dxidyj=disrec%dxidyj ! ! write(*,*)'copyfs 1: ',lokcs,discopy%varreslink,disrec%varreslink ceq%phase_varres(lokcs)%disfra=discopy ! write(*,*)'copyfs 2: ',phase_varres(lokcs)%disfra%varreslink 1000 continue return end subroutine copy_fracset_record !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine suspend_species_implicitly !\begin{verbatim} subroutine suspend_species_implicitly(ceq) ! loop through all entered species and suspend those with an element suspended implicit none TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer loksp,iel,lokel sploop: do loksp=1,noofsp if(.not.btest(splista(loksp)%status,spsus)) then elloop: do iel=1,splista(loksp)%noofel lokel=splista(loksp)%ellinks(iel) if(btest(ellista(lokel)%status,elsus)) then ! an element is suspended, suspend this species implicitly splista(loksp)%status=ibset(splista(loksp)%status,spsus) splista(loksp)%status=ibset(splista(loksp)%status,spimsus) goto 200 endif enddo elloop endif 200 continue enddo sploop 1000 continue return end subroutine suspend_species_implicitly !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine suspend_phases_implicitly !\begin{verbatim} subroutine suspend_phases_implicitly(ceq) ! loop through all entered phases and suspend constituents and ! SUSPEND phases with all constituents in a sublattice suspended ! dimension lokcs(9) implicit none TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer lokph,lokcs,ncc,kk,kkl,nek,icon,ll,loksp,jl ! ! BEWARE not adopted fro parallel processing ! phloop: do lokph=1,noofph if(.not.btest(phlista(lokph)%status1,phhid)) then ! locate all composition sets and store indices in lokcs ncc=phlista(lokph)%noofcs kk=0 sublloop: do ll=1,phlista(lokph)%noofsubl kkl=kk nek=0 constloop: do icon=1,phlista(lokph)%nooffr(ll) kk=kk+1 loksp=phlista(lokph)%constitlist(kk) if(btest(splista(loksp)%status,spsus)) then ! a constituent is suspended, mark this also in constat for all comp.sets compsets: do jl=1,ncc lokcs=phlista(lokph)%linktocs(jl) ceq%phase_varres(lokcs)%constat(kk)=& ibset(ceq%phase_varres(lokcs)%constat(kk),consus) ceq%phase_varres(lokcs)%constat(kk)=& ibset(ceq%phase_varres(lokcs)%constat(kk),conimsus) ! mark that some constituents are suspended in this composition set ceq%phase_varres(lokcs)%status2=& ibset(ceq%phase_varres(lokcs)%status2,CSCONSUS) enddo compsets goto 200 else nek=nek+1 endif enddo constloop if(nek.eq.0) then ! this sublattice has all constituents suspended, hide/suspend the phase phlista(lokph)%status1=ibset(phlista(lokph)%status1,phhid) phlista(lokph)%status1=ibset(phlista(lokph)%status1,phimhid) ! also set amount to zero ?? compsets2: do jl=1,ncc lokcs=phlista(lokph)%linktocs(jl) ! ceq%phase_varres(lokcs)%amount=zero ceq%phase_varres(lokcs)%amfu=zero ceq%phase_varres(lokcs)%netcharge=zero enddo compsets2 endif goto 300 200 continue kk=kkl+phlista(lokph)%nooffr(ll) kkl=kk-1 enddo sublloop 300 continue endif enddo phloop 1000 continue return end subroutine suspend_phases_implicitly !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine restore_species_implicitly_suspended !\begin{verbatim} subroutine restore_species_implicitly_suspended ! loop through all implicitly suspended species and restore those with ! all elements enteded implicit none !\end{verbatim} %+ integer loksp,lokel sploop: do loksp=1,noofsp if(btest(splista(loksp)%status,spimsus)) then elloop: do lokel=1,splista(loksp)%noofel ! an element is suspended, keep species suspended if(btest(ellista(lokel)%status,elsus)) goto 200 enddo elloop ! all elements entered, restore species as entered splista(loksp)%status=ibclr(splista(loksp)%status,spsus) splista(loksp)%status=ibclr(splista(loksp)%status,spimsus) endif 200 continue enddo sploop 1000 continue return end subroutine restore_species_implicitly_suspended !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine restore_phases_implicitly_suspended !\begin{verbatim} subroutine restore_phases_implicitly_suspended ! loop through all implicitly suspended phases and restore those with ! at least one constituent entered in each sublattice implicit none !\end{verbatim} integer lokph,ll,kk,kkl,icon,loksp phloop: do lokph=1,noofph if(btest(phlista(lokph)%status1,phimhid)) then kk=0 sublloop: do ll=1,phlista(lokph)%noofsubl kkl=kk constloop: do icon=1,phlista(lokph)%nooffr(ll) kk=kk+1 loksp=phlista(lokph)%constitlist(kk) if(.not.btest(splista(loksp)%status,spsus)) goto 200 enddo constloop ! all constituents in this sublattice are suspended, keep the phase hidden goto 300 200 continue kk=kkl+phlista(lokph)%nooffr(ll) kkl=kk-1 enddo sublloop ! all sublattices have at least one constituent entered, restore it phlista(lokph)%status1=ibclr(phlista(lokph)%status1,phhid) phlista(lokph)%status1=ibclr(phlista(lokph)%status1,phimhid) 300 continue endif enddo phloop 1000 continue return end subroutine restore_phases_implicitly_suspended !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine add_to_reference_phase !\begin{verbatim} subroutine add_to_reference_phase(loksp) ! add this element to the reference phase ! loksp: species index of new element implicit none integer loksp !\end{verbatim} ! one must extend all arrays in phlista, phase_varres and phase_varres integer lokph,noc,i,nprop,mc2,lokcs integer, dimension(maxel) :: isave lokph=0 lokcs=phlista(lokph)%linktocs(1) ! constitlist noc=phlista(lokph)%tnooffr do i=1,noc isave(i)=phlista(lokph)%constitlist(i) enddo deallocate(phlista(lokph)%constitlist) noc=noc+1 allocate(phlista(lokph)%constitlist(noc)) isave(noc)=loksp do i=1,noc phlista(lokph)%constitlist(i)=isave(i) enddo phlista(lokph)%tnooffr=noc phlista(lokph)%nooffr(1)=noc ! phase_varres, no data need saving ! write(*,*)'Deallocate constat 5: ',size(firsteq%phase_varres(lokcs)%constat) deallocate(firsteq%phase_varres(lokcs)%constat) deallocate(firsteq%phase_varres(lokcs)%yfr) deallocate(firsteq%phase_varres(lokcs)%mmyfr) ! write(*,*)'Allocate constat 5: ',noc allocate(firsteq%phase_varres(lokcs)%constat(noc)) firsteq%phase_varres(lokcs)%constat(noc)=0 allocate(firsteq%phase_varres(lokcs)%yfr(noc)) allocate(firsteq%phase_varres(lokcs)%mmyfr(noc)) firsteq%phase_varres(lokcs)%yfr=one firsteq%phase_varres(lokcs)%mmyfr=zero nprop=firsteq%phase_varres(lokcs)%nprop deallocate(firsteq%phase_varres(lokcs)%dgval) deallocate(firsteq%phase_varres(lokcs)%d2gval) allocate(firsteq%phase_varres(lokcs)%dgval(3,noc,nprop)) mc2=noc*(noc+1)/2 allocate(firsteq%phase_varres(lokcs)%d2gval(mc2,nprop)) ! ready!! 1000 continue return end subroutine add_to_reference_phase !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! ================================================ FILE: src/models/gtp3H.F90 ================================================ ! gtp3H included in gtp3.F90 ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !> 14. Additions and model properties !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! ! Additions have a unique number, given sequentially as implemented ! These are all defined in gtp3.F90 ! integer, public, parameter :: INDENMAGNETIC=1 ! integer, public, parameter :: XIONGMAGNETIC=2 ! integer, public, parameter :: DEBYECP=3 ! integer, public, parameter :: EINSTEINCP=4 ! integer, public, parameter :: TWOSTATEMODEL1=5 ! integer, public, parameter :: ELASTICMODEL1=6 ! integer, public, parameter :: VOLMOD1=7 ! integer, public, parameter :: UNUSED_CRYSTBREAKDOWNMOD=8 ! integer, public, parameter :: SECONDEINSTEIN=9 ! integer, public, parameter :: SCHOTTKYANOMALY=10 ! integer, public, parameter :: DIFFCOEFS=11 !------------------------------------ ! For each addition XX there is a subroutine create_XX ! called from the add_addrecord ! and a subroutine calc_XX ! called from the addition_selector, called from calcg_internal ! There is a common list routine !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine addition_selector !\begin{verbatim} subroutine addition_selector(addrec,moded,phres,lokph,mc,ceq) ! called when finding an addition record while calculating G for a phase ! addrec is addition record ! moded is 0, 1 or 2 if no, first or 2nd order derivatives should be calculated ! phres is ? ! lokph is phase location ! mc is number of constitution fractions ! ceq is current equilibrium record implicit none type(gtp_phase_add), pointer :: addrec integer moded,lokph,mc TYPE(gtp_phase_varres), pointer :: phres type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} ! write(*,*)'3H select addition: ',addrec%type addition: select case(addrec%type) case default write(kou,*)'3H No such addition type ',addrec%type,lokph gx%bmperr=4330 ! 1 Inden-Hillert magnetic case(indenmagnetic) ! Inden magnetic addrec%propval=zero call calc_magnetic_inden(moded,phres,addrec,lokph,mc,ceq) ! 2 Inden-Hillert-Qing-Xiong magnetism case(xiongmagnetic) ! Inden-Qing-Xiong addrec%propval=zero call calc_xiongmagnetic(moded,phres,addrec,lokph,mc,ceq) ! write(kou,*)'3H Inden-Qing-Xiong magn model not tested yet' ! gx%bmperr=4332 ! 3 Debye Cp case(debyecp) ! Debye Cp addrec%propval=zero call calc_debyecp(moded,phres,addrec,lokph,mc,ceq) write(kou,*)'3H Debye Cp model not implemented yet' gx%bmperr=4331 ! 4 Einsten Cp case(einsteincp) ! Einstein Cp addrec%propval=zero call calc_einsteincp(moded,phres,addrec,lokph,mc,ceq) ! gx%bmperr=4331 ! 5 Twostate liquid case(twostatemodel1) ! Two state model with composition variable G2 addrec%propval=zero ! write(*,*)'3H selecting calc_twostate_model1: ',mc call calc_twostate_model1(moded,phres,addrec,lokph,mc,ceq) ! changed below not to calculate G2 as a mixing parameter ! call calc_twostate_model2(moded,phres,addrec,lokph,mc,ceq) ! 6 Elastic model case(elasticmodel1) ! Elastic model ! addrec%propval=zero call calc_elastica(moded,phres,addrec,lokph,mc,ceq) write(kou,*)' Elastic model not implemented yet' gx%bmperr=4399 ! 7 Volume model case(volmod1) ! Simple volume model depending on V0, VA and VB addrec%propval=zero call calc_volmod1(moded,phres,addrec,lokph,mc,ceq) ! 8 UNUSED ! case(crystalbreakdownmod) ! Limiting heat capacity of extrapolated solid ! addrec%propval=zero ! call calc_crystalbreakdownmod(moded,phres,addrec,lokph,mc,ceq) ! 9 case(secondeinstein) ! Adding a second Einstein Cp addrec%propval=zero call calc_secondeinstein(moded,phres,addrec,lokph,mc,ceq) ! 10 case(schottkyanomaly) ! Adding a second Schottky anomaly Cp addrec%propval=zero call calc_schottky_anomaly(moded,phres,addrec,lokph,mc,ceq) ! 11 case(diffcoefs) ! Calculating diffusion coefficients addrec%propval=zero call calc_diffusion(moded,phres,addrec,lokph,mc,ceq) ! gx%bmperr=4333 ! 12 see also 5, twostatemodel1 ! NOT USED case(twostatemodel2) ! Two state model with composition independent G2 ! addrec%propval=zero ! write(*,*)'3H selecting calc_twostate_model1: ',mc ! call calc_twostate_model1(moded,phres,addrec,lokph,mc,ceq) ! changed not to calculate G2 as a mixing parameter ! call calc_twostate_model2(moded,phres,addrec,lokph,mc,ceq) write(*,*)'3H Attempt to add obsolete liquid 2-state model' end select addition 1000 continue return end subroutine addition_selector !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine add_addrecord !\begin{verbatim} subroutine add_addrecord(lokph,extra,addtyp) ! generic subroutine to add an addition typ addtyp (including Inden) implicit none integer lokph,addtyp character extra*(*) !\end{verbatim} integer aff double precision xxx character name*24,more*4 type(gtp_phase_add), pointer :: newadd,addrec,lastrec logical bcc ! ! write(*,*)'3H creating addrecord: ',trim(extra),addtyp,lokph ! check if this addition already entered lastrec=>phlista(lokph)%additions addrec=>lastrec do while(associated(addrec)) if(addrec%type.eq.addtyp) then write(*,*)'3H addition already entered ',trim(phlista(lokph)%name),& addtyp,lokph,extra goto 1000 else lastrec=>addrec addrec=>lastrec%nextadd endif enddo ! NOTE EET is not an addition, it is comparing the entropy of solid and liquid ! create addition record ! write(*,*)'3H adding addition record',lokph,addtyp addition: select case(addtyp) !----------------------------------------- case default write(kou,*)'No addtion type ',addtyp,lokph !----------------------------------------- case(indenmagnetic) ! Inden magnetic ! 1 if(extra(1:1).eq.'Y' .or. extra(1:1).eq.'y') then ! bcc model aff=-1 call create_magrec_inden(newadd,aff) else aff=-3 call create_magrec_inden(newadd,aff) endif !----------------------------------------- case(xiongmagnetic) ! Inden-Qing-Xiong. Assume bcc if BCC part of phase name ! 2 ! bcc=.false. ! if(index('BCC',phlista(lokph)%name).gt.0) bcc=.true. if(extra(1:1).eq.'Y' .or. extra(1:1).eq.'y') then bcc=.TRUE. else bcc=.FALSE. endif ! ibm=.FALSE. more=' ' ! extra(2:2) means using individual Bohr magneton numbers if(extra(2:2).eq.'I') more(1:1)='I' ! extra(3:3) means using ferromagnetic as reference state if(extra(3:3).eq.'R') more(2:2)='R' ! lokph because we need to check if average or individual Boghr magnetons ! call create_xiongmagnetic(newadd,' ',bcc) ! call create_xiongmagnetic(newadd,ibm,bcc) ! write(*,*)'3H add extra: "',trim(extra),'" and more: "',more,'"' call create_xiongmagnetic(newadd,more,bcc) !----------------------------------------- case(debyecp) ! Debye Cp UNUSED ! 3 ! call create_debyecp(newadd) !----------------------------------------- case(einsteincp) ! Einstein Cp ! 4 call create_einsteincp(newadd) !----------------------------------------- case(twostatemodel1) ! Liquid 2 state model ! 5 ! NEW set bit to allow endmember parameter modification! Question asked in PMON6 ! write(*,*)'3H setting bit ph2state: ',PH2STATE ! phlista(lokph)%status1=ibset(phlista(lokph)%status1,PH2STATE) ! write(*,*)'3H extra "',extra,'"' if(extra(1:1).eq.'N') then phlista(lokph)%status1=ibset(phlista(lokph)%status1,PH2STATE) write(*,*)'3H G2 is assumed to be composition independent' call create_newtwostate_model1(newadd) ! return that the addition type has changed ... addtyp=twostatemodel2 else phlista(lokph)%status1=ibclr(phlista(lokph)%status1,PH2STATE) call create_twostate_model1(newadd) endif !----------------------------------------- case(elasticmodel1) ! Elastic model 1 ! 6 call create_elastic_model_a(newadd) !----------------------------------------- case(volmod1) ! Volume model 1 ! 7 call create_volmod1(newadd) !----------------------------------------- ! case(crystalbreakdownmod) ! Crystal Breakdown model ! 8 UNUSED ! call create_crystalbreakdownmod(newadd) !----------------------------------------- case(secondeinstein) ! Second Einstein T ! 9 call create_secondeinstein(newadd) !----------------------------------------- case(schottkyanomaly) ! Schottky anomaly ! 10 call create_schottky_anomaly(newadd) !----------------------------------------- case(diffcoefs) ! diffusion coefficients ! 11 call create_diffusion(newadd,lokph,extra) !----------------------------------------- end select addition !----------------------------------------- if(gx%bmperr.ne.0) goto 1000 ! initiate status word for this addition ! newadd%status=0 if(associated(phlista(lokph)%additions)) then ! write(*,*)'3H adding new addition record to phase ',lokph,addtyp lastrec%nextadd=>newadd else ! write(*,*)'3H adding first addition record to phase',lokph,addtyp phlista(lokph)%additions=>newadd endif 1000 return end subroutine add_addrecord !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine need_propertyid !\begin{verbatim} subroutine need_propertyid(id,typty) ! get the index of the property needed implicit none integer typty character*4 id !\end{verbatim} %+ ! here the property list is searched for "id" and its index stored in addrec do typty=1,ndefprop if(propid(typty)%symbol.eq.id) then goto 1000 endif enddo write(*,*)'3H Parameter id ',id,' not found' gx%bmperr=4335 typty=-1 1000 continue return end subroutine need_propertyid !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine setpermolebit !\begin{verbatim} subroutine setpermolebit(lokph,addtype) ! set bit in addition record that addition is per mole ! lokph is phase record ! addtype is the addtion record type implicit none integer lokph,addtype !\end{verbatim} type(gtp_phase_add), pointer :: addrec addrec=>phlista(lokph)%additions ! write(*,*)'3H set size bit: ',addtype do while(associated(addrec)) if(addrec%type.eq.addtype) then write(*,*)'3H setting bit ADDPERMOL for addition type ',addtype addrec%status=ibset(addrec%status,ADDPERMOL) goto 1000 endif addrec=>addrec%nextadd enddo write(*,*)'3H Cannot find addition ',addtype 1000 continue return end subroutine setpermolebit !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine create_magrec_inden !\begin{verbatim} subroutine create_magrec_inden(addrec,aff) ! enters the magnetic model implicit none type(gtp_phase_add), pointer :: addrec integer aff !\end{verbatim} %+ integer typty,ip,nc character text*128 integer, parameter :: ncc=6 double precision coeff(ncc) integer koder(5,ncc) ! There is some trouble with memory leaks in expressions to fix!!! TYPE(tpfun_expression), target :: llow2,lhigh2 TYPE(tpfun_expression), pointer :: llow,lhigh ! if(aff.eq.-1) then ! bcc, aff=-1 ! Magnetic function below Curie Temperature ! problem in ct1xfn to start a function with +1 or 1 text=' 1.0-.905299383*T**(-1)-.153008346*T**3-'//& '.00680037095*T**9-.00153008346*T**15 ;' ! write(*,*)'3H emm 1: ',text(1:len_trim(text)) ip=1 nc=ncc call ct1xfn(text,ip,nc,coeff,koder,.FALSE.) ! write(*,17)'3H emm 1B:',nc,(coeff(i),i=1,nc) 17 format(a,i3,5(1PE11.3)) if(gx%bmperr.ne.0) goto 1000 ! Trouble with memory leaks for expressions to be fixed ... llow=>llow2 ! call ct1mexpr(nc,coeff,koder,llow) ! Attempt to remove big memory leak call ct1mexpr(nc,coeff,koder,llow2) if(gx%bmperr.ne.0) goto 1000 ! Magnetic function above Curie Temperature text=' -.0641731208*T**(-5)-.00203724193*T**(-15)'//& '-4.27820805E-04*T**(-25) ; ' ! write(*,*)'3H emm 2: ',text(1:len_trim(text)) ip=1 nc=ncc call ct1xfn(text,ip,nc,coeff,koder,.FALSE.) if(gx%bmperr.ne.0) goto 1000 ! call ct1mexpr(nc,coeff,koder,lhigh) ! Attempt to remove big memory leak call ct1mexpr(nc,coeff,koder,lhigh2) if(gx%bmperr.ne.0) goto 1000 else !------------ ! fcc, aff=-3 ! Magnetic function below Curie Temperature text='+1.0-.860338755*T**(-1)-.17449124*T**3-.00775516624*T**9'//& '-.0017449124*T**15 ; ' ip=1 nc=ncc call ct1xfn(text,ip,nc,coeff,koder,.FALSE.) if(gx%bmperr.ne.0) goto 1000 llow=>llow2 ! call ct1mexpr(nc,coeff,koder,llow) ! Attempt to remove big memory leak call ct1mexpr(nc,coeff,koder,llow2) if(gx%bmperr.ne.0) goto 1000 ! Magnetic function above Curie Temperature text='-.0426902268*T**(-5)-.0013552453*T**(-15)'//& '-2.84601512E-04*T**(-25) ; ' ip=1 nc=ncc call ct1xfn(text,ip,nc,coeff,koder,.FALSE.) if(gx%bmperr.ne.0) goto 1000 ! call ct1mexpr(nc,coeff,koder,lhigh) ! Attempt to remove big memory leak call ct1mexpr(nc,coeff,koder,lhigh2) if(gx%bmperr.ne.0) goto 1000 endif ! reserve an addition record allocate(addrec) ! store data in record allocate(addrec%explink(2)) nullify(addrec%nextadd) addrec%status=0 addrec%aff=aff addrec%type=indenmagnetic ! attempt to remove memory leak ! addrec%explink(1)=llow ! addrec%explink(2)=lhigh ! write(*,*)'3H magnetic expression links' addrec%explink(1)=llow2 addrec%explink(2)=lhigh2 ! addrecs declared in gtp3.F90 but I am not sure it is needed or used addrecs=addrecs+1 allocate(addrec%need_property(2)) addrec%addrecno=addrecs addrec%need_property=0 ! here the property list is searched for TC and BM call need_propertyid('TC ',typty) if(gx%bmperr.ne.0) goto 1000 addrec%need_property(1)=typty call need_propertyid('BMAG',typty) if(gx%bmperr.ne.0) goto 1000 addrec%need_property(2)=typty 1000 continue return end subroutine create_magrec_inden !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_magnetic_inden !\begin{verbatim} subroutine calc_magnetic_inden(moded,phres,lokadd,lokph,mc,ceq) ! calculates Indens magnetic contribution ! NOTE: values for function not saved, should be done to save time. ! Gmagn = RT*f(T/Tc)*ln(beta+1) ! moded: integer, 0=only G, S, Cp; 1=G and dG/dy; 2=Gm dG/dy and d2G/dy2 ! phres: pointer, to phase\_varres record ! lokadd: pointer, to addition record ! lokph: integer, phase record ! mc: integer, number of constituents ! ceq: pointer, to gtp_equilibrium_data implicit none integer moded,lokph,mc TYPE(gtp_phase_varres) :: phres TYPE(gtp_phase_add), pointer :: lokadd TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer itc,ibm,jl,noprop,ik,k,jk,j,jxsym double precision logb1,invb1,iafftc,iaffbm,rgasm,rt,tao,gmagn,msize double precision dtaodt,dtaodp,beta,d2taodp2,d2taodtdp,tc,tv double precision tao2(2),ftao(6),dtao(3,mc),d2tao(mc*(mc+1)/2) double precision addgval(6),daddgval(3,mc),d2addgval(mc*(mc+1)/2) logical addpermole ! phres points to result record with gval etc for this phase TYPE(tpfun_expression), pointer :: exprot ! dgdt = Gmagn/T + RT*df/dtao*dtao/dT*ln(beta+1) ! dgdp = RT df/dtao*dtao/dP*ln(beta+1) ! dgdy = RT*df/dtao*dtao/dy*ln(beta+1) + RT*f/(beta+1)*dbeta/dy ! d2gdt2=2*R*df/dtao*dtao/dT*ln(beta+1) + RT*d2f/dtao2*(dtao/dT)**2*ln(beta+1) ! +RT*df/dtao*d2tao/dT2*ln(beta+1) ! d2gdtdp= ... ! d2gdp2= ! d2gdtdy= ! d2gdpdy= ! d2gdydy= ! listprop(1) is the number of properties calculated ! listprop(2:listprop(1)) give the typty of different properties ! calculated in gval(*,i) etc ! one has to find those with typty equal for need_property in the magnetic ! record, i.e. typty=2 for TC and typty=3 for BM ! the properties needed. ! noprop=phres%listprop(1)-1 itc=0; ibm=0 ! write(*,*)'3H cmi 2: ',mc,noprop,(phres%listprop(j),j=1,noprop) ! Inden magnetic need properties in need_property(1..2) findix: do jl=2,noprop if(phres%listprop(jl).eq.lokadd%need_property(1)) then itc=jl elseif(phres%listprop(jl).eq.lokadd%need_property(2)) then ibm=jl endif enddo findix if(itc.eq.0 .or. ibm.eq.0) then ! it is no error if no TC or BM but then magnetic contribution is zero ! write(*,12)phlista(lokph)%name 12 format('3H Warning: Magnetic addition for phase ',a& /9x,'but no values for TC or BM, magnetic contribution zero') goto 1000 endif tc=phres%gval(1,itc) beta=phres%gval(1,ibm) ! Probably beta should be divided by atoms/formula unit ... ! write(*,95)'3H Magnetic values in: ',itc,ibm,tc,beta,phres%abnorm(1) 95 format(a,2i3,4(1PE12.3)) if(tc.lt.zero) then ! we should take care of the case when tc and beta have different signs ! note: all derivatives of tc must be multiplied with iaff iafftc=one/lokadd%aff do ik=1,mc do k=1,3 phres%dgval(k,ik,itc)=iafftc*phres%dgval(k,ik,itc) enddo do jk=ik,mc jxsym=kxsym(ik,jk) phres%d2gval(jxsym,itc)=& iafftc*phres%d2gval(jxsym,itc) ! phres%d2gval(ixsym(ik,jk),itc)=& ! iafftc*phres%d2gval(ixsym(ik,jk),itc) enddo enddo do k=1,6 phres%gval(k,itc)=iafftc*phres%gval(k,itc) enddo tc=phres%gval(1,itc) ! write(*,*)'3H Inden 1: ',tc,iafftc else iafftc=zero endif ! avoid diving with zero, tc is a temperature so 0.01 degree is small if(tc.lt.one) tc=1.0D-2 if(beta.lt.zero) then ! note all derivatives of bm must be multipled by iaffbm ! iaffbm=one/addlista(lokadd)%aff iaffbm=one/lokadd%aff do ik=1,mc do k=1,3 phres%dgval(k,ik,ibm)=iaffbm*phres%dgval(k,ik,ibm) enddo do jk=ik,mc jxsym=kxsym(ik,jk) phres%d2gval(jxsym,ibm)=& iaffbm*phres%d2gval(jxsym,ibm) enddo enddo do k=1,6 phres%gval(k,ibm)=iaffbm*phres%gval(k,ibm) enddo beta=phres%gval(1,ibm) ! write(*,*)'3H Inden 2: ',beta,iaffbm endif ! tv=ceq%tpval(1) rgasm=globaldata%rgas rt=rgasm*tv tao=tv/tc tao2(1)=tao ! one should save values of ftao if tao2 is the same next time .... ! but as tc depend on the constitution that is maybe not so often. if(tao.lt.one) then exprot=>lokadd%explink(1) else exprot=>lokadd%explink(2) endif call ct1efn(exprot,tao2,ftao,ceq%eq_tpres) logb1=log(beta+one) invb1=one/(beta+one) gmagn=rt*ftao(1)*logb1 ! if(ocv()) then ! write(*,98)'3H m1: ',tc,beta,ftao(1),logb1,rt ! write(*,98)'3H m2: ',rt*gmagn,rt*(gmagn+phres%gval(1,1)),iafftc !98 format(a,5(1PE14.6)) ! endif ! dtaodt=one/tc dtaodp=-tao/tc*phres%gval(3,itc) addgval(1)=gmagn addgval(2)=gmagn/tv+rt*ftao(2)*dtaodt*logb1 addgval(3)=rt*ftao(2)*dtaodp*logb1+rt*ftao(1)*invb1*phres%gval(3,ibm) ! phres%gval(1,1)=phres%gval(1,1)+addgval(1)/rt ! phres%gval(2,1)=phres%gval(2,1)+addgval(2)/rt ! phres%gval(3,1)=phres%gval(3,1)+addgval(3)/rt ! save these in record do j=1,3 lokadd%propval(j)=addgval(j) phres%gval(j,1)=phres%gval(j,1)+addgval(j)/rt enddo ! write(*,77)lokadd%type,(lokadd%propval(j),j=1,4) !77 format('3H Addition ',i2,': ',4(1pe12.4)) ! ignore second derivatives if no derivatives wanted if(moded.eq.0) then goto 1000 endif ! Now all derivatives ! phres%gval(*,itc) are TC and derivatives wrt T and P ! phres%dgval(*,*,itc) are derivatives of TC wrt T, P and Y ! phres%d2gval(*,itc) are derivatives of TC wrt Y1 and Y2 ! phres%gval(*,ibm) are beta and dervatives etc ! TC and beta must not depend on T, only on P and Y ! dtaodt=one/tc ! dtaodp=-tao/tc*phres%gval(3,itc) ! d2taodt2 is zero d2taodtdp=-one/tc*phres%gval(3,itc) d2taodp2=2.0d0*tao/tc**2*phres%gval(3,itc)-tao/tc*phres%gval(6,itc) ! 1-6 means F, F.T, T.P, F.T.T, F.T.P and F.P.P addgval(4)=2.0d0*rgasm*ftao(2)*dtaodt*logb1+& rt*ftao(4)*(dtaodt)**2*logb1 addgval(5)=rgasm*ftao(2)*dtaodp*logb1+& rgasm*ftao(1)*invb1*phres%gval(3,ibm)+& rt*ftao(4)*dtaodt*dtaodp*logb1+& rt*ftao(2)*d2taodtdp*logb1+& rt*ftao(2)*dtaodt*invb1*phres%gval(3,ibm) addgval(6)=rt*ftao(4)*(dtaodp)**2*logb1+& rt*ftao(2)*d2taodp2*logb1+rt*ftao(1)*dtaodp*invb1*phres%gval(3,ibm)+& rt*ftao(2)*dtaodp*invb1*phres%gval(3,ibm)-& rt*ftao(1)*(invb1*phres%gval(3,ibm))**2+& rt*ftao(1)*invb1*phres%gval(6,ibm) ! G, G.T and G.Y, G.T.Y and G.Y1.Y2 correct (no P dependence checked) do j=1,mc dtao(1,j)=-tao*phres%dgval(1,j,itc)/tc dtao(2,j)=-phres%dgval(1,j,itc)/tc**2 dtao(3,j)=2.0d0*tao*phres%gval(3,itc)*phres%dgval(1,j,itc)/tc**2-& tao*phres%dgval(3,j,itc)/tc do k=j,mc jxsym=kxsym(j,k) d2tao(jxsym)=& 2.0*tao*phres%dgval(1,j,itc)*phres%dgval(1,k,itc)/tc**2& -tao*phres%d2gval(jxsym,itc)/tc enddo enddo do j=1,mc ! first derivative wrt Y, checked for bcc in Cr-Fe-Mo, error in fcc in c-cr-fe? daddgval(1,j)=rt*ftao(2)*dtao(1,j)*logb1+& rt*ftao(1)*invb1*phres%dgval(1,j,ibm) ! write(*,43)j,daddgval(1,j),dtao(1,j),phres%dgval(1,j,ibm) !43 format('3H Inden 4: ',i2,6(1pe12.5)) ! second derivative wrt to T and Y, checked daddgval(2,j)=rgasm*ftao(2)*dtao(1,j)*logb1+& rgasm*ftao(1)*invb1*phres%dgval(1,j,ibm)+& rt*ftao(4)*dtaodt*dtao(1,j)*logb1+& rt*ftao(2)*dtao(2,j)*logb1+& rt*ftao(2)*dtaodt*invb1*phres%dgval(1,j,ibm) ! write(*,56)rgasm*ftao(2)*dtao(1,j)*logb1,& ! rgasm*ftao(1)*invb1*phres%dgval(1,j,ibm),& ! rt*ftao(4)*dtaodt*dtao(1,j)*logb1,& ! rgasm*ftao(2)*dtao(2,j)*logb1,& ! rt*ftao(2)*dtaodt*invb1*phres%dgval(1,j,ibm) !56 format('3H calcmag : ',5(1PE13.5)) ! second derivative wrt P and Y, no P dependence daddgval(3,j)=rt*ftao(4)*dtaodp*dtao(1,j)*logb1+& rt*ftao(2)*dtao(3,j)*logb1+& rt*ftao(2)*dtao(1,j)*invb1*phres%gval(3,ibm)-& rt*ftao(1)*invb1**2*phres%gval(3,ibm)*phres%dgval(1,j,ibm)+& rt*ftao(1)*invb1*phres%dgval(3,j,ibm) do k=j,mc ! second derivatives wrt Y1 and Y2, wrong jxsym=kxsym(j,k) d2addgval(jxsym)=rt*ftao(4)*dtao(1,j)*dtao(1,k)*logb1+& rt*ftao(2)*d2tao(jxsym)*logb1+& rt*ftao(2)*dtao(1,j)*invb1*phres%dgval(1,k,ibm)+& rt*ftao(2)*dtao(1,k)*invb1*phres%dgval(1,j,ibm)-& rt*ftao(1)*invb1**2*phres%dgval(1,j,ibm)*phres%dgval(1,k,ibm)+& rt*ftao(1)*invb1*phres%d2gval(jxsym,ibm) ! d2addgval(ixsym(j,k))=rt*ftao(4)*dtao(1,j)*dtao(1,k)*logb1+& ! rt*ftao(2)*d2tao(ixsym(j,k))*logb1+& ! rt*ftao(2)*dtao(1,j)*invb1*phres%dgval(1,k,ibm)+& ! rt*ftao(2)*dtao(1,k)*invb1*phres%dgval(1,j,ibm)-& ! rt*ftao(1)*invb1**2*phres%dgval(1,j,ibm)*phres%dgval(1,k,ibm)+& ! rt*ftao(1)*invb1*phres%d2gval(ixsym(j,k),ibm) ! write(*,57)rt*ftao(4)*dtao(1,j)*dtao(1,k)*logb1,& ! R rt*ftao(2)*d2tao(ixsym(j,k))*logb1,& ! rt*ftao(2)*dtao(1,j)*invb1*phres%dgval(1,k,ibm),& ! rt*ftao(2)*dtao(1,k)*invb1*phres%dgval(1,j,ibm),& ! -rt*ftao(1)*invb1**2*phres%dgval(1,j,ibm)*phres%dgval(1,k,ibm),& ! rt*ftao(1)*invb1*phres%d2gval(ixsym(j,k),ibm) !57 format('3H mag2y: ',6(1PE12.4)) enddo enddo ! now add all to the total G and its derivatives ! NOTE if addpermole bit set we have to multiply with derivatives of ! the size of the phase ... if(btest(lokadd%status,ADDPERMOL)) then addpermole=.TRUE.; msize=phres%abnorm(1) ! write(*,'(a,i4,l2,1pe12.4)')'3H msize magadd 1: ',lokph,addpermole,msize ! UNFINISHED: ignoring that msize depend on fractions else addpermole=.FALSE.; msize=one endif do j=1,mc ! write(*,99)'3H magadd 1: ',1,j,phres%dgval(1,j,1),daddgval(1,j)/rt do k=1,3 ! first derivatives phres%dgval(k,j,1)=phres%dgval(k,j,1)+msize*daddgval(k,j)/rt enddo 99 format(a,2i3,2(1pe16.8)) do k=j,mc ! second derivatives ! write(*,99)'3H magadd 2: ',k,j,rt*phres%d2gval(ixsym(j,k),1),& ! d2addgval(ixsym(j,k)) jxsym=kxsym(j,k) phres%d2gval(jxsym,1)=phres%d2gval(jxsym,1)+& msize*d2addgval(jxsym)/rt ! phres%d2gval(ixsym(j,k),1)=phres%d2gval(ixsym(j,k),1)+& ! msize*d2addgval(ixsym(j,k))/rt enddo enddo ! write(*,*)'3H cm 7: ',phres%gval(1,1),addgval(1)/rt ! note phres%gval(1..3,1) already calculated above do j=4,6 lokadd%propval(j)=msize*addgval(j) phres%gval(j,1)=phres%gval(j,1)+msize*addgval(j)/rt enddo 1000 continue return end subroutine calc_magnetic_inden !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine create_xiongmagnetic !\begin{verbatim} subroutine create_xiongmagnetic(addrec,more,bcc) ! adds a Xiong type magnetic record, we must separate fcc and bcc by extra ! copied from Inden magnetic model ! The difference is that it uses CTA for Curie temperature and NTA for Neel ! and individual (IBM=.TRUE.) or average Bohr magneton numbers ! BCC is .TRUE. if it is a BCC phase implicit none ! logical ibm,bcc logical bcc character more*(*) ! integer lokph type(gtp_phase_add), pointer :: addrec !\end{verbatim} %+ integer typty,ip,nc,jj character text*128 integer, parameter :: ncc=6 double precision coeff(ncc),dval logical ibm,ferroref integer koder(5,ncc) ! TYPE(tpfun_expression), pointer :: llow,lhigh TYPE(tpfun_expression) :: llow,lhigh ! ! from W Xiong et al Calphad (2012) 11-20 ! ! G = RT g(tao) ln(b* + 1) ! ! tao = T/Tc ! b*= \Pi_i (b_i + 1)**(x_i) - 1 ! ! tao<0 g(tao)=0 ! ! tao<1 g(tao) = 1-1/D( 0.38438376/(p*tao)+0.63570895(1/p-1)* ! ! (tao**3/6 + tao**9/135 + tao**15/600 + tao**21/1617) ) ! ! tao>1 g(tao) = tao**(-7)/D( 1/21 + tao**(-14)/630 + tao**(-28)/2975 + ! tao**(-42)/8232) ! ! p=0.37 for bcc and p=0.25 for non-bcc (like fcc) ! ! for bcc: +1-.880323235*TAO**(-1)-.152870878*TAO**3-.00679426123*TAO**9 ! -.00152870878*TAO**15-5.67238878E-04*TAO**21 ! ! -.0403514888*TAO**(-7)-.00134504963*TAO**(-21) ! -2.84834039E-04*TAO**(-35)-1.02937472E-04*TAO**(-49) ! ! for non-bcc: ! ! +1-.842849633*TAO**(-1)-.174242226*TAO**3-.00774409892*TAO**9 ! -.00174242226*TAO**15-6.46538871E-04*TAO**21 ! ! -.0261039233*TAO**(-7)-8.70130777E-04*TAO**(-21) ! -1.84262988E-04*TAO**(-35)-6.65916411E-05*TAO**(-49) ! ! write(*,*)'3H Qing-Xiong magnetic model',bcc ! ! write(*,*)'3H create more: "',more,'"' ibm=.FALSE. if(more(1:1).eq.'I') ibm=.TRUE. ! This is a secret way to set ferromgantic reference state for alloys ferroref=.FALSE. if(more(2:2).eq.'R') ferroref=.TRUE. if(bcc) then ! Magnetic function below Curie/Neel Temperature, ! problem in ct1xfn to start a function with +1 or 1 if(ferroref) then text=' -.152870878*T**3-.00679426123*T**9'//& '-.00152870878*T**15-5.67238878E-04*T**21' else text=' +1-.880323235*T**(-1)-.152870878*T**3-.00679426123*T**9'//& '-.00152870878*T**15-5.67238878E-04*T**21' endif ! CHANGE OF REFERENCE STATE OF THE ELEMENTS ! text=' +1-.152870878*T**3-.00679426123*T**9'//& ! '-.00152870878*T**15-5.67238878E-04*T**21' ! write(*,*)'3H emm 1: ',trim(text) ip=1 nc=ncc call ct1xfn(text,ip,nc,coeff,koder,.FALSE.) ! write(*,17)'3H emm 1B:',nc,(coeff(i),i=1,nc) 17 format(a,i3,5(1PE11.3)) if(gx%bmperr.ne.0) goto 1000 call ct1mexpr(nc,coeff,koder,llow) if(gx%bmperr.ne.0) goto 1000 ! Magnetic function above Curie/Neel Temperature if(ferroref) then text=' -1+0.880323235*T**(-1)-.0403514888*T**(-7)'//& '-.00134504963*T**(-21)'//& '-2.84834039E-04*T**(-35)-1.02937472E-04*T**(-49)' else text='-.0403514888*T**(-7)-.00134504963*T**(-21)'//& '-2.84834039E-04*T**(-35)-1.02937472E-04*T**(-49)' endif ! CHANGE OF REFERENCE STATE OF THE ELEMENTS ! text=' +.880323235*T**(-1)-.0403514888*T**(-7)-.00134504963*T**(-21)'//& ! '-2.84834039E-04*T**(-35)-1.02937472E-04*T**(-49)' ! write(*,*)'3H emm 2: ',trim(text) ip=1 nc=ncc call ct1xfn(text,ip,nc,coeff,koder,.FALSE.) if(gx%bmperr.ne.0) goto 1000 call ct1mexpr(nc,coeff,koder,lhigh) if(gx%bmperr.ne.0) goto 1000 ! this is 1/(p*D) in eq. A9 in Qing et al, p=0.37 ! dval=0.880323235D0 dval=one/(0.49649686D0+0.37D0*(0.33461979D0-0.49649686D0)) ! write(*,*)'3H added Qing-Xiong magnetic contribution to a bcc phase' else !------------ ! fcc ! Magnetic function below Curie/Neel Temperature ! REFERENCE STATE AT T=0 if(ferroref) then text=' -.174242226*T**3-.00774409892*T**9'//& '-.00174242226*T**15-6.46538871E-04*T**21' else text=' +1-.842849633*T**(-1)-.174242226*T**3-.00774409892*T**9'//& '-.00174242226*T**15-6.46538871E-04*T**21' endif ip=1 nc=ncc call ct1xfn(text,ip,nc,coeff,koder,.FALSE.) if(gx%bmperr.ne.0) goto 1000 call ct1mexpr(nc,coeff,koder,llow) if(gx%bmperr.ne.0) goto 1000 ! Magnetic function above Curie/Neel Temperature if(ferroref) then text=' -1+0.843849633*T**(-1)-.0261039233*T**(-7)'//& '-8.70130777E-04*T**(-21)-1.84262988E-04*T**(-35)'//& '-6.65916411E-05*T**(-49)' else text=' -.0261039233*T**(-7)'//& '-8.70130777E-04*T**(-21)-1.84262988E-04*T**(-35)'//& '-6.65916411E-05*T**(-49)' endif ip=1 nc=ncc call ct1xfn(text,ip,nc,coeff,koder,.FALSE.) if(gx%bmperr.ne.0) goto 1000 call ct1mexpr(nc,coeff,koder,lhigh) if(gx%bmperr.ne.0) goto 1000 ! this is 1/(p*D) in eq. A9 in Qing et al for FCC, p=0.25; 1/p-1 =3.0 ! dval=4.0D0/(0.33461979D0+3.0D0*0.49649686D0) ! dval=0.842849633D0 dval=one/(0.49649686D0+0.25D0*(0.33461979D0-0.49649686D0)) ! write(*,*)'3H added Qing-Xiong magnetic contribution to a non-bcc phase' endif ! reserve an addition record ! write(*,*)'3H 1/(pD)= ',dval allocate(addrec) ! store data in record allocate(addrec%explink(2)) allocate(addrec%constants(1)) nullify(addrec%nextadd) addrec%type=xiongmagnetic ! beware of segmentation fault here !!! llow and llhigh no longer pointers addrec%explink(1)=llow addrec%explink(2)=lhigh addrec%constants(1)=dval addrecs=addrecs+1 ! Set bit 1 that there are properties addrec%status=0 addrec%status=ibset(addrec%status,ADDHAVEPAR) if(bcc) addrec%status=ibset(addrec%status,ADDBCCMAG) ! write(*,*)'3H Qing-Xiong magnetic addition: ',addrec%status,bcc,ADDBCCMAG allocate(addrec%need_property(3)) addrec%addrecno=addrecs ! here the property list is searched for CTA, NTA and IBM call need_propertyid('CTA ',typty) if(gx%bmperr.ne.0) goto 1000 addrec%need_property(1)=typty ! The individual Bohr magneton number or not set in PMON ! WHEN READ FROM A UNFORMATTED FILE, DO WE KNOW LOKPH?? ! if(btest(phlista(lokph)%status1,PHBMAV)) then if(.not.ibm) then ! This model use an effective Bohr magneton number b*=prod(b_i+1)**x_i -1 call need_propertyid('BMAG ',typty) else ! or an individual Bohr magneton number b*=prod(b_i+1)**x_i -1 ! write(*,*)'3H using induvidual Bohr magneton numbers',& ! btest(phlista(lokph)%status1,PHBMAV) call need_propertyid('IBM ',typty) endif !--------------------------------------------------- if(gx%bmperr.ne.0) goto 1000 addrec%need_property(2)=typty ! NTA is not so important, anti-magnetic contributions usually small call need_propertyid('NTA ',typty) if(gx%bmperr.ne.0) then gx%bmperr=0 addrec%need_property(3)=0 else addrec%need_property(3)=typty endif ! write(*,*)'3H need properties: ',(addrec%need_property(jj),jj=1,3) 1000 continue return end subroutine create_xiongmagnetic !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_xiongmagnetic !\begin{verbatim} subroutine calc_xiongmagnetic(moded,phres,lokadd,lokph,mc,ceq) ! calculates Indens-Qing-Xiong magnetic contribution ! ! Gmagn = RT*f(T/Tc)*ln(beta+1) ! moded: integer, 0=only G, S, Cp; 1=G and dG/dy; 2=Gm dG/dy and d2G/dy2 ! phres: pointer, to phase\_varres record ! lokadd: pointer, to addition record ! lokph: integer, phase record ! mc: integer, number of constituents ! ceq: pointer, to gtp_equilibrium_data implicit none integer moded,lokph,mc ! phres points to result record with gval etc for this phase TYPE(gtp_phase_varres) :: phres TYPE(gtp_phase_add), pointer :: lokadd TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer itc,itn,ibm,jl,noprop,ik,k,jk,j,jxsym,ip double precision logb1,invb1,iafftc,iaffbm,rgasm,rt,tao,gmagn,msize double precision dtaodt,dtaodp,beta,d2taodp2,d2taodtdp,tc,tv,plus,fixit double precision tao2(2),ftao(6),dtao(3,mc),d2tao(mc*(mc+1)/2) double precision addgval(6),daddgval(3,mc),d2addgval(mc*(mc+1)/2) double precision tn,tcsave,tnsave,gmdo_inf,dgmdo_infdt,d2gmdo_infdt2 double precision check(6) logical addpermole character line*128,tps(2)*3 TYPE(tpfun_expression), pointer :: exprot ! dgdt = Gmagn/T + RT*df/dtao*dtao/dT*ln(beta+1) ! dgdp = RT df/dtao*dtao/dP*ln(beta+1) ! dgdy = RT*df/dtao*dtao/dy*ln(beta+1) + RT*f/(beta+1)*dbeta/dy ! d2gdt2=2*R*df/dtao*dtao/dT*ln(beta+1) + RT*d2f/dtao2*(dtao/dT)**2*ln(beta+1) ! +RT*df/dtao*d2tao/dT2*ln(beta+1) ! d2gdtdp= ... ! d2gdp2= ! d2gdtdy= suck ! d2gdpdy= ! d2gdydy= ! listprop(1) is the number of properties calculated ! listprop(2:listprop(1)) give the typty of different properties ! calculated in gval(*,i) etc ! one has to find those with typty equal for need_property in the magnetic ! record, i.e. typty for CTA/NTA and typty for BMAG/IBM ! the properties needed. ! noprop=phres%listprop(1)-1 itc=0; ibm=0; itn=0 lokadd%propval=zero ! write(*,*)'3H cmi 2: ',noprop,(phres%listprop(i),i=1,noprop) ! Inden-Qing-Xiong magnetic need properties in need_property(1..3) findix: do jl=2,noprop if(phres%listprop(jl).eq.lokadd%need_property(1)) then itc=jl elseif(phres%listprop(jl).eq.lokadd%need_property(2)) then ! we may also use an "average" Bohr magneton number in BMAG ibm=jl elseif(phres%listprop(jl).eq.lokadd%need_property(3)) then itn=jl endif enddo findix ! check that the needed properties are defined ! write(*,*)'3H found magnetic properties: ',itc,ibm,itn if(ibm.eq.0 .or. (itc.eq.0 .and. itn.eq.0)) then ! it is no error if no CTA, NTA or BMAG but then magnetic contribution is zero write(*,12)trim(phlista(lokph)%name),itc,itn,ibm 12 format('3H *** Warning: Magnetic addition for phase ',a,& ' not calculated as '/& 10x,'some values for CTA, NTA or BMAG/IBM are zero',3i3) goto 1000 else tc=-one tn=-one if(itc.gt.0) tc=phres%gval(1,itc) if(itn.gt.0) tn=phres%gval(1,itn) endif ! I am not sure I calculate correct derivatives for indivudal Bohr magnetons ... if(.not.btest(phlista(lokph)%status1,PHBMAV)) then write(*,*)'3H *** Bohr magneton number derivatives not calculated' endif beta=phres%gval(1,ibm) ! write(*,95)'3H Magnetic values in: ',itc,itn,ibm,tc,tn,beta 95 format(a,3i3,3(1PE15.6)) if(beta.le.zero .or. (tc.le.zero .and. tn.le.zero)) then ! no magnetic contribution gmagn=zero addgval=zero daddgval=zero d2addgval=zero goto 1000 endif ! we should use the appropriate tao=t/tc or tao=t/tn ! BUT WE MAY HAVE BOTH tc>0 and tn>0 !! ! use AF model unless tc negative, both cannot be negative here (test above) ! BUT WE MAY HAVE BOTH AS POSITIVE!! tcsave=tc if(tc.le.zero) then ! no ferro but maybe antiferro. One of them must be positive here!! ! Divide by AFF=3.0? ! tc=tn/3.0D0 ! beta=beta/3.0D0 tc=tn ! we use this index below to extract its value itc=itn ! elseif(tn.gt.zero) then ! we have both AFM and FM, use FM, i.e. tc so nothing to do endif ! tv=ceq%tpval(1) rgasm=globaldata%rgas rt=rgasm*tv tao=tv/tc tao2(1)=tao ! one should save values of ftao if tao2 is the same next time .... ! but as tc depend on the constitution that is maybe not so often. if(tao.lt.one) then exprot=>lokadd%explink(1) ! VERY CLUMSY bug for debugging else exprot=>lokadd%explink(2) endif ! plus=one plus=zero ! calculate function and derivatives wrt T, functions already created call ct1efn(exprot,tao2,ftao,ceq%eq_tpres) ! copied from list_addition ! tps(1)='tao' ! tps(2)='err' ! ip=1 ! line=' ' ! call ct1wfn(exprot,tps,line,ip) ! write(*,'(a,a,a/2(1pe12.4))')'f(tao)=',trim(line),';',tao,ftao(1) ! write(*,'(a,2(1pe12.4))')'3H tao, f(tao): ',tao,ftao(1) ! call wrice(kou,4,8,78,line(1:ip)) ! the functions entered in explink use reference state at T=infinity ! correct for using reference state at T=0 ! -1.0D0+0.38438376D0*lokadd%constants(1)*T/tc ! lokadd%constants(1) = 1/(p*D) in eq. A9 in paper by Qing ! NOTE tc may depend on P, we need the dtaodp and d2taodp2 dtaodp=-tao/tc*phres%gval(3,itc) d2taodtdp=-one/tc*phres%gval(3,itc) d2taodp2=2.0d0*tao/tc**2*phres%gval(3,itc)-tao/tc*phres%gval(6,itc) ! fixit=0.38438376D0*lokadd%constants(1) ! this is for BCC ! fixit=0.880323235D0 fixit=zero ftao(1)=ftao(1)+plus*(fixit*tv/tc-one) ftao(2)=ftao(2)+plus*fixit/tc ftao(3)=ftao(3)-plus*fixit*tv*dtaodp/tc**2 ! this is d2ftaodT2, no change ! ftao(4)=ftao(4) ! this is d2ftaodTdP ftao(5)=ftao(5)-plus*fixit*dtaodp/tc**2 ftao(6)=ftao(6)+2.0D0*plus*fixit*tv*d2taodp2/tc**3 ! if(plus.gt.zero) then ! write(*,'(a,e17.9,a,e12.4)')'3H f(tao) correction: -1+',& ! fixit,'/tao;',beta ! else ! write(*,'(a,e14.6,a,e14.6)')'3H f(tao) correction: +1-',& ! fixit,'/tao;',beta ! endif !------------------------------------------------------ logb1=log(beta+one) invb1=one/(beta+one) gmagn=rt*ftao(1)*logb1 ! ! Calculate Gmdo_inf/RT, which value to use for "p"? ! THERE ARE T and composition derivatives of this also!! ! gmdo_inf=-logb1*(one-0.38438376D0*lokadd%constants(1)/tao) ! dgmdo_infdt=-logb1/tv ! gmdo_inf=-rt*logb1*(one-0.38438376D0*lokadd%constants(1)/tc) ! write(*,'(a,2(1pe14.6),a/5(1pe12.4))')'3H Gmdo(inf): ',& ! rgasm*logb1*0.38438376D0*lokadd%constants(1)*tc,rgasm*logb1,'*T',& ! rgasm,logb1,0.38438376D0,lokadd%constants(1),tc ! gmdo_inf=-rgasm*logb1*(tv-0.38438376D0*lokadd%constants(1)*tc) ! dgmdo_infdt=-rgasm*logb1 ! d2gmdo_infdt2=zero ! write(*,88)'3H gmdo_inf: ',tv,gmdo_inf,dgmdo_infdt !88 format(a,F8.2,4(1pe12.4)) ! ! write(*,98)'3H cm 97: ',tc,beta,ftao(1),logb1,rt ! write(*,98)'3H cm 98: ',rt*gmagn,rt*(gmagn+phres%gval(1,1)),tcx,iafftc !98 format(a,5(1PE14.6)) ! dtaodt=one/tc ! d2taodT2=zero ! this already calculated above ! dtaodp=-tao/tc*phres%gval(3,itc) ! addgval(1)=gmagn+gmdo_inf ! addgval(2)=gmagn/tv+rt*ftao(2)*dtaodt*logb1+dgmdo_infdt ! addgval(3)=rt*ftao(2)*dtaodp*logb1+rt*ftao(1)*invb1*phres%gval(3,ibm)+& ! d2gmdo_infdt2 addgval(1)=gmagn addgval(2)=gmagn/tv+rt*ftao(2)*dtaodt*logb1 addgval(3)=rt*ftao(2)*dtaodp*logb1+rt*ftao(1)*invb1*phres%gval(3,ibm) ! make sure d2G/dT2 is calculated and stored so it can be listed addgval(4)=(2.0D0*ftao(2)+tv*ftao(4)*dtaodt)*rgasm*dtaodt*logb1 ! phres%gval(1,1)=phres%gval(1,1)+addgval(1)/rt ! phres%gval(2,1)=phres%gval(2,1)+addgval(2)/rt ! phres%gval(3,1)=phres%gval(3,1)+addgval(3)/rt ! save these in record ! NOTE if parallel calculation the same stored values %propval will be ! written by all threads so they must not be used!! ! write(*,77)lokadd%type,(lokadd%propval(j),j=1,4) !77 format('3H addition ',i2,': ',4(1pe12.4)) ! if(moded.eq.0) then if(moded.eq.0) then ! They are included only for listing and debugging if(btest(lokadd%status,ADDPERMOL)) then addpermole=.TRUE.; msize=phres%abnorm(1) else msize=one endif do j=1,4 lokadd%propval(j)=msize*addgval(j) phres%gval(j,1)=phres%gval(j,1)+msize*addgval(j)/rt enddo ! ignore second derivatives if no derivatives wanted goto 1000 endif ! Now all derivatives with respect to fractions ... ! phres%gval(*,itc) are TC and derivatives wrt T and P ! phres%dgval(*,*,itc) are derivatives of TC wrt T, P and Y ! phres%d2gval(*,itc) are derivatives of TC wrt Y1 and Y2 ! phres%gval(*,ibm) are beta and dervatives etc ! TC and beta must not depend on T, only on P and Y ! dtaodt=one/tc ! dtaodp=-tao/tc*phres%gval(3,itc) ! d2taodt2 is zero ! d2taodtdp=-one/tc*phres%gval(3,itc) ! d2taodp2=2.0d0*tao/tc**2*phres%gval(3,itc)-tao/tc*phres%gval(6,itc) ! 1-6 means F, F.T, T.P, F.T.T, F.T.P and F.P.P ! addgval(4)=2.0d0*rgasm*ftao(2)*dtaodt*logb1+& ! rt*ftao(4)*(dtaodt)**2*logb1 addgval(5)=rgasm*ftao(2)*dtaodp*logb1+& rgasm*ftao(1)*invb1*phres%gval(3,ibm)+& rt*ftao(4)*dtaodt*dtaodp*logb1+& rt*ftao(2)*d2taodtdp*logb1+& rt*ftao(2)*dtaodt*invb1*phres%gval(3,ibm) addgval(6)=rt*ftao(4)*(dtaodp)**2*logb1+& rt*ftao(2)*d2taodp2*logb1+rt*ftao(1)*dtaodp*invb1*phres%gval(3,ibm)+& rt*ftao(2)*dtaodp*invb1*phres%gval(3,ibm)-& rt*ftao(1)*(invb1*phres%gval(3,ibm))**2+& rt*ftao(1)*invb1*phres%gval(6,ibm) ! G, G.T and G.Y, G.T.Y and G.Y1.Y2 correct (no P dependence checked) do j=1,mc dtao(1,j)=-tao*phres%dgval(1,j,itc)/tc dtao(2,j)=-phres%dgval(1,j,itc)/tc**2 dtao(3,j)=2.0d0*tao*phres%gval(3,itc)*phres%dgval(1,j,itc)/tc**2-& tao*phres%dgval(3,j,itc)/tc do k=j,mc jxsym=kxsym(j,k) d2tao(jxsym)=& 2.0*tao*phres%dgval(1,j,itc)*phres%dgval(1,k,itc)/tc**2& -tao*phres%d2gval(jxsym,itc)/tc ! d2tao(ixsym(j,k))=& ! 2.0*tao*phres%dgval(1,j,itc)*phres%dgval(1,k,itc)/tc**2& ! -tao*phres%d2gval(ixsym(j,k),itc)/tc enddo enddo do j=1,mc ! first derivative wrt Y, checked for bcc in Cr-Fe-Mo, error in fcc in c-cr-fe? daddgval(1,j)=rt*ftao(2)*dtao(1,j)*logb1+& rt*ftao(1)*invb1*phres%dgval(1,j,ibm) ! write(*,43)j,daddgval(1,j),dtao(1,j),phres%dgval(1,j,ibm) !43 format('3H Inden 4: ',i2,6(1pe12.5)) ! second derivative wrt to T and Y, checked daddgval(2,j)=rgasm*ftao(2)*dtao(1,j)*logb1+& rgasm*ftao(1)*invb1*phres%dgval(1,j,ibm)+& rt*ftao(4)*dtaodt*dtao(1,j)*logb1+& rt*ftao(2)*dtao(2,j)*logb1+& rt*ftao(2)*dtaodt*invb1*phres%dgval(1,j,ibm) ! write(*,56)rgasm*ftao(2)*dtao(1,j)*logb1,& ! rgasm*ftao(1)*invb1*phres%dgval(1,j,ibm),& ! rt*ftao(4)*dtaodt*dtao(1,j)*logb1,& ! rgasm*ftao(2)*dtao(2,j)*logb1,& ! rt*ftao(2)*dtaodt*invb1*phres%dgval(1,j,ibm) !56 format('3H calcmag : ',5(1PE13.5)) ! second derivative wrt P and Y, no P dependence daddgval(3,j)=rt*ftao(4)*dtaodp*dtao(1,j)*logb1+& rt*ftao(2)*dtao(3,j)*logb1+& rt*ftao(2)*dtao(1,j)*invb1*phres%gval(3,ibm)-& rt*ftao(1)*invb1**2*phres%gval(3,ibm)*phres%dgval(1,j,ibm)+& rt*ftao(1)*invb1*phres%dgval(3,j,ibm) do k=j,mc ! second derivatives wrt Y1 and Y2, wrong ?? jxsym=kxsym(j,k) d2addgval(jxsym)=rt*ftao(4)*dtao(1,j)*dtao(1,k)*logb1+& rt*ftao(2)*d2tao(jxsym)*logb1+& rt*ftao(2)*dtao(1,j)*invb1*phres%dgval(1,k,ibm)+& rt*ftao(2)*dtao(1,k)*invb1*phres%dgval(1,j,ibm)-& rt*ftao(1)*invb1**2*phres%dgval(1,j,ibm)*phres%dgval(1,k,ibm)+& rt*ftao(1)*invb1*phres%d2gval(jxsym,ibm) ! d2addgval(ixsym(j,k))=rt*ftao(4)*dtao(1,j)*dtao(1,k)*logb1+& ! rt*ftao(2)*d2tao(ixsym(j,k))*logb1+& ! rt*ftao(2)*dtao(1,j)*invb1*phres%dgval(1,k,ibm)+& ! rt*ftao(2)*dtao(1,k)*invb1*phres%dgval(1,j,ibm)-& ! rt*ftao(1)*invb1**2*phres%dgval(1,j,ibm)*phres%dgval(1,k,ibm)+& ! rt*ftao(1)*invb1*phres%d2gval(ixsym(j,k),ibm) ! write(*,57)rt*ftao(4)*dtao(1,j)*dtao(1,k)*logb1,& ! rt*ftao(2)*d2tao(ixsym(j,k))*logb1,& ! rt*ftao(2)*dtao(1,j)*invb1*phres%dgval(1,k,ibm),& ! rt*ftao(2)*dtao(1,k)*invb1*phres%dgval(1,j,ibm),& ! -rt*ftao(1)*invb1**2*phres%dgval(1,j,ibm)*phres%dgval(1,k,ibm),& ! rt*ftao(1)*invb1*phres%d2gval(ixsym(j,k),ibm) !57 format('3H mag2y: ',6(1PE12.4)) enddo enddo ! now add all to the total G ! NOTE if addpermole bit set we have to multiply with derivatives of ! the size of the phase ... if(btest(lokadd%status,ADDPERMOL)) then addpermole=.TRUE.; msize=phres%abnorm(1) ! write(*,'(a,i4,l2,1pe12.4)')'3H msize magadd 2: ',lokph,addpermole,msize else addpermole=.FALSE.; msize=one endif do j=1,mc do k=1,3 ! write(*,99)'3H magadd 1: ',k,j,rt*phres%dgval(k,j,1),daddgval(k,j) phres%dgval(k,j,1)=phres%dgval(k,j,1)+msize*daddgval(k,j)/rt enddo !99 format(a,2i3,2(1pe16.8)) do k=j,mc ! write(*,99)'3H magadd 2: ',k,j,rt*phres%d2gval(ixsym(j,k),1),& ! d2addgval(ixsym(j,k)) jxsym=kxsym(j,k) phres%d2gval(jxsym,1)=phres%d2gval(jxsym,1)+& msize*d2addgval(jxsym)/rt ! phres%d2gval(ixsym(j,k),1)=phres%d2gval(ixsym(j,k),1)+& ! msize*d2addgval(ixsym(j,k))/rt enddo enddo ! write(*,*)'3H cm 7: ',rt*phres%gval(1,1),addgval(1) ! note phres%gval(1..3,1) already calculated above, multiplied with misize?? do j=1,6 lokadd%propval(j)=msize*addgval(j) phres%gval(j,1)=phres%gval(j,1)+msize*addgval(j)/rt enddo ! we may have destroyed the original value of tc if we have AFM tc=tcsave ! write(*,900)tc,tn,tao,beta,phres%gval(4,1),lokadd%propval(4) 900 format('3H QX magn1: ',2F9.2,2F9.3,2(1pe12.4)) ! jump here if no magnetic contribution 1000 continue ! write(*,900)tc,tn,tao,beta,phres%gval(1,1),lokadd%propval(1) return end subroutine calc_xiongmagnetic !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine create_volmod1 !\begin{verbatim} subroutine create_volmod1(addrec) ! create addition record for the simple volume model ! ! currently only V = V0 * exp(VA(T)) ! V0 is property (typty) 21, VA is 22 and reserved VB (Bulk modulus) 23 ! but VB is not implemented yet implicit none type(gtp_phase_add), pointer :: addrec !\end{verbatim} %+ integer typty,kk ! reserve an addition record allocate(addrec) ! store data in record nullify(addrec%nextadd) addrec%status=0 addrec%type=volmod1 ! addrecs declared in gtp3.F90 but I am not sure it is needed or used addrecs=addrecs+1 addrec%addrecno=addrecs allocate(addrec%need_property(3)) ! properties needed call need_propertyid('V0 ',typty) if(gx%bmperr.ne.0) goto 1000 addrec%need_property(1)=typty call need_propertyid('VA ',typty) if(gx%bmperr.ne.0) goto 1000 addrec%need_property(2)=typty call need_propertyid('VB ',typty) if(gx%bmperr.ne.0) goto 1000 addrec%need_property(3)=typty ! write(*,*)'Added volume model 1' ! store zero in 6 values for propval addrec%propval=zero 1000 continue ! write(*,*)'3H created volume addition',addrecs return end subroutine create_volmod1 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_volmod1 !\begin{verbatim} %- subroutine calc_volmod1(moded,phres,lokadd,lokph,mc,ceq) ! calculate the simple volume model, CURRENTLY IGNORING COMPOSITION DEPENDENCE ! ! G = P*V0(x)*exp(VA(T,x)) ! moded: integer, 0=only G, S, Cp; 1=G and dG/dy; 2=Gm dG/dy and d2G/dy2 ! phres: pointer, to phase\_varres record ! lokadd: pointer, to addition record ! lokph: integer, phase record index ! mc: integer, number of constituents ! ceq: pointer, to gtp_equilibrium_data implicit none integer moded,lokph,mc ! phres points to result record with gval etc for this phase TYPE(gtp_phase_varres) :: phres TYPE(gtp_phase_add), pointer :: lokadd TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer jl,iv0,iva,ivb,noprop double precision v0,va,vb,vol,deltap,pvol ! propval are stored locally in addition record lokadd%propval=zero ! if this bit not set there are no volume parameters if(.not.btest(lokadd%status,ADDHAVEPAR)) goto 1000 iv0=0; iva=0; ivb=0; v0=zero; va=zero; vb=zero noprop=phres%listprop(1)-1 findix: do jl=2,noprop if(phres%listprop(jl).eq.lokadd%need_property(1)) then iv0=jl v0=phres%gval(1,iv0) elseif(phres%listprop(jl).eq.lokadd%need_property(2)) then iva=jl va=phres%gval(1,iva) elseif(phres%listprop(jl).eq.lokadd%need_property(3)) then ivb=jl vb=phres%gval(1,ivb) endif enddo findix ! write(*,'(a,3i3)')'3H volmodel: ',iv0,iva,ivb ! if iv0 is zero there are no volume data if(iv0.eq.0) goto 1000 ! reference pressure is 1 bar deltap=ceq%tpval(2)-1.0D5 if(ivb.ne.zero) then ! if ivb not zero there are bulk modulus data ... NOT IMPLEMENTED write(*,*)'3H Volume model with bulk modulus not implemented' else vol=v0/ceq%rtn if(iva.ne.zero) then ! NOTE all values should be divided by RT vol=v0*exp(va)/ceq%rtn endif ! write(*,*)'3H v0, va: ',v0,va pvol=deltap*vol ! contribtions to G and derivatives, G, G.T, G.P=V, G.T.T, G.T.P, G.P.P ! NOTE there may be other parameters which depend on P! phres%gval(1,1)=phres%gval(1,1)+pvol ! G.T phres%gval(2,1)=phres%gval(2,1)+pvol*phres%gval(2,iva) ! G.P phres%gval(3,1)=phres%gval(3,1)+vol ! G.T.T phres%gval(4,1)=phres%gval(4,1)+& pvol*(phres%gval(2,iva)**2+phres%gval(4,iva)) ! G.T.P phres%gval(5,1)=phres%gval(5,1)+vol*phres%gval(2,iva) ! G.P.P ! for the moment ignore pressure and composition dependence ... ! phres%gval(6,1)=phres%gval(6,1) endif ! write(*,*)'Calculated volume ',pvol,vol,deltap ! store some property values lokadd%propval(1)=pvol lokadd%propval(2)=pvol*phres%gval(2,iva) lokadd%propval(3)=vol lokadd%propval(4)=pvol*(phres%gval(2,iva)**2+phres%gval(4,iva)) lokadd%propval(5)=vol*phres%gval(2,iva) lokadd%propval(6)=zero 1000 continue return end subroutine calc_volmod1 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine create_elastic_model_a !\begin{verbatim} subroutine create_elastic_model_a(newadd) ! addition record to calculate the elastic energy contribution implicit none type(gtp_phase_add), pointer :: newadd !\end{verbatim} %+ integer typty allocate(newadd) newadd%type=elasticmodel1 allocate(newadd%need_property(5)) newadd%status=0 ! needed properties newadd%need_property=0 call need_propertyid('LPX ',typty) if(gx%bmperr.ne.0) goto 1000 newadd%need_property(1)=typty call need_propertyid('EC11',typty) if(gx%bmperr.ne.0) goto 1000 newadd%need_property(2)=typty call need_propertyid('EC12',typty) if(gx%bmperr.ne.0) goto 1000 newadd%need_property(3)=typty call need_propertyid('EC44',typty) if(gx%bmperr.ne.0) goto 1000 newadd%need_property(4)=typty call need_propertyid('LPTH',typty) if(gx%bmperr.ne.0) goto 1000 newadd%need_property(5)=typty ! now elastica is declared as pointer, is that OK? allocate(newadd%elastica) 1000 continue return end subroutine create_elastic_model_a !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_elastica !\begin{verbatim} subroutine calc_elastica(moded,phres,addrec,lokph,mc,ceq) ! calculates elastic contribution and adds to G and derivatives implicit none integer moded,lokph,mc type(gtp_phase_varres), pointer :: phres type(gtp_phase_add), pointer :: addrec type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer jl,ilpx,ilpth,iec11,iec12,iec44,noprop,i1,i2 double precision sum1,sum2 ! get the current lattice parameters and elastic constants ilpx=0; ilpth=0; iec11=0; iec12=0; iec44=0 noprop=phres%listprop(1)-1 findix: do jl=2,noprop if(phres%listprop(jl).eq.addrec%need_property(1)) then ilpx=jl elseif(phres%listprop(jl).eq.addrec%need_property(2)) then iec11=jl elseif(phres%listprop(jl).eq.addrec%need_property(3)) then iec12=jl elseif(phres%listprop(jl).eq.addrec%need_property(4)) then iec44=jl elseif(phres%listprop(jl).eq.addrec%need_property(5)) then ! this one may not be needed initially at least ilpth=jl endif enddo findix if(ilpx.eq.0 .or. iec11.eq.0 .or. iec12.eq.0 .or. iec44.eq.0) then write(*,11)'3H Missing elastic parameter index: ',ilpx,iec11,iec12,iec44 11 format(a,5i4) endif ! write(*,11)'3H indices: ',ilpx,iec11,iec12,iec44 ! take care of the special elastic record ! ignore compsition derivatives at present ... ! elastic constant matrix, Voigt notation, symetric addrec%elastica%cmat=zero addrec%elastica%cmat(1,1)=phres%gval(1,iec11) addrec%elastica%cmat(2,2)=phres%gval(1,iec11) addrec%elastica%cmat(3,3)=phres%gval(1,iec11) addrec%elastica%cmat(4,4)=phres%gval(1,iec44) addrec%elastica%cmat(5,5)=phres%gval(1,iec44) addrec%elastica%cmat(6,6)=phres%gval(1,iec44) addrec%elastica%cmat(1,2)=phres%gval(1,iec12) addrec%elastica%cmat(1,3)=phres%gval(1,iec12) addrec%elastica%cmat(2,3)=phres%gval(1,iec12) addrec%elastica%cmat(2,1)=phres%gval(1,iec12) addrec%elastica%cmat(3,1)=phres%gval(1,iec12) addrec%elastica%cmat(3,2)=phres%gval(1,iec12) ! write(*,22)phres%gval(1,iec11),phres%gval(1,iec12),phres%gval(1,iec44) 22 format('Elastic constants: ',3(1pe12.4)) ! write(*,19)(addrec%elastica%cmat(1,i1),i1=1,6) ! write(*,19)(addrec%elastica%cmat(2,i1),i1=1,6) ! write(*,19)(addrec%elastica%cmat(3,i1),i1=1,6) ! write(*,19)(addrec%elastica%cmat(4,i1),i1=1,6) ! write(*,19)(addrec%elastica%cmat(5,i1),i1=1,6) ! write(*,19)(addrec%elastica%cmat(6,i1),i1=1,6) 19 format('3H CIJ: ',6(1pe12.4)) !.................... ! equilibrium lattice constant (cubic, just diagonal) addrec%elastica%latticepar=zero addrec%elastica%latticepar(1,1)=phres%gval(1,ilpx) addrec%elastica%latticepar(2,2)=phres%gval(1,ilpx) addrec%elastica%latticepar(3,3)=phres%gval(1,ilpx) ! write(*,23)'3H Lattice parameter: ',phres%gval(1,ilpx) !.................... ! The equilibrium lattice distances are in LPX (cubic lattice) ! The current lattice parameters are in ceq%phres%curlat(3,3) ! generate epsa, Voigt notation ! write(*,23)'3H curlat 1: ',(phres%curlat(i1,1),i1=1,3) ! write(*,23)'3H curlat 2: ',(phres%curlat(i1,2),i1=1,3) ! write(*,23)'3H curlat 3: ',(phres%curlat(i1,3),i1=1,3) 23 format(a,3(1pe12.4)) addrec%elastica%epsa(1)=(phres%curlat(1,1)-addrec%elastica%latticepar(1,1))& /addrec%elastica%latticepar(1,1) addrec%elastica%epsa(2)=(phres%curlat(2,2)-addrec%elastica%latticepar(2,2))& /addrec%elastica%latticepar(2,2) addrec%elastica%epsa(3)=(phres%curlat(3,3)-addrec%elastica%latticepar(3,3))& /addrec%elastica%latticepar(3,3) ! as addrec%elastica%latticepar(2,3) is zero for cubic use (1,1) addrec%elastica%epsa(4)=& (2*(phres%curlat(2,3)-addrec%elastica%latticepar(2,3)))& /addrec%elastica%latticepar(1,1) addrec%elastica%epsa(5)=& (2*(phres%curlat(1,3)-addrec%elastica%latticepar(1,3)))& /addrec%elastica%latticepar(1,1) addrec%elastica%epsa(6)=& (2*(phres%curlat(1,2)-addrec%elastica%latticepar(1,2)))& /addrec%elastica%latticepar(1,1) ! write(*,25)'3H ev1: ',(addrec%elastica%epsa(i1),i1=1,6) 25 format(a,6(1pe12.4)) !.................... ! calculate the elastic energy ... I do not know how to use F08 matrix mult sum1=zero do i1=1,6 sum2=zero do i2=1,6 sum2=sum2+addrec%elastica%cmat(i1,i2)*addrec%elastica%epsa(i2) enddo ! write(*,23)'3H sum2: ',sum2 sum1=sum1+addrec%elastica%epsa(i1)*sum2 enddo addrec%elastica%eeadd(1)=5.0D-1*sum1 write(*,30)'3H: Elastic energy: ',addrec%elastica%eeadd(1) 30 format(a,1pe15.7) ! TYPE gtp_elastic_modela ! double precision, dimension(3,3) :: latticepar ! epsilon in Voigt notation ! double precision, dimension(6) :: epsa ! elastic constant matrix in Voigt notation ! double precision, dimension(6,6) :: cmat ! calculated elastic energy addition (with derivative to T and P?) ! double precision, dimension(6) :: eeadd ! maybe more ! end TYPE gtp_elastic_modela 1000 continue return end subroutine calc_elastica !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine set_lattice_parameters !\begin{verbatim} subroutine set_lattice_parameters(iph,ics,xxx,ceq) ! temporary way to set current lattice parameters for use with elastic model a implicit none integer iph,ics double precision, dimension(3,3) :: xxx type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer lokph,lokcs call get_phase_compset(iph,ics,lokph,lokcs) if(gx%bmperr.ne.0) goto 1000 ceq%phase_varres(lokcs)%curlat=xxx ! write(*,*)'3H Phase+set: ',lokph,lokcs ! write(*,23)'3H slp 1: ',(ceq%phase_varres(lokcs)%curlat(i1,1),i1=1,3) ! write(*,23)'3H slp 2: ',(ceq%phase_varres(lokcs)%curlat(i1,2),i1=1,3) ! write(*,23)'3H slp 3: ',(ceq%phase_varres(lokcs)%curlat(i1,3),i1=1,3) 23 format(a,3(1pe12.4)) 1000 continue return end subroutine set_lattice_parameters !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine create_einsteincp !\begin{verbatim} subroutine create_einsteincp(newadd) implicit none type(gtp_phase_add), pointer :: newadd !\end{verbatim} %+ integer, parameter :: ncc=6 integer typty ! ! G/RT = 1.5*R*THET + 3*ln( 1 - exp( -THET/T ) ) ! No need to use TPFUN ! ! gtp_phase_add has variables: ! integer :: type,addrecno,aff ! integer, allocatable :: need_property ! type(tpfun_expression), dimension, pointer :: explink ! type(gtp_phase_add), pointer :: nextadd ! for spme additions one may create other records but they must have ! the variables type and nextadd !------------------------------------------ allocate(newadd) ! Both Einstein and Debye models use THET newadd%type=einsteincp newadd%status=0 ! call need_propertyid('THET',typty) call need_propertyid('LNTH',typty) if(gx%bmperr.ne.0) goto 1000 allocate(newadd%need_property(1)) newadd%need_property(1)=typty nullify(newadd%nextadd) 1000 continue return end subroutine create_einsteincp !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_einsteincp !\begin{verbatim} subroutine calc_einsteincp(moded,phres,addrec,lokph,mc,ceq) ! Calculate the contibution due to Einste Cp model for low T ! moded 0, 1 or 2 ! phres all results ! addrec pointer to addition record ! lokph phase record ! mc number of variable fractions ! ceq equilibrum record ! ! G = 1.5*R*THET + 3*R*T*ln( 1 - exp( -THET/T ) ) ! This is easier to handle inside the calc routine without TPFUN ! implicit none integer moded,lokph,mc type(gtp_phase_varres), pointer :: phres type(gtp_phase_add), pointer :: addrec type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer ith,noprop,extreme,j1,j2 double precision kvot,expkvot,expmkvot,ln1mexpkvot,kvotexpkvotm1,fact ! double precision del1,del2,del3,del4,gein,dgeindt,d2geindt2,theta double precision gein,dgeindt,d2geindt2,msize,theta,test double precision addphm(6) logical addpermole double precision, allocatable :: dthet(:),d2thet(:),dein(:),d2ein(:) ! noprop=phres%listprop(1)-1 ! write(*,*)'3H thet: ',phres%listprop(2),addrec%need_property(1) findix: do ith=2,noprop if(phres%listprop(ith).eq.addrec%need_property(1)) goto 100 enddo findix ! write(*,*)'3H No value of THET for phase ',trim(phlista(lokph)%name) write(*,*)'3H No value of LNTH for phase ',trim(phlista(lokph)%name) gx%bmperr=4336; goto 1000 100 continue if(phres%gval(1,ith).le.one) then ! write(*,69)'3H Illegal THET for phase ',trim(phlista(lokph)%name),& write(*,69)'3H Illegal LNTH for phase ',trim(phlista(lokph)%name),& phres%gval(1,ith) 69 format(a,a,1pe12.4) gx%bmperr=4399; goto 1000 endif ! NOTE the parameter value is ln(thera)! take the exponential! ! ln(thet) is in gval(1,ith), derivatives in dgval(*,ith,*) and d2gval(ith,*) ! G/RT = 1.5*THET/T + 3*LN(1-exp(-THET/T)) ! NOTE ALL VALUES CALCULATED AS FOR G/RT ! kvot=theta/T if(phres%gval(1,ith).gt.1.0D2) then ! write(*,*)'3H Probably wrong value of THET, parameter should be ln(THET)' write(*,*)'3H Probably wrong value of LNTH, parameter should be ln(THET)' write(*,*)'3H error in phase: ',trim(phlista(lokph)%name) gx%bmperr=4399; goto 1000 endif ! The exp( ) because the parameter value is LN(THETA) theta=exp(phres%gval(1,ith)) ! kvot=exp(phres%gval(1,ith))/ceq%tpval(1) kvot=theta/ceq%tpval(1) ! write(*,*)'3H LN(THET): ',trim(phlista(lokph)%name),phres%gval(1,ith),theta ! write(*,'(a,4(1pe11.3))')'3H dTH/dyi: ',(phres%dgval(1,j1,ith),j1=1,mc) ! write(*,'(a,4(2i2,1pe11.3))')'3H d2TH/dyidyj: ',& ! ((j1,j2,phres%d2gval(ixsym(j1,j2),ith),j2=j1,mc),j1=1,mc) ! We must convert all derivatives to real THET ?? no ?? allocate(dthet(mc)) allocate(d2thet(mc*(mc+1)/2)) do j1=1,mc do j2=j1,mc d2thet(ixsym(j1,j2))=phres%d2gval(ixsym(j1,j2),ith) enddo dthet(j1)=phres%dgval(1,j1,ith) enddo ! do j1=1,mc ! do j2=j1,mc ! d2thet(ixsym(j1,j2))=exp(phres%d2gval(ixsym(j1,j2),ith)) ! enddo ! dthet(j1)=exp(phres%dgval(1,j1,ith)) ! enddo ! write(*,'(a,4(1pe11.3))')'3H A dTH/dyi: ',(dthet(j1),j1=1,mc) ! write(*,'(a,4(2i2,1pe11.3))')'3H A d2TH/dyidyj: ',& ! ((j1,j2,d2thet(ixsym(j1,j2)),j2=j1,mc),j1=1,mc) ! simpler .... if it is correct?? ! dTHETA/dy_i = d/dyi(exp(LNTH))= exp(LNTH)*d/dy1(LNTH) = THETA*dLNTH/dy1 ?? ! do j1=1,mc ! do j2=j1,mc ! d2thet(ixsym(j1,j2))=theta*phres%d2gval(ixsym(j1,j2),ith) ! enddo ! dthet(j1)=theta*phres%dgval(1,j1,ith) ! enddo ! write(*,'(a,4(1pe11.3))')'3H B dTH/dyi: ',(dthet(j1),j1=1,mc) ! write(*,'(a,4(2i2,1pe11.3))')'3H B d2TH/dyidyj: ',& ! ((j1,j2,d2thet(ixsym(j1,j2)),j2=j1,mc),j1=1,mc) ! write(*,70)'3H phres: ',ceq%tpval(1),phres%gval(1,1),phres%gval(2,1),& ! phres%gval(3,1),phres%gval(4,1),kvot ! we should be careful with numeric overflow, for small T or large T ! no risk for overflow for exp(-kvot) if(kvot.gt.1.0D2) then ! T is very small, kvot very large, exp(kvot) may cause overflow, ! exp(-kvot) is very small, ln(1-exp(-kvot)) is close to zero ! exp(kvot) may cause overflow, kvot/(exp(kvot)-1)= ! kvot*exp(-kvot)/(1-exp(-kvot)) = (1-kvot+kvot**2/2-...)/(1-kvot/2+...) = 1 extreme=-1 ! kvotexpkvotm1=one expmkvot=zero kvotexpkvotm1=zero ln1mexpkvot=zero elseif(kvot.lt.1.0D-2) then ! T is very big, kvot is very small, exp(-kvot) approch 1, 1-exp(-kvot)=kvot ! exp(-kvot) is close unity, ln(1-exp(-kvot))=ln(1-(1-kvot+kvot**2/2+...)) = ! ln(kvot-kvot**2/2+...)=ln(kvot) ! exp(kvot) is close to unity: exp(kvot)-1 = kvot+kvot**2/2+ ... extreme=1 expmkvot=exp(-kvot) kvotexpkvotm1=kvot/(exp(kvot)-one) ln1mexpkvot=log(one-expmkvot) else ! range of T and kvot where value varies, take care of composition derivatives extreme=0 expmkvot=exp(-kvot) kvotexpkvotm1=kvot/(exp(kvot)-one) ln1mexpkvot=log(one-expmkvot) ! ln1mexpkvot=log(exp(kvot)-one) endif ! kvot is +THETA/T; gein is integrated cp contribution to the Gibbs energy ! gein is Einsten contribution/RT gein=1.5D0*kvot+3.0D0*ln1mexpkvot ! write(*,71)'3H Cp E1:',extreme,ceq%tpval(1),gein,ln1mexpkvot,expmkvot,& ! kvotexpkvotm1 ! first derivative wrt T taking care of overflow dgeindt=3.0D0*(ln1mexpkvot-kvotexpkvotm1)/ceq%tpval(1) ! second derivative wrt T ! This is d2G/dT**2/(RT) = -T**2/R*(Einstein Cp/RT) (or rather Cv/RT) if(extreme.eq.-1) then ! take care of overflow at low T, kvotexpkvotm1=expmkvot=0 set above d2geindt2=zero else d2geindt2=-3.0D0*kvotexpkvotm1**2/(expmkvot*ceq%tpval(1)**2) endif ! NOTE if addpermole bit set we have to multiply with derivatives of ! the size of the phase ... if(btest(addrec%status,ADDPERMOL)) then addpermole=.TRUE.; msize=phres%abnorm(1) ! write(*,'(a,i4,l2,1pe12.4)')'3H msize lowT: ',lokph,addpermole,msize else addpermole=.FALSE.; msize=one ! write(*,'(a,i4,l2,1pe12.4)')'3H msize lowT: ',lokph,addpermole,msize endif ! BEGIN NEW CODE --------------------------------------------------------- ! wrong G^Ein/RT = gein = 1.5*THETA/T + 3*LN(exp(THETA/T) - 1) ! G^Ein/RT = gein = 1.5*THETA/T + 3*LN(1-exp(-THETA/T)) ! where z=ln(THETA); THETA=exp(z); z depend on composition; kvot=THETA/T ! we have dz/dy_i etc in phres%dgval(1,i,ith); (note z does not depend on T) ! d2z/dy_idy_j in phres%d2gval(ixsym(i,j)) ! ! wrong G^Ein = RT*(G^Ein/RT) = 1.5*R*T*kvot + 3*R*T*ln(exp(kvot) - 1); ! kvot=THETA/T ! G^Ein = 1.5*R*THETA + 3*R*T*ln(1-exp(-THETA/T)); THETA=exp(z(y_i)) ! ! dG^Ein/dy_i=1.5*R*dTHETA/dy_i+3*R*exp(-THETA/T)/(1-exp(-THETA/T))*dTHETA/dy_i ! = (1.5+3*exp(-THETA/T)/(exp(-THETA/T)-1))*R*dTHETA/dy_i ! Composition derivative of the Einstein function is ! dEin/dy_i/RT = ((1.5+3*exp(-THETA/T)/(exp(-THETA/T)-1)/T)*dTHETA/dy_i ! dTHETA/dy_i = exp(z)*dz/y_i = THETA*dz/dy_i ! dEin/dy_i/RT = ((1.5+(3/T)*exp(-THETA/T)/(1-exp(-THETA/T)))*(THETA/T)*dz/dy_i ! dTHETA/dy_i = exp(z)*dz/y_i = THETA*dz/y_i ! REMEMBER kvot=THET/T; expmkvot=exp(-kvot); gasconstant R=globaldata%rgas ! ! This is composition derivatives of THET ! ! as I want NOTE expmkvot is exp(-kvot) !! NOW IT WORKS !!! SUCK fact=1.5D0*(one+expmkvot)/(one-expmkvot)*kvot ! the curve below better, correct shape ... ! write(*,77)'3H Einstein dE/dy',lokph,1,theta,phres%dgval(1,1,ith),fact,& ! phres%dgval(1,1,1),phres%dgval(1,1,1)+fact*phres%dgval(1,1,ith) 77 format(a,2i2,5(1pe12.4)) ! allocate(dein(mc)) ! allocate(d2ein(mc*(mc+1)/2)) ! VERY MESSY CODING AND I DO NOT UNDERSTAND IT/BoS 2021.04.02 do j1=1,mc ! write(*,77)'3H Einstein dE/dy',lokph,j1,theta,phres%dgval(1,j1,ith),fact,& ! phres%dgval(1,j1,1),phres%dgval(1,j1,1)+fact*phres%dgval(1,j1,ith) ! we must use dthet(j1)=THETA*dgval(1,j1,ith) and not dgval(1,j1,ith) !! ! old phres%dgval(1,j1,1)=msize*(phres%dgval(1,j1,1)+fact*phres%dgval(1,j1,ith)) phres%dgval(1,j1,1)=phres%dgval(1,j1,1)+msize*fact*dthet(j1) ! write(*,*)'3H second derivatives missing for Einstein, SUCK' ! dein(j1)=msize*fact*dthet(j1) do j2=j1,mc ! d2Ein/dy1dy2 = (1.5R*theta+3*R*(exp(kvot)-1)**(-1))*d2theta/dy1dy2 - ! 3*R*exp(kvot)/(T*(exp(kvot)-1))**2*dtheta/dy1*dtheta/dy2 phres%d2gval(ixsym(j1,j2),1)=phres%d2gval(ixsym(j1,j2),1)+& msize*(fact*d2thet(ixsym(j1,j2))-& 3.0d0*exp(kvot)*(ceq%tpval(1)*(exp(kvot)-one))**(-2)*& dthet(j1)*dthet(j2)) ! d2ein(ixsym(j1,j2))=msize*(fact*d2thet(ixsym(j1,j2))-& ! 3.0d0*exp(kvot)*(ceq%tpval(1)*(exp(kvot)-one))**(-2)*& ! dthet(j1)*dthet(j2)) enddo enddo ! listing .... ! write(*,'(a,4(1pe11.3))')'3H dein: ',(dein(j1),j1=1,mc) ! write(*,'(a,4(2i2,1pe11.3))')'3H d2ein: ',& ! ((j1,j2,d2ein(ixsym(j1,j2)),j2=j1,mc),j1=1,mc) ! ! END NEW CODE ---------------------------------------------------------- ! debug value of G ! write(*,77)'3H Einstein ln(theta):',lokph,0,theta,gein,test,msize ! return the values in phres%gval(*,1) phres%gval(1,1)=phres%gval(1,1)+msize*gein phres%gval(2,1)=phres%gval(2,1)+msize*dgeindt ! phres%gval(3,1)=phres%gval(3,1) phres%gval(4,1)=phres%gval(4,1)+msize*d2geindt2 ! phres%gval(5,1)=phres%gval(5,1) ! phres%gval(6,1)=phres%gval(6,1) addrec%propval(1)=msize*gein addrec%propval(2)=msize*dgeindt addrec%propval(4)=msize*d2geindt2 ! write(*,70)'3H Cp E3: ',ceq%tpval(1),gein,dgeindt,d2geindt2 70 format(a,F7.2,5(1pe12.4)) 71 format(a,i3,1x,F7.2,5(1pe12.4)) ! ! NOTE Missing implementation of derivatives wrt comp.dep of THET. ! the THET parameter cannot depend on T ! write(*,*)'3H calc_einsteincp not including composition dependence of thet' ! addphm should be G^phys, dG^phys/dT, dG^phys/dP, d2G^phys/dT^2 etc addphm=zero addphm(1)=gein addphm(2)=dgeindt addphm(4)=d2geindt2 ! correct for formula unit call add_size_derivatives(moded,phres,addphm,lokph,mc,ceq) ! 1000 continue return end subroutine calc_einsteincp !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine add_size_derivatives !\begin{verbatim} subroutine add_size_derivatives(moded,phres,addphm,lokph,mc,ceq) ! Many physical models are defined per mole of atoms, as the Gibbs energy ! is calculate per mole formula unit this routine will handle the ! additional derivatives needed when M*ADD(1 mole) ! mc is number of constituent variables ! addphm(1..6) is G, dG/dt, dG/dp, d2G/dt2, d2G/dtdp, d2G/dp2 for the addition implicit none integer moded,lokph,mc type(gtp_phase_varres), pointer :: phres ! type(gtp_phase_add), pointer :: addrec type(gtp_equilibrium_data), pointer :: ceq double precision addphm(6) !\end{verbatim} %+ integer i1,i2,j1,j2,jxsym,k,s1,s2 double precision site1,site2 ! Moles of constituents per mole formula units is: ! M = \sum_s a_s \sum_i y_si; dM/dy = a_s ! what about disordered fraction sets? ignore .... UNFINISHED?? ! sites are in phres%sites ! number of constituents in siblattice s is in phlista(lokph)%nooffr(s) goto 1000 write(*,*)'3H inside add_size_derivatives',lokph,addphm(1) s1=1 s2=1 site1=phres%sites(s1) j1=1 do i1=1,mc ! ! G^phy_M = N*G^phy_m (already done) ! dG^phy_M/dyi = (dN/dyi)*G^phy_m + N*(dG^phy_m/dyi) ?? ! d2G/dyidyj = (dN/dyi)*(dGm/dyj)+(dN/dyj)*(dGm/dyi)+N*(d2Gm/dyidyj) ignore ! dN/dyi = a_s for sublattice s with constituent i ! and d2N/dyidyj = 0 ! ! I am not sure about this routine .... ! ! dGM/dyi = (dN/dyi)*Gm (+N*(dGM/dyi) already done) do k=1,3 ! this is dG/dy and d2G/dtdy and d2G/dpdy (k=1,2,3) phres%dgval(k,i1,1)=phres%dgval(k,i1,1)+site1*addphm(k) enddo write(*,*)'3H addition to mu',i1,site1*addphm(1) ! write(*,*)'3H ignoring 2nd derivatives of size' !+ j2=1 !+ site2=phres%sites(s2) !+ do i2=i1,mc ! For the moment ignore all second derivatives !! ! no second derivatives wrt same constituents twice !+ if(i2.gt.i1) then !+ site2=phres%sites(s2) !+ jxsym=kxsym(i1,i2) ! d2G/dyidyj = (dN/dyi)*(dGm/dyj)+(dN/dyj)*(dGm/dyi) (+N*(d2Gm/dyidyj) done) !+ phres%d2gval(jxsym,1)=phres%d2gval(jxsym,1)+site1*site2*addphm(1) !+ endif !+ j2=j2+1 !+ if(j2.gt.phlista(lokph)%nooffr(s2)) then !+ j2=1; s2=s2+1 !+ if(s2.le.phlista(lokph)%noofsubl) site2=phres%sites(s2) !+ endif !+ enddo j1=j1+1 if(j1.gt.phlista(lokph)%nooffr(s1)) then j1=1; s1=s1+1 if(s1.le.phlista(lokph)%noofsubl) site1=phres%sites(s1) endif enddo 1000 continue return end subroutine add_size_derivatives !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine create_schottky_anomaly !\begin{verbatim} subroutine create_schottky_anomaly(newadd) ! Adding a Schottky anomaly to Cp implicit none type(gtp_phase_add), pointer :: newadd !\end{verbatim} %+ integer, parameter :: ncc=6 integer typty ! ! G/RT = SAM * ln( 1 + exp( SAM/T ) ) ! No need to use TPFUN ! ! gtp_phase_add has variables: ! integer :: type,addrecno,aff ! integer, allocatable :: need_property ! type(tpfun_expression), dimension, pointer :: explink ! type(gtp_phase_add), pointer :: nextadd ! for spme additions one may create other records but they must have ! the variables type and nextadd !------------------------------------------ allocate(newadd) ! Schottky anomaly uses THT2 and DCP2, same as second Einstein newadd%status=0 newadd%type=schottkyanomaly allocate(newadd%need_property(2)) call need_propertyid('TSCH',typty) if(gx%bmperr.ne.0) goto 1000 newadd%need_property(1)=typty call need_propertyid('CSCH',typty) if(gx%bmperr.ne.0) goto 1000 newadd%need_property(2)=typty nullify(newadd%nextadd) 1000 continue return end subroutine create_schottky_anomaly !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_schottky_anomaly !\begin{verbatim} subroutine calc_schottky_anomaly(moded,phres,addrec,lokph,mc,ceq) ! Calculate the contibution due to a Schottky anomaly ! moded 0, 1 or 2 ! phres all results ! addrec pointer to addition record ! lokph phase record ! mc number of variable fractions ! ceq equilibrum record ! ! G = DCP2*T*ln( 1 + exp( -THT2/T ) ) ! dG/dT = DCP2*(ln(1+exp(-THT2/T))+(THT/T)*(1+exp(+THT2/T))**(-1) ! d2G/dT2 = -DCP2*THT2**2*T**(-3)*exp(THT2/T)*(1+exp(+THT2/T))**(-2) ! implicit none integer moded,lokph,mc type(gtp_phase_varres), pointer :: phres type(gtp_phase_add), pointer :: addrec type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer ith,jth,noprop,extreme,j1 double precision kvot,expkvot,expmkvot,ln1pexpmkvot,kvotexpkvotp1,fact double precision gsch,dgschdt,d2gschdt2,dcp2,msize logical addpermole ! noprop=phres%listprop(1)-1 ! write(*,*)'3H lnth: ',phres%listprop(2),addrec%need_property(1) ith=0 jth=0 findix: do j1=2,noprop if(phres%listprop(j1).eq.addrec%need_property(1)) then ith=j1 elseif(phres%listprop(j1).eq.addrec%need_property(2)) then jth=j1 endif enddo findix ! ith is THT2 and jth is DCP2 if(ith.eq.0 .or. jth.eq.0) then ! write(*,*)'3H missing Schottky anomaly parameter for phase ',& ! trim(phlista(lokph)%name) goto 1000 endif ! phres%gval(1,ith) and phres(1,jth) must not depend on T kvot=exp(phres%gval(1,ith))/ceq%tpval(1) dcp2=phres%gval(1,jth) if(kvot.le.zero) goto 1000 ! we should be careful with numeric overflow, for small T or large T if(kvot.gt.1.0D2) then ! T is very small, kvot very large, exp(kvot) may cause overflow, ! exp(-kvot) is very small, ln(1-exp(-kvot)) is close to zero ! exp(kvot) may cause overflow, kvot/(exp(kvot)-1)= ! kvot*exp(-kvot)/(1-exp(-kvot)) = (1-kvot+kvot**2/2-...)/(1-kvot/2+...) = 1 extreme=-1 expmkvot=zero kvotexpkvotp1=zero ln1pexpmkvot=zero elseif(kvot.lt.1.0D-2) then ! T is very big, kvot is very small, exp(-kvot) approch 1, 1-exp(-kvot)=kvot ! exp(-kvot) is close unity, ln(1-exp(-kvot))=ln(1-(1-kvot+kvot**2/2+...)) = ! ln(kvot-kvot**2/2+...)=ln(kvot) ! exp(kvot) is close to unity: exp(kvot)-1 = kvot+kvot**2/2+ ... extreme=1 expmkvot=exp(-kvot) kvotexpkvotp1=kvot/(exp(kvot)+one) ln1pexpmkvot=log(one+expmkvot) else ! normal range of T and kvot extreme=0 expmkvot=exp(-kvot) kvotexpkvotp1=kvot/(exp(kvot)+one) ln1pexpmkvot=log(one+expmkvot) endif ! ! Note this is the G/RT value dcp2*ln(1+exp(tht2/T) ! G = DCP2*T*ln( 1 + exp( -THT2/T ) ) gsch=dcp2*ln1pexpmkvot ! write(*,71)'3H Cp E1:',extreme,ceq%tpval(1),gein,ln1mexpkvot,expmkvot,& ! kvotexpkvotm1 ! first derivative wrt T taking care of overflow ! dcp2*ln(1+exp(tht2))/T -(tht2/T**2)/exp ! dG/dT = DCP2*(ln(1+exp(-THT2/T))+(THT/T)*(1+exp(+THT2/T))**(-1) dgschdt=DCP2*(ln1pexpmkvot-kvotexpkvotp1)/ceq%tpval(1) ! This is d2G/dT**2/(RT) = -T**2/R*(Einstein Cp/RT) (or rather Cv/RT) if(extreme.eq.-1) then ! take care of overflow at low T, kvotexpkvotm1=expmkvot=0 set above d2gschdt2=zero else ! d2G/dT2 = -DCP2*THT2**2*T**(-3)*exp(THT2/T)*(1+exp(+THT2/T))**(-2) d2gschdt2=-DCP2*kvotexpkvotp1**2/(expmkvot*ceq%tpval(1)) endif ! first derivative for each constituent. The parameter value is ln(theta) ! and we should divide by RT ! fact=1.5D0*kvot+3.0D0*kvotexpkvotm1 ! do j1=1,mc ! phres%dgval(1,j1,1)=phres%dgval(1,j1,1)+fact*phres%dgval(1,j1,ith) ! enddo ! return the values in phres%gval(*,1) ! NOTE if addpermole bit set we have to multiply with derivatives of ! the size of the phase ... if(btest(addrec%status,ADDPERMOL)) then addpermole=.TRUE.; msize=phres%abnorm(1) ! write(*,'(a,i4,l2,1pe12.4)')'3H msize schky: ',lokph,addpermole,msize else addpermole=.FALSE.; msize=one endif ! phres%gval(1,1)=phres%gval(1,1)+msize*gsch phres%gval(2,1)=phres%gval(2,1)+msize*dgschdt ! phres%gval(3,1)=phres%gval(3,1) phres%gval(4,1)=phres%gval(4,1)+msize*d2gschdt2 ! phres%gval(5,1)=phres%gval(5,1) ! phres%gval(6,1)=phres%gval(6,1) addrec%propval(1)=msize*gsch addrec%propval(2)=msize*dgschdt addrec%propval(4)=msize*d2gschdt2 ! write(*,70)'3H Schottky: ',ceq%tpval(1),gsch,dgschdt,d2gschdt2 70 format(a,F7.2,5(1pe12.4)) 71 format(a,i3,1x,F7.2,5(1pe12.4)) ! ! Missing implem of derivatives wrt comp.dep of thet. thet2 cannot depend on T ! 1000 continue return end subroutine calc_schottky_anomaly !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine create_secondeinstein !\begin{verbatim} subroutine create_secondeinstein(newadd) implicit none type(gtp_phase_add), pointer :: newadd !\end{verbatim} %+ integer, parameter :: ncc=6 integer typty ! ! G/RT = DCP2*ln( 1 - exp( -THT2/T ) ) ! No need to use TPFUN ! ! gtp_phase_add has variables: ! integer :: type,addrecno,aff ! integer, allocatable :: need_property ! type(tpfun_expression), dimension, pointer :: explink ! type(gtp_phase_add), pointer :: nextadd ! for spme additions one may create other records but they must have ! the variables type and nextadd !------------------------------------------ allocate(newadd) newadd%type=secondeinstein newadd%status=0 ! The second Einstein use THT2 and DCP2 allocate(newadd%need_property(2)) call need_propertyid('THT2',typty) if(gx%bmperr.ne.0) goto 1000 newadd%need_property(1)=typty call need_propertyid('DCP2',typty) if(gx%bmperr.ne.0) goto 1000 newadd%need_property(2)=typty nullify(newadd%nextadd) write(*,*)'3H created 2nd Einstein: ',newadd%type 1000 continue return end subroutine create_secondeinstein !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_secondeinstein !\begin{verbatim} subroutine calc_secondeinstein(moded,phres,addrec,lokph,mc,ceq) ! Calculate the contibution due to Einste Cp model for low T ! moded 0, 1 or 2 ! phres all results ! addrec pointer to addition record ! lokph phase record ! mc number of variable fractions ! ceq equilibrum record ! ! G = 1.5*R*THET + 3*R*T*ln( 1 - exp( -THET/T ) ) ! This is easier to handle inside the calc routine without TPFUN ! implicit none integer moded,lokph,mc type(gtp_phase_varres), pointer :: phres type(gtp_phase_add), pointer :: addrec type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer ith,jth,noprop,extreme,j1 double precision kvot,expkvot,expmkvot,ln1mexpkvot,kvotexpkvotm1,fact ! double precision del1,del2,del3,del4,gein,dgeindt,d2geindt2 double precision gein,dgeindt,d2geindt2,deltacp,msize logical addpermole ! noprop=phres%listprop(1)-1 ! write(*,*)'3H tht2: ',phres%listprop(2),addrec%need_property(1),& ! addrec%need_property(2) ith=0; jth=0; findix: do j1=2,noprop if(phres%listprop(j1).eq.addrec%need_property(1)) then ith=j1 elseif(phres%listprop(j1).eq.addrec%need_property(2)) then jth=j1 endif enddo findix if(ith.eq.0 .or. jth.eq.0) then write(*,*)'3H Missing second Einstein properties for phase ',& trim(phlista(lokph)%name) gx%bmperr=4336; goto 1000 endif 100 continue if(phres%gval(1,ith).le.one) then write(*,70)'3H Illegal LNTH for phase ',trim(phlista(lokph)%name),& phres%gval(1,ith) gx%bmperr=4399; goto 1000 endif ! NOTE the parameter value is ln(thera)! take the exponential! ! thet is in gval(1,ith), derivatives in dgval(*,ith,*) and d2gval(ith,*) ! G/RT = phres%gval(1,jth)*R*LN(exp(THET/T) - 1) ! NOTE ALL VALUES CALCULATED AS FOR G/RT kvot=exp(phres%gval(1,ith))/ceq%tpval(1) ! write(*,70)'3H phres: ',ceq%tpval(1),phres%gval(1,1),phres%gval(2,1),& ! phres%gval(3,1),phres%gval(4,1),kvot ! we should be careful with numeric overflow, for small T or large T ! no risk for overflow for exp(-kvot) if(kvot.gt.1.0D2) then ! T is very small, kvot very large, exp(kvot) may cause overflow, ! exp(-kvot) is very small, ln(1-exp(-kvot)) is close to zero ! exp(kvot) may cause overflow, kvot/(exp(kvot)-1)= ! kvot*exp(-kvot)/(1-exp(-kvot)) = (1-kvot+kvot**2/2-...)/(1-kvot/2+...) = 1 extreme=-1 ! kvotexpkvotm1=one expmkvot=zero kvotexpkvotm1=zero ln1mexpkvot=zero elseif(kvot.lt.1.0D-2) then ! T is very big, kvot is very small, exp(-kvot) approch 1, 1-exp(-kvot)=kvot ! exp(-kvot) is close unity, ln(1-exp(-kvot))=ln(1-(1-kvot+kvot**2/2+...)) = ! ln(kvot-kvot**2/2+...)=ln(kvot) ! exp(kvot) is close to unity: exp(kvot)-1 = kvot+kvot**2/2+ ... extreme=1 expmkvot=exp(-kvot) kvotexpkvotm1=kvot/(exp(kvot)-one) ln1mexpkvot=log(one-expmkvot) else ! normal range of T and kvot extreme=0 expmkvot=exp(-kvot) kvotexpkvotm1=kvot/(exp(kvot)-one) ln1mexpkvot=log(one-expmkvot) endif ! ! The Delta Cp value is given in phres%gval(1,jth) It can be negative! ! and it can depend on P and composition !! NOT IMPLEMENTED !! BEWHERE ! In normal Einstein deltacp=3.0 deltacp=phres%gval(1,jth) gein=deltacp*ln1mexpkvot ! write(*,71)'3H Cp E1:',extreme,ceq%tpval(1),gein,ln1mexpkvot,expmkvot,& ! kvotexpkvotm1 ! first derivative wrt T taking care of overflow dgeindt=deltacp*(ln1mexpkvot-kvotexpkvotm1)/ceq%tpval(1) ! This is d2G/dT**2/(RT) = -T**2/R*(Einstein Cp/RT) (or rather Cv/RT) if(extreme.eq.-1) then ! take care of overflow at low T, kvotexpkvotm1=expmkvot=0 set above d2geindt2=zero else d2geindt2=-deltacp*kvotexpkvotm1**2/(expmkvot*ceq%tpval(1)**2) endif ! write(*,16)'3H 2nd Einstein: ',kvot,deltacp,d2geindt2 16 format(a,6(1pe12.4)) ! check if addition is per mole if(btest(addrec%status,ADDPERMOL)) then addpermole=.TRUE.; msize=phres%abnorm(1) ! write(*,'(a,i4,l2,1pe12.4)')'3H msize 2ndein: ',lokph,addpermole,msize else addpermole=.FALSE.; msize=one endif ! first derivative for each constituent. The parameter value is ln(theta) ! and we should divide by RT fact=deltacp*kvotexpkvotm1 do j1=1,mc phres%dgval(1,j1,1)=phres%dgval(1,j1,1)+fact*phres%dgval(1,j1,ith) enddo ! return the values in phres%gval(*,1) phres%gval(1,1)=phres%gval(1,1)+msize*gein phres%gval(2,1)=phres%gval(2,1)+msize*dgeindt ! phres%gval(3,1)=phres%gval(3,1) phres%gval(4,1)=phres%gval(4,1)+msize*d2geindt2 ! phres%gval(5,1)=phres%gval(5,1) ! phres%gval(6,1)=phres%gval(6,1) addrec%propval(1)=msize*gein addrec%propval(2)=msize*dgeindt addrec%propval(4)=msize*d2geindt2 ! write(*,70)'3H Cp E3: ',ceq%tpval(1),gein,dgeindt,d2geindt2 70 format(a,F7.2,5(1pe12.4)) 71 format(a,i3,1x,F7.2,5(1pe12.4)) ! ! Missing implem of derivatives wrt comp.dep of tht2 and dcp2. ! Neither tht2 nor dcp2 can depend on T ! 1000 continue return end subroutine calc_secondeinstein !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine create_twostate_model1 !\begin{verbatim} subroutine create_twostate_model1(addrec) ! newadd is location where pointer to new addition record should be stored implicit none type(gtp_phase_add), pointer :: addrec !\end{verbatim} %+ integer typty ! this is bad programming as it cannot be deallocated but it will never be ... ! maybe pointers can be deallocated? allocate(addrec) addrec%status=0 ! nullify pointer to next addition nullify(addrec%nextadd) !----------------------------- ! The model consists of two contributions ! The first is the harmonic vibrations of an ideal amprthous phase ! this requires a THETA representing the Einstein T ! The second is a term - RT*(1+exp(G2/RT)) ! which represent the change from "solid like" to "liquid like" !----------------------------- ! I am not sure what this is used for addrecs=addrecs+1 addrec%addrecno=addrecs ! property needed allocate(addrec%need_property(2)) call need_propertyid('G2 ',typty) addrec%need_property(1)=typty ! call need_propertyid('THET ',typty) call need_propertyid('LNTH ',typty) addrec%need_property(2)=typty ! type of addition addrec%type=twostatemodel1 ! store zero. Used to extract current value of this property addrec%propval=zero 1000 continue ! write(*,*)'Created two state liquid record' return end subroutine create_twostate_model1 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine create_newtwostate_model1 !\begin{verbatim} subroutine create_newtwostate_model1(addrec) ! newadd is location where pointer to new addition record should be stored implicit none type(gtp_phase_add), pointer :: addrec !\end{verbatim} %+ integer typty ! this is bad programming as it cannot be deallocated but it will never be ... ! maybe pointers can be deallocated? allocate(addrec) ! nullify pointer to next addition nullify(addrec%nextadd) addrec%status=0 !----------------------------- ! The model consists of two contributions ! The first is the harmonic vibrations of an ideal amprthous phase ! this requires a THETA representing the Einstein T ! The second is a term - RT*(1+exp(G2/RT)) ! which represent the change from "solid like" to "liquid like" !----------------------------- ! I am not sure what this is used for addrecs=addrecs+1 addrec%addrecno=addrecs ! property needed G2 is not needed as composition independent allocate(addrec%need_property(1)) ! call need_propertyid('G2 ',typty) ! addrec%need_property(1)=typty ! call need_propertyid('THETA ',typty) call need_propertyid('LNTH ',typty) addrec%need_property(1)=typty ! type of addition this is 12 addrec%type=twostatemodel2 ! store zero. Used to extract current value of this property addrec%propval=zero 1000 continue ! write(*,*)'Created two state liquid record ',twostatemodel2 return end subroutine create_newtwostate_model1 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_twostate_model_john !\begin{verbatim} subroutine calc_twostate_model_john(moded,phres,addrec,lokph,mc,ceq) ! subroutine calc_twostate_model1(moded,phres,addrec,lokph,mc,ceq) ! CURRENTLY NOT USED ! This routine works OK but I am testing a modification ! moded is 0, 1 or 2 if no, first or 2nd order derivatives should be calculated ! addrec is addition record ! phres is phase_varres record ! lokph is phase location ! mc is number of constitution fractions ! ceq is current equilibrium record implicit none integer moded,lokph,mc TYPE(GTP_PHASE_ADD), pointer :: addrec TYPE(GTP_PHASE_VARRES), pointer :: phres TYPE(GTP_EQUILIBRIUM_DATA), pointer :: ceq !\end{verbatim} %+ ! two state model for extrapolating liquid to low T ! DG = d(H-RT) + RT( dln(d)+(1-d)ln(1-d)) ! where d is "liquid like" atoms. H is enthalpy to form defects ! At equilibrium ! ! d = exp(-H/RT) / (1 + e(-H/RT) ) is the integrated Einstein Cp -H/R is THET ! ! G^liq - G^amorph = G^amorph - RT ln(1+exp(-DG_d/RT) ! DG_d is the enthalpy of forming 1 mole of defects in the glassy state ! !------------------------------ ! The value of Gd for the phase is calculated and added to G integer jj,noprop,ig2,ith,extreme,jth,kth ! double precision del1,del2,del3,del4,gein,dgeindt,d2geindt2 double precision gein,dgeindt,d2geindt2 double precision g2ein,dg2eindt,d2g2eindt2,theta2,dcpl double precision kvot,expkvot,expmkvot,ln1mexpkvot,kvotexpkvotm1 double precision g2val,dg2,expg2,expmg2,rt,tv,rg,dg2dt,dgfdt,d2g2dt2 double precision expmg2p1,msize logical addpermole ! This is Johns original model write(*,*)'3H THIS VERSION OF TWOSTATE MODEL SHOULD NOT BE USED!' stop ! number of properties calculatied noprop=phres%listprop(1)-1 ! locate the THET and G2 property record ig2=0 ith=0 jth=0 kth=0 ! check if addition is per mole if(btest(addrec%status,ADDPERMOL)) then addpermole=.TRUE.; msize=phres%abnorm(1) ! write(*,'(a,i4,l2,1pe12.4)')'3H msize john: ',lokph,addpermole,msize else addpermole=.FALSE.; msize=one endif findix: do jj=2,noprop if(phres%listprop(jj).eq.addrec%need_property(1)) then ! current values of G2 is stored in phres%gval(1,ig2) ig2=jj; elseif(phres%listprop(jj).eq.addrec%need_property(2)) then ! current value of THET are stored in phres%gval(1,ith) ith=jj ! SECOND EINSTEIN CP CONTRBUTION ADDED SEPARATELY ! elseif(phres%listprop(jj).eq.14) then ! current value of LIQUID THET are stored in with index 14 VISC ! jth=jj ! theta2=exp(phres%gval(1,jth)) ! write(*,*)'3H found liquid theta: ',theta2 ! elseif(phres%listprop(jj).eq.27) then ! current value of LIQUID THET are stored in with index 14 VISC ! kth=jj ! dcpl=phres%gval(1,kth) ! write(*,*)'3H found liquid delta-cp: ',dcpl endif enddo findix if(ith.eq.0) then ! write(*,*)'3H Cannot find value for amorphous THET' write(*,*)'3H warning no values for amorphous LNTH' gein=zero; dgeindt=zero; d2geindt2=zero goto 300 ! gx%bmperr=4367; goto 1000 endif !---------------------------------- ! for the moment the composition dependence is ignored ! write(*,19)'3H 2no1: ',phres%gval(1,1),phres%gval(2,1),phres%gval(4,1) !------ this THET part copied from calc_einstein ! thet is in gval(1,ith), derivatives in dgval(*,ith,*) and d2gval(ith,*) ! G/RT = 1.5*THET/T + 3*R*LN(exp(THET/T) - 1) ! NOTE ALL VALUES CALCULATED AS FOR G/RT ! kvot=theta/T ! NOTE the stored value is ln(theta)! !!! kvot=exp(phres%gval(1,ith))/ceq%tpval(1) ! write(*,70)'3H phres: ',ceq%tpval(1),phres%gval(1,1),phres%gval(2,1),& ! phres%gval(3,1),phres%gval(4,1),kvot ! we should be careful with numeric overflow, for small T or large T ! no risk for overflow for exp(-kvot) ! expmkvot=exp(-kvot) ! ln1mexpkvot=log(one-expmkvot) if(kvot.gt.1.0D2) then ! T is very small, kvot very large, exp(kvot) may cause overflow, ! exp(-kvot) is very small, ln(1-exp(-kvot)) is close to zero ! exp(kvot) may cause overflow, kvot/(exp(kvot)-1)= ! kvot*exp(-kvot)/(1-exp(-kvot)) = (1-kvot+kvot**2/2-...)/(1-kvot/2+...) = 1 extreme=-1 expmkvot=zero ln1mexpkvot=zero kvotexpkvotm1=zero elseif(kvot.lt.1.0D-2) then ! T is very big, kvot is very small, exp(-kvot) approch 1, 1-exp(-kvot)=kvot ! exp(-kvot) is close unity, ln(1-exp(-kvot))=ln(1-(1-kvot+kvot**2/2+...)) = ! ln(kvot-kvot**2/2+...)=ln(kvot) ! exp(kvot) is close to unity: exp(kvot)-1 = kvot+kvot**2/2+ ... extreme=1 expmkvot=exp(-kvot) ln1mexpkvot=log(one-expmkvot) kvotexpkvotm1=kvot/(exp(kvot)-one) else ! normal range of T and kvot extreme=0 expmkvot=exp(-kvot) ln1mexpkvot=log(one-expmkvot) kvotexpkvotm1=kvot/(exp(kvot)-one) endif ! gein=1.5D0*kvot+3.0D0*ln1mexpkvot ! write(*,71)'3H Cp E1:',extreme,ceq%tpval(1),gein,ln1mexpkvot,expmkvot,& ! kvotexpkvotm1 ! first derivative wrt T taking care of overflow dgeindt=3.0D0*(ln1mexpkvot-kvotexpkvotm1)/ceq%tpval(1) ! This is d2G/dT**2/(RT) = -T**2/R*(Einstein Cp/RT) (or rather Cv/RT) if(extreme.eq.-1) then ! take care of overflow at low T d2geindt2=zero else d2geindt2=-3.0D0*kvotexpkvotm1**2/(expmkvot*ceq%tpval(1)**2) endif ! return the values in phres%gval(*,1) phres%gval(1,1)=phres%gval(1,1)+msize*gein phres%gval(2,1)=phres%gval(2,1)+msize*dgeindt ! phres%gval(3,1)=phres%gval(3,1) phres%gval(4,1)=phres%gval(4,1)+msize*d2geindt2 ! ! ????????????????????????????? ! ! NO DERIVATIVES WITH RESPECT TO FRACTIONS ?????????????????? ! ! ????????????????????????????? ! ! phres%gval(5,1)=phres%gval(5,1) ! phres%gval(6,1)=phres%gval(6,1) ! addrec%propval(1)=gein ! addrec%propval(2)=dgeindt ! addrec%propval(4)=d2geindt2 ! write(*,71)'3H Cp E3: ',extreme,ceq%tpval(1),gein,dgeindt,d2geindt2 70 format(a,F7.2,5(1pe12.4)) 71 format(a,i3,1x,F7.2,5(1pe12.4)) ! thet cannot depend on T ! Missing implementation of derivatives wrt comp.dep of thet. tv=ceq%tpval(1) !-------------------------- two state part DIVIDED BY RT ! hump was an attempt to reduce the hump due to state change entropy ! it does not seem to work ... in fact it is the same as scaling G^HT-G^LT ! ****************** This is Johns orignal model ********************* ! hump=1.0 ! Jump here if no Einstein solid 300 continue if(ig2.eq.0) then write(*,*)'Cannot find value for G2 two-state parameter' gx%bmperr=4367; goto 1000 endif ! NOTE g2val and derivatives in phres%gval(..) are not divided by RT !! g2val=phres%gval(1,ig2); dg2dt=phres%gval(2,ig2) dg2=zero; d2g2dt2=zero if(g2val.eq.zero .and. dg2dt.eq.zero) then ! write(*,*)'3H: G2 parameter zero, ignoring bump',g2val goto 900 endif ! write(*,19)'3H +am ',phres%gval(1,1),phres%gval(2,1),phres%gval(4,1) 19 format(a,6(1pe11.3)) rt=ceq%rtn ! tv=ceq%tpval(1) rg=globaldata%rgas ! expmg2=exp(-g2val/rt) ! if(g2val/rt.gt.2.0D2) then ! expmg2=exp(-g2val/(rt)) ! expg2=one/expmg2 ! elseif(g2val/rt.lt.1e-30) then ! expmg2=exp(-g2val/(rt)) ! expg2=one/expmg2 ! else expmg2=exp(-g2val/(rt)) expmg2p1=expmg2+one expg2=one/expmg2 ! endif ! dg2=log(one+expmg2) dg2=log(expmg2p1) ! write(*,19)'3H G2: ',g2val/rt,expmg2,dg2,dg2*rt ! NOTE values added to gval(*,1) must be divided by RT ! G = G - RT*ln(1+exp(-g2/RT)) ! G ! phres%gval(1,1)=phres%gval(1,1)-dg2 ! (R*ln(1+g2val) + (g2/tv-dg2/dt)/(1+exp(-g2/RT)))/RT ! G.T ! dgfdt=(rg*dg2+(g2val/tv-dg2dt)/(expg2+one))/(rt) dgfdt=(rg*dg2+(g2val/tv-dg2dt)/(expg2+one))/(rt) ! phres%gval(2,1)=phres%gval(2,1)-dgfdt ! G.P is zero ! ****************** This is Johns orignal model ********************* !-------------------------- tentative: ! d2g2/dt2/(1+exp(g2/RT)+ ! ((g2/tv)**2+(dg2/dt)**2-2*g2/tv*dg2/dt)*exp(g2/rt)/((1+exp(g2/RT)))**2/rt ! G.T.T ! This what my derivation gives: ! d2g2dt2=(phres%gval(4,ig2)/(one+expg2)+& ! works after Qing checked the signs d2g2dt2=(phres%gval(4,ig2)/(one+expg2)-& ((g2val/tv)**2+(dg2dt)**2-2.0D0*(g2val/tv)*dg2dt)*expg2/& (rt*(one+expg2)**2))/rt ! phres%gval(4,1)=phres%gval(4,1)+d2g2dt2 ! Maybe the error is here !! YES now it works! ! phres%gval(4,1)=phres%gval(4,1)-d2g2dt2 ! write(*,19)'3H dg2A: ',tv, g2val/rt, one/(one+expg2),& ! -rg*tv**2*phres%gval(4,1),& ! -rg*tv**2*d2g2dt2, ! The Eistein contribution is OK ! -rg*tv**2*d2geindt2 ! -rg*tv*phres%gval(4,ig2)/(one+expg2),& ! -rg*tv*((g2val/tv)**2+(dg2dt)**2-2.0D0*(g2val/tv)*dg2dt)*expg2/& ! (rt*(one+expg2)**2) ! write(*,19)'3H dg2B: ',phres%gval(4,ig2)/(one+expg2),& ! (g2val/tv)**2+(dg2dt)**2-2.0D0*(g2val/tv)*dg2dt,& ! rt*(one+expg2)**2 ! G.T.P is zero ! G.P.P is zero 800 continue phres%gval(1,1)=phres%gval(1,1)-msize*dg2 phres%gval(2,1)=phres%gval(2,1)-msize*dgfdt phres%gval(4,1)=phres%gval(4,1)+msize*d2g2dt2 ! ! ! write(*,19)'3H 2st:',phres%gval(1,1),phres%gval(2,1),phres%gval(4,1) ! save local values divided by RT? ! THIS ROUTINE CURRENTLY NOT USED <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 900 continue addrec%propval=zero addrec%propval(1)=msize*(gein-dg2) addrec%propval(2)=msize*(dgeindt-dgfdt) addrec%propval(4)=msize*(d2geindt2-d2g2dt2) 1000 continue write(*,*)'3H YOU ARE USING WRONG LIQUID TWOSTATE MODEL' return end subroutine calc_twostate_model_john !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_twostate_model1 !\begin{verbatim} subroutine calc_twostate_model1(moded,phres,addrec,lokph,mc,ceq) ! this routine is used when G2 and LNTH are composition dependent ! subroutine calc_twostate_modelny(moded,phres,addrec,lokph,mc,ceq) ! The routine _john works OK but I am testing a modification ! moded is 0, 1 or 2 if no, first or 2nd order derivatives should be calculated ! addrec is addition record ! phres is phase_varres record ! lokph is phase location ! mc is number of constitution fractions ! ceq is current equilibrium record implicit none integer moded,lokph,mc TYPE(GTP_PHASE_ADD), pointer :: addrec TYPE(GTP_PHASE_VARRES), pointer :: phres TYPE(GTP_EQUILIBRIUM_DATA), pointer :: ceq !\end{verbatim} %+ ! two state model for extrapolating liquid to low T ! DG = d(H-RT) + RT( dln(d)+(1-d)ln(1-d)) ! where d is "liquid like" atoms. H is enthalpy to form defects ! At equilibrium ! ! d = exp(-H/RT) / (1 + e(-H/RT) ) is the integrated Einstein Cp -H/R is THET ! ! G^liq - G^amorph = G^amorph - RT ln(1+exp(-DG_d/RT) ! DG_d is the enthalpy of forming 1 mole of defects in the glassy state ! !------------------------------ ! The value of Gd for the phase is calculated and added to G integer jj,noprop,ig2,ith,extreme,jth,kth ! double precision del1,del2,del3,del4,gein,dgeindt,d2geindt2 double precision gein,dgeindt,d2geindt2 double precision xi,hump double precision, parameter :: humpfact=5.0D0 logical addpermole ! double precision g2ein,dg2eindt,d2g2eindt2,theta2,dcpl double precision kvot,expkvot,expmkvot,ln1mexpkvot,kvotexpkvotm1 double precision g2val,dg2,expg2,expmg2,rt,tv,rg,dg2dt,dgfdt,d2g2dt2 double precision expmg2p1,fact,g2sum,msize,fact2 double precision, allocatable :: mux(:) integer, save :: maxwarnings=0 ! number of properties calculatied noprop=phres%listprop(1)-1 ! locate the THET and G2 property record ig2=0 ith=0 jth=0 ! check if addition is per mole if(btest(addrec%status,ADDPERMOL)) then addpermole=.TRUE.; msize=phres%abnorm(1) ! write(*,'(a,i4,l2,1pe12.4)')'3H msize 2-state: ',lokph,addpermole,msize else addpermole=.FALSE.; msize=one endif findix: do jj=2,noprop if(phres%listprop(jj).eq.addrec%need_property(1)) then ! current values of G2 is stored in phres%gval(1,ig2) ig2=jj; elseif(phres%listprop(jj).eq.addrec%need_property(2)) then ! current value of LNTH are stored in phres%gval(1,ith) ith=jj ! elseif(phres%listprop(jj).eq.22) then ! current value of DCP2 are stored in phres%gval(1,ith) ! jth=jj endif enddo findix if(ith.eq.0) then ! write(*,*)'3H Cannot find value for amorphous LNTH' if(maxwarnings.lt.20) then maxwarnings=maxwarnings+1 write(*,*)'3H twostatemodel1 no values for amorphous LNTH:',maxwarnings endif gein=zero; dgeindt=zero; d2geindt2=zero goto 300 ! gx%bmperr=4367; goto 1000 endif if(ig2.eq.0) then write(*,*)'3H twostate_model1 Cannot find G2 two-state parameter' gx%bmperr=4367; goto 1000 endif !---------------------------------- ! for the moment the composition dependence is ignored ! write(*,19)'3H 2no1: ',phres%gval(1,1),phres%gval(2,1),phres%gval(4,1) !------ this THET part copied from calc_einstein ! thet is in gval(1,ith), derivatives in dgval(*,ith,*) and d2gval(ith,*) ! G/RT = 1.5*THET/T + 3*R*LN(exp(THET/T) - 1) ! NOTE ALL VALUES CALCULATED AS FOR G/RT ! kvot=theta/T ! NOTE the stored value is ln(theta! !!! kvot=exp(phres%gval(1,ith))/ceq%tpval(1) ! write(*,70)'3H phres: ',ceq%tpval(1),phres%gval(1,1),phres%gval(2,1),& ! phres%gval(3,1),phres%gval(4,1),kvot ! we should be careful with numeric overflow, for small T or large T ! no risk for overflow for exp(-kvot) ! expmkvot=exp(-kvot) ! ln1mexpkvot=log(one-expmkvot) if(kvot.gt.1.0D2) then ! T is very small, kvot very large, exp(kvot) may cause overflow, ! exp(-kvot) is very small, ln(1-exp(-kvot)) is close to zero ! exp(kvot) may cause overflow, kvot/(exp(kvot)-1)= ! kvot*exp(-kvot)/(1-exp(-kvot)) = (1-kvot+kvot**2/2-...)/(1-kvot/2+...) = 1 extreme=-1 expmkvot=zero ln1mexpkvot=zero kvotexpkvotm1=zero elseif(kvot.lt.1.0D-2) then ! T is very big, kvot is very small, exp(-kvot) approch 1, 1-exp(-kvot)=kvot ! exp(-kvot) is close unity, ln(1-exp(-kvot))=ln(1-(1-kvot+kvot**2/2+...)) = ! ln(kvot-kvot**2/2+...)=ln(kvot) ! exp(kvot) is close to unity: exp(kvot)-1 = kvot+kvot**2/2+ ... extreme=1 expmkvot=exp(-kvot) ln1mexpkvot=log(one-expmkvot) kvotexpkvotm1=kvot/(exp(kvot)-one) else ! normal range of T and kvot extreme=0 expmkvot=exp(-kvot) ln1mexpkvot=log(one-expmkvot) kvotexpkvotm1=kvot/(exp(kvot)-one) endif ! gein=1.5D0*kvot+3.0D0*ln1mexpkvot ! write(*,71)'3H Cp E1:',extreme,ceq%tpval(1),gein,ln1mexpkvot,expmkvot,& ! kvotexpkvotm1 ! first derivative wrt T taking care of overflow dgeindt=3.0D0*(ln1mexpkvot-kvotexpkvotm1)/ceq%tpval(1) ! This is d2G/dT**2/(RT) = -T**2/R*(Einstein Cp/RT) (or rather Cv/RT) if(extreme.eq.-1) then ! take care of overflow at low T d2geindt2=zero else d2geindt2=-3.0D0*kvotexpkvotm1**2/(expmkvot*ceq%tpval(1)**2) endif ! composition variable Variable LNTH fact=1.5D0*(one+expmkvot)/(one-expmkvot)*kvot ! the curve below better, correct shape ... do jj=1,mc phres%dgval(1,jj,1)=msize*(phres%dgval(1,jj,1)+fact*phres%dgval(1,jj,ith)) enddo !-------------------------- jump here if no LNTH variable ! return the values in phres%gval(*,1) 300 continue phres%gval(1,1)=phres%gval(1,1)+msize*gein phres%gval(2,1)=phres%gval(2,1)+msize*dgeindt ! phres%gval(3,1)=phres%gval(3,1) phres%gval(4,1)=phres%gval(4,1)+msize*d2geindt2 ! phres%gval(5,1)=phres%gval(5,1) ! phres%gval(6,1)=phres%gval(6,1) ! write(*,71)'3H Cp E3: ',extreme,ceq%tpval(1),gein,dgeindt,d2geindt2 70 format(a,F7.2,5(1pe12.4)) 71 format(a,i3,1x,F7.2,5(1pe12.4)) ! thet cannot depend on T ! include the composition dependence of the eistein contribution? DONE ABOVE ! End of Einstein part !---------------------------------------------------------------- ! write(*,*)'3H calc_twostate_model1 not including composition dependence thet' !-------------------------- two state part DIVIDE BY RT ! NOTE the values in phres%gval(1,ig2), phres%dgval(1,jj,ig2) ! are not divided by T. ! rt=ceq%rtn tv=ceq%tpval(1) rg=globaldata%rgas g2val=phres%gval(1,ig2); dg2dt=phres%gval(2,ig2) dg2=zero; d2g2dt2=zero; expmg2=zero ! write(*,*)'3H gval1: ',g2val if(g2val.eq.zero .and. dg2dt.eq.zero) then write(*,*)'3H: G2 parameter zero, ignoring 2-state model' goto 900 endif d2g2dt2=phres%gval(4,ig2) goto 600 !------------------------------------------ 600 continue ! if g2val is positive we are in the amorphous region ! if g2val is negative we are in the liquid region ! The if statements here ensure expmg2 is between 1e-60 and 1e+60 ! write(*,'(a,6(1pe12.4))')'3H g2val: ',g2val,dg2dt,-g2val/rt if(-g2val/rt.gt.2.0D2) then ! LIQUID REGION exp(200) >> 1, thus d2g=ln(1+exp(g2val))=g2val ! and the derivatives are those above. DIVIDED BY RT? dg2=g2val/rt dgfdt=dg2dt/rt d2g2dt2=d2g2dt2/rt goto 700 elseif(-g2val/rt.lt.-2.0D2) then ! Low T AMORPHOUS REGION: exp(-200)=0; ln(1)=0 and everything is zero dg2=zero dg2dt=zero d2g2dt2=zero goto 900 else ! intermediate T range, we have to calculate, exp( -200 to +200) is OK expmg2=exp(-g2val/rt) expg2=one/expmg2 expmg2p1=expmg2+one dg2=log(expmg2p1) ! write(*,'(a,4(1pe12.4))')'3H intermed: ',phres%gval(1,ig2),& ! g2val/rt,expmg2p1,dg2 endif ! write(*,19)'3H gval8: ',g2val/rt,expmg2,dg2 ! write(*,19)'3H dg2: ',tv,g2val,expmg2,dg2 ! write(*,19)'3H G2: ',tv,xi,g2val/rt,expmg2,dg2,dg2*rt ! NOTE values added to phres%gval(*,1) must be divided by RT ! G = G - RT*ln(1+exp(-g2/RT)) ! G ! phres%gval(1,1)=phres%gval(1,1)-dg2 ! (R*ln(1+g2val) + (g2/tv-dg2/dt)/(1+exp(-g2/RT)))/RT ! G.T dgfdt=(rg*dg2+(g2val/tv-dg2dt)/(expg2+one))/rt ! dgfdt=dg2+(g2val/tv-dg2dt)/(expg2+one) ! G.P is zero !-------------------------- tentative: ! d2g2/dt2/(1+exp(g2/RT)+ ! ((g2/tv)**2+(dg2/dt)**2-2*g2/tv*dg2/dt)*exp(g2/rt)/((1+exp(g2/RT)))**2/rt ! G.T.T ! Fixed sign problem ! d2g2dt2=(phres%gval(4,ig2)/(one+expg2)-& d2g2dt2=(d2g2dt2/(one+expg2)-& ((g2val/tv)**2+(dg2dt)**2-2.0D0*(g2val/tv)*dg2dt)*expg2/& (rt*(one+expg2)**2))/rt 700 continue ! write(*,705)'3H 2SL: ',g2val/rt, dg2, dgfdt, dgfdt, d2g2dt2, tv,& ! rt, expg2, dg2dt, msize, d2g2dt2*rt 705 format(a,6(1pe12.4)/8x,6(1pe12.4)) ! THIS IS THE SUBROUTINE USED FOR 2STATE LIQUID with composition dependent GD ! This should be OK/ 2020.02.27 phres%gval(1,1)=phres%gval(1,1)-msize*dg2 phres%gval(2,1)=phres%gval(2,1)-msize*dgfdt phres%gval(4,1)=phres%gval(4,1)+msize*d2g2dt2 ! values of T, \xi, g, s and cp ! ! ADDING DERIVATIVES WITH RESPECT TO FRACTIONS !!!!!!!!!!! ! fact=expmg2/(expmg2+one)/rt fact2=(fact/rt)**2/expmg2*phres%gval(2,ig2) ! write(*,*)'3H calculating twostatemodel, wrong dg/dy?',fact2 do jj=1,mc phres%dgval(1,jj,1)=phres%dgval(1,jj,1)+fact*phres%dgval(1,jj,ig2) ! d2(G2)/dydT ! phres%dgval(1,jj,1)=phres%dgval(2,jj,1)-fact2*phres%dgval(1,jj,ig2) ! ignore other 2nd derivatives enddo goto 900 !============================================================ !----------skipping old code below ! Searching for bug when entering G2 as a comp.dependent parameter rather ! than as a part of the pure element data. Liquid with: T=1950; x(v)=.5 ! 1. OC exactly same as TC when G2 is part of pure elements: ! G=-127282 J; a(ti)=2.9601E-4; a(v)=5.1269E-4 (SER refstate) ! 2. When modeling G2 as a separate parameter we get: ! TC: G=-127223 J; ac(ti)=2.9714E-4; ac(v)=5.1446E-4; <<<<<<<<<<<< ! OC: G=-127223 J; ac(ti)=3.3896E-4; ac(v)=4.5099E-4 (divided by RT) ! 3. The chemical potential wrong and give strange (wrong) phase diagram ! OC: divide by T: G=-127223 J; ac(ti)=2.9714E-4; ac(v)=5.1446E-4 WoW ! but the phase diagram still wrong, not same composition at BCC/LIQ minimum!! ! BCC is identical in TC and OC, no problem with Einstein ! 4. Calculating liquid at T=1920; x(v)=.1 gives different results: ! TC: G=-122239 J; ac(ti)=5.4656E-4; ac(v)=1.2773E-4 ! OC: G=-122239 J; ac(ti)=5.2677E-4; ac(v)=1.7801E-4 ! T=1900, x(v)=.1 (for BCC!!) ! TC: G=-120324 J; ac(ti)=5.6252E-4; ac(v)=1.4795E-4 BCC! DGM(liq)=-4.49E-3 ! OC: G=-120324 J; ac(ti)=5.6252E-4; ac(v)=1.4795E-4 BCC! DGM(liq)=-1.02E-2 ! T=1910, x(v)=.1 (TC gives 2-phase equil, BCC+LIQ, OC just BCC) ! 5. After some more changes (introducing msize mm) which should NOT change ! the result, it is bad again ... SUCK ! OC: divide by T: G=-127223 J; ac(ti)=2.5623E-4; ac(v)=5.9662E-4 ! does some variable have random a value?? BCC stable at this calc ! OC: divide by RT: G=-127223 J; ac(ti)=3.3896E-4; ac(v)=4.5099E-4 (as above) ! mulip with 0.5/T: G=-127223 J; ac(ti)=3.0040E-4; ac(v)=5.0889E-4 ! muli with 0.52/T: G=-127223 J; ac(ti)=2.9849E-4; ac(v)=5.1214E-4 ! muli with 0.53/T: G=-127223 J; ac(ti)=2.9754E-4; ac(v)=5.1377E-4 ! this also gave reasonable phase diagram!! ! mul with 0.533/T: G=-127223 J; ac(ti)=2.9726E-4; ac(v)=5.1426E-4 ! mu with 0.5335/T: G=-127223 J; ac(ti)=2.9721E-4; ac(v)=5.1434E-4 ! mu with 0.5338/T: G=-127223 J; ac(ti)=2.9818E-4; ac(v)=5.1439E-4 ! mul with 0.534/T: G=-127223 J; ac(ti)=2.9717E-4; ac(v)=5.1442E-4 ! mu with 0.5342/T: G=-127223 J; ac(ti)=2.9715E-4; ac(v)=5.1446E-4 ! phase diagram correct with multiplied factor with 0.534... Wow, why? ! correct: G=-127223 J; ac(ti)=2.9714E-4; ac(v)=5.1446E-4 ! muli with 0.54/T: G=-127223 J; ac(ti)=2.9660E-4; ac(v)=5.1541E-4 !--------------------------------------------- ! COMPLETELY NONSCIENTIFIC ... ENGINEERING !--------------------------------------------- ! the factor /rt because phres%dgval(1,jj,ig2) is not divided by RT ! fact=expmg2/(expmg2+one)/rt ! no RT?? No, activites zero ! fact=expmg2/(expmg2+one) !>>>>>>>>>>>>>> this factor 0.5336 gives correct chemical potentials fact=0.5342D0*msize*expmg2/(expmg2+one)/tv !>>>>>>>>>>>>>> but I do not understad why ! fact=msize*expmg2/(expmg2+one)/rt ! sign?? - no good; ! fact=10*expmg2/(expmg2+one)/rt !! fact=10*expmg2/(expmg2+one)/rt ! fact=1.2E0*expmg2/(expmg2+one)/tv ! write(*,'(a,6(1pe12.4))')'3H missing dg2/dy: ',expmg2,tv,msize,fact ! temporary debug ...; calculate contribution to chemical potential ! allocate(mux(mc)) ! mux=zero g2sum=dg2 do jj=1,mc ! check than x1*mu1+x2*mu2=g ! g2sum=g2sum-phres%yfr(jj)*fact*phres%dgval(1,jj,ig2) ! in dgval(i,j,k) index i=1 means d/y; 2 means d2/dydT, 3 means d2/dydP ! index j is constituent; index k is property, k=1 is G ! write(*,710)ig2,jj,phres%dgval(1,jj,1),phres%dgval(1,jj,ig2)/rt,& ! fact*phres%dgval(1,jj,ig2),& ! phres%dgval(1,jj,1)+fact*phres%dgval(1,jj,ig2),phres%yfr(jj) ! phres%dgval(2,jj,1),phres%dgval(2,jj,ig2)/rt,& ! phres%dgval(2,jj,1)+fact*phres%dgval(2,jj,ig2) 710 format('3H G2: ',2i2,6(1pe11.3)) phres%dgval(1,jj,1)=phres%dgval(1,jj,1)+fact*phres%dgval(1,jj,ig2) phres%dgval(2,jj,1)=phres%dgval(2,jj,1)+fact*phres%dgval(2,jj,ig2) enddo ! do jj=1,mc ! mux(jj)=g2sum+fact*phres%dgval(1,jj,ig2) ! enddo! These should be the same! ! g2sum=zero ! do jj=1,mc ! g2sum=g2sum+phres%yfr(jj)*mux(jj) ! enddo ! write(*,*)'3H same?: ',dg2,g2sum 800 continue ! write(*,19)'3H G9: ',tv,hump,dg2*rt,-dgfdt*rt,-d2g2dt2*rt*tv ! phres%gval(4,1)=phres%gval(4,1)-d2g2dt2 ! write(*,19)'3H dg2A: ',tv, g2val/rt, one/(one+expg2),& ! -rg*tv**2*phres%gval(4,1),& ! -rg*tv**2*d2g2dt2, ! The Eistein contribution is OK ! -rg*tv**2*d2geindt2 ! -rg*tv*phres%gval(4,ig2)/(one+expg2),& ! -rg*tv*((g2val/tv)**2+(dg2dt)**2-2.0D0*(g2val/tv)*dg2dt)*expg2/& ! (rt*(one+expg2)**2) ! write(*,19)'3H dg2B: ',phres%gval(4,ig2)/(one+expg2),& ! (g2val/tv)**2+(dg2dt)**2-2.0D0*(g2val/tv)*dg2dt,& ! rt*(one+expg2)**2 ! G.T.P is zero ! G.P.P is zero ! write(*,19)'3H 2st:',phres%gval(1,1),phres%gval(2,1),phres%gval(4,1) ! jump here skipping old code above !============================================================ ! save Einstein and G2 values in addrec, multiply with RT? 900 continue addrec%propval=zero addrec%propval(1)=msize*(gein-dg2) addrec%propval(2)=msize*(dgeindt-dgfdt) addrec%propval(4)=msize*(d2geindt2-d2g2dt2) ! 1000 continue return ! this routine is used when G2 and LNTH are composition dependent end subroutine calc_twostate_model1 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_twostate_model2 !\begin{verbatim} subroutine calc_twostate_model2(moded,phres,addrec,lokph,mc,ceq) ! subroutine calc_twostate_model_nomix(moded,phres,addrec,lokph,mc,ceq) ! moded is 0, 1 or 2 if no, first or 2nd order derivatives should be calculated ! addrec is addition record ! ! IN THIS VERSION G2 is treated as a composition independent parameter ! thus this just handles the Einsten Cp ! NOTE Einstein LNTH should be composition dependent ! ! phres is phase_varres record ! lokph is phase location ! mc is number of constitution fractions ! ceq is current equilibrium record implicit none integer moded,lokph,mc TYPE(GTP_PHASE_ADD), pointer :: addrec TYPE(GTP_PHASE_VARRES), pointer :: phres TYPE(GTP_EQUILIBRIUM_DATA), pointer :: ceq !\end{verbatim} %+ ! two state model for extrapolating liquid to low T ! DG = d(H-RT) + RT( dln(d)+(1-d)ln(1-d)) ! where d is "liquid like" atoms. H is enthalpy to form defects ! At equilibrium ! ! d = exp(-H/RT) / (1 + e(-H/RT) ) is the integrated Einstein Cp -H/R is THET ! ! G^liq - G^amorph = G^amorph - RT ln(1+exp(-DG_d/RT) ! DG_d is the enthalpy of forming 1 mole of defects in the glassy state ! !------------------------------ ! The value of Gd for the phase is calculated and added to G integer jj,noprop,ig2,ith,extreme,jth,kth ! double precision del1,del2,del3,del4,gein,dgeindt,d2geindt2 double precision gein,dgeindt,d2geindt2 double precision xi,hump double precision, parameter :: humpfact=5.0D0 logical addpermole ! double precision g2ein,dg2eindt,d2g2eindt2,theta2,dcpl double precision kvot,expkvot,expmkvot,ln1mexpkvot,kvotexpkvotm1 double precision g2val,dg2,expg2,expmg2,rt,tv,rg,dg2dt,dgfdt,d2g2dt2 double precision expmg2p1,fact,g2sum,msize double precision, allocatable :: mux(:) integer, save :: maxwarnings=0 ! number of properties calculatied noprop=phres%listprop(1)-1 ! locate the THET and G2 property record ig2=0 ith=0 jth=0 ! check if addition is per mole if(btest(addrec%status,ADDPERMOL)) then addpermole=.TRUE.; msize=phres%abnorm(1) ! write(*,'(a,i4,l2,1pe12.4)')'3H msize 2-state: ',lokph,addpermole,msize else addpermole=.FALSE.; msize=one endif findix: do jj=2,noprop ! start from 2 as phres%listprop(1) is always G if(phres%listprop(jj).eq.addrec%need_property(1)) then ! current value of THET are stored in phres%gval(1,ith) ith=jj endif enddo findix if(ith.eq.0) then ! write(*,*)'3H Cannot find value for amorphous LNTH' if(maxwarnings.lt.20) then maxwarnings=maxwarnings+1 write(*,*)'3H twostatemodel2 no values for amorphous LNTH:',maxwarnings endif gein=zero; dgeindt=zero; d2geindt2=zero goto 1000 ! goto 300 ! gx%bmperr=4367; goto 1000 endif ! write(*,*)'3H Using composition independent G2 values, THET=',& ! phres%gval(1,ith) ! if(ig2.eq.0) then ! write(*,*)'3H Cannot find value for G2 two-state parameter' ! gx%bmperr=4367; goto 1000 ! endif !---------------------------------- ! for the moment the composition dependence is ignored ! write(*,19)'3H 2no1: ',phres%gval(1,1),phres%gval(2,1),phres%gval(4,1) !------ this THET part copied from calc_einstein ! thet is in gval(1,ith), derivatives in dgval(*,ith,*) and d2gval(ith,*) ! G/RT = 1.5*THET/T + 3*R*LN(exp(THET/T) - 1) ! NOTE ALL VALUES CALCULATED AS FOR G/RT ! kvot=theta/T ! NOTE the stored value is ln(theta)! !!! kvot=exp(phres%gval(1,ith))/ceq%tpval(1) ! write(*,70)'3H phres: ',ceq%tpval(1),phres%gval(1,1),phres%gval(2,1),& ! phres%gval(3,1),phres%gval(4,1),kvot ! we should be careful with numeric overflow, for small T or large T ! no risk for overflow for exp(-kvot) ! expmkvot=exp(-kvot) ! ln1mexpkvot=log(one-expmkvot) if(kvot.gt.1.0D2) then ! T is very small, kvot very large, exp(kvot) may cause overflow, ! exp(-kvot) is very small, ln(1-exp(-kvot)) is close to zero ! exp(kvot) may cause overflow, kvot/(exp(kvot)-1)= ! kvot*exp(-kvot)/(1-exp(-kvot)) = (1-kvot+kvot**2/2-...)/(1-kvot/2+...) = 1 extreme=-1 expmkvot=zero ln1mexpkvot=zero kvotexpkvotm1=zero elseif(kvot.lt.1.0D-2) then ! T is very big, kvot is very small, exp(-kvot) approch 1, 1-exp(-kvot)=kvot ! exp(-kvot) is close unity, ln(1-exp(-kvot))=ln(1-(1-kvot+kvot**2/2+...)) = ! ln(kvot-kvot**2/2+...)=ln(kvot) ! exp(kvot) is close to unity: exp(kvot)-1 = kvot+kvot**2/2+ ... extreme=1 expmkvot=exp(-kvot) ln1mexpkvot=log(one-expmkvot) kvotexpkvotm1=kvot/(exp(kvot)-one) else ! normal range of T and kvot extreme=0 expmkvot=exp(-kvot) ln1mexpkvot=log(one-expmkvot) kvotexpkvotm1=kvot/(exp(kvot)-one) endif ! gein=1.5D0*kvot+3.0D0*ln1mexpkvot ! write(*,71)'3H Cp E1:',extreme,ceq%tpval(1),gein,ln1mexpkvot,expmkvot,& ! kvotexpkvotm1 ! first derivative wrt T taking care of overflow dgeindt=3.0D0*(ln1mexpkvot-kvotexpkvotm1)/ceq%tpval(1) ! This is d2G/dT**2/(RT) = -T**2/R*(Einstein Cp/RT) (or rather Cv/RT) if(extreme.eq.-1) then ! take care of overflow at low T d2geindt2=zero else d2geindt2=-3.0D0*kvotexpkvotm1**2/(expmkvot*ceq%tpval(1)**2) endif ! derivatives with respect to composition dependence of THET fact=1.5D0*(one+expmkvot)/(one-expmkvot)*kvot do jj=1,mc phres%dgval(1,jj,1)=msize*(phres%dgval(1,jj,1)+fact*phres%dgval(1,jj,ith)) enddo ! Ignore second derivatives as this seems a small efect, !-------------------------- jump here if no THET variable ! return the values in phres%gval(*,1) 300 continue phres%gval(1,1)=phres%gval(1,1)+msize*gein phres%gval(2,1)=phres%gval(2,1)+msize*dgeindt ! phres%gval(3,1)=phres%gval(3,1) phres%gval(4,1)=phres%gval(4,1)+msize*d2geindt2 ! phres%gval(5,1)=phres%gval(5,1) ! phres%gval(6,1)=phres%gval(6,1) ! write(*,71)'3H Cp E3: ',extreme,ceq%tpval(1),gein,dgeindt,d2geindt2 70 format(a,F7.2,5(1pe12.4)) 71 format(a,i3,1x,F7.2,5(1pe12.4)) !---------------------------------------------------------------- ! skip the 2-state model as G2 included in the ^oG for the endmember ! goto 1000 1000 continue return end subroutine calc_twostate_model2 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_twostate_model_endmember !\begin{verbatim} subroutine calc_twostate_model_endmember(proprec,g2values,ceq) ! This calculated G2 (GD in some papers) for a pure endmember ! No composition dependence ! Value calculated here added to ^oG for the endmember ! moded is 0, 1 or 2 if no, first or 2nd order derivatives should be calculated ! phres is phase_varres record ! lokph is phase location ! ceq is current equilibrium record implicit none TYPE(gtp_property), pointer :: proprec TYPE(GTP_EQUILIBRIUM_DATA), pointer :: ceq double precision g2values(6) !\end{verbatim} TYPE(gtp_property), pointer :: propg2 integer lokfun,typty double precision tv,rt,rg,dg2,dgfdt,expg2,expmg2,expmg2p1 double precision g2val,dg2dt,d2g2dt2,vals(6) g2values=zero ! do not destroy the value of proprec!! propg2=>proprec ! At present %proptype 16 is G2 but can be changed anytime!! ! However, it will always be called G2 and need_property('G2 ',typty) ! will return is current index call need_propertyid('G2 ',typty) ! write(*,*)'3H found G2 typty: ',typty liq2state: do while(associated(propg2)) ! How to find addrec%need_property ....?? ! if(phres%listprop(jl).eq.addrec%need_property(1)) then ! ilpx=jl ! write(*,*)'3H property: ',propg2%proptype if(propg2%proptype.eq.typty) goto 77 propg2=>propg2%nextpr enddo liq2state write(*,*)'Missing liquid twostate parameter G2' gx%bmperr=4399; goto 1000 ! found p 77 continue ! calculate G2 value at current T for the endmember lokfun=propg2%degreelink(0) call eval_tpfun(lokfun,ceq%tpval,vals,ceq%eq_tpres) if(gx%bmperr.ne.0) goto 1000 ! write(*,'(a,3(1pe12.4))')'3H G2 endmember: ',vals(1),vals(2),vals(4) g2val=vals(1) dg2dt=vals(2) d2g2dt2=vals(4) ! rt=ceq%rtn tv=ceq%tpval(1) rg=globaldata%rgas ! if g2val is positive we are in the amorphous region ! if g2val is negative we are in the liquid region ! The if statements here ensure expmg2 is between 1e-60 and 1e+60 ! write(*,'(a,6(1pe12.4))')'3H g2val: ',g2val,dg2dt,-g2val/rt if(-g2val/rt.gt.2.0D2) then ! LIQUID REGION exp(200) >> 1, thus d2g=ln(1+exp(g2val))=g2val ! and the derivatives are those above. DIVIDED BY RT? dg2=g2val/rt dgfdt=dg2dt/rt d2g2dt2=d2g2dt2/rt goto 700 elseif(-g2val/rt.lt.-2.0D2) then ! AMORPHOUS REGION: exp(-200)=0; ln(1)=0 and everything is zero dg2=zero dg2dt=zero d2g2dt2=zero goto 700 else ! intermediate T range, we have to calculate, exp( -200 to +200) is OK expmg2=exp(-g2val/rt) expg2=one/expmg2 expmg2p1=expmg2+one dg2=log(expmg2p1) ! write(*,'(a,4(1pe12.4))')'3H intermed: ',g2val/rt,expmg2p1,dg2 endif ! write(*,19)'3H gval8: ',g2val/rt,expmg2,dg2 ! write(*,19)'3H dg2: ',tv,g2val,expmg2,dg2 ! write(*,19)'3H G2: ',tv,xi,g2val/rt,expmg2,dg2,dg2*rt ! NOTE values added to phres%gval(*,1) must be divided by RT ! G = G - RT*ln(1+exp(-g2/RT)) ! G ! phres%gval(1,1)=phres%gval(1,1)-dg2 ! (R*ln(1+g2val) + (g2/tv-dg2/dt)/(1+exp(-g2/RT)))/RT ! G.T dgfdt=(rg*dg2+(g2val/tv-dg2dt)/(expg2+one))/rt ! dgfdt=dg2+(g2val/tv-dg2dt)/(expg2+one) ! G.P is zero !-------------------------- tentative: ! d2g2/dt2/(1+exp(g2/RT)+ ! ((g2/tv)**2+(dg2/dt)**2-2*g2/tv*dg2/dt)*exp(g2/rt)/((1+exp(g2/RT)))**2/rt ! G.T.T ! Fixed sign problem ! d2g2dt2=(phres%gval(4,ig2)/(one+expg2)-& d2g2dt2=(d2g2dt2/(one+expg2)-& ((g2val/tv)**2+(dg2dt)**2-2.0D0*(g2val/tv)*dg2dt)*expg2/& (rt*(one+expg2)**2))/rt 700 continue ! return these values to be added to ^oG for the endmember ! g2values(1)=-g2val/rt g2values(1)=-dg2 ! g2values(2)=-dg2dt g2values(2)=-dgfdt g2values(4)=d2g2dt2 ! write(*,'(a,3(1pe12.4))')'3H g2values: ',g2values(1),g2values(2),g2values(4) ! No P derivatives (yet) ! write(*,705)'3H 2SL: ',g2val/rt, dg2, dgfdt, dgfdt, d2g2dt2, tv,& ! rt, expg2, dg2dt, msize, d2g2dt2*rt 705 format(a,6(1pe12.4)/8x,6(1pe12.4)) ! each endmember has its own value of G2 ! phres%gval(1,1)=phres%gval(1,1)-msize*dg2 ! phres%gval(2,1)=phres%gval(2,1)-msize*dgfdt ! phres%gval(4,1)=phres%gval(4,1)+msize*d2g2dt2 ! values of T, \xi, g, s and cp ! 1000 continue return end subroutine calc_twostate_model_endmember !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_twostate_model_old !\begin{verbatim} subroutine calc_twostate_model_old(moded,phres,addrec,lokph,mc,ceq) ! Failed attempt to decrease the hump when the g2 parameter changes sign ! moded is 0, 1 or 2 if no, first or 2nd order derivatives should be calculated ! addrec is addition record ! phres is phase_varres record ! lokph is phase location ! mc is number of constitution fractions ! ceq is current equilibrium record implicit none integer moded,lokph,mc TYPE(GTP_PHASE_ADD), pointer :: addrec TYPE(GTP_PHASE_VARRES), pointer :: phres TYPE(GTP_EQUILIBRIUM_DATA), pointer :: ceq !\end{verbatim} ! two state model for extrapolating liquid to low T ! DG = d(H-RT) + RT( dln(d)+(1-d)ln(1-d)) ! where d is "liquid like" atoms. H is enthalpy to form defects ! At equilibrium ! ! d = exp(-H/RT) / (1 + e(-H/RT) ) is the integrated Einstein Cp -H/R is THET ! ! G^liq - G^amorph = G^amorph - RT ln(1+exp(-DG_d/RT) ! DG_d is the enthalpy of forming 1 mole of defects in the glassy state ! !------------------------------ ! The value of Gd for the phase is calculated and added to G integer jj,noprop,ig2,ith,extreme,m4 ! double precision del1,del2,del3,del4,gein,dgeindt,d2geindt2 double precision gein,dgeindt,d2geindt2 double precision kvot,expkvot,expmkvot,ln1mexpkvot,kvotexpkvotm1 double precision g2val,dg2,expg2,expmg2,rt,tv,rg,dg2dt,dgfdt,d2g2dt2 double precision hump,fq,dfq,d2fq,addq,daddq,d2addq,dd ! number of properties calculatied noprop=phres%listprop(1)-1 ! locate the LNTH and G2 property record ig2=0 ith=0 findix: do jj=2,noprop if(phres%listprop(jj).eq.addrec%need_property(1)) then ! current values of G2 is stored in phres%gval(1,ig2) ig2=jj; elseif(phres%listprop(jj).eq.addrec%need_property(2)) then ! current value of THET are stored in phres%gval(1,ith) ith=jj endif enddo findix if(ith.eq.0) then write(*,*)'Cannot find value for amorphous LNTH' gx%bmperr=4399; goto 1000 endif if(ig2.eq.0) then write(*,*)'Cannot find value for G2 two-state parameter' gx%bmperr=4399; goto 1000 endif !---------------------------------- ! for the moment the composition dependence is ignored ! write(*,19)'3H 2no1: ',phres%gval(1,1),phres%gval(2,1),phres%gval(4,1) !------ this THET part copied from calc_einstein ! thet is in gval(1,ith), derivatives in dgval(*,ith,*) and d2gval(ith,*) ! G/RT = 1.5*THET/T + 3*R*LN(exp(THET/T) - 1) ! NOTE ALL VALUES CALCULATED AS FOR G/RT ! kvot=theta/T ! NOTE the stored value is ln(theta! !!! kvot=exp(phres%gval(1,ith))/ceq%tpval(1) ! write(*,70)'3H phres: ',ceq%tpval(1),phres%gval(1,1),phres%gval(2,1),& ! phres%gval(3,1),phres%gval(4,1),kvot ! we should be careful with numeric overflow, for small T or large T ! no risk for overflow for exp(-kvot) ! expmkvot=exp(-kvot) ! ln1mexpkvot=log(one-expmkvot) if(kvot.gt.1.0D2) then ! T is very small, kvot very large, exp(kvot) may cause overflow, ! exp(-kvot) is very small, ln(1-exp(-kvot)) is close to zero ! exp(kvot) may cause overflow, kvot/(exp(kvot)-1)= ! kvot*exp(-kvot)/(1-exp(-kvot)) = (1-kvot+kvot**2/2-...)/(1-kvot/2+...) = 1 extreme=-1 expmkvot=zero ln1mexpkvot=zero kvotexpkvotm1=zero elseif(kvot.lt.1.0D-2) then ! T is very big, kvot is very small, exp(-kvot) approch 1, 1-exp(-kvot)=kvot ! exp(-kvot) is close unity, ln(1-exp(-kvot))=ln(1-(1-kvot+kvot**2/2+...)) = ! ln(kvot-kvot**2/2+...)=ln(kvot) ! exp(kvot) is close to unity: exp(kvot)-1 = kvot+kvot**2/2+ ... extreme=1 expmkvot=exp(-kvot) ln1mexpkvot=log(one-expmkvot) kvotexpkvotm1=kvot/(exp(kvot)-one) else ! normal range of T and kvot extreme=0 expmkvot=exp(-kvot) ln1mexpkvot=log(one-expmkvot) kvotexpkvotm1=kvot/(exp(kvot)-one) endif ! gein=1.5D0*kvot+3.0D0*ln1mexpkvot ! write(*,71)'3H Cp E1:',extreme,ceq%tpval(1),gein,ln1mexpkvot,expmkvot,& ! kvotexpkvotm1 ! first derivative wrt T taking care of overflow dgeindt=3.0D0*(ln1mexpkvot-kvotexpkvotm1)/ceq%tpval(1) ! This is d2G/dT**2/(RT) = -T**2/R*(Einstein Cp/RT) (or rather Cv/RT) if(extreme.eq.-1) then ! take care of overflow at low T d2geindt2=zero else d2geindt2=-3.0D0*kvotexpkvotm1**2/(expmkvot*ceq%tpval(1)**2) endif ! return the values in phres%gval(*,1) phres%gval(1,1)=phres%gval(1,1)+gein phres%gval(2,1)=phres%gval(2,1)+dgeindt ! phres%gval(3,1)=phres%gval(3,1) phres%gval(4,1)=phres%gval(4,1)+d2geindt2 ! phres%gval(5,1)=phres%gval(5,1) ! phres%gval(6,1)=phres%gval(6,1) addrec%propval(1)=gein addrec%propval(2)=dgeindt addrec%propval(4)=d2geindt2 ! write(*,71)'3H Cp E3: ',extreme,ceq%tpval(1),gein,dgeindt,d2geindt2 70 format(a,F7.2,5(1pe12.4)) 71 format(a,i3,1x,F7.2,5(1pe12.4)) ! thet cannot depend on T ! Missing implem of derivatives wrt comp.dep of thet. !-------------------------- two state part DIVIDE BY RT ! NOTE g2val and derivatives not divided by RT !! g2val=phres%gval(1,ig2) dg2dt=phres%gval(2,ig2) dg2=zero; d2g2dt2=zero if(g2val.eq.zero .and. dg2dt.eq.zero) then write(*,*)'3H: G2 parameter zero, ignoring twostate model',g2val goto 900 endif ! write(*,19)'3H +am ',phres%gval(1,1),phres%gval(2,1),phres%gval(4,1) 19 format(a,6(1pe11.3)) rt=ceq%rtn tv=ceq%tpval(1) rg=globaldata%rgas ! expmg2=exp(-g2val/rt) ! if(g2val/rt.gt.2.0D2) then ! expmg2=exp(-g2val/(rt)) ! expg2=one/expmg2 ! elseif(g2val/rt.lt.1e-30) then ! expmg2=exp(-g2val/(rt)) ! expg2=one/expmg2 ! else expmg2=exp(-g2val/(rt)) expg2=one/expmg2 ! endif ! dg2=log(one+expmg2) dg2=log(one+expmg2) ! write(*,19)'3H G2: ',g2val/rt,expmg2,dg2,dg2*rt ! NOTE values added to gval(*,1) must be divided by RT ! G = G - RT*ln(1+exp(-g2/RT)) ! G phres%gval(1,1)=phres%gval(1,1)-dg2 ! (R*ln(1+g2val) + (g2/tv-dg2/dt)/(1+exp(-g2/RT)))/RT ! G.T ! dgfdt=(rg*dg2+(g2val/tv-dg2dt)/(expg2+one))/(rt) dgfdt=(rg*dg2+(g2val/tv-dg2dt)/(expg2+one))/(rt) phres%gval(2,1)=phres%gval(2,1)-dgfdt ! G.P is zero !-------------------------- tentative: ! d2g2/dt2/(1+exp(g2/RT)+ ! ((g2/tv)**2+(dg2/dt)**2-2*g2/tv*dg2/dt)*exp(g2/rt)/((1+exp(g2/RT)))**2/rt ! G.T.T ! This what my derivation gives: ! d2g2dt2=(phres%gval(4,ig2)/(one+expg2)+& ! Qing proposal, works after fixing the sign also below d2g2dt2=(phres%gval(4,ig2)/(one+expg2)-& ! This is which is the same as TC ! d2g2dt2=(-phres%gval(4,ig2)/(one+expg2)+& ((g2val/tv)**2+(dg2dt)**2-2.0D0*(g2val/tv)*dg2dt)*expg2/& (rt*(one+expg2)**2))/rt ! Maybe the error is here !! YES now it works! phres%gval(4,1)=phres%gval(4,1)+d2g2dt2 ! phres%gval(4,1)=phres%gval(4,1)-d2g2dt2 ! G.T.P is zero ! G.P.P is zero ! This is my addition to the two-state model to control the size of the hump ! goto 1000 hump=1.0D0 m4=2 fq=g2val/rt dfq=dg2dt/rt-fq/tv d2fq=phres%gval(4,ith)/rt-2.0D0/(rt*tv)*(dg2dt+g2val/tv) dd=one+(2.0D-1*fq)**m4 addq=hump/dd daddq=-m4*hump*fq**(m4-1)*dfq/dd**2 d2addq=-m4*hump*fq**(m4-2)*((m4-1)*dfq**2+fq*d2fq)/dd**2+& 2.0d0*m4**2*hump*fq**(2*m4-2)*dfq**2/dd**3 ! ignoring T dependence d2addq=5.0D-5/dd phres%gval(1,1)=phres%gval(1,1)+addq phres%gval(2,1)=phres%gval(2,1)+daddq phres%gval(4,1)=phres%gval(4,1)+d2addq write(*,800)'3H added hump',tv,fq,dd,-rg*tv**2*d2addq 800 format(a,6(1pe11.3)) ! save local values divided by RT? 900 continue addrec%propval=zero addrec%propval(1)=gein-dg2 addrec%propval(2)=dgeindt-dgfdt addrec%propval(4)=d2geindt2-d2g2dt2 1000 continue return end subroutine calc_twostate_model_old !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine create_debyecp !\begin{verbatim} subroutine create_debyecp(addrec) ! enters a record for the debye model implicit none type(gtp_phase_add), pointer :: addrec !\end{verbatim} %+ integer typty ! reserve an addition record allocate(addrec) ! Set the type of addition and look for needed parameter properties addrec%type=debyecp addrec%status=0 allocate(addrec%need_property(1)) call need_propertyid('LNTH ',typty) if(gx%bmperr.ne.0) goto 1000 addrec%need_property(1)=typty ! missing things for the actual Cp function ... ! write(kou,*)'Not implemented yet'; gx%bmperr=4078 ! 1000 continue return end subroutine create_debyecp !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_debyecp !\begin{verbatim} subroutine calc_debyecp(moded,phres,lokadd,lokph,mc,ceq) ! calculates Mauro Debye contribution ! NOTE: values for function not saved, should be done to save calculation time. ! moded: integer, 0=only G, S, Cp; 1=G and dG/dy; 2=Gm dG/dy and d2G/dy2 ! phres: pointer, to phase\_varres record ! lokadd: pointer, to addition record ! lokph: integer, phase record ! mc: integer, number of constituents ! ceq: pointer, to gtp_equilibrium_data implicit none integer moded,lokph,mc TYPE(gtp_equilibrium_data), pointer :: ceq TYPE(gtp_phase_add), pointer :: lokadd TYPE(gtp_phase_varres) :: phres !\end{verbatim} integer ith,noprop ! value of THET and derivatives have type ?? noprop=phres%listprop(1)-1 ! write(*,*)'3H cmi 2: ',noprop,(phres%listprop(i),i=1,noprop) ! Find thet, index stored in need_property(1) do ith=2,noprop if(phres%listprop(ith).eq.lokadd%need_property(1)) goto 100 enddo write(*,*)'3H No Debye temperature LNTH',lokph gx%bmperr=4336; goto 1000 100 continue write(*,*)'3H Deby low T heat capacity model not implemented' gx%bmperr=4078 1000 continue return end subroutine calc_debyecp !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine create_diffusion !\begin{verbatim} subroutine create_diffusion(addrec,lokph,text) implicit none integer lokph character text*(*) type(gtp_phase_add), pointer :: addrec !\end{verbatim} %+ integer typty,jj,last,is,js,ks,loksp,loksp2,ll,nsl character typ*24,quest*38,spname*24 double precision alpha type(gtp_diffusion_model), pointer :: diffcoef logical once ! initiate quest='Dependent constituent in sublattice X:' ! reserve an addition record allocate(addrec) ! nullify pointer to next addition nullify(addrec%nextadd) addrec%status=0 ! Set the type of addition and look for needed parameter properties addrec%type=diffcoefs ! Some information is needed last=1 100 continue call gparcdx('Type of diffusion model: ',text,last,1,typ,'SIMPLE',& '?Amend diffusion') call capson(typ) ! write(*,*)'3H typ: ',index('MAGNETIC',trim(typ)),trim(typ) if(index('SIMPLE',trim(typ)).eq.1) then write(*,*)'Simple diffusion model selected' jj=2 elseif(index('MAGNETIC',trim(typ)).eq.1) then write(*,*)'Magnetic diffusion model selected' jj=3 else write(*,*)'Dilute diffusion model selected' jj=1 endif ! allocate diffusion record for data allocate(addrec%diffcoefs) diffcoef=>addrec%diffcoefs ! addrec%diffcoefs=>diffcoef ! ???????????? must we have a diffusion record for each composition set?? diffcoef%difftypemodel=jj diffcoef%status=0 nullify(diffcoef%nextcompset) ! dependent component for each sublattice nsl=phlista(lokph)%noofsubl allocate(diffcoef%depcon(nsl)) is=1 do ll=1,nsl quest(37:37)=char(ll+ichar('0')) once=.true. 200 continue loksp=phlista(lokph)%constitlist(is) spname=splista(loksp)%symbol call gparcdx(quest,text,last,1,typ,spname,'?Amend diffusion') call find_species_record(typ,loksp2) if(gx%bmperr.ne.0) then if(once) then once=.false. write(*,*)'No such species' else goto 1000 endif endif ! we must also check this species is a constient in the sublattice!! if(loksp2.ne.loksp) then do js=is,is+phlista(lokph)%nooffr(ll)-1 if(loksp2.eq.phlista(lokph)%constitlist(js)) goto 250 enddo write(*,*)'This species is not a constituent of this sublattice' if(once) goto 200 gx%bmperr=4399; goto 1000 endif 250 continue ! is is always the first constituent in each sublattice diffcoef%depcon(ll)=loksp2 is=is+phlista(lokph)%nooffr(ll) enddo ! for jj=3 we must ask for ALPHA and ALPHA2 (with species names) if(jj.eq.3) then allocate(diffcoef%alpha(phlista(lokph)%nooffr(2))) call gparrdx('Value of ALPHA: ',text,last,alpha,0.3D0,'?Amend diffusion') diffcoef%alpha(1)=alpha if(nsl.eq.2 .and. phlista(lokph)%nooffr(2).gt.1) then ks=2 is=phlista(lokph)%nooffr(1) loop: do ll=1,phlista(lokph)%nooffr(2) loksp=phlista(lokph)%constitlist(is+ll) ! if constituent is Va ignore!! if(.not.btest(splista(loksp)%status,SPVA)) then spname=splista(loksp)%symbol quest='Value of ALPHA2&'//trim(spname) call gparrdx(quest,text,last,alpha,1.0D0,'?Amend diffusion') if(ks.le.size(diffcoef%alpha)) diffcoef%alpha(ks)=alpha ks=ks+1 endif enddo loop endif ! write(*,*)'3H alpha: ',diffcoef%alpha endif ! write(*,*)'3H depcon: ',diffcoef%depcon ! This addition may use MQ, MF, MG and maybe more allocate(addrec%need_property(3)) call need_propertyid('MQ ',typty) addrec%need_property(1)=typty call need_propertyid('MF ',typty) addrec%need_property(2)=typty call need_propertyid('MG ',typty) addrec%need_property(3)=typty if(gx%bmperr.ne.0) goto 1000 write(*,*)'Diffusion record created' ! write(kou,*)'Not implemented yet'; gx%bmperr=4078 1000 continue return end subroutine create_diffusion !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine diffusion_onoff !\begin{verbatim} subroutine diffusion_onoff(phasetup,bitval) ! switches the bit which calculates diffusion coefficients on/off ! if bitval 0 calculate is turned on, 1 turn off implicit none integer bitval type(gtp_phasetuple) :: phasetup !\end{verbatim} %+ integer lokph type(gtp_phase_add), pointer :: addrec lokph=phasetup%lokph addrec=>phlista(lokph)%additions loop: do while(associated(addrec)) if(addrec%type.eq.DIFFCOEFS) then if(bitval.eq.0) then addrec%diffcoefs%status=ibclr(addrec%diffcoefs%status,0) else addrec%diffcoefs%status=ibset(addrec%diffcoefs%status,0) endif exit loop endif enddo loop 1000 continue return end subroutine diffusion_onoff !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_diffusion !\begin{verbatim} subroutine calc_diffusion(moded,phres,lokadd,lokph,mc,ceq) ! calculates diffusion coefficients ! NOTE: values for function not saved, should be done to save calculation time. ! moded: integer, 0=only G, S, Cp; 1=G and dG/dy; 2=Gm dG/dy and d2G/dy2 ! phres: pointer, to phase\_varres record ! lokadd: pointer, to addition record ! lokph: integer, phase record ! mc: integer, number of constituents ! ceq: pointer, to gtp_equilibrium_data implicit none integer moded,lokph,mc TYPE(gtp_equilibrium_data), pointer :: ceq TYPE(gtp_phase_add), pointer :: lokadd TYPE(gtp_phase_varres) :: phres !\end{verbatim} %+ type(gtp_diffusion_model), pointer :: diffcoef diffcoef=>lokadd%diffcoefs ! write(*,*)'Diffusion phase and model: ',trim(phlista(lokph)%name),& ! diffcoef%difftypemodel ! write(*,*)'Dependent const: ',diffcoef%depcon ! write(*,*)'Alpha: ',diffcoef%alpha ! write(*,*)'Calculation on the diffusion record not implemented' 1000 continue return end subroutine calc_diffusion !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_diffusion_matrix !\begin{verbatim} subroutine get_diffusion_matrix(phtup,mdm,dcval,ceq) ! extracts calculated diffusion coefficients for a phase tuple ! phtup phase tuple ! dcval diffusion matrix ! ceq: pointer, to gtp_equilibrium_data implicit none integer mdm double precision dcval(mdm,*) TYPE(gtp_phasetuple) :: phtup TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} TYPE(gtp_phase_add), pointer :: lokadd TYPE(gtp_phase_varres) :: phres 1000 continue return end subroutine get_diffusion_matrix !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_addition !\begin{verbatim} subroutine list_addition(unit,CHTD,phname,ftyp,lokadd) ! list description of an addition for a phase on unit ! used when writing databases files and phase data implicit none integer unit,ftyp ! CHTD is letter for TDB files TYPE_DEFINITION ... suck character CHTD*1,phname*(*) TYPE(gtp_phase_add), pointer :: lokadd !\end{verbatim} %+ integer ip TYPE(tpfun_expression), pointer :: exprot character line*256,tps(2)*3,chc*2 double precision ff ! if(unit.eq.kou) then chc=' ' else chc='$ ' endif ! ! if(.not.btest(lokadd%status,ADDHAVEPAR)) then ! skip additions with no parameters for this phase ! REMOVED THIS because it creates confusion ! If parameters added before addition specified then ADDHAVEPAR is not set ! write(*,*)chc,'3H No parameters for addition: ',& ! trim(additioname(lokadd%type)) ! goto 1000 ! else ! write(*,*)'3H status word for this addition: ',lokadd%status ! endif addition: select case(lokadd%type) case default write(unit,*)'Unknown addtion type: ',phname,lokadd%type case(indenmagnetic) ! Inden magnetic model if(ftyp.eq.2) then ! TDB file: I do not think I have saved the enthalpy factor, bcc (-1) it is 0.4 ff=0.28D0 if(lokadd%aff.eq.-1) ff=0.4D0 write(unit,88)CHTD,phname(1:len_trim(phname)),lokadd%aff,ff 88 format(' TYPE_DEFINITION ',a,' GES A_P_D ',a,' MAGNETIC ',i3,F8.4,'!') else write(unit,100)lokadd%aff 100 format(2x,'+ Magnetic model by Inden, anti-ferromagnetic factor:',i3,/& 4x,'Magnetic function below the ordering temperature TC',& ' with TAO=T/TC:') tps(1)='TAO' tps(2)='err' ip=1 line=' ' exprot=>lokadd%explink(1) call ct1wfn(exprot,tps,line,ip) call wrice(unit,4,8,78,line(1:ip)) write(unit,110) 110 format(4x,'Magnetic function above the ordering temperature TC ',& 'with TAO=T/TC:') ip=1 line=' ' exprot=>lokadd%explink(2) call ct1wfn(exprot,tps,line,ip) call wrice(unit,4,8,78,line(1:ip)) ! write current values of gmagn and values ! write(unit,120)(lokadd%propval(ip),ip=1,4) !120 format(' Curr. contrib. G, G.T etc:',4(1pe12.4)) endif !--------------------------------------------- case(debyecp) ! Debye Cp model write(unit,200)chc 200 format(a,'+ Debye Cp model, not implemented yet') !--------------------------------------------- case(xiongmagnetic) ! Inden-Qing-Xiong write(unit,300)chc,lokadd%status 300 format(a,'+ Inden magnetic model modified by Qing and Xiong ',Z8/& 4x,'with separate Curie and Neel temperatures.'/& 4x,'Magnetic function below the ordering temperature TC ',& ' with TAO=T/TC:') tps(1)='TAO' tps(2)='err' ip=1 line=' ' exprot=>lokadd%explink(1) call ct1wfn(exprot,tps,line,ip) call wrice(unit,4,8,78,line(1:ip)) write(unit,110) ip=1 line=' ' exprot=>lokadd%explink(2) call ct1wfn(exprot,tps,line,ip) call wrice(unit,4,8,78,line(1:ip)) !--------------------------------------------- case(einsteincp) ! Einstein Cp model write(unit,400)chc 400 format(a,'+ Einstein Cp model: 1.5R*exp(LNTH(x)) +',& ' 3RT*ln(1-exp(-exp(LNTH(x))/T))') !--------------------------------------------- case(elasticmodel1) ! Elastic model 1 write(unit,500) 500 format(1x,'+ Elastic model 1, with P interpreted as a force in',& ' the X direction.') !--------------------------------------------- case(twostatemodel1) ! Liquid two state model including Einstein write(unit,510)chc,chc 510 format(a,'+ Liquid 2 state model: G(liq)-RT*ln(1+exp(-G2(x,T)/RT))'/& a,'+ Einstein Cp model: 1.5R*exp(LNTH(x)) ',& '+ 3RT*ln(1-exp(-exp(LNTH(x))/T))') !--------------------------------------------- case(volmod1) ! Volume model 1 write(unit,520)chc 520 format(a,'+ Volume model P*V0(x)*exp(VA(x,T))') !--------------------------------------------- ! case(crystalbreakdownmod) ! Crystal breakdown model UNUSED, EET not listed ! write(unit,530)chc !530 format(a,'+ Crystal breakdown model used above current value of CBT') !--------------------------------------------- case(secondeinstein) ! Second Einstein Cp contribution write(unit,540)chc 540 format(a,'+ Second Einstein: DCP2(x)*RT*ln(exp(ln(THT2(x))/T)-1)') !--------------------------------------------- case(schottkyanomaly) ! Schottky Anomaly write(unit,550)chc 550 format(a,'+ Schottky anomaly DSCH(x)*RT*ln(1+exp(-ln(TSCH(x))/T)) ') !--------------------------------------------- ! THIS MODEL IS OBSOLETE case(twostatemodel2) ! Liquid two state model with fix G2 and Einstein write(unit,511)chc,chc 511 format(a,' + wrong Liquid 2 state model: G(liq)-RT*ln(1+exp(-G2(T)/RT))'/& a,' + Einstein Cp model: 1.5R*exp(LNTH(x)) ',& '+ 3RT*ln(1-exp(exp(LNTH(x))/T))') !--------------------------------------------- end select addition 1000 continue return end subroutine list_addition !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_addition_values !\begin{verbatim} subroutine list_addition_values(unit,phres) ! lists calculated values for this addition ! Used for the command CALCULATE PHASE to inform about additions implicit none integer unit TYPE(gtp_phase_varres), pointer :: phres !\end{verbatim} integer lokph,j1 TYPE(gtp_phase_add), pointer :: addrec ! lokph=phres%phlink addrec=>phlista(lokph)%additions do while(associated(addrec)) ! write(lut,77)addrec%type,(addrec%propval(j1),j1=1,4) 77 format('Addition type ',i2,': ',4(1pe12.4)) ! ignore additions without parameters if(btest(addrec%status,ADDHAVEPAR)) & write(lut,78)additioname(addrec%type),(addrec%propval(j1),j1=1,4) 78 format('Addition/RT ',a,':',4(1pe10.2)) addrec=>addrec%nextadd enddo 1000 continue return end subroutine list_addition_values !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine set_database_ternary !\begin{verbatim} subroutine set_database_ternary(line) ! separate a database line to parts to add a ternary extrapolation method implicit none character line*(*) ! transform a database line with one or more ternary extrapolation methods ! text is "phase-name species1 species2 species3 mode (mabe several) !\end{verbatim} integer lokph,ip,jp,iph,lcs character phase*24,species(3)*24,tkmode*6 write(*,'(a,a,a)')'3H in set_database_ternary: "',trim(line),'"' ! split line in individual parts, phase, species, tkmode ip=index(line,' ') phase=line(1:ip) call find_phase_by_name(phase,iph,lcs) if(gx%bmperr.ne.0) then write(*,*)'3H bad phase name ',trim(phase),' for ternary extrapolation' goto 1000 endif lokph=phases(iph) do while(line(ip:ip).eq.' ') ip=ip+1 enddo 100 continue ! only one space between constituents jp=index(line(ip:),' ') species(1)=line(ip:ip+jp-1) ip=ip+jp ! A special case is for setting all ternaries as Kohler. Maybe simplest ! to loop through all constituents and call add_ternary for each if(species(1)(1:1).eq.'*') then species(2)=' ' species(3)=' ' tkmode='KKK' write(*,*)'3H Setting all ternaries as Kohler not yet implemented' ! Simplest maybe to loop though all ternaries and call ! call add_ternary_extrapol_method(lokph,tkmode,species) ! for each ... goto 1000 endif ! write(*,*)'3H after species 1: "',trim(line(ip:)),'"' jp=index(line(ip:),' ') species(2)=line(ip:ip+jp-1) ip=ip+jp ! write(*,*)'3H after species 2: "',trim(line(ip:)),'"' jp=index(line(ip:),' ') species(3)=line(ip:ip+jp-1) ip=ip+jp ! write(*,*)'3H after species 3: "',trim(line(ip:)),'"' jp=index(line(ip:),' ') tkmode=line(ip:ip+jp-1) ! possibly there is a ; after the tkmode, remove it. lcs=index(tkmode,';') if(lcs.gt.0) then tkmode(lcs:)=' ' endif ! write(*,*)'3H TernaryXpol tkmode "',tkmode,'"' ! write(*,77)trim(phlista(lokph)%name),trim(species(1)),trim(species(2)),& ! trim(species(3)),tkmode 77 format('3H call add_ternary: ',a,1x,a,1x,a,1x,a,1x,a) 150 continue call add_ternary_extrapol_method(lokph,tkmode,species) ! there can be several ternary mode in line ... ! write(*,*)'3H back from add_ternary_extrapolation_method' if(gx%bmperr.eq.4051) then write(*,*)'3H Ternary extrapolation ignored as a constituent not present' gx%bmperr=0 endif ip=ip+jp jp=len_trim(line) if(jp.gt.ip) then ! skip spaces do while(line(ip:ip).eq.' ') ip=ip+1 enddo if(line(ip:ip).ne.'!') then ! write(*,*)'3H one more ternary: "',trim(line(ip:)),'"' goto 100 endif endif ! 1000 continue return end subroutine set_database_ternary !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine add_ternary_extrapol_method !\begin{verbatim} ! subroutine add_ternary_extrapol_method(lokph,tkmode,species) subroutine add_ternary_extrapol_method(lokph,tkmode,species) ! add a Toop or Kohler extrapolation method for a ternary subsystem to a phase ! interactive or from database implicit none integer lokph character tkmode*(*) ! mode is KKK, TiTiK, TiTjTk etc. with i j k integers 1, 2 or 3, TKM as captial ! Complicated ... !\end{verbatim} ! conx is the constituent index in the phase ! integer, parameter :: talloc=2 integer jj,kk,loksp,conx(3),done,conix,uniqid type(gtp_endmember), pointer :: endmem type(gtp_interaction),pointer :: intrec12,intrec13,intrec23,intrec type(gtp_interaction),pointer :: intrec1,intrec2 type(gtp_tooprec), pointer :: newtoop character dummy*24,xmode(3)*1,ch1*1,species(3)*24 character amend*128 ! ktorg has : element order, fraction index, Took/Koler spec ! integer xter3(3),toopcon(3),conind(3),nobin,tch logical checkdup,saveamend,onlym ! for debugging integer nextmethod integer aheremethod12, aheremethod13,aheremethod23 ! this is incremented by 1 each time a record is created in any phase ! integer, save ::uniqid=0 ! ! tch=5 write(*,8)trim(species(1)),trim(species(2)),trim(species(3)),& tkmode,trim(phlista(lokph)%name) ! if(tch.ge.3) write(*,8)trim(species(1)),trim(species(2)),trim(species(3)),& ! tkmode,trim(phlista(lokph)%name) 8 format('3H add_ternary_extrapol ',a,' ',a,' ',a,' using ',a,' in ',a) if(phlista(lokph)%noofsubl.gt.1) then write(*,*)'3H Kohler/Toop not allowed for phases with sublattices' gx%bmperr=4399; goto 1000 endif if(associated(phlista(lokph)%disordered)) then write(*,*)'3H Kohler/Toop not allowed for phases with disordered set' gx%bmperr=4399; goto 1000 endif ! A special case when all ternaries are set as Kohler .... ! Note, the order of species will changed below but the ! original amend text will be saved in one of the tooprec records for output if(trim(tkmode).eq.'KKK') then amend=trim(phlista(lokph)%name)//' TERNARY_EXTRA '//& ' '//trim(species(1))//' '//trim(species(2))//& ' '//trim(species(3))//' '//tkmode//' ' ! no final ! as list on TDB file may include several extrapol write(*,*)'3H Executing KKK amend ',trim(amend)! endif ! !----------------------------------- to be considered ! The asymmetric method is given in the order of binaries A-B, A-C and B-C ! by 3 letters T, K or M. ! The letter T must be followed by a number 1ndicating which of the 3 ! constituents that is the Toop element, for example T1T1K ! means the first constituent is Toop when extrapolating A-B and A-C whereas ! the binary A-B extrapolates is Kohler. Examples: ! T1T1K means A-B and A-C is Toop with A as Toop and B-C is Kohler ! KKK means Kohler by all ! T1KT1 is illegal as A is not part of the (last) BC binary. ! T2KT2 means A-B and B-C is Toop with B as toop and B-C is Kohler ! T3T3K is wrong as A-B cannot have C as Toop element ! T1KT1 is wrong as B-C cannot have A as Toop element ! T1T3T2 has A as Toop in A-B, C as Toop in A-C and B as Toop in B-C ! T1MM has Toop for A-B and ;uggianu for A-C and B-C ! The relevant information is stored locally for each binary A-B, A-C and B-C ! ! this routine in gtp3X stores the asymmetry data in the asymmetry record' ! ! modified 111225/BoS to use subroutine set_ternary_asymmetry ! also used when from reading from TDB/XTDB file call capson(species(1)) call capson(species(2)) call capson(species(3)) call capson(tkmode) amend=trim(phlista(lokph)%name)//' '//trim(species(1))//' '//& trim(species(2))//' '//trim(species(3))//' '//trim(tkmode)//' ! ' write(*,77)trim(amend) 77 format('3H calling set_ternary_asymmetry in gtp3XQ with'/'"',a,'"') ! ! write(*,*)'3H This subroutine add_ternary_extrapol_method does not work yet' ! gx%bmperr=4399; goto 1000 ! call set_ternary_asymmetry(amend) goto 1000 ! ! code below redundant ------------------------------------ ! ! For each binary the constituent indices are stored, indicating in the ! and if any of them is a Toop element and if the third elemt is Kohler ! A constituent can be Toop or Kohler in different ternaries ! xter3=0; toopcon=0; jj=1; onlym=.TRUE. !--------------------------------------------------------------- tkmodel: do kk=1,3 ! Check only Ti, K and M in tkmode, to simplfy indexing copy to xmode(3)*1 ! For a Toop constituent save index in toopcon ! The code here is messy because I have had different ideas some redundant code xmode(kk)=tkmode(jj:jj) jj=jj+1 if(.not.(xmode(kk).eq.'T' .or. xmode(kk).eq.'K' .or. & xmode(kk).eq.'M')) then write(*,*)'3H only letters T, K or M allowed for extrapolations: ',& tkmode gx%bmperr=4399; goto 1000 endif if(xmode(kk).eq.'T') then ! this converts ascii value to integer, subtract ascii value of character 0 toopcon(kk)=ichar(tkmode(jj:jj))-ichar('0') jj=jj+1 if(toopcon(kk).le.0 .or. toopcon(kk).gt.3) then write(*,*)'3H extrapolation T must be followed by intger 1, 2 or 3' gx%bmperr=4399; goto 1000 endif ! binary jj=1 j=2 jj=3 ! if kk=1: A-B A is Toop; B is Toop; illegal ! kk=2: A-C A is Toop; illegal C is Toop ! kk=3; B-C illegal B is Toop C is Toop if(kk.eq.1 .and. toopcon(kk).eq.3) then write(*,*)'3H illegal Toop constituent',kk,toopcon(kk) gx%bmperr=4399; goto 1000 elseif(kk.eq.2 .and. toopcon(kk).eq.2) then write(*,*)'3H illegal Toop constituent',kk,toopcon(kk) gx%bmperr=4399; goto 1000 elseif(kk.eq.3 .and. toopcon(kk).eq.1) then write(*,*)'3H illegal Toop constituent',kk,toopcon(kk) gx%bmperr=4399; goto 1000 endif ! Set that for ternary kk the Toop element is toopcon(kk) if(tch.ge.3) write(*,*)'3H Toop xter3 ',kk,' is : ',toopcon(kk) xter3(kk)=toopcon(kk) onlym=.FALSE. elseif(xmode(kk).eq.'K') then ! the binary kk has Kohler method for 3rd element, save its negative value onlym=.FALSE. if(kk.eq.1) then ! binary A-B has 3rd element as Kohler xter3(kk)=-3 elseif(kk.eq.2) then ! binary A-C has 2nd element as Kohler xter3(kk)=-2 else ! binary B-C has 1st element as Kohler xter3(kk)=-1 endif if(tch.ge.3) write(*,*)'3H Kohler xter3 ',kk,' is : ',xter3(kk) ! there is no 'else' ! else endif enddo tkmodel !---------------------- if(onlym) then write(*,'(a)')'3H All species have Muggianu extrapolation by default' goto 1000 endif !---------------------------- ! find the 3 asymmetric constituents, store their constituent index in conind conx=0 ! write(*,'(a,3i3,1x,3i3,1x,3a2)')'3H looking for constituents: ',conx,& ! xter3,xmode all3: do jj=1,3 call find_species_record_noabbr(species(jj),loksp) if(gx%bmperr.ne.0) then ! needed for mqmqma model ... they have a number -Qij which may vary ! write(*,*)'3H Constituent search allowing abbreviations' gx%bmperr=0 call find_species_record(species(jj),loksp) endif if(gx%bmperr.ne.0) goto 1000 ! check if species a constituent and save constinuent index in ktorder isconst: do kk=1,size(phlista(lokph)%constitlist) ! write(*,'(a,5i5)')'3H constituent?',jj,kk,& ! phlista(lokph)%constitlist(kk),loksp if(loksp.eq.phlista(lokph)%constitlist(kk)) then ! element jj in the ternary has constituent index kk conx(jj)=kk if(tch.ge.3) write(*,'(a,2i4,2x,2i4)')'3H conx ',jj,kk,& phlista(lokph)%constitlist(kk),loksp ! we found the constituent, take nest one cycle all3 endif enddo isconst ! the loop for constituents did not find the element write(*,*)'3H no such constituent: ',jj,species(jj) gx%bmperr=4052; goto 1000 enddo all3 ! if(tch.ge.3) write(*,'(a,3i3,1x,3i3,1x,3a2)')'3H found all const: ',conx,& xter3,xmode if(conx(1).eq.conx(2) .or. conx(1).eq.conx(3) .or. conx(2).eq.conx(3)) then write(*,*)'3H Same element twice, not a ternary!' gx%bmperr=4399; goto 1000 endif !------------------------------- Kohler OK above ! Rearrange in the order of the fraction indices Kohler: do kk=1,3 if(xter3(kk).lt.0) xter3(kk)=-conx(-xter3(kk)) enddo Kohler !------------------------------- ! Replace any Toop constituents with its constiuent incex Toop: do kk=1,3 if(xter3(kk).gt.0) xter3(kk)=conx(xter3(kk)) enddo Toop !---------------------- ! convert toopcon to fraction index, those are in conx do kk=1,3 if(toopcon(kk).gt.0) toopcon(kk)=conx(toopcon(kk)) enddo ! write(*,'(a,10i4)')'3H toopcon as fraction indices: ',toopcon !------------------------------- ! if(tch.ge.3) write(*,'(a,3i3,1x,3i3,1x,3a2)')'3H Replaced by index: ',conx,& xter3,xmode ! Kohler OK here ! ! sort constituents in constituent order ! xter3 here is either the toopcon or the Kohler constituent index ! according to the original order the elements were entered ! if 1>2 change order if(conx(1).gt.conx(2)) then jj=conx(1); conx(1)=conx(2); conx(2)=jj dummy=species(1); species(1)=species(2); species(2)=dummy ! But this change means the order of the binaries changes from/to ! A B C is A-B A-C B-C ! B A C is B-A B-C A-C fisrt same, shift 2 and 3 ! these rearrange the binaroes .... different order jj=xter3(2); xter3(2)=xter3(3); xter3(3)=jj ch1=xmode(2); xmode(2)=xmode(3); xmode(3)=ch1 jj=toopcon(2); toopcon(2)=toopcon(3); toopcon(3)=jj if(tch.ge.3) write(*,'(a,3(3i3,1x),3a2)')'3H Rearranged step 1: ',conx,& xter3,toopcon,xmode endif ! check if 2>3 if(conx(2).gt.conx(3)) then jj=conx(2); conx(2)=conx(3); conx(3)=jj dummy=species(2); species(2)=species(3); species(3)=dummy ! B A C B-A B-C A-C ! B C A B-C B-A C-A shift first and second, third the same jj=xter3(1); xter3(1)=xter3(2); xter3(2)=jj ch1=xmode(1); xmode(1)=xmode(2); xmode(2)=ch1 jj=toopcon(1); toopcon(1)=toopcon(2); toopcon(2)=jj if(tch.ge.3) write(*,'(a,3(3i3,1x),3a2)')'3H Rearranged step 2: ',conx,& xter3,toopcon,xmode endif ! now 3 > (1,2) check again if 1>2 if(conx(1).gt.conx(2)) then jj=conx(1); conx(1)=conx(2); conx(2)=jj dummy=species(1); species(1)=species(2); species(2)=dummy ! B C A same shift as first ! C B A jj=xter3(2); xter3(2)=xter3(3); xter3(3)=jj ch1=xmode(2); xmode(2)=xmode(3); xmode(3)=ch1 jj=toopcon(2); toopcon(2)=toopcon(3); toopcon(3)=jj ! if(tch.ge.3) write(*,'(a,3(3i3,1x),3a2)')'3H Rearranged step 3: ',conx,& write(*,'(a,3(3i3,1x),3a2)')'3H Rearranged step 3: ',conx,& xter3,toopcon,xmode endif !**************** redundant after here write(*,'("3H The constituents in alphabetical order: ",3i3)')conx ! The conx order is the (alphabetical) order of the constituents ! The endmembers are in that order. The interactions are not ordered ! xter3 is the original input order, conx is in alphabetical order ! toopcon is the toop element in each, zero if none ! Replace any Koher extrapolation with its constituent index ! Kohler2: do kk=1,3 ! if(xter3(kk).lt.0) xter3(kk)=-conx(-xter3(kk)) ! enddo Kohler2 ! Replace any Toop constituents with its constiuent incex .... does not work ! Toop2: do kk=1,3 ! if(xter3(kk).gt.0) xter3(kk)=conx(xter3(kk)) ! enddo Toop2 ! write(*,'(a,3i3,1x,3i3,1x,3a2)')'3H Sorted xter3 and conx: ',conx,& ! xter3,xmode !--------------------------------------------------------- ! now we have to find the interaction records ! Some binary parameter in the ternary may not have an interaction record. ! there should be a check if this ternary is a duplicate ...!!! ! Phases with one sublattice are always disordered and has no disordered link ! Try to give reasonable error messages endmem=>phlista(lokph)%ordered if(.not.associated(endmem)) then write(*,*)'3H No endmembers or interaction in this phase!' gx%bmperr=4399; goto 1000 endif ! nullify pointers from binary interactions nullify(intrec1); nullify(intrec2) nullify(intrec12); nullify(intrec13); nullify(intrec23) ! ! look for endmember with lowest constituent index (they are ordered that way) if(tch.ge.3) write(*,'(a,3i3)')'3H search endmemembers: ',conx(1) ! write(*,'(a,10I4)')'3H endmemfraclinks: ',endmem%fraclinks(1,1) ! write(*,*)'3H where is line with 5 numbers written?' conix=1 !*************** before or after here ? if(tch.ge.3) write(*,*)'3H start findem loop' findem: do while(associated(endmem)) ! write(*,'(a,3i3)')'3H endmem2: ',conix,endmem%fraclinks(1,1),conx(conix) if(endmem%fraclinks(1,1).eq.conx(conix)) then ! we found the endmember with conx(conix) as constituent ! if comix=1 look for interaction record with conx(2) or conx(3) if(tch.ge.3) write(*,*)'3H found endmember: ',conix,conx(conix) intrec=>endmem%intpointer findexcess: do while(associated(intrec)) if(tch.ge.3) write(*,*)'3H loop interaction: ',2,conx(2) if(intrec%fraclink(1).eq.conx(2)) then ! this must be interaction 1-2 ?? or 2-3 ?? intrec12=>intrec write(*,222)trim(species(1)),trim(species(2)),conix 222 format('3H Found interaction ',a,'-',a,' from endmember: ',i5) ! we do not know the order of interaction 1-2 and 1-3 if(associated(intrec13)) exit findexcess elseif(intrec%fraclink(1).eq.conx(3)) then if(conix.eq.1) then ! this must be interaction 1-3, endmember 2 intrec13=>intrec write(*,222)trim(species(1)),trim(species(3)),conix ! we do not know the order of interaction 1-2 and 1-3 if(associated(intrec12)) exit findexcess else ! this must be interaction 2-3 intrec23=>intrec write(*,222)trim(species(2)),trim(species(3)),conix exit findem endif endif if(tch.ge.3) write(*,*)'3H loop intrec: ',& endmem%fraclinks(1,1),intrec%fraclink(1) intrec=>intrec%nextlink enddo findexcess if(tch.ge.3) write(*,'(a,l2,i3,2x,3i3)')'3H exit findexcess',& associated(intrec),conix,conx(conix) ! when we come here we have found 1-2 and 1-3 and look for 2-3 if(conix.eq.1) then if(.not.associated(intrec12) .or. .not.associated(intrec13)) & write(*,224)conix,conx,endmem%fraclinks(1,1) 224 format('3H some interactions missing',i3,2x,3i3,2x,i3) ! increment conix and search for endmember conx(2) conix=2 else if(.not.associated(intrec23)) & write(*,*)'3H some interactions are missing' exit findem endif endif endmem=>endmem%nextem enddo findem !*************** before here ! write(*,*)'3H end findem loop' ! we come here when we found or not found intrec12, intrec13 and intrec23 !------------------------------------------------------------ ! check values of xter3 if(tch.ge.3) then do kk=1,3 write(*,44)trim(species(kk)),xter3(kk),conx(kk) 44 format('3H constituent ',a,' xter3: ',i2,i5) enddo endif !-------------------------------------- if(tch.ge.3) then write(*,111)conx(1),conx(2),conx(1),conx(3),conx(2),conx(3),& associated(intrec12),associated(intrec13),associated(intrec23) 111 format('3H Found binary interaction records for ',3(i2,'-',i2),3x,3l2) write(*,*)'3H Allocate tooprecords!' endif !=================== now we create the tooprec records ===================== ! In gtp_phaserecord pointers toopfirst, tooplast include all tooprec records ! It is needed to list the ternary extrapolation. It also has lasttoopid ! The gtp_intrec has a tooprec pointer with tooprec data for that interaction ! Each ternary AMEND TERNARY will be saved in one of the tooprec records if(.not.associated(phlista(lokph)%tooplast)) then ! the phase ternary extrapolation record needed for listing only allocate(phlista(lokph)%toopfirst) phlista(lokph)%tooplast=>phlista(lokph)%toopfirst phlista(lokph)%lasttoopid=0 ! nullify the nexttoop pointer in toopfirst nullify(phlista(lokph)%toopfirst%nexttoop) nullify(phlista(lokph)%toopfirst%binint) phlista(lokph)%toopfirst%amend1=' ' phlista(lokph)%toopfirst%amend2=' ' phlista(lokph)%toopfirst%amend3=' ' kk=size(phlista(lokph)%constitlist) ! Hm, in a 4 component systems there are only 2 extrapolations?. But the ! tooprec for a binary is involved in the extrapolations for other binaries nobin=kk*(kk-1)/2 write(*,'(a,i3)')'3H allocating special binary extrapolations ',nobin phlista(lokph)%toopfirst%free=nobin else nobin=phlista(lokph)%toopfirst%free ! write(*,'(a,i3)')'3H max special binary extrapolations ',nobin endif ! phase record has pointers toopfirst and tooplast and integer lasttoopid ! interaction record has pointer tooprec needed for calculations ! the tooprec record are linked by nexttoop with a sequantial index toopid ! Each original AMEND command is saved in one tooprec saveamend=.TRUE. ! this is to indicate that a tooprec has been added ! at the first calculation some checka are made to avoid duplicates ! and it is set to zero phlista(lokph)%toopfirst%endmemel=-1 ! total number of binaries !------------------------ create a tooprec for binary 1-2 ! Check if intrec12 already has a tooprec, (nullified when intrec created) ! conx(1) is the endmember fraction index ! write(*,*)'3H creating tooprecords',associated(intrec12) if(.not.associated(intrec12)) then write(*,220)conx(1),conx(2),1,2,& trim(species(1)),trim(species(2)) ! trim(species(abs(conx(1)))),trim(species(abs(conx(2)))) 220 format('3H The binary ',i2,'-',i2,' (or ',i2,'-',i2,')',& ' with species: ',a,' - ',a,' has no excess') goto 300 else ! this routine returns with a new or old newtoop record if(tch.ge.3) write(*,*)'3H calling create_toop_record for 1-2' call create_toop_record(lokph,intrec12,conx(1),nobin) newtoop=>intrec12%tooprec jj=newtoop%free if(tch.ge.3) then write(*,221)'3H Toop1: ',(newtoop%toop1(kk),kk=1,size(newtoop%toop1)) write(*,221)'3H Toop2: ',(newtoop%toop2(kk),kk=1,size(newtoop%toop1)) write(*,221)'3H Kohler:',(newtoop%kohler(kk),kk=1,size(newtoop%toop1)) 221 format('3H arrays: ',a,45i3) endif endif ! save Kohler constituent fraction (or zero if none) ! write(*,'(a,3i3,2x,3i3)')'3H xter3, toopcon: ',xter3,toopcon if(xter3(1).lt.0) newtoop%Kohler(jj)=xter3(1) if(toopcon(1).gt.0) then !------------------------------------------------------------ ! This is the 1-2 binary of 1-2-3 with a Toop constituent 1, 2 or 3 !------------------------------------------------------------ ! If toopcon(1)>0 it represents a Toop constituent ! Then one should add the fraction of conx(3) to the NON-toopcon ! if conx(1) is equal to toopcon(1) then Toop2(jj)=toopcon(1) ! if conx(2) is equal to toopcon(1) then Toop1(jj)=toopcon(1) ! otherwise toopcon(1) can be ignored as toopcon is not part of the binary ! write(*,'(a,3i3,2x,3i3)')'3H Toop 1-2: ',toopcon,conx if(toopcon(1).eq.conx(1)) then ! toopcon(1) is the first constituent in 1-2, add conx(3) to second fraction newtoop%Toop2(jj)=conx(3) elseif(toopcon(1).eq.conx(2)) then newtoop%Toop1(jj)=conx(3) endif endif if(tch.ge.3) then write(*,'(a,i3,2x,3i3,2x,3i3)')'3H newtoop 1-2: ',jj,& newtoop%toop1(jj),newtoop%toop2(jj),newtoop%kohler(jj),& intrec12%tooprec%toop1(jj),intrec12%tooprec%toop2(jj),& intrec12%tooprec%kohler(jj) ! extract the elements from the interaction record write(*,600)trim(species(1)),trim(species(2)),trim(species(3)),xter3,& conx,toopcon,newtoop%toop1(jj),newtoop%toop2(jj),newtoop%kohler(jj) ! xter3 refers to the binary 1, 2 or 3 ! conx is constituent index endif ! !------------------------------------------------------------------- if(saveamend) then if(len(newtoop%amend1).le.1) then ! we can only save 1 amend command in each topec record ... ! This can be a probem if elements are ordered alphabetically ! one may run of of binaries to store A-B-X, A-B-Y etc newtoop%amend1=trim(amend) saveamend=.FALSE. ! write(*,*)'3H Executing amend: ',newtoop%amend elseif(len(newtoop%amend2).le.1) then newtoop%amend2=trim(amend) saveamend=.FALSE. elseif(len(newtoop%amend3).le.1) then newtoop%amend3=trim(amend) saveamend=.FALSE. endif ! if all were full hopefully there is another binary where it can be saved!!! endif ! write(*,*)'3H Finished storing data for tooprec 1-2' !------------ repeat (almost) the same thing for binary 1-3 ------------- ! jump here if no intrec12 existed 300 continue ! Check if intrec3 exist and already has a tooprec if(.not.associated(intrec13)) then write(*,220)conx(1),conx(3),1,3,& trim(species(1)),trim(species(3)) ! trim(species(abs(conx(1)))),trim(species(abs(conx(3)))) goto 400 else ! write(*,*)'3H calling create_toop_record for 1-3' call create_toop_record(lokph,intrec13,conx(1),nobin) newtoop=>intrec13%tooprec jj=newtoop%free ! write(*,*)'3H data in newtoop 1-3: ',newtoop%free,jj endif ! enter the data for 1-3 extrapolation A-C-B ! if A is Toop the fraction index of A shoule be in toopcon(1) ! if C is Toop the fraction index of B should be in toopcon(3) ! if B is Kohler the negative fraction shoule be in xter(3) if(xter3(2).lt.0) newtoop%Kohler(jj)=xter3(2) if(toopcon(2).gt.0) then !------------------------------------------------------------ ! This is the 1-3 binary of 1-2-3 with a Toop constituent !------------------------------------------------------------ ! If toopcon(2)>0 that represent a Toop constituent ! if conx(1) is equal to toopcon(2) then Toop2(jj)=conx(2) ! if conx(3) is equal to toopcon(2) then Toop1(jj)=conx(2) ! otherwise toopcon(2) can be ignored as it is not part of the binary 1-3 ! write(*,'(a,3i3,2x,3i3)')'3H Toop 1-3: ',toopcon,conx if(toopcon(2).eq.conx(1)) then ! first element is Toop; add fraction of conx(2) to NON-toop element ! newtoop%Toop2(jj)=toopcon(2) newtoop%Toop2(jj)=conx(2) elseif(toopcon(2).eq.conx(3)) then ! newtoop%Toop1(jj)=toopcon(2) newtoop%Toop1(jj)=conx(2) endif endif if(tch.ge.3) then write(*,'(a,i3,2x,3i3,2x,3i3)')'3H newtoop 1-3: ',jj,& newtoop%toop1(jj),newtoop%toop2(jj),newtoop%kohler(jj),& intrec12%tooprec%toop1(jj),intrec12%tooprec%toop2(jj),& intrec12%tooprec%kohler(jj) ! write(*,600)trim(species(1)),trim(species(3)),trim(species(2)),xter3,& conx,toopcon,newtoop%toop1(jj),newtoop%toop2(jj),newtoop%kohler(jj) endif ! we may not have managed to save the amend? if(saveamend) then if(len(newtoop%amend1).le.1) then newtoop%amend1=trim(amend) saveamend=.FALSE. elseif(len(newtoop%amend2).le.1) then newtoop%amend2=trim(amend) saveamend=.FALSE. elseif(len(newtoop%amend3).le.1) then newtoop%amend3=trim(amend) saveamend=.FALSE. endif endif ! write(*,*)'3H Finished storing data for tooprec 1-3' !------------ repeat (almost) the same thing for binary 2-3 ------------- ! jump here if no intrec13 existed 400 continue ! Check if intrec23 exist and already has a tooprec if(.not.associated(intrec23)) then write(*,220)conx(2),conx(3),2,3,& trim(species(2)),trim(species(3)) ! trim(species(abs(conx(2)))),trim(species(abs(conx(3)))) goto 500 else ! write(*,*)'3H calling create_toop_record for 2-3' call create_toop_record(lokph,intrec23,conx(2),nobin) newtoop=>intrec23%tooprec jj=newtoop%free ! write(*,*)'3H data in newtoop 2-3: ',newtoop%free endif 411 continue ! enter the data for 2-3 extrapolation B-C-A ! enter the data for 1-3 extrapolation A-C-B ! if B is Toop the fraction index of B shoule be in extrapolatio(2) ! if C is Toop the fraction index of C should be in extrapolatio(3) ! if A is Kohler the negative fraction index of A shoule be in extrapolatio(1) ! A negative value in Toop1 or Toop2 is ignored as well as a positive in Kohler ! if(xter3(3).gt.0 .and. xter3(3).ne.toopcon(3)) newtoop%Toop1(jj)=toopcon(3) ! if(xter3(3).gt.0 .and. xter3(3).ne.toopcon(3)) newtoop%Toop2(jj)=toopcon(3) if(xter3(3).lt.0) newtoop%Kohler(jj)=xter3(3) if(toopcon(3).gt.0) then !------------------------------------------------------------ ! This is the 2-3 binary of 1-2-3 with a Toop constituent !------------------------------------------------------------ ! If toopcon(3)>0 it represent a Toop constituent ! if conx(2) is equal to toopcon(3) then add conx(1) to the NON-toop element ! if conx(3) is equal to toopcon(3) then the same ! otherwise toopcon(3) can be ignored as it is not part of the binary! ! write(*,'(a,3i3,2x,3i3)')'3H Toop 2-3: ',toopcon,conx if(toopcon(3).eq.conx(2)) then ! toopcon(3) is the first constituent in 2-3 ! newtoop%Toop2(jj)=toopcon(3) newtoop%Toop2(jj)=conx(1) elseif(toopcon(3).eq.conx(3)) then ! newtoop%Toop1(jj)=toopcon(3) newtoop%Toop1(jj)=conx(1) endif endif if(tch.ge.3) then write(*,'(a,i3,2x,3i3,2x,3i3)')'3H newtoop 2-3: ',jj,& newtoop%toop1(jj),newtoop%toop2(jj),newtoop%kohler(jj),& intrec12%tooprec%toop1(jj),intrec12%tooprec%toop2(jj),& intrec12%tooprec%kohler(jj) endif !************* furure check **************** ! if any of Toop1, Toop2 and Kohler arrays have the same fraction index ! more than once one should add/subract only once. I think it can happen ! for real cases, maybe one can eliminate duplicate indices when calculating ! Added check in zeroth tooprec in %free set to -1 when adding ternary !---------------------------------------------------- if(tch.ge.3) then write(*,600)trim(species(2)),trim(species(3)),trim(species(1)),xter3,& conx,toopcon,newtoop%toop1(jj),newtoop%toop2(jj),newtoop%kohler(jj) 600 format('3H Binary ',a,'-',a,' extrapolerad to ',a,': ',4(3i3,2x)) endif if(saveamend) then if(len(newtoop%amend1).le.1) then newtoop%amend1=trim(amend) saveamend=.FALSE. elseif(len(newtoop%amend2).le.1) then newtoop%amend2=trim(amend) saveamend=.FALSE. elseif(len(newtoop%amend3).le.1) then newtoop%amend3=trim(amend) saveamend=.FALSE. else write(*,603)trim(amend) 603 format('3XQ WARNING *** failed to save amend ternary command:'/a/& ' maybe try to order constituents differently') endif endif ! write(*,*)'3H Finished storing data for tooprec 2-3' !--------------------------------------------- ! jump here if no intrec13 existed 500 continue if(.not.associated(newtoop)) then write(*,*)'3H there are no interaction parameters to extrapolate' goto 1000 endif !=================================================================== ! Puuuuuuuuuuuuuuuuuhhhhhhhhhhhhhhhhhhhh 1000 continue return ! Error: Found duplicate method 1100 continue write(*,*)'3H Error creating ternary extrapolation' ! write(*,1110)duplicate%uniqid,duplicate%const1,duplicate%const2,& ! duplicate%const3,conx(1),conx(2),conx(3) ! write(*,1110)duplicate%uniqid,trim(species(1)),trim(species(2)),& ! trim(species(3)),conx(1),conx(2),conx(3) 1110 format('3H Error: The ternary ',a,1x,a,1x,a,1x,' & already has a ternary extrapolation',3i3) gx%bmperr=4399; goto 1000 ! Error: Trying to enter a method with wrong set of constituents 1200 continue ! write(*,1210)trim(species(1)),trim(species(2)),trim(species(3)),conx,& ! duplicate%const1,duplicate%const2,duplicate%const3 1210 format('3H Error: ternary system with ',a,'-',a,'-',a,': ',3i3,& ' does not fit method: ',3i3) end subroutine add_ternary_extrapol_method !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_ternary_extrapol_data !\begin{verbatim} ! subroutine list_ternary_extrapol_data(lut) subroutine list_ternary_extrapol_data(lut) ! lists the data structure generated by Toop/Kohler ternary commands implicit none integer lut ! outout unit lut !\end{verbatim} type(gtp_tooprec), pointer :: tooprec character species(3)*24 integer lokph,i1,i2,nz loop1: do lokph=1,noofph tooprec=>phlista(lokph)%tooplast if(.not.associated(tooprec)) cycle loop1 ! write(lut,10)trim(phlista(lokph)%name) 10 format('The ',a,' phase has ternary extrapolation methods') loop2: do while(associated(tooprec)) ! the last tooprec has toopid zero and is empty and %binint is nullified ! if(tooprec%toopid.eq.0) exit loop2 if(associated(tooprec%binint)) then ! The endmember constituent is saved in the tooprec i1=tooprec%endmemel i2=tooprec%binint%fraclink(1) nz=tooprec%free ! phlista(lookph)%constitlist(i1) is index to species list species(1)=splista((phlista(lokph)%constitlist(i1)))%symbol species(2)=splista((phlista(lokph)%constitlist(i2)))%symbol write(lut,100)i1,i2,trim(species(1)),trim(species(2)),tooprec%toopid 100 format(3x,'Binary ',i2,'-',i2,' (',a,'-',a,& ') has Toop/Kohler extraplations:' ,i3) write(lut,110)'Toop1: ',(tooprec%toop1(i1),i1=1,nz) write(lut,110)'Toop2: ',(tooprec%toop2(i1),i1=1,nz) write(lut,110)'Kohler: ',(tooprec%kohler(i1),i1=1,nz) 110 format(6x,a,10i3) ! if there is an amend command list it if(len(tooprec%amend1).gt.1) write(lut,120) tooprec%amend1 if(len(tooprec%amend2).gt.1) write(lut,120) tooprec%amend2 if(len(tooprec%amend3).gt.1) write(lut,120) tooprec%amend3 120 format(6x,'There is an amend command: ',a) endif tooprec=>tooprec%nexttoop enddo loop2 enddo loop1 1000 continue return end subroutine list_ternary_extrapol_data !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine create_toop_record !\begin{verbatim} ! subroutine create_toop_record subroutine create_toop_record(lokph,intrec,endmem,nobin) ! this replaces a 3 times repeated part of add_ternary_extrapol_method ! Also works for Kohler implicit none type(gtp_interaction), pointer :: intrec ! lokph is phase index, endmem is fraction index for endmember, nobin is size integer lokph,endmem,nobin !\end{verbatim} type(gtp_tooprec), pointer :: newtoop integer jj,kk ! we come here if we have to create or extend a tooprecord ! for storing a new ternary parameter with Toop/Kohler extrapolation ! write(*,'(a,3i3)')'3H creating tooprec with endmember ',endmem if(.not.associated(intrec%tooprec)) then ! write(*,*)'3H creating intrec%tooprec' allocate(newtoop) intrec%tooprec=>newtoop ! write(*,*)'3H created intrec%tooprec' ! add the new tooprec in the list from phlista(lokph)%tooplast and add uniqeid newtoop%nexttoop=>phlista(lokph)%tooplast phlista(lokph)%tooplast=>newtoop phlista(lokph)%lasttoopid=phlista(lokph)%lasttoopid+1 newtoop%toopid=phlista(lokph)%lasttoopid ! link the tooprecord from intrec13%tooprec and endmember fraction index intrec%tooprec=>newtoop ! newtoop%endmemel=conx(1) newtoop%endmemel=endmem ! Allocate space for data, this binary may have several ternary extrapolations allocate(newtoop%Toop1(nobin)) allocate(newtoop%Toop2(nobin)) allocate(newtoop%Kohler(nobin)) newtoop%Toop1=0 newtoop%Toop2=0 newtoop%Kohler=0 jj=1 newtoop%free=jj newtoop%amend1=' ' newtoop%amend2=' ' newtoop%amend3=' ' ! set crosslinks with interaction record newtoop%binint=>intrec intrec%tooprec=>newtoop else ! there is already a ternary extrapolation record, find place to store data newtoop=>intrec%tooprec jj=size(newtoop%Toop1) if(newtoop%free.eq.jj) then ! Tested that it works to extend. Already stored values kept write(*,90)trim(phlista(lokph)%name),newtoop%toopid,jj,newtoop%free 90 format('3H extending tooprecord for ',a,5i5) ! This should dynamically expand the arrays, the old content is kept newtoop%Toop1 = [ newtoop%Toop1, ( 0, kk=1,jj+5 ) ] newtoop%Toop2 = [ newtoop%Toop2, ( 0, kk=1,jj+5 ) ] newtoop%Kohler = [ newtoop%Kohler, ( 0, kk=1,jj+5 ) ] ! write(*,'(a,i5)')'3H extended size: ',size(newtoop%Toop1) ! save the new dimension in phlista(lokph)%toopfirst%free)) phlista(lokph)%toopfirst%free=jj+5 endif ! newtoop% free is the place to store new data in the arrays jj=newtoop%free+1 newtoop%free=jj endif ! write(*,*)'3H data in newtoop: ',newtoop%free ! reurn to enter data in intrec, newtoop%free is place to store new data 1000 continue return end subroutine create_toop_record !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ ================================================ FILE: src/models/gtp3X.F90 ================================================ ! ! gtp3X included in gtp3.F90, separate gtp3XQ for MQMQA ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !> 15. Section: calculate G and other things !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calcg !\begin{verbatim} subroutine calcg(iph,ics,moded,lokres,ceq) ! calculates G for phase iph and composition set ics in equilibrium ceq ! checks first that phase and composition set exists ! Data taken and stored in equilibrium record ceq ! lokres is set to the phase_varres record with all fractions and results ! moded is 0, 1 or 2 depending on calculating no, first or 2nd derivarives implicit none TYPE(gtp_equilibrium_data), pointer :: ceq integer iph,ics,moded,lokres !\end{verbatim} integer jcs,lokcs,lokph ! write(*,*)'3X in calcg',iph,ics,moded if(gx%bmperr.ne.0) then write(*,*)'3X Error code set when calling calcg: ',gx%bmperr goto 1000 endif if(iph.le.0 .or. iph.gt.noofph) then ! the selected_element_reference phase with iph=0 is calculated separtely gx%bmperr=4050; goto 1000 endif lokph=phases(iph) if(lokph.le.0 .or.lokph.gt.noofph) then gx%bmperr=4050; goto 1000 endif ! write(*,*)'3X calcg 1: ',phlista(lokph)%name ! find fractions for this composition set if(ics.le.1) then jcs=1 elseif(ics.le.phlista(lokph)%noofcs) then jcs=ics else ! no such composition set ! write(*,*)'3X calcg 1 error 4072' gx%bmperr=4072; goto 1000 endif ! if(phlista(1)%noofcs.gt.1) then ! strange error that liquid (phase 1) has 3 composition set ! write(*,*)'3X csbug: ',lokph,jcs,phlista(1)%noofcs ! stop 'csbug' ! endif ! Find fraction record this composition set lokcs=phlista(lokph)%linktocs(ics) ! write(*,*)'3X in calcg: ',lokcs !----- ! mcs=1 ! lokcs=phlista(lokph)%cslink ! do while(mcs.lt.jcs) ! mcs=mcs+1 ! firsteq is the first equilibrium and a global variable in this module ! lokcs=firsteq%phase_varres(lokcs)%next ! if(lokcs.le.0) then ! write(*,*)'3X calcg 2 error 4072' ! gx%bmperr=4072; goto 1000 ! endif ! enddo lokres=lokcs ! write(*,*)'3X calcg 7: ',lokres,trim(ceq%eqname) ! call using the local structure phase_varres ! results can be obtained through lokres ! write(*,17)'3X calcg: ',lokph,lokres,ceq%phase_varres(lokres)%yfr(1) 17 format(a,2i4,1pe15.6) call calcg_internal(lokph,moded,ceq%phase_varres(lokres),ceq) 1000 continue ! if phlista(lokph)%toopfirst then set phlista(lokph)%toopfirst%endmemel to 0 ! to indicate that redundant toop/Kohler fraction indices if(associated(phlista(lokph)%toopfirst)) phlista(lokph)%toopfirst%endmemel=0 ! write(*,*)'3X back from calcg_internal' return end subroutine calcg !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calcg_internal !\begin{verbatim} subroutine calcg_internal(lokph,moded,cps,ceq) ! Central calculating routine calculating G and everyting else for a phase ! ceq is the equilibrium record, cps is the phase_varres record for lokph ! moded is type of calculation, 0=only G, 1 G and first derivatives ! 2=G and all second derivatives ! Can also handle the ionic liquid model now .... implicit none integer lokph,moded TYPE(gtp_equilibrium_data), pointer :: ceq TYPE(gtp_phase_varres), target :: cps !\end{verbatim} ! fractype defines fraction type (1=constituent fractions) ! empermut and ipermut permutation of fractions for phases with option F and B ! permrecord, maxprec and sameint to handle permutation in the interaction tree integer, parameter :: permstacklimit=150 integer fractype,epermut,ipermut,typty,pmq,maxprec,already integer sameint(5) integer, dimension(permstacklimit) :: lastpmq,maxpmq ! character bug*60 ! dimension sites(maxsubl),pushpop(maxpp) double precision, dimension(:), allocatable :: dpyq(:),d2pyq(:),d2vals(:) double precision, dimension(:,:), allocatable :: dvals(:,:) double precision vals(6) ! this array has the sum of constituents up to and including current sublattice integer incffr(0:maxsubl) ! Kohler-Toop binary excess model link type(gtp_tooprec), pointer :: tooprec ! in local gz: gz%intlevel level of interaction, gz%intcon and gz%intlat are ! used also in cgint when calculating interactions. TYPE(gtp_parcalc) :: gz ! disordered fraction set ! TYPE(gtp_fraction_set) :: fracset,dislink TYPE(gtp_fraction_set), pointer :: fracset,dislink TYPE(gtp_phase_varres), pointer :: phres,phpart,phmain TYPE(gtp_property), pointer :: proprec TYPE(gtp_endmember), pointer :: endmemrec TYPE(gtp_interaction), pointer :: intrec TYPE(gtp_pystack), pointer :: pystack TYPE(gtp_phase_add), pointer :: addrec ! for an ordered phase like FCC with a disordered contribution one must ! calculate the ordered part twice, one with original fractions and once ! with these replaced by the disordered fractions. and subdrahera. This means ! one must have space to save fractions and results ! double precision, dimension(:), allocatable :: savey double precision, dimension(maxconst) :: savey double precision, dimension(:,:), allocatable :: saveg double precision, dimension(:,:,:), allocatable :: savedg double precision, dimension(:,:), allocatable :: saved2g double precision, dimension(:,:), allocatable :: tmpd2g ! added when implicit none double precision rtg,pyq,ymult,add1,sum,yionva,fsites,xxx,sublf integer nofc2,nprop,nsl,msl,lokdiseq,ll,id,id1,id2,lm,qz integer lokfun,itp,nz,intlat,ic,jd,jk,ic1,jpr,ipy,i1,j1,jj,jxsym integer i2,j2,ider,is,kk,ioff,norfc,iw,iw1,iw2,lprop,jonva,icat integer nsit1,nsit2 ! cqc configurational entropy integer nclust double precision, allocatable, dimension(:,:) :: gclust ! mqmqa endmember counting and other specials integer mqmqj,kend ! double precision, dimension(:,:), allocatable :: fhv ! double precision, dimension(:,:,:), allocatable :: dfhv ! double precision, dimension(:,:), allocatable :: d2fhv double precision g2val(6) ! to handle parameters with wildcard constituent and other things logical wildc,nevertwice,first,chkperm,ionicliq,iliqsave,iliqva,iliqneut ! mobility parameters must not have wildcard constituents logical liq2state,wildmob,mqmqa ! pointer to mqmqaf record with all fraction records for MQMQA ! type(gtp_mqmqa_var), pointer :: mqf ! debugging for partitioning and ordering integer idlist(9) ! calculate RT to normalize all Gibbs energies, ceq is current equilibrium rtg=globaldata%rgas*ceq%tpval(1) ceq%rtn=rtg ! if(ocv()) write(*,*)'3X in gcalc_internal: ',lokph !----------------------- chkperm=.false. mqmqa=.false. already=0 if(btest(phlista(lokph)%status1,PHMQMQA)) then ! write(*,*)'3X phase has MQMQA model' mqmqa=.TRUE. ! if allocated inititate all excess checks to false, not a good place .... ! if(allocated(mqmqa_data%csumx)) then ! write(*,*)'3X in calcg_internal inititate mqmqa_data%csumx' ! mqmqa_data%csumx=.FALSE. ! endif endif if(btest(phlista(lokph)%status1,PHFORD) .or. & btest(phlista(lokph)%status1,PHBORD)) then ! PHPALM is needed for phases with permutations such as ordered FCC/BCC/HCP chkperm=.true. if(.not.btest(phlista(lokph)%status1,PHPALM)) then ! write(*,*)'3X calling palmtree ',lokph,cps%phtupx ! This is needed only once unless parameters are changed. It numbers the ! interaction records sequentially for the permutations ! palmtree is in gtp3Y.F90 for some unknown reason ... call palmtree(lokph) if(gx%bmperr.ne.0) goto 1000 ! this must be zeroed if a new interaction parameter is added ! phlista(lokph)%status1=ibset(phlista(lokph)%status1,PHPALM) endif endif !----------------------------------------------------------------- 50 continue ! local work arrays for products of Y and calculated parameters are allocated gz%nofc=phlista(lokph)%tnooffr nofc2=gz%nofc*(gz%nofc+1)/2 ! write(*,*)'3X in calcginternal ',btest(phlista(lokph)%status1,PHLIQ2STATE) ! write(*,17)'3X calcg, ',lokph,gz%nofc,nofc2,size(cps%d2gval),cps%nprop,& ! cps%yfr(1) !17 format(a,5i4,1pe15.6) ! for disordered fraction sets gz%nofc must be from disordered fraction record ! maybe these should not be allocated for moded=0 and 1 ! write(*,*)'3X allocate: ',gz%nofc,nofc2 allocate(dpyq(gz%nofc)) allocate(d2pyq(nofc2)) ! these return values from excess parameters that may depend on constitution allocate(dvals(3,gz%nofc)) allocate(d2vals(nofc2)) nullify(pystack) ! do they have to be zeroed? YES! dpyq=zero d2pyq=zero ! dimension for number of parameter properties nprop=cps%nprop ! phres will point either to ordered or disordered results ! phmain will always point to record for ordered phase_varres phmain=>cps phres=>cps ! zero result arrays for all properties, maybe one should do it separately for ! each property as it is found but it may be faster to do it like this anyway phres%gval=zero if(moded.gt.0) then phres%dgval=zero if(moded.gt.1) then phres%d2gval=zero endif endif ! debugging mqmqa entropy sconfmqmqa=zero ! copy current values of T, P and RT from gtp_phase_varres gz%tpv(1)=ceq%tpval(1) gz%tpv(2)=ceq%tpval(2) ! write(*,*)'3X calcg_i: ',gz%tpv gz%rgast=ceq%tpval(1)*globaldata%rgas ! gz%rgast=ceq%tpval(1)*ceq%rgas ! this is used to check the number of times an ordered phase is calculated first=.true. !------------------------------------------------------------------- ! calculate configurational entropy. nsl=phlista(lokph)%noofsubl ionicliq=.FALSE. iliqsave=.FALSE. if(btest(phlista(lokph)%status1,PHIONLIQ)) then call config_entropy_i2sl(moded,nsl,phlista(lokph)%nooffr,phres,& phlista(lokph)%i2slx,gz%tpv(1)) ionicliq=.TRUE. ! iliqsave=.FALSE. iliqva=.FALSE. jonva=0 elseif(mqmqa) then ! ! MQMQA FactSage entropy model ! strange error OC dies when calling this using "c g" as first command ! OK when using c ph .... , problem with arguments ! write(*,222)moded,lokph,phlista(lokph)%tnooffr,phres%yfr(1),gz%tpv(1) 222 format('3X call mqmqa entropy: ',3i3,2(1pe12.4)) ! in gtp3_XQ ! attempt to extract configurational entropy, gval(2,1) id dG/dT sconfmqmqa=phres%gval(2,1) call config_entropy_mqmqa1(phres,moded,lokph,gz%tpv(1)) ! attempt to simplify the call .... ! when we come back mqmqaf should have some arrays allocated .... ! DO NOT SET THIS POINTER BEFORE ARRAYS ARE ALLOCATED IN CONFIG_ENTROPY_MQMQA ! this pointer now obsolete, phres%mqmqaf used inside _mqmqa1 ! mqf=>phres%mqmqaf ! write(*,'(a,1pe12.4)')'3X MQMQA cfgG:',phres%gval(1,1)*gz%rgast*phres%amfu ! write(*,'(a,1pe12.4)')'3X MQMQA cfgG:',phres%gval(1,1)*gz%rgast ! do mqmqj=1,mqf%npair ! write(*,777)mqf%pair(mqmqj),(mqf%dpair(mqmqj,kk),kk=1,mqf%nconst) ! write(*,777)mqf%pair(mqmqj),mqf%dpair(mqmqj,1),mqf%dpair(mqmqj,2),& ! mqf%dpair(mqmqj,3) 777 format('3X pairs:',F10.6,2x,10F9.5) ! enddo ! attempt to extract configurational entropy ! write(*,*)'3X back from config_entropy_mqmqa1 ' sconfmqmqa=(phres%gval(2,1)-sconfmqmqa)*rtg ! write(*,'("3X MQMQA dG/dT: ",1pe12.4)')sconfmqmqa elseif(btest(phlista(lokph)%status1,PHQCE)) then ! this is the corrected QC, Hillert-Selleby-Sundman model call config_entropy_qchillert(moded,phlista(lokph)%nooffr(1),& phres,phlista(lokph),gz%tpv(1)) ! write(*,480)'3X dg/dt/RT: 1: ',qcmodel,phres%yfr(3),& ! phres%gval(1,1),phres%gval(2,1) 480 format(a,i2,6(1pe12.4)) ! several old versions to be deleted ... ! call config_entropy_cqc(moded,phlista(lokph)%tnooffr(1),& ! phres,phlista(lokph),nclust,gclust,gz%tpv(1)) elseif(btest(phlista(lokph)%status1,PHCVMCE)) then ! the classical quasichemical or tetraherdon CVM model with LRO call config_entropy_qcwithlro(moded,phlista(lokph)%tnooffr,phres,& phlista(lokph),gz%tpv(1)) ! phstate elseif(btest(phlista(lokph)%status1,PHTISR)) then ! the configurational model by E Kremer (Calphad 2022) call config_entropy_tisr(moded,phlista(lokph)%tnooffr,phres,& phlista(lokph),gz%tpv(1)) elseif(btest(phlista(lokph)%status1,PHSROT)) then ! the configurational model is a modified tetrahedron quasichemical model call config_entropy_srot(moded,phlista(lokph)%tnooffr,phres,& phlista(lokph),gz%tpv(1)) ! phstate elseif(btest(phlista(lokph)%status1,PHSSRO)) then ! CVM tetraheron SRO (no LRO) configurational entropy call config_entropy_ssro(moded,lokph,phres,gz%tpv(1)) ! phstate elseif(btest(phlista(lokph)%status1,PHCVMTFL)) then ! CVM tetraheron SRO (no LRO) configurational entropy call config_entropy_cvmtfl(moded,lokph,phres,gz%tpv(1)) else !----------- the CF Bragg-Williams ideal configurational entropy per sublattice ! NOTE: for phases with disordered fraction set this is calculated ! ONLY for the original constituent fraction set with ordering sublattices call config_entropy(moded,nsl,phlista(lokph)%nooffr,phres,gz%tpv(1)) endif if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'3X segmentation fault 10' !------------------------------------------------------------------- ! MQMQA separate calculation of G as well (as above) the entropy!!! ! NO no 2state model, einstein, magnetism etc. if(mqmqa) then ! write(*,*)'3X Separate routine for nonconfig MQMQA' call calc_mqmqa(lokph,phres,ceq) ! write(*,*)'3X back from nonconfig MQMQA' goto 1000 endif !------------------------------------------------------------------- ! start BIG LOOP for all fraction variables and parameters ! there may be several different properties in addition to G like TC, MQ& etc ! each of these are stored in separate gval(*,ipy) where ipy is an integer ! set for each property. lprop is incremented by one for each new property ! found (each phase may have different) and in listprop the original type ! of property is stored. listprop will always be associated with phmain !100 continue ! yionva is used as indicator below if there are Va or just neutrals ... yionva=zero nevertwice=.true. lprop=2 phmain%listprop=0 phmain%listprop(1)=lprop ! write(*,168)'3X lprop0:',lprop,0,(phmain%listprop(jj),jj=1,10) fractype=0 ! write(*,*)'3X calcg 99: ',lokph,cps%phtupx,cps%disfra%varreslink !-------------------------------------------------------------------- ! VERY STRANGE ERROR ! wrong results calculating with disordered fraction set disappeared ! when adding this write statements (and the one after the else statement ! and the one with the text nevertwice: further below) ! write(*,101)'3X calcg 100 ',nsl,phlista(lokph)%nooffs,& ! btest(phmain%status2,CSORDER),phres%gval(1,1),cps%gval(1,1) 101 format(a,2i4,1x,l,4(1pe14.4)) !-------------------------------------------------------------------- ! loop for different types of fractions: site fractions, mole fractions ... fractyp: do while(fractype.lt.phlista(lokph)%nooffs) 105 continue ! write(*,7)'3X label 105: ',fractype,btest(phlista(lokph)%status1,PHSUBO),& ! btest(phmain%status2,CSORDER),btest(phlista(lokph)%status1,PHMFS),& ! fracset%totdis,phres%gval(1,1) 7 format(a,i2,3(1x,l),i3,3(1pe12.4)) fractype=fractype+1 ! write(*,*)'3X segmentation fault 20',fractype ! return here for calculating with disordered fractions for same fraction type 110 continue ! gz%nofc is number of fraction variables, msl is number of sublattices ! for this set of fractions!!! Ordering in FCC may have 5 sublattices with ! 4 participating in ordering and one interstitial. The second fraction ! set may have 2 sublattices, 1 for the 4 ordering and one interstitial ! fracset=phmain%disfra fracset=>phmain%disfra ! write(*,*)'3X segmentation fault 30',associated(fracset) ftype: if(fractype.eq.1) then !---------------------------------------------- ordered (or only) fraction set if(btest(phlista(lokph)%status1,PHMFS)) then ! there is a disordered fractions set, we need additional fracset if(fracset%totdis.ne.0) then if(btest(phlista(lokph)%status1,PHSUBO)) then ! if phsubo set skip subtracting the ordered part as disordered, just add goto 106 endif ! the phase can totally disorder, if disordered skip ordered part ! the CSORDER bit set by calc_disfrac called from set_constitution if(btest(phmain%status2,CSORDER)) then ! the phase is ordered, we have to calculate this part twice ! write(*,*)'3X Setting nevertwice false' nevertwice=.false. ! independent if ordered or disordered always calculate first fraction set else ! the phase is disordered, skip ordered part and just calculate disordered ! nevertwice is already set TRUE goto 105 endif endif endif 106 continue gz%nofc=phlista(lokph)%tnooffr msl=nsl incffr(0)=0 do qz=1,nsl incffr(qz)=incffr(qz-1)+phlista(lokph)%nooffr(qz) enddo ! write(*,*)'3X after 106: ',fractype,nevertwice ! the results will be stored in the results arrays indicated by phres ! it was set above for the ordered fraction set. else !------------------------------------------------- ! disorderd/other fraction sets, take data from gtp_fraction_set ! write(*,*)'3X Fraction type: ',fractype,cps%disfra%varreslink msl=fracset%ndd gz%nofc=fracset%tnoofxfr incffr(0)=0 do qz=1,msl incffr(qz)=incffr(qz-1)+fracset%nooffr(qz) enddo ! we have to deallocate and allocate local arrays, not if moded=0 or 1?? deallocate(dpyq) deallocate(d2pyq) allocate(dpyq(gz%nofc)) allocate(d2pyq(nofc2)) if(ocv()) write(*,*)'3X Allocated dpyq 2' dpyq=zero deallocate(dvals) deallocate(d2vals) allocate(dvals(3,gz%nofc)) allocate(d2vals(nofc2)) if(ocv()) write(*,*)'3X Allocated vals 2' ! the results will be stored in result arrays indicated by phres ! for the disordered fraction set phres must be set here and the arrays zeroed ! dislink=cps%disfra dislink=>cps%disfra ! write(*,*)'3X Calc internal disordred part 1A',dislink%fsites lokdiseq=dislink%varreslink ! write(*,*)'3X Calc internal disordred part 1B',lokdiseq phres=>ceq%phase_varres(lokdiseq) ! Wow phres%gval etc not allocated !! if(.not.allocated(phres%gval)) then allocate(phres%gval(6,nprop)) endif phres%gval=zero ! write(*,*)'3X Calc internal disordred part 1c',& ! allocated(phres%dgval),gz%nofc if(moded.gt.0) then if(.not.allocated(phres%dgval)) then allocate(phres%dgval(3,gz%nofc,nprop)) endif phres%dgval=zero if(moded.gt.1) then nofc2=gz%nofc*(gz%nofc+1)/2 ! write(*,*)'3X segmentation fault 48: ',& ! allocated(phres%d2gval),nofc2 if(.not.allocated(phres%d2gval)) then allocate(phres%d2gval(nofc2,nprop)) endif phres%d2gval=zero endif endif ! write(*,*)'3X Calc internal disordred part 2' endif ftype !========================================================== ! there can be ordered and disordered fraction sets selected by fractype if(fractype.eq.1) then endmemrec=>phlista(lokph)%ordered else endmemrec=>phlista(lokph)%disordered endif ! ! here we take one endmember at a time but to speed up when having several ! CPU we give one endmamber plus its interaction tree to each tread. ! To handle this all endmember records should be in an array. An attempt to ! implement this was made in calcg_internal2 but not updated for permutations ! ! empermut, lastpmq and maxpmq controls permutations (option F and B) ! maxpmq is set to zero for each new endmember but keep its content ! during calculation of all permutations of the same endmember and interactions ! big loop for all permutation of fractions (ordering option F and B) ! including all interaction parameters linked from this endmember ! endmemloop: do while(associated(endmemrec)) ! ! The array maxpmq is used for interaction permutations. It must be ! initialized to zero at the first endmember permutation. It is set to ! limits for the interacton permutations for all interaction records. maxpmq=0 maxprec=0 epermut=0 sameint=0 !--------------------------------- quick test of mqmqa reference state if(mqmqa) then stop '3X MQMQA separate routine' endif empermut: do while(epermut.lt.endmemrec%noofpermut) epermut=epermut+1 ! calculate py, calculate parameter, calculate contribution to G etc ! py is product of all fractions, dpy are first derivatives and d2py second pyq=one if(moded.gt.0) then ! moded=0, only G, =1 only G and dG/dy, moded=2 all Gm dG/dy and d2G/dy2 dpyq=zero if(moded.gt.1) then d2pyq=zero endif endif wildmob=.FALSE. pyqloop: do ll=1,msl id=endmemrec%fraclinks(ll,epermut) ! debugging 4SL with wildcards idlist(ll)=id ! remove next line when all fixed ! if(ll.lt.5) clist(ll)=id ! id negative means wildcard, independent of the fraction in this sublattice if(id.lt.0) then gz%yfrem(ll)=one wildmob=.TRUE. else gz%yfrem(ll)=phres%yfr(id) if(gz%yfrem(ll).lt.bmpymin) gz%yfrem(ll)=bmpymin if(gz%yfrem(ll).gt.one) gz%yfrem(ll)=one endif ! gz%endcon is used for interaction parameters below gz%endcon(ll)=id pyq=pyq*gz%yfrem(ll) ! write(*,33)ll,epermut,id,gz%yfrem(ll),pyq 33 format('3X py: ',i3,2i5,2(1pe12.4)) if(ionicliq .and. ll.eq.2) then ! For ionic liquid we must check when Va or neutral in second sublattice ! i2slx(1) is index of vacancy, i2slx(2) is first neutral if(id.eq.phlista(lokph)%i2slx(1) .and. yionva.eq.zero) then iliqva=.TRUE. yionva=gz%yfrem(ll) jonva=phlista(lokph)%i2slx(1) ! We found Va. Save all calculated values as the follwing terms should all ! be multiplied with Q (done after finishing calculation) ! nprop=phmain%nprop ! we have already extracted nprop above .... allocate(saveg(6,nprop)) saveg=phres%gval ! if(ocv()) write(*,*)'3X saveg allocated 1A:',size(saveg),& ! gz%nofc,nofc2,nprop,moded if(moded.gt.0) then ! only allocate if needed, some "out of memory" problems here calculating grid ! with just ionic liquid phase allocate(savedg(3,gz%nofc,nprop)) allocate(saved2g(nofc2,nprop)) savedg=phres%dgval saved2g=phres%d2gval endif ! if(ocv()) write(*,*)'3X saveg allocated 1B: ' ! write(*,*)'3X Config G 3A: ',phres%gval(1,1)*rtg phres%gval=zero phres%dgval=zero phres%d2gval=zero ! write(*,*)'3X Config G 3B: ',phres%gval(1,1)*rtg iliqsave=.TRUE. ! write(*,117)'3X Saved ionliq G at Va id: ',& ! id,yionva,saveg(1,1) 117 format(a,i3,6(1pe12.4)) elseif(id.eq.phlista(lokph)%i2slx(2) .and. jonva.eq.0) then ! we have NO vacancy but a neutral in second sublattice iliqva=.FALSE. yionva=-one jonva=0 why1: if(.not.iliqsave) then ! We may have model without Va, for exampel (Ca+2)p(O-2,SiO4-4,SiO2)q, if so ! we must save all calculated values as the rest should be multiplied with Q ! nprop=phmain%nprop ! we already know nprop from above allocate(saveg(6,nprop)) allocate(savedg(3,gz%nofc,nprop)) allocate(saved2g(nofc2,nprop)) ! if(ocv()) write(*,*)'3X saveg allocated 2:',size(saveg) saveg=phres%gval savedg=phres%dgval saved2g=phres%d2gval phres%gval=zero phres%dgval=zero phres%d2gval=zero iliqsave=.TRUE. ! write(*,117)'3X Saved ionliq G at neutral id: ',& ! id,yionva,saveg(1,1) ! else ! write(*,*)'3X neutral: ',jonva,yionva,iliqva endif why1 endif endif enddo pyqloop if(moded.eq.0) goto 150 !---------------------------------------------------- first derivatives of py dpyqloop: do ll=1,msl ! here pyq is known, same loop as above to calculate dpyq(i)=pyq/y_i id=endmemrec%fraclinks(ll,epermut) if(id.gt.0) then ! pyq was multiplied with gz%yfrem(11) above, now divide with it dpyq(id)=pyq/gz%yfrem(ll) ! write(*,*)'3X dpq/dy: ',ll,id,dpyq(id) elseif(.not.ionicliq) then ! wildcard in the sublattice and NOT ionic liquid do iw=incffr(ll-1)+1,incffr(ll) dpyq(iw)=pyq enddo elseif(ll.ne.1) then ! wildcard in second subl of ionic liquid, same as for CEF do iw=incffr(ll-1)+1,incffr(ll) dpyq(iw)=pyq enddo ! else ! wildcard in first subl of ionic liquid then just ignore first derivatives ! with respect to constituents in first sublattice ! continue endif enddo dpyqloop if(moded.le.1) goto 150 !---------------------------------------------------- second derivatives of py ! searching for bug with interaction wildcards in 4SL ! write(*,68)'3X d2P/dyi2A:',nofc2,(d2pyq(id),id=1,nofc2) ! d2pyq is all zero here d2pyqloop1: do ll=1,msl id1=endmemrec%fraclinks(ll,epermut) ! too complicated here ... jxsym=ixsym(ll,ll+1) d2pyloop2: do lm=ll+1,msl id2=endmemrec%fraclinks(lm,epermut) if(id1.gt.0) then if(id2.gt.0) then d2pyq(ixsym(id1,id2))=dpyq(id1)/gz%yfrem(lm) else ! wildcard in sublattice lm, real component in ll ! do iw=incffr(lm)+1,incffr(lm) ! d2pyq(ixsym(id1,iw))=dpyq(id1) ! enddo ! This derivative should be zero!! /170324/BoS continue wildmob=.TRUE. endif else ! wildcard in sublattice ll, real component in lm if(id2.gt.0) then ! do iw=incffr(ll-1)+1,incffr(ll) ! d2pyq(ixsym(id2,iw))=one ! enddo ! This should be zero!! /170324/BoS continue else ! wildcards in both sublattice ll and lm ! do iw1=incffr(ll-1)+1,incffr(ll) ! do iw2=incffr(lm-1)+1,incffr(lm) ! d2pyq(ixsym(iw1,iw2))=pyq ! enddo ! enddo ! I think this should be zero too!! /170324/BoS endif wildmob=.TRUE. endif enddo d2pyloop2 enddo d2pyqloop1 ! searching for bug with interaction wildcards in 4SL ! write(*,67)'B:' ,pyq,(idlist(iw1),iw1=1,nsl) 67 format('3X endmem',a,e12.4,9i4) ! write(*,68)'3X d2P/dyi2B:',nofc2,(d2pyq(id),id=1,nofc2) 68 format(a,i3,5(1pe12.4)/,(16x,5e12.4)) !---- jump here if moded is 0 or 1 150 continue ! ! if debugpar nonzero add call for debug_endmemberpar(....) here ! !----------------------------------------------------- ! d2pyq contains 2nd serivatives of endmember fractions. ! write(*,228)'3X d2pyq 0:',d2pyq ! write(*,*)'3X Config G 4A: ',phres%gval(1,1)*rtg ! write(*,154)'3X endmember permutation: ',epermut,(clist(i),i=1,4) 154 format(a,i5,4i4,'--------------------------------') 155 format(a,i5,10i4) proprec=>endmemrec%propointer ! for liquids with twostate models first calculate the g2 parameter if(btest(phlista(lokph)%status1,PH2STATE)) then write(*,*)'3X Phase ',trim(phlista(lokph)%name),& ' has PH2STATE bit set' call calc_twostate_model_endmember(proprec,g2val,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,'(a,6(1pe12.4))')'3X g2val:',g2val liq2state=.true. else liq2state=.false. g2val=zero endif emprop: do while(associated(proprec)) typty=proprec%proptype if(typty.ne.1) then ! if property different from 1 (=G) find where to store it, use phmain link ! First check if the parameter is a mobility and there are wildcrds if(wildmob) then ! nowildcard(1..3) set in gtp_init in gtp3A.F90 for mobility parameters ! typty is indicator*100 + constituent index do qz=1,3 if(typty/100.eq.nowildcard(qz)) then write(*,*)& '3X mobilities must not have wildcards',lokph gx%bmperr=4374; goto 1000 endif enddo endif do qz=2,lprop-1 if(phmain%listprop(qz).eq.typty) goto 170 enddo ! a new property, save its typty in listprop and increment lprop ! note that the property index typty is not used as index in gval etc ! as that can be very large. lprop is incremented by 1 for each property ! actually used in the model of the phase. lprop is last free index qz=lprop if(qz.gt.size(phmain%listprop)) then write(*,*)'Too many differnt parameter identifiers',qz gx%bmperr=4338; goto 1000 endif phmain%listprop(qz)=typty ! a bit stupid to allocate listprop, it should have fixed allocation ... if(allocated(phmain%listprop)) then ! if(lprop.ge.nprop) then ! VERY STRANGE ERROR, nprop is suddenly zero .... if(lprop.ge.size(phmain%listprop)) then write(*,169)'3X Too many parameter properties ',& lprop,nprop,typty,lokph,& size(phmain%listprop),phlista(lokph)%name 169 format(a,3i3,2x,2i3,2x,a) gx%bmperr=4338; goto 1000 endif else write(*,*)'3X Internal error, listprop not allocated',& lokph,phlista(lokph)%name gx%bmperr=4339; goto 1000 endif lprop=lprop+1 phmain%listprop(1)=lprop ! listprop(1) is number of defined properties, listprop(2..) is property ! write(*,168)'3X lprop: ',lprop,typty,& ! (phmain%listprop(ipy),ipy=1,lprop) 168 format(a,2i5,': ',10i5) ! jump here is we already have found this property and know its ipy 170 continue ipy=qz else ipy=1 endif !================ here we calculate the endmember parameter ============ ! calculate function and derivatives wrt T and P ! the results from eval_tpfun must also be different in different treads ... lokfun=proprec%degreelink(0) call eval_tpfun(lokfun,ceq%tpval,vals,ceq%eq_tpres) ! write(*,167)'3X eval_tpfun: ',ipy,lokfun,pyq,vals(1),vals(1)/rtg 167 format(a,2i5,6(1pe12.4)) if(gx%bmperr.ne.0) goto 1000 prop1: if(ipy.eq.1) then ! property 1 i.e. Gibbs energy, should be divided by RT vals=vals/rtg if(liq2state) then ! if phase has liquid twostate model add g2val!! ! write(*,'(a,6(1pe12.4))')'3X +g2val',& ! vals(1),g2val(1),vals(1)+g2val(1),& ! vals(4),g2val(4),vals(4)+g2val(4) vals=vals+g2val endif endif prop1 ! write(*,*)'3X property type: ',typty,ipy,vals(1) !================ now we calculated the endmember parameter ============ ! take care of derivatives of fraction variables ... ! write(*,173)'3X endmember: ',endmemrec%antalem,ipy,pyq,vals(1) 173 format(a,2i4,4(1pe12.4)) ! multiply with py and derivatives. vals is composition independent ! write(*,*)'3X Config G 4B: ',vals(1)*rtg ! segmentation fault between 64 and 65 .... noderz2: if(moded.gt.0) then derloopz2: do id=1,gz%nofc do itp=1,3 phres%dgval(itp,id,ipy)=phres%dgval(itp,id,ipy)+ & dpyq(id)*vals(itp) enddo if(moded.gt.1 .and. dpyq(id).gt.zero) then jxsym=kxsym(id,id+1) do jd=id+1,gz%nofc ! trying to replace calls of ixsym ... OK here if(ixsym(id,jd).ne.jxsym) then write(*,*)'ISYM error 1',id,jd,ixsym(id,jd),jxsym stop endif ! write(*,*)'3X segfault 64C',allocated(d2pyq),& ! d2pyq(jxsym) ! write(*,*)'3X segfault 64E',allocated(phres%d2gval) ! phres%d2gval not allocated!! ! write(*,*)'3X segfault 64F',phres%d2gval(jxsym,ipy) phres%d2gval(jxsym,ipy)= & phres%d2gval(jxsym,ipy)+ & d2pyq(jxsym)*vals(1) jxsym=jxsym+jd enddo endif enddo derloopz2 endif noderz2 do itp=1,6 phres%gval(itp,ipy)=phres%gval(itp,ipy)+pyq*vals(itp) enddo ! write(*,171)'3X phres7: ',ipy,phres%gval(1,1),phres%gval(1,ipy),& ! pyq,vals(1) 171 format(a,i3,6(1pe12.4)) ! strange values of mobilities for ordered phases ... EINSTEIN ! if(ipy.ne.1) then ! write(*,173)'3X gval: ',phmain%listprop(ipy),ipy,& ! phres%gval(1,ipy),pyq,vals(1) ! endif proprec=>proprec%nextpr ! write(*,*)'3X Config G 4C: ',phres%gval(1,1)*rtg ! debug problem with mobility calculation ! if(ipy.eq.2) then ! write(*,172)'3X mob: ',ipy,phmain%listprop(1),& ! phmain%listprop(ipy),& ! pyq,vals(1),pyq*vals(1),phres%gval(1,ipy) !172 format(a,3i4,6(1pe12.4)) ! endif enddo emprop !------------------------------------------------------------------ ! take link to first interaction records, use push and pop to save pyq etc ! pmq keeps track of the location in LASTPMQ and MAXPMQ ! for each interaction record in this binary interaction tree intrec=>endmemrec%intpointer gz%intlevel=0 pmq=1 ! looking for Toop/Kohler calculations ! write(*,*)'3X start interloop: ',associated(intrec) ! pmq is initiated by palmtree above in the interaction records ! write(*,*)'3X excess 0: ',associated(intrec),phres%gval(1,1)*rtg interloop: do while(associated(intrec)) !---------------------------------------------------------------- ! come back here an interaction at a higher level or a poped next that must ! be pushed 200 continue gz%intlevel=gz%intlevel+1 ! write(*,*)'3X excess 1: ',gz%intlevel,phres%gval(1,1)*rtg ! write(*,*)'3X is there a tooprec?: ',associated(intrec%tooprec) call push_pyval(pystack,intrec,pmq,& pyq,dpyq,d2pyq,moded,gz%nofc) ! intrec%order is initiated by palmtree to set a sequential number pmq=intrec%order ! check if there is a Kohler-Toop link (NOT YET) ! write(*,*)'3X testing tooprec: ',associated(intrec%tooprec) if(associated(intrec%tooprec)) then ! write(*,*)'3X Toop/Kohler model: ',& ! associated(intrec%tooprec),chkperm,gz%intlevel tooprec=>intrec%tooprec if(chkperm) then write(*,*)'3X Toop/Kohler and permutations is illegal' gx%bmperr=4399; goto 1000 endif ! we need this additional information inside calc_toop ! I find it very elegant just to include a pointer to the phase_varres record! tooprec%phres=>cps else nullify(tooprec) endif ! write(*,155)'3X Pushed: ',pmq,gz%intlevel !------------------------------------------------------------------- ! come back here for another permutation of same paremeter (no push needed) 220 continue bford: if(chkperm) then setipermut: if(maxpmq(pmq).eq.0) then ! ipermut must be initiated and saved in lastpmq ipermut=1; lastpmq(pmq)=ipermut ! On level 1 the number of permutation is in first location ! On level 2 it is more complicated but the first number of perm is in 2nd loc maxpmq(pmq)=intrec%noofip(gz%intlevel) else ! lastpmq and maxpmq already initiated (NOTE: they are used for all ! permutations of the same endmember, that is why they are stored here ! They cannot be pushed on the stack as the stack is also popped ipermut=lastpmq(pmq)+1 plimit: if(ipermut.gt.maxpmq(pmq)) then ! maximum interaction level allowed when permutations is 2 level: if(gz%intlevel.eq.1) then ! This is always simple for level 1, maxpmq(pmq)=maxpmq(pmq)+& intrec%noofip(1) ! write(*,155)'3X new limit: ',ipermut,& ! maxpmq(pmq) if(ipermut.le.maxpmq(pmq)) goto 230 elseif(gz%intlevel.gt.2) then write(*,*)'3X Max level 2 interactions allowed' gx%bmperr=4340; goto 1000 else varying: if(intrec%noofip(1).eq.1) then ! If this is 1 then noofip(2) is number of permutations each time maxpmq(pmq)=maxpmq(pmq)+intrec%noofip(2) if(ipermut.le.maxpmq(pmq)) goto 230 else ! This is more complicated, different number of permutations each time ! Example: noofip=(3,2,1,0,12) means there are 3 different permutations ! first time; 2 the second time; 1 the last time none; ! 12 is the total number of permutationss (including first order) ! Example 1: end member (A:A:A:A), no permutation ! first int B in 1 with perms: 2nd int C in 2 with perms: (3,3,3,3,12) ! (AB:A:A:A) (AB:AC:A:A) (AB:A:AC:A) (AB:A:A:AC) ! (A:AB:A:A) (AC:AB:A:A) (A:AB:AC:A) (A:AB:A:AC) ! (A:A:AB:A) (AC:A:AB:A) (A:AC:AB:A) (A:A:AB:AC) ! (A:A:A:AB) (AC:A:A:AB) (A:AC:A:AB) (A:A:AC:AB) ! Example 2: end member (A:A:A:A), no permutation ! first int B in 1 with perms: 2nd int B in 2 with perms: (3,2,1,0,6) ! (AB:A:A:A) (AB:AB:A:A) (AB:A:AB:A) (AB:A:A:AB) ! (A:AB:A:A) (A:AB:AB:A) (A:AB:A:AB) ! (A:A:AB:A) (A:A:AB:AB) ! (A:A:A:AB) none ! If mod(ipermut,noofip(1)) is 0 one should start from index 2 nz=intrec%noofip(1) ! write(*,155)'3X noofip: ',ipermut,pmq,& ! maxpmq(pmq),(intrec%noofip(j),j=1,nz) if(maxpmq(pmq).gt.0) then ! Previous increase of limit was greater than zero, special case for noofip=2 if(intrec%noofip(1).eq.2) then maxpmq(pmq)=-maxpmq(pmq) else nz=mod(ipermut-1,intrec%noofip(1)) if(nz.eq.0) then maxpmq(pmq)=-maxpmq(pmq) else maxpmq(pmq)=maxpmq(pmq)+& intrec%noofip(1+nz) endif endif if(ipermut.le.maxpmq(pmq)) goto 230 else ! Previous increase of limit was 0, start repeating values from noofip(2.. maxpmq(pmq)=intrec%noofip(2)-& maxpmq(pmq) if(ipermut.le.maxpmq(pmq)) goto 230 endif ! write(*,155)'3X noperm: ',ipermut,pmq,& ! lastpmq(pmq),maxpmq(pmq) endif varying ! as we have passed the limit of permutations, take higher or next interaction !??? if(ipermut.le.maxpmq(pmq)) goto 230 endif level ! We have exeeded the permutation limit, we should not go to any ! higher interaction but to a next interaction on same level (if any) ! or go down one level if(associated(intrec%highlink)) then if(gz%intlevel.eq.2) then write(*,229)gz%intlevel 229 format('3X Error, max 2 levels of interactions',/& ' with permutations!! ',i3) gx%bmperr=4340; goto 1000 endif ! Take the link to higher as no more permutations here goto 290 endif !.............................. ! No higher level, if we cannot pop we must return to endmember if(gz%intlevel.eq.0) exit interloop ! we must pop lower order interaction records here to get correct permutation call pop_pyval(pystack,intrec,pmq,& pyq,dpyq,d2pyq,moded,gz%nofc) gz%intlevel=gz%intlevel-1 pmq=intrec%order !................................. ! intrec must not be associated in the popint: do-loop nullify(intrec) goto 295 endif plimit ! We have now the permutation for this interaction in ipermut 230 continue endif setipermut ! Found the permutations for option F and B, save it in lastpmq(pmq) lastpmq(pmq)=ipermut ! Without permutations just set ipermut=1 else ! write(*,*)'3X no permutations' ipermut=1 endif bford !------------------------------------------------------------------- ! Code below until label 290 the same with and without permutations ! extract sublattice, constituent and fraction of interacting constituent ! NOTE "ic" used several times below, do not manipulate it!!! intlat=intrec%sublattice(ipermut) ic=intrec%fraclink(ipermut) gz%intlat(gz%intlevel)=intlat gz%intcon(gz%intlevel)=ic ! if intlat or ic is zero or less give error message and skip if(intlat.le.0 .or. ic.le.0) then if(already.eq.0 .or. intrec%antalint.ne.already) then already=intrec%antalint write(*,231)'3X error: ',phlista(lokph)%alphaindex,& (idlist(iw1),iw1=1,nsl),& (gz%intlat(iw1),gz%intcon(iw1),iw1=1,gz%intlevel) write(*,231)'3X intp: ',intrec%antalint,gz%intlevel,& ipermut,intlat,ic,pmq,maxpmq(pmq) 231 format(a,10i5) endif goto 290 endif gz%yfrint(gz%intlevel)=phres%yfr(ic) ! write(*,*)'3X excess 2: ',ionicliq,iliqsave if(ionicliq .and. iliqsave) then if(intlat.eq.1 .and. yionva.gt.zero) then ! iliqsave is TRUE for ionic_liquid and for excess parameters without anions ! For cation interactions multiply with yionva. If no vacancies yionva=-1.0 gz%yfrint(gz%intlevel)=phres%yfr(ic)*yionva ! write(*,*)'3X *yionva: ',yionva,gz%yfrint(gz%intlevel) endif endif ! calculate new PY incl derivatives. Moded to avoid unrequested derivatives ! ! IF interaction endmember is WILDCARD then the interaction is special, ! L(*,A) is y_A *(1-y_A) where 1-y_A is the sum of all fractions except A ! pyq = pyq * y_ic * (y_ix + y_iy + ... ) (all_other_in_same_sublattice)) ! derivatives are calculated for all constituents in intlat ! note one can also have wildcards in other sublattices .... if(gz%endcon(intlat).gt.0) then wildc=.FALSE. ymult=gz%yfrint(gz%intlevel) else if(iliqsave) then ! I sincerely hope wildcards are never used in 2nd subl of ionic liquids ... write(*,*)'3X Wildcard in second sublattice illegal for ionic liquids' gx%bmperr=4341; goto 1000 endif wildc=.TRUE. wildmob=.TRUE. ! write(*,*)'3X wildcard found!' ymult=gz%yfrint(gz%intlevel)*(one-gz%yfrint(gz%intlevel)) endif ! write(*,228)'3X d2pyq 1:',d2pyq !--------------------------------- ! write(*,*)'3X ionic liquid: ',iliqsave,yionva cationintandva: if(.not.iliqsave) then ! iliqsave is TRUE when interaction in first sublattice and Va in second ! write(*,228)'3X d2pyq 7:',d2pyq modedx: if(moded.gt.0) then ! ...................................... loop for first derivatives iloop1: do id=1,gz%nofc if(moded.gt.1) then ! ...................................... second derivatives ! For all models except ionic liquids 2nd derivatives are simple ... iloop2B: do jd=id+1,gz%nofc ! d2pyq(ixsym(id,jd))=d2pyq(ixsym(id,jd))*ymult jxsym=kxsym(id,jd) d2pyq(jxsym)=d2pyq(jxsym)*ymult enddo iloop2B d2pyq(ixsym(id,ic))=dpyq(id) endif ! I FORGOT THIS LINE WHEN TRYING TO FIX IONIC LIQUID !!! TOTAL MESS !!! dpyq(id)=dpyq(id)*ymult enddo iloop1 endif modedx else ! here we have cation interaction with Va in second subl. ! SPECIAL FOR IONIC LIQUID ! This is needed for interactions from endmembers with Va in second sublattice ! as the model must be compatibel with a regular solution, like ! (Mo+4,Pd+2,Rh+3)p(Va)q must be identical to (Mo,Pd,Rh) and ! (Fe+2)p(Va,C)q must be identical to (Fe,C) ! This requires that each cation fracition is multiplied with fraction of Va ! Instead of just yA+yB+yVa one must have yA+yB+yVa**2 ! write(*,228)'3X pyq 0:',pyq ! write(*,228)'3X dpyq 1:',dpyq ! write(*,228)'3X divers:',ymult,yionva,gz%yfrem(1) if(jonva.le.0 .and. intlat.eq.1) then write(*,*)'Illegal cation interaction with neutral' gx%bmperr=4265; goto 1000 endif ! ...................................... loop for first derivatives iliqloop1: do id=1,gz%nofc seconder2: if(moded.gt.1) then ! CODE BELOW IS UNCERTAIN ! This IF loop is only executed when Va in second sublattice, i.e. when cation ! interactions which should also be multiplied with the power of yionva ! which is gz%intlevel+1 ! jonva=phlista(lokph)%i2slx(1) is index of vacancy, i2slx(2) is first neutral ! index of the constituent in first sublattice is gz%endcon(1) ! index of the constituent in second sublattice is gz%endcon(2) = jonva ! index of interaction constituents are in gz%intcon(gz%intlevel+) ! pyq, dpyq and d2pyq set for the endmember ! ! NOTE: some 2nd derivatives wrong for (Fe+2)p(Va,C)q and more ... ! NOT tested (Ca+2)p(O-2,SiO4-4,SiO2)q ! ...................................... loop for second derivatives iloop2X: do jd=id+1,gz%nofc jxsym=kxsym(id,jd) if(jd.le.phlista(lokph)%nooffr(1)) then ! both id and jd are cations, interaction must be multiplied with yionva ! d2pyq(ixsym(id,jd))=& ! d2pyq(ixsym(id,jd))*ymult*yionva d2pyq(jxsym)=d2pyq(jxsym)*ymult*yionva ! write(*,215)gz%intlevel,ic,id,jd,& ! d2pyq(ixsym(id,jd)),ymult,& ! d2pyq(ixsym(id,jd))*ymult*yionva 215 format('3X d2pyq: ',4i3,4(1pe12.4)) elseif(jd.lt.jonva) then ! if jdintrec%propointer ! write(*,218)'3X pyq: ',associated(proprec),ymult,pyq 218 format(a,l2,2(1pe12.4)) ! list values of pyq, dpyg, d2pyg ! write(*,228)'3X pyq:',pyq ! write(*,228)'3X dpy:',dpyq ! write(*,228)'3X d2py:',d2pyq 219 format(a,6(1pe12.4)) !.............................. ! Here we finally calculate the interaction parameter .... SUCK intprop: do while(associated(proprec)) ! calculate interaction parameter, can depend on composition ! maybe faster to zero here than inside cgint ?? vals=zero dvals=zero d2vals=zero ! call cgint(lokph,proprec,moded,vals,dvals,d2vals,gz,ceq) call cgint(lokph,proprec,moded,& vals,dvals,d2vals,gz,tooprec,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,228)'3X val:',vals(1),(dvals(1,id),id=1,gz%nofc) ! G parameters (ipy=1) are divided by RT inside cgint typty=proprec%proptype if(typty.ne.1) then ! check if magnetic and wildcard ... if(wildmob) then ! nowildcard(1..3) set in gtp_init in gtp3A.F90 for mobility parameters ! typty is indicator*100 + constituent index do qz=1,3 if(typty/100.eq.nowildcard(qz)) then write(*,*)& '3X mobilities must not have wildcards',lokph gx%bmperr=4374; goto 1000 endif enddo endif ! other properties than 1 (G) must be stored in different gval(*,ipy) etc do qz=2,lprop-1 if(phmain%listprop(qz).eq.typty) goto 250 enddo ! a new property, save its typty in listprop and increment lprop qz=lprop phmain%listprop(qz)=typty lprop=lprop+1 phmain%listprop(1)=lprop 250 continue ! here the value of ipy is set, 1 means G ipy=qz else ipy=1 endif ! note: adding to phres%gval at the end of noder4: if(....) noder4: if(moded.gt.0) then iloop3: do id=1,gz%nofc if(moded.gt.1) then ! Testing using jxsym ... OK here also jxsym=kxsym(id,id) ! iloop4: do jd=id+1,gz%nofc ! This loop was constructed for normal cases when pyq has each fraction once ! in ionic liquids Va can have a power so loop for all! iloop4: do jd=id,gz%nofc ! phres%d2gval(ixsym(id,jd),ipy)= & ! phres%d2gval(ixsym(id,jd),ipy)+ & ! d2pyq(ixsym(id,jd))*vals(1) if(ixsym(id,jd).ne.jxsym) then write(*,*)'ISYM error 2',id,jd,& ixsym(id,jd),jxsym stop endif phres%d2gval(jxsym,ipy)= & phres%d2gval(jxsym,ipy)+ & d2pyq(jxsym)*vals(1) jxsym=jxsym+jd ! write(*,251)'3X G:',id,jd,ixsym(id,jd),& ! d2pyq(ixsym(id,jd)),vals(1) 251 format(a,3i3,4(1pe12.4)) enddo iloop4 endif ! toop7: if(associated(tooprec)) then ! this is part of iloop3 is for all components "id", starting 30 lines above ! Normally binay interactions depend only on the constituents gz%iq(1) ! and gz%iq(2) but Toop/Kohler method depend also on other constituents! ! Thus dvals may not be correctly updated but that is taken care here ! write(*,'(a,i3,5(1pe12.4))')'3X toop7: ',& ! id,pyq,dvals(1,id),phres%dgval(1,id,ipy)+pyq*dvals(1,id),& ! (phres%dgval(1,id,ipy)-pyq*dvals(1,id))*gz%rgast ! For those like me who forget: ! dgval)1,j,1) is derivative of G wrt constituent j ! dgval(2,j,1) is derivative of G wrt constituent j and T ! dgval(3,j,1) is derivative of G wrt constituent j and P. ! Third index is for other properties such as TC, BMAGN etc ! write(*,'("3X Toop: ",i3,1pe12.4,2x,3(1pe12.4))')id,pyq,& ! dvals(1,id),dvals(2,id),dvals(3,id) ! do itp=1,3 ! phres%dgval(itp,id,ipy)=phres%dgval(itp,id,ipy)-pyq*dvals(itp,id) ! enddo ! I think this is already taken into account in calc_toop ! ignore contribution to the second derivatives phres%d2gval ! iloop3 ends just a few lines below ! endif toop7 do itp=1,3 phres%dgval(itp,id,ipy)=& phres%dgval(itp,id,ipy)+dpyq(id)*vals(itp) enddo enddo iloop3 ! write(*,211)'3X Interactions: ',gz%iq,jonva 211 format(a,5i3,5x,i3) ! if(jonva.gt.0) then ! write(*,212)jonva,phres%dgval(1,jonva,1)*rtg 212 format('3X with va: ',i3,6(1pe12.4)) ! endif !............................... ! below contribution to derivatives from composition dependent parameters ! the values of gz%iq represent interacting constituents and are set in cgint cdex1: if(gz%iq(5).gt.0) then ! gz%iq(5) is nonzero only for TOOP and similar models not implemented yet ... gx%bmperr=4086; goto 1000 elseif(gz%iq(4).gt.0) then !............................... ! composition dependent reciprocal parameter ! for ionic liquid one must consider extra vacancy fractions ... ! remember ipy is property type for this parameter, set above ! write(*,333)'3X comp dep reciprocal:',gz%iq,pyq,vals(1) 333 format(a,5i4,4(1pe14.6)) if(moded.gt.0) then do jk=1,4 if(moded.gt.1) then ! contribution to second derivatives with respect to 2 const previously ignored ! No second derivatives calculated in cgint for this case ! no jxsym here ... to complicated do qz=jk,4 ! phres%d2gval(ixsym(gz%iq(jk),gz%iq(qz)),ipy)=& ! phres%d2gval(ixsym(gz%iq(jk),gz%iq(qz)),ipy)+& ! dpyq(gz%iq(jk))*dvals(1,gz%iq(qz))+& ! dpyq(gz%iq(qz))*dvals(1,gz%iq(jk)) ! I do not trust optimized gfortran will eliminate 2 calls to ixsym !!! jxsym=ixsym(gz%iq(jk),gz%iq(qz)) phres%d2gval(jxsym,ipy)=& phres%d2gval(jxsym,ipy)+& dpyq(gz%iq(jk))*dvals(1,gz%iq(qz))+& dpyq(gz%iq(qz))*dvals(1,gz%iq(jk)) enddo endif ! first derivatives, including 2nd wrt T and P do itp=1,3 ! itp=1 for 1st derivative, =2 for 2nd derivative also with T, =3 also with P phres%dgval(itp,gz%iq(jk),ipy)=& phres%dgval(itp,gz%iq(jk),ipy)+& pyq*dvals(itp,gz%iq(jk)) enddo enddo endif elseif(gz%iq(3).gt.0) then !cedex1 ! composition dependent ternary interaction in same sublattice, Mats model ! PROBABLY ERRORS HERE as no consideration of derivatives wrt other endmember ! constituents, only to the 3 interacting ! ALSO used to indicate derivatives wrt vacancies in ionic liquid model ??? NO! !...<<<<<<<...... indentation back 2 levels if(moded.gt.1) then noindent1: do jk=1,3 do qz=jk+1,3 ! the second derivative for jk=qz calculated below as it is simpler ! phres%d2gval(ixsym(gz%iq(jk),gz%iq(qz)),ipy)=& ! phres%d2gval(ixsym(gz%iq(jk),gz%iq(qz)),ipy)+& ! dpyq(gz%iq(jk))*dvals(1,gz%iq(qz))+& ! dpyq(gz%iq(qz))*dvals(1,gz%iq(jk)) ! not trusting gfortran optimizing jxsym=ixsym(gz%iq(jk),gz%iq(qz)) phres%d2gval(jxsym,ipy)=& phres%d2gval(jxsym,ipy)+& dpyq(gz%iq(jk))*dvals(1,gz%iq(qz))+& dpyq(gz%iq(qz))*dvals(1,gz%iq(jk)) enddo enddo noindent1 endif do jk=1,3 do itp=1,3 phres%dgval(itp,gz%iq(jk),ipy)=& phres%dgval(itp,gz%iq(jk),ipy)& +pyq*dvals(itp,gz%iq(jk)) enddo ! phres%d2gval(ixsym(gz%iq(jk),gz%iq(jk)),ipy)=& ! phres%d2gval(ixsym(gz%iq(jk),gz%iq(jk)),ipy)+& ! 2.0D0*dpyq(gz%iq(jk))*dvals(1,gz%iq(jk)) ! not trusing gforntran optimizing jxsym=ixsym(gz%iq(jk),gz%iq(jk)) phres%d2gval(jxsym,ipy)=& phres%d2gval(jxsym,ipy)+& 2.0D0*dpyq(gz%iq(jk))*dvals(1,gz%iq(jk)) enddo !...>>>>>>...........indentation forward elseif(gz%iq(2).gt.0) then !cedex1 ! gz%iq(2) nonzero means composition dependent binary interaction parameter, ! only RK yet. noder3B: if(moded.gt.1) then ! one can maybe make this loop faster by just looping throungh endmembrs ! but then one must handle wildcard endmembers .... ! and there may be other bugs here anyway .... do ic1=1,gz%nofc ! add1=dpyq(ic1)*dvals(1,gz%iq(1))+& ! dpyq(gz%iq(1))*dvals(1,ic1)+& ! pyq*d2vals(ixsym(ic1,gz%iq(1))) ! phres%d2gval(ixsym(ic1,gz%iq(1)),ipy)=& ! phres%d2gval(ixsym(ic1,gz%iq(1)),ipy)+add1 ! not trusing gfortran optimizing jxsym=ixsym(ic1,gz%iq(1)) add1=dpyq(ic1)*dvals(1,gz%iq(1))+& dpyq(gz%iq(1))*dvals(1,ic1)+& pyq*d2vals(jxsym) phres%d2gval(jxsym,ipy)=& phres%d2gval(jxsym,ipy)+add1 if(ic1.ne.gz%iq(1)) then ! this IF to avoid that the second derivative gz%iq(1) and gz%iq(2) is ! calculated twice. ic1 will at some time be equal to gz%iq(1) and to gz%iq(2) ! add1=dpyq(ic1)*dvals(1,gz%iq(2))+& ! dpyq(gz%iq(2))*dvals(1,ic1)+& ! pyq*d2vals(ixsym(ic1,gz%iq(2))) ! phres%d2gval(ixsym(ic1,gz%iq(2)),ipy)=add1+& ! phres%d2gval(ixsym(ic1,gz%iq(2)),ipy) ! not trusting gfortran optimizing jxsym=ixsym(ic1,gz%iq(2)) add1=dpyq(ic1)*dvals(1,gz%iq(2))+& dpyq(gz%iq(2))*dvals(1,ic1)+& pyq*d2vals(jxsym) phres%d2gval(jxsym,ipy)=add1+& phres%d2gval(jxsym,ipy) endif enddo endif noder3B do itp=1,3 phres%dgval(itp,gz%iq(1),ipy)=& phres%dgval(itp,gz%iq(1),ipy)& +pyq*dvals(itp,gz%iq(1)) phres%dgval(itp,gz%iq(2),ipy)=& phres%dgval(itp,gz%iq(2),ipy)& +pyq*dvals(itp,gz%iq(2)) ! to many indentations-------------------------------------------- catx: if(ionicliq) then ! for ionic liquid when interactions involve cations there is a contribution ! due to the vacancy fraction multiplied with the cations yc1*yc2*yva**2 ! we are dealing with binary RK interactions, gz%intlevel=1, check if ! interaction is in first sublattice (between cations) and vacancy in second if(iliqva .and. jonva.gt.0) then if(gz%intlat(1).eq.1) then ! add pyq multipled with the derivative with respect to vacancy fraction ! This should be done for d2gval also but I skip that at present ... phres%dgval(itp,jonva,ipy)=& phres%dgval(itp,jonva,ipy)+pyq*dvals(itp,jonva) ! write(*,*)'3X jonva:',jonva,pyq,dvals(1,jonva) elseif(gz%intlat(1).eq.2 .and. gz%iq(2).gt.jonva) then ! This fixed the problem with Pd-Ru-Te in the fuel (+ fix in cgint) ! write(*,55)'3X (C:Va,K)',iliqva,gz%intlat(1),jonva,gz%iq(1),& ! gz%iq(2),gz%endcon(1),pyq,dvals(itp,gz%endcon(1)) 55 format(a,l2,5i3,4(1pe12.4)) icat=gz%endcon(1) if(icat.gt.0) then phres%dgval(itp,icat,ipy)=& phres%dgval(itp,icat,ipy)+pyq*dvals(itp,icat) ! else ! wow, icat can be -99 meaning interaction between neutrals .... ! but then just skip as the assignment above is not relevant ! Error occured for ionic liquid with: ! 1 2 3 4 5 6 7 8 9 10 11 ! BA+2 CE+3 CS+ GD+3 LA+3 MO+4 PD+2 PU+3 RU+4 U+4 ZR+4 : ! I- MOO4-2 O-2 VA CEO2 CS2TE CSO2 I2 MOO3 O PUO2 TE TEO2 ! 12 13 14 15 16 17 18 19 20 21 22 23 24 ! we come here with: BA+2:VA,TE; PD+2:VA,TE; RU+4:VA,TE; *:CS2TE,TE ! gz%intlat(1)=2 OK; jonva=15 OK; gz%iq(1)=17(Cs2Te); gz%iq(2)=23(Te); ! gz%endcon(1)=-99 ! write(*,55)'3X Instroini:',iliqva,gz%intlat(1),jonva,& ! gz%iq(1),gz%iq(2),gz%endcon(1),pyq endif endif endif endif catx ! increase indendation----------------------------------------- enddo endif cdex1 ! end contribution to derivates from composition dependent parameters !...................... endif noder4 ! finally add the contribution to G, G.T etc iloop6: do itp=1,6 phres%gval(itp,ipy)=phres%gval(itp,ipy)+pyq*vals(itp) enddo iloop6 ! debug problem with mobility calculation ! if(ipy.eq.2) then ! write(*,172)'3X imob:',ipy,phmain%listprop(1),& ! phmain%listprop(ipy),& ! pyq,vals(1),pyq*vals(1),phres%gval(1,ipy) ! endif proprec=>proprec%nextpr enddo intprop ! write(*,*)'3X Config G 4F: ',phres%gval(1,1)*rtg ! finished one interaction (or permutation on this level), go to higher level ! note that ipermut is saved in lastpmq(pmq). If there are more ! permutations on this level they will be calculated later also including ! higher order parameters. !------------------------------------------------------------------ ! Take link to higher level records for current permutation 290 continue intrec=>intrec%highlink wrong: if(chkperm .and. associated(intrec)) then ! We must go to higher as we can have interactions with different permutations? jpr=intrec%order if(lastpmq(jpr).gt.0 .and.lastpmq(jpr).ge.maxpmq(jpr)) then ! if we nullify here we will take next rather than higher ! nullify(intrec) ! write(*,155)'3X Maybe skipping higer?: ',jpr,& ! lastpmq(jpr),maxpmq(jpr),gz%intlevel ! if(maxpmq(jpr).lt.0) maxpmq(jpr)=intrec%noofip(2)-& ! maxpmq(jpr) endif endif wrong ! if intrec is associated then go to big "interloop: do while()" loop 295 continue popint: do while(.not.associated(intrec)) ! No higher level, pop lower order interaction records, if no pop: endmember if(gz%intlevel.eq.0) exit interloop call pop_pyval(pystack,intrec,pmq,& pyq,dpyq,d2pyq,moded,gz%nofc) gz%intlevel=gz%intlevel-1 pmq=intrec%order ! check if we have more permutations for this record if(chkperm) then if(lastpmq(pmq).lt.maxpmq(pmq)) then ! here we could maybe use cycle interloop ??/Bosse 2023.12.16 goto 200 endif endif intrec=>intrec%nextlink enddo popint ! we should loop here if we found a higher order record or ! a lower order record with a next link enddo interloop 298 continue ! write(*,*)'3X Config G 4X: ',phres%gval(1,1)*rtg ! take next permutation of the end member fractions enddo empermut 300 continue ! take next end member ! write(*,155)'3X endmem: ',epermut,endmemrec%noofpermut,endmemrec%antalem endmemrec=>endmemrec%nextem enddo endmemloop ! write(*,*)'3X Config G 5: ',phres%gval(1,1)*rtg !------------------------------------------------------------------------ ! end loop for this fraction type, initiation for next in the beginning of loop ! but we may have to calculate once again with same fraction type but ! with the fractions as disordered fractions ! write(*,*)'3X Testing nevertwice ',nevertwice ! Jump to 400 terminates calculation for this fraction type ! write(*,303)'3X Nevertwice: ',nevertwice,& ! btest(phlista(lokph)%status1,phsubo),& ! first,fractype,phres%gval(1,1) 303 format(a,3(1x,l1),i3,4(1pe12.4)) ! write(*,623)'3X order/disorder: ',lprop,phres%gval(1,2),phres%gval(1,3) if(nevertwice) goto 400 ! UNIFINISHED ?? ! TEST IF WE SHOULD SUBTRACT THE ORDERED ENERGY AS DISORDERED AS IN THE ! CURRENT IMPLEMENTATION IN THERMO-CALC. BY JUMPING TO 400 WE SKIP THAT. if(btest(phlista(lokph)%status1,phsubo)) then ! write(*,*)'3X phsubo bit set' goto 400 endif ! PARTITION PROBLEM FOR ORDERED PHASES ! goto 400 !------------------------------------------------ ! write(*,611)'3X ftyp1:',fractype,btest(phlista(lokph)%status1,phmfs),& ! btest(phmain%status2,csorder),first,lokph,phres%gval(1,1) 611 format(a,i3,3(1x,L),i3,3(1pe12.4)) disord: if(fractype.eq.1 .and. btest(phlista(lokph)%status1,phmfs) & .and. btest(phmain%status2,csorder)) then ! Handle additions of several fraction set ?? Additions calculated ! after both ordered and disordered fraction set calculated ! write(*,611)'3X ftyp:',fractype,btest(phlista(lokph)%status1,phmfs),& ! btest(phmain%status2,csorder),first,lokph,phres%gval(1,1) returnoradd: if(first) then ! we have calculated for the first, now calculate for second fraction type ! alternative method: no need to calculate with all fractions as disordered first=.false. ! write(*,*)'3X: next fraction type' ! goto 400 ! we must save phres%yfr before disorder .... ! allocate(savey(gz%nofc)) ! this creates problem with pointers in disordery?? avoid by allocating savey?? ! savey=phres%yfr do j1=1,size(phres%yfr) savey(j1)=phres%yfr(j1) enddo !------------ code below was removed for a while but is now reinstated ! write(*,*)'3X cg: ',phmain%phlink,phmain%disfra%varreslink ! ??? very uncertain how to call disordery ..... ! call disordery(phmain,phmain%disfra%varreslink,ceq) ! write(*,*)'3X At disordery: ',phmain%disfra%varreslink,& ! cps%disfra%varreslink call disordery(phmain,ceq) ! if call to disordery here no crash in disordery ... ! if call moved to after assignment of savey there is a crash (GNU fortran) !---------- ! allocate(savey(gz%nofc)) ! savey=phres%yfr ! nprop=phmain%nprop ! error calculating volumes for order/disorder, V0 in gval(1,2), VA in gval(1,3) ! write(*,623)'3X V0,VA 1: ',lprop,phres%gval(1,2),phres%gval(1,3) 623 format(a,i3,6(1pe12.4)) ! we already know nprop allocate(saveg(6,nprop)) allocate(savedg(3,gz%nofc,nprop)) allocate(saved2g(nofc2,nprop)) ! write(*,*)'3X saveg allocated 3: ',size(saveg) saveg=phres%gval savedg=phres%dgval saved2g=phres%d2gval ! do i1=1,gz%nofc ! write(*,602)'3X G4y: ',i1,phres%dgval(1,i1,1),savedg(1,i1,1) ! enddo phres%gval=zero phres%dgval=zero phres%d2gval=zero goto 110 else ! We have now calculated the 4SL model both as original and disordered ! We should now subtract the disordered from the ordered ! this is debug output ! do i1=1,gz%nofc ! write(*,602)'3X G4x: ',i1,phres%dgval(1,i1,1),savedg(1,i1,1) ! enddo 602 format(a,i3,6(1pe14.6)) ! Ordered part calculated with disordered fractions, subtract this ! from the first, restore fractions and deallocate ! THIS IS TRICKY ! NOTE all sublattices are identical in this case with the same number ! of constituents ! First sum all second derivatives into tmpd2g, moded=1 means only 1st deriv ! error calculating volumes for order/disorder, V0 in gval(1,2), VA in gval(1,3) ! write(*,623)'3X V0,VA 2: ',lprop,phres%gval(1,2),phres%gval(1,3) noder6A: if(moded.gt.1) then nz=fracset%tnoofxfr ! allocate(tmpd2g(nz*(nz+1)/2,nprop)) ! tmpd2g=zero !-------------------------------------------------------------------------- ! simplest way of correcting 2nd deruvatives, Gord(y=x) in phres%d2gval ! phres%d2gval(i,j) = saved2g(i,j) - phres%d2gval(i,j) do ipy=1,lprop-1 do i1=1,gz%nofc ! jxsym=ixsym(i1,i1) jxsym=kxsym(i1,i1) ! It should work with jxsym here do i2=i1,gz%nofc ! if(ixsym(i1,i2).ne.jxsym) then ! this ixsym test works and has run of few 1000 times, removed for speed!! ! write(*,*)'ISYM error 3',i1,i2,ixsym(i1,i2),jxsym ! stop ! endif phres%d2gval(jxsym,ipy)=& saved2g(jxsym,ipy)-& phres%d2gval(jxsym,ipy) ! adding i2 to jxsym here seems correct!! jxsym=jxsym+i2 ! phres%d2gval(ixsym(i1,i2),ipy)=& ! saved2g(ixsym(i1,i2),ipy)-& ! phres%d2gval(ixsym(i1,i2),ipy) enddo enddo enddo ! goto 667 ! old code removed !667 continue if(allocated(tmpd2g)) deallocate(tmpd2g) endif noder6A !--------------------- ! sum all first partial derivates to first sublattice noder6B: if(moded.gt.0) then ! write(*,613)'3X dG/dx: ',fracset%ndd,fracset%nooffr do ipy=1,lprop-1 do ider=1,3 do is=1,fracset%nooffr(1) sum=zero kk=is do ll=1,fracset%latd sum=sum+phres%dgval(ider,kk,ipy) ! it is not really necessary to put phres%dgval it to zero, just for prudence ! phres%dgval(ider,kk,ipy)=zero kk=kk+fracset%nooffr(1) enddo phres%dgval(ider,is,ipy)=sum enddo if(fracset%ndd.eq.2) then ! one can have 2 sets of ordered subl like (Al,Fe)(Al,Fe)...(C,Va)(C,Va)... ! BUT I doubt that works ... ioff=fracset%nooffr(1)*fracset%latd do is=1,fracset%nooffr(2) sum=zero kk=ioff+is do ll=fracset%latd+1,phlista(lokph)%noofsubl sum=sum+phres%dgval(ider,kk,ipy) phres%dgval(ider,kk,ipy)=zero kk=kk+fracset%nooffr(2) enddo phres%dgval(ider,ioff+is,ipy)=sum enddo endif enddo enddo !------------------------- if(moded.gt.0) then do ipy=1,lprop-1 ! loop in negative direction avoid destroy the values in phres%dgval first subl do i1=gz%nofc,1,-1 ! all derivatives wrt same element from all sublattices is in first sublattice j1=fracset%y2x(i1) do ider=1,3 ! Finally subtract this contribution from saved values ! phres%dgval(ider,i1,ipy)=savedg(ider,i1,ipy)-& xxx=savedg(ider,i1,ipy)-& phres%dgval(ider,j1,ipy)*fracset%dxidyj(i1) ! write(*,615)'3X Gy-Gx: ',ider,i1,ipy,j1,& ! savedg(ider,i1,ipy),phres%dgval(ider,j1,ipy),& ! fracset%dxidyj(i1),xxx !615 format(a,4i3,4(1pe14.6)) phres%dgval(ider,i1,ipy)=xxx enddo enddo enddo endif endif noder6B ! check for bug, phres%gval(1,1) must not be negative!! ! write(*,617)'3X do=o-oasd: ',saveg(1,1),phres%gval(1,1),& ! saveg(1,1)-phres%gval(1,1) 617 format(a,6(1pe12.4)) do ipy=1,lprop-1 do ider=1,6 phres%gval(ider,ipy)=saveg(ider,ipy)-& phres%gval(ider,ipy) enddo enddo ! error calculating volumes for order/disorder, V0 in gval(1,2), VA in gval(1,3) ! write(*,623)'3X V0,VA 3: ',lprop,phres%gval(1,2),phres%gval(1,3) ! restore ordered fractions and deallocate save arrays why not allocate savey? ! write(*,612)'3X yd: ',(phres%yfr(ipy),ipy=1,gz%nofc) ! do ipy=1,gz%nofc phres%yfr=savey ! enddo ! write(*,612)'3X yo: ',(phres%yfr(ipy),ipy=1,gz%nofc) 612 format(a,6(1pe11.3)/(7x,6e11.3)) ! why set to zero if I deallocate ?? ! savey=zero ! saveg=zero ! savedg=zero ! saved2g=zero ! if(ocv()) write(*,*)'3X saveg DE-allocated 1: ',size(saveg) ! deallocate(savey) deallocate(saveg) deallocate(savedg) deallocate(saved2g) endif returnoradd ! code above reinstated but has problems .... endif disord ! WE CAN JUMP HERE WITHOUT CALCULATING THE ORDERED PART AS DISORDERED 400 continue ! write(*,*)'3X calcg_internal at label 400' enddo fractyp ! norfc=phlista(lokph)%tnooffr ! 4SL FCC all correct here ! write(*,69)'3X d2G/dy2B:',norfc,(phres%d2gval(ixsym(j1,j1),1),j1=1,norfc) 69 format(a,i3,6(1pe12.4)) !-------------------------------------------------------------- ! finished loops for all fractypes, now add together G and all ! partial derivatives for all fractypes 410 continue ! cheking for properties ! if(ocv()) then ! write(*,411)lprop-1,(phmain%listprop(j1),j1=2,lprop) ! write(*,412)'Val: ',(phmain%gval(1,j1),j1=1,lprop-1) !411 format('3X Properties: ',i3,': ',10i4) 412 format(a,(6E12.4)) ! endif norfc=phlista(lokph)%tnooffr fractionsets: if(btest(phlista(lokph)%status1,phmfs)) then !---------------------------------------------------------------- ! for disordered part of sigma we may have to multiply the disordered ! part with fsites to have correct formula unit ! write(*,*)'3X fsites 1: ',phmain%disfra%fsites fsites=phmain%disfra%fsites ! add together contributions from different fractypes ! phres is last calculated part, set phpart to ordered part (phmain) phpart=>phmain ! loop for all second and first derivatives using chain rule ! and coefficients from fracset%dxidyj ! d2f1/dyidyj = d2f2/dxkdxl*dxk/dyi*dxl/dyj ! gz%nofc are number of disordered constituents ! norfc are number of ordered constituents ! lprop-1 is number of properties to be summed ! G(tot) = GD(x)+(GO(y)-GO(y=x)) ! G(tot).yj = dGD(x).dxi*dxdyj + (GO(y).yj - GO(y=x).yj) ! configurational entropy calculated only for GO(y) noder7A: if(moded.gt.0) then do i1=1,norfc j1=fracset%y2x(i1) ! second derivatives noder7B: if(moded.gt.1) then ! problem using jxsym here, map13 crashed FCC 4 sublattice orering!!! ! PAY ATTENTION TO indices!! we have both i1, i2 and j1, j2 ! jxsym=ixsym(i1,i1) jxsym=kxsym(i1,i1) do i2=i1,norfc ! add the contributions from the disordered part j2=fracset%y2x(i2) ! if(ixsym(i1,i2).ne.jxsym) then ! this ixsym test works and has run of few 1000 times, removed for speed!! ! write(*,*)'ISYM error 4',i1,i2,ixsym(i1,i2),jxsym ! stop ! endif do ipy=1,lprop-1 phpart%d2gval(jxsym,ipy)=& phpart%d2gval(jxsym,ipy)+& fsites*phres%d2gval(ixsym(j1,j2),ipy)*& fracset%dxidyj(i1)*fracset%dxidyj(i2) ! phpart%d2gval(ixsym(i1,i2),ipy)=& ! phpart%d2gval(ixsym(i1,i2),ipy)+& ! fsites*phres%d2gval(ixsym(j1,j2),ipy)*& ! fracset%dxidyj(i1)*fracset%dxidyj(i2) enddo jxsym=jxsym+i2 enddo endif noder7B ! first derivatives do ipy=1,lprop-1 ! add1=phpart%dgval(1,i1,ipy) do ider=1,3 ! phpart%dgval(ider,i1,ipy)=phpart%dgval(ider,i1,ipy)+& xxx=phpart%dgval(ider,i1,ipy)+& fsites*phres%dgval(ider,j1,ipy)*fracset%dxidyj(i1) ! phres have the disordred contribution ! write(*,413)'3X Gd+Go:',ider,i1,j1,& ! phpart%dgval(ider,i1,ipy),fsites,& ! phres%dgval(ider,j1,ipy),fracset%dxidyj(i1),xxx ! write(*,413)'3X Gd+Go:',ider,i1,j1,& ! phmain%dgval(ider,i1,ipy),fsites,& ! phres%dgval(ider,j1,ipy),fracset%dxidyj(i1),xxx phpart%dgval(ider,i1,ipy)=xxx enddo enddo enddo endif noder7A 413 format(a,3i3,6(1pe12.4)) ! Check Integral values, phpart%gval(1,1) is ordered-ordasdis, phres is disord ! write(*,617)'3X g=do+d: ',phpart%gval(1,1),fsites*phres%gval(1,1),& ! phpart%gval(1,1)+fsites*phres%gval(1,1) do ipy=1,lprop-1 ! add1=phpart%gval(1,ipy) do ider=1,6 phpart%gval(ider,ipy)=phpart%gval(ider,ipy)+& fsites*phres%gval(ider,ipy) enddo ! if(ocv()) write(*,413)'3X G:',ipy,0,0,& ! write(*,413)'3X G:',ipy,0,0,& ! phpart%gval(1,ipy),add1,phres%gval(1,ipy) enddo ! write(*,413)'3X 413:',ipy,0,0,& ! phpart%gval(1,ipy),add1,phres%gval(1,1) endif fractionsets ! now set phres to ordered+disorded results and forget phpart phres=>phmain !................................ ! write(*,*)'3X: ioliq+saved: ',ionicliq,iliqsave,phres%gval(1,1) ionliqsum: if(ionicliq .and. iliqsave) then ! For ionic liquid we may have to add gsave+Q*gval (with chain rule ...) ! G = saveg + Q*phres%gval with 1st and 2nd derivatives ! NOT FINISHED !!! interaction parameters above with VA must be treated ! !vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! BEWHARE: FOR IONIC_LIQUID Thermo-Calc (version S) calculates G = Q G_M ! if there are no end-member parameters (G_M is the Gibbs energy per ! formula unit and Q is the number of sites in second sublattice), ! This is wrong (but all endmember parameters are never zero for a real liquid) !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! ! write(*,*)'3X Config G 6: ',phres%gval(1,1)*rtg if(moded.eq.0) goto 490 ! write(*,491)'3X ionliq: ',phlista(lokph)%i2slx,phlista(lokph)%nooffr 491 format(a,2i3,5x,2i3) firstd: do i1=1,norfc ! jxsym=ixsym(i1,i1) jxsym=kxsym(i1,i1) secondd: do i2=i1,norfc do ipy=1,lprop-1 ! write(*,497)'3X adding: ',i1,i2,ixsym(i1,i2),ipy 497 format(a,10i3) ! if(ixsym(i1,i2).ne.jxsym) then ! this ixsym test works and has run of few 1000 times, removed for speed!! ! write(*,*)'ISYM error 5',i1,i2,ixsym(i1,i2),jxsym ! stop ! endif phres%d2gval(jxsym,ipy)=saved2g(jxsym,ipy)+& phres%sites(2)*phres%d2gval(jxsym,ipy) ! phres%d2gval(ixsym(i1,i2),ipy)=saved2g(ixsym(i1,i2),ipy)+& ! phres%sites(2)*phres%d2gval(ixsym(i1,i2),ipy) add1=zero ! IMPORTANT note dpqdy(i1) the the charge of iq, do not confuse with dpyq ... if(i1.le.phlista(lokph)%nooffr(1)) then add1=phres%dpqdy(i1)*phres%dgval(1,i2,ipy) endif if(i2.le.phlista(lokph)%nooffr(1)) then add1=add1+phres%dpqdy(i2)*phres%dgval(1,i1,ipy) endif phres%d2gval(jxsym,ipy)=phres%d2gval(jxsym,ipy)+add1 ! phres%d2gval(ixsym(i1,i2),ipy)=phres%d2gval(ixsym(i1,i2),ipy)+& ! add1 jxsym=jxsym+i2 enddo enddo secondd ! hm, when debugging here phres%dgval(1,*,1)=0 so ... add1=savedg(1,i1,1) sum=phres%dgval(1,i1,1) if(phres%dpqdy(i1).lt.1.0D-60) phres%dpqdy(i1)=zero do ipy=1,lprop-1 do ider=1,3 ! this calculates the proper ionic liquid model, not Q times phres%dgval(ider,i1,ipy)=& savedg(ider,i1,ipy)+& phres%sites(2)*phres%dgval(ider,i1,ipy) ! The contribution from the derivative of Q = \sum_i nu_i y_i, dQ/dy_i = nu_i ! G = G1 + Q G2 where ! G1 = \sum_i \sum_j y_i y_j G_ij + config.entropy ! G2 = y_va\sum_i y_i G_i + Q\sum_k y_k G_k ! Above were added: dG/dy_i = dG1/dy_i + + Q dG2/dy_i ! For cations we must add also dG/dy_i = dG/dy_i + nu_i G2 if(i1.le.phlista(lokph)%nooffr(1)) then ! nooffr(1) is the number of constituents in first sublattice phres%dgval(ider,i1,ipy)=phres%dgval(ider,i1,ipy)+& phres%dpqdy(i1)*phres%gval(ider,ipy) endif enddo enddo ! write(*,747)'3X suming: ',i1,savedg(1,i1,1)*rtg,phres%dgval(1,i1,1)*rtg,& ! phres%dpqdy(i1),phres%gval(1,1) ! write(*,747)'3Xx:',i1,add1,sum,phres%dgval(1,i1,1),phres%dpqdy(i1),& ! phres%sites(2),savedg(1,i1,1) !747 format(a,i2,6(1pe12.4)) enddo firstd ! write(*,*)'3X summed: ',savedg(1,1,1)*rtg,phres%dgval(1,1,1)*rtg ! Integral values: G = saveg + Q*phres%gval with T and P derivatives 490 continue ! write(*,492)'3X ionsum: ',saveg(1,1),phres%gval(1,1),& ! (saveg(1,1)+phres%gval(1,1))*rtg*phres%sites(2) 492 format(a,6(1pe12.4)) ! write(*,*)'3X Config G 7A: ',phres%gval(1,1)*rtg do ipy=1,lprop-1 do ider=1,6 phres%gval(ider,ipy)=saveg(ider,ipy)+& phres%sites(2)*phres%gval(ider,ipy) enddo enddo ! write(*,*)'3X Config G 7B: ',phres%gval(1,1)*rtg,saveg(1,1)*rtg ! strange bug which changes the results for a calculation with only C1 ! if the ionic liquid has been non-suspended at some previous calculation ... saveg=zero ! if(ocv()) write(*,*)'3X deallocated saveg 2: ',size(saveg) ! no need to set them zero if they will be deallocated?? ! savedg=zero ! saved2g=zero deallocate(saveg) if(moded.gt.0) then deallocate(savedg) deallocate(saved2g) endif !499 continue endif ionliqsum !................................ ! we have now finished calculate all parameters including those ! properties that affect the Gibbs energy indirectly like Curie T etc ! The label here just a label, there is no explict jump here 500 continue ! write(*,69)'3Xa d2G/dy2C:',norfc,(phres%d2gval(ixsym(j1,j1),1),j1=1,norfc) if(btest(phmain%status2,CSADDG)) then ! we have an constant addition to G, at present just a constant /RT if(allocated(phmain%addg)) then xxx=phmain%addg(1)/ceq%rtn else write(*,*)'3X not allocated addg' xxx=zero endif ! write(*,*)'Addition to G:',xxx ! a constant addition affects G and dG/dy and d2G/dy2 phmain%gval(1,1)=phmain%gval(1,1)+xxx ! dgval( 1/dT/dP , i , property) do id=1,gz%nofc phmain%dgval(1,id,1)=phmain%dgval(1,id,1)+xxx do jd=id,gz%nofc ! doubting gfortran optimizer ... jxsym=kxsym(id,jd) ! phmain%d2gval(ixsym(id,jd),1)=phmain%d2gval(ixsym(id,jd),1)+xxx phmain%d2gval(jxsym,1)=phmain%d2gval(jxsym,1)+xxx enddo enddo endif ! uniquac model uniquac: if(btest(phlista(lokph)%status1,phuniquac)) then ! write(*,'(a,6(1pe12.4))')'3X calling uniquac: ',& ! phmain%dgval(1,1,1),phres%dgval(1,2,1) call uniquac_model(moded,gz%nofc,phmain,ceq) if(gx%bmperr.ne.0) goto 1000 endif uniquac !................................ ! calculate additions like magnetic contributions etc and add to G ! Now also Einstein, twostate liquid, volume ... ! if liq2state is FALSE we should add that constribution ! using composition dependent G2 parameters addrec=>phlista(lokph)%additions ! write(*,*)'3X check for first addrec: ',associated(addrec) additions: do while(associated(addrec)) ! Note for phases with a disordered fraction set, gz%nofc is equal to ! the disordered number of fractions here gz%nofc=phlista(lokph)%tnooffr ! moded is 0, 1 or 2 if derivatives should be calculated, phres is pointer ! to result arrays, lokadd is the addition record, listprop is needed to ! find where TC and BM are stored, gz%nofc are number of constituents ! EINSTEIN ! write(*,*)'3X addition select: ',phres%gval(1,2),gz%nofc ! write(*,1001)'Addto: ',gx%bmperr,(phres%gval(j1,1),j1=1,4) call addition_selector(addrec,moded,phres,lokph,gz%nofc,ceq) if(gx%bmperr.ne.0) goto 1000 ! NOTE that the addition record is not in the dynamic data structure ! but the values calculated are returned added to phres which is dynamic ! There is a temporary storage of results for listing only. addrec=>addrec%nextadd ! write(*,*)'3X check for next addrec: ',associated(addrec) enddo additions ! there are some special properties like mobilities and similar which ! have a conmponent or constituent index like MQ& ! ipy=typty/100+mod(typty,100) ! if(ipy.gt.10) then ! write(*,*)'3X Property ',typty,ipy ! write(*,*)'3X extra 2: ',phres%gval(1,2) 1000 continue ! ipy=phlista(lokph)%linktocs(1) ! write(*,*)'3X exit 1: ',lokph,ipy,ceq%phase_varres(ipy)%disfra%varreslink ! ipy=phlista(lokph)%linktocs(2) ! if(ipy.gt.0) & ! write(*,*)'3X exit 2: ',lokph,ipy,ceq%phase_varres(ipy)%disfra%varreslink if(chkperm) then ! wait for checking for errors .... ! write(*,*)'3X Press return' ! read(*,297)ch1 !297 format(a) endif ! 4SL all correct here also! ! write(*,69)'3Xb d2G/dy2F:',norfc,(phres%d2gval(ixsym(j1,j1),1),j1=1,norfc) ! running out of memory?? ! these are locally allocated, should be deallocated automatically ! Segmentation fault if I do not write ... but ... reason somewhere else ! write(*,*)'3X deallocate dpyq?',allocated(dpyq) if(allocated(dpyq)) deallocate(dpyq) ! write(*,*)'3X deallocate d2pyq?',allocated(d2pyq) if(allocated(d2pyq)) deallocate(d2pyq) ! write(*,*)'3X deallocate dvals?',allocated(dvals) if(allocated(dvals)) deallocate(dvals) ! write(*,*)'3X deallocate d2vals?',allocated(d2vals) if(allocated(d2vals)) deallocate(d2vals) ! write(*,*)'3X calcg_internal all deallocated' ! if(size(phres%yfr).gt.2) then ! debug cqc: ! write(*,480)'3X dg/dt/RT: 2: ',qcmodel,phres%yfr(3),& ! phres%gval(1,1),phres%gval(2,1) ! endif ! write(*,1001)'Total: ',gx%bmperr,(phres%gval(j1,1),j1=1,4) ! write(*,1002)(phres%dgval(1,i,1),i=1,3) ! write(*,1003)(phres%d2gval(i,1),i=1,6) 1001 format('3X/',a,i5,4(1PE12.4)) 1002 format('3X calcg dg: ',3(1PE15.7)) 1003 format('3X calcg d2g: ',6(1PE11.3)) return end subroutine calcg_internal !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! !\addtotable subroutine cgint !\begin{verbatim} subroutine cgint(lokph,lokpty,moded,vals,dvals,d2vals,gz,tooprec,ceq) ! calculates an excess parameter that can be composition dependent ! gz%yfrem are the site fractions in the end member record ! gz%yfrint are the site fractions in the interaction record(s) ! lokpty is the property index, lokph is the phase record ! vals, dvals, d2vals multiplied by endmember and interaction fractions outside ! moded=0 means only G, =1 G and dG/dy, =2 all implicit none integer moded,lokph TYPE(gtp_property), pointer :: lokpty TYPE(gtp_parcalc) :: gz double precision vals(6),dvals(3,gz%nofc) TYPE(gtp_equilibrium_data), pointer :: ceq TYPE(gtp_tooprec), pointer :: tooprec !\end{verbatim} ! temporary data like gz%intlevel, gz%nofc etc double precision d2vals(gz%nofc*(gz%nofc+1)/2),valtp(6) double precision vv(0:2),fvv(0:2) integer lfun,jdeg,jint,qz,ivax,icat double precision rtg,dx0,dx,dx1,dx2,ct,fvs,dvax0,dvax1,dvax2,yionva double precision ycat0,dcat1,dcat2,dyvan1,dyvan2 double precision, parameter :: onethird=one/3.0D0,two=2.0D0 logical ionicliq,iliqva,iliqneut,iliq3cat ! zeroing 5 iq, and vals, dvals and d2vals ! write(*,*)'3X cgint 1:',gz%iq(1),gz%iq(2),gz%iq(3) ! why zero qz%iq, it has been set before calling ... gz%iq=0 ! these 3 arrays are in the call and may already have some stored values ! vals=zero ! dvals=zero ! d2vals=zero !------------- rtg=gz%rgast ! to avoid warnings from -Wmaybe-uninitiated icat=0 ivax=0 dvax0=zero dvax1=zero ! write(*,*)'3X in cgint',lokph if(lokpty%degree.eq.0) then !---------------------------------------------------------------------- ! Easy: no composition dependence. This applies also to Toop/Kohler parameters lfun=lokpty%degreelink(0) call eval_tpfun(lfun,gz%tpv,vals,ceq%eq_tpres) if(gx%bmperr.ne.0) goto 1000 if(lokpty%proptype.eq.1) then vals=vals/rtg endif goto 1000 endif !---------------------------------------------------------------------- ! for composition dependent param set default variables for ionic liquid ionicliq=.FALSE. iliqva=.FALSE. iliqneut=.FALSE. yionva=zero if(btest(phlista(lokph)%status1,PHIONLIQ)) then ! prepare for ionic liquid interactions ! write(*,17)'3X RK: ',phlista(lokph)%i2slx(1),gz%endcon(gz%intlat(1)) 17 format(a,10i4) ! write(*,*)'3X ionicliq set true' ! write(*,17)'3X Const in subl: ',gz%intlat(1),gz%endcon(gz%intlat(1)),& ! gz%endcon(2),phlista(lokph)%i2slx(1),gz%intlevel ionicliq=.TRUE. if(gz%endcon(2).eq.phlista(lokph)%i2slx(1)) then ! VA endmember in the 2nd sublattice, this is the complicated case yionva=gz%yfrem(2) ivax=phlista(lokph)%i2slx(1) ! write(*,64)'3X iliq with Va: ',ivax,yionva 64 format(a,i3,6(1pe12.4)) if(gz%intlat(1).eq.1) then ! interaction in sublattice 1 between two cations same as substituional L_A,B ! with each cation fraction multiplied with vacancy ! Also set TRUE for reciprocal interactions (gz%intlevel=2) iliqva=.TRUE. else ! interaction in sublattice 2 between Va and neutral (i.e. cation and neutral) ! same as substitutional L_A,B with cation fraction multiplied with vacancy ! Hm, I am not sure interactions are ordered so all interactions in first ! sublattice comes before any in second sublattice ?? iliqneut=.TRUE. endif ! else ! constituent in second sublattice is not vacancy, no particular action ?? ! write(*,17)'3X 2nd sublattice constituent not Va: ',gz%endcon(2) endif endif intlev: if(gz%intlevel.eq.1) then !---------------------------------------------------------------------- ! plain binary Redlich Kister or Toop/Kohler method ! gz%endcon can be wildcard, i.e. negative ! but for the moment give error message in that case ! A binary wildcard excess parameter means y_A ( 1 - y_A) * L_A* ! most naturally gz%intcon(1) would be negative gz%iq(1)=gz%endcon(gz%intlat(1)) gz%iq(2)=gz%intcon(1) if(gz%iq(1).lt.0 .or. gz%iq(2).lt.0) then ! composition dependent wildcard interaction not implemented ! y(1-y) ( L0 + (2y-1) L1 + (2y-1)**2 L2 + ....) ?? gx%bmperr=4031; goto 1000 endif if(associated(tooprec)) then ! This is a Kohler-Toop method parameter ! only for binary interaction parameters with Kohler or Toop models ! if no composition dependence we never come here as we exit 50 lines above call calc_toop(lokph,lokpty,moded,vals,dvals,d2vals,gz,tooprec,ceq) ! we have calculated all, skip the rest of this subroutine goto 1000 endif ! endmember fraction minus interaction fraction dx0=gz%yfrem(gz%intlat(1))-gz%yfrint(1) ! ycat is one unless ionic liquid with vacancy-neutral interaction ycat0=one if(ionicliq) then if(iliqva) then ! interaction between cations with vacancy on second sublattice ! NOTE intraction fraction alreay multiplied with yionva before calling cgint dvax0=gz%yfrem(gz%intlat(1))-gz%yfrint(1)/yionva ! dvax0=dx0 dx0=yionva*dvax0 ! write(*,65)'3X Va on 2nd: ',gz%iq(2),gz%intlat(1),dvax0,dx0,& ! gz%yfrem(gz%intlat(1)),gz%yfrint(1) 65 format(a,2i3,6(1pe12.4)) elseif(iliqneut) then ! interaction between vacancy and neutral in second sublattice ! we must know the cation (if only neutrals set to one) icat=gz%endcon(1) ycat0=gz%yfrem(1) ! the fraction difference is between (y_cation * y_Va - y_neutral) dx0=gz%yfrem(1)*yionva-gz%yfrint(1) dvax0=ycat0 ! write(*,*)'3X dx0: ',dx0,ycat0,yionva endif endif vals=zero dx=one dx1=zero dx2=zero dvax1=zero dvax2=zero dyvan1=one dyvan2=one ! write(*,*)'3X cgint 2:',gz%iq(1),gz%iq(2),gz%iq(3),icat ! write(*,*)'3X c1bug: ',ionicliq,iliqva,iliqneut ! special for ionic liquid: when two cation interacts with Va in second ! sublattice the vacancy fraction is raised by power 2 RK: do jdeg=0,lokpty%degree lfun=lokpty%degreelink(jdeg) call eval_tpfun(lfun,gz%tpv,valtp,ceq%eq_tpres) if(gx%bmperr.ne.0) goto 1000 if(lokpty%proptype.eq.1) then ! property type 1 is G and should be normalized by RT valtp=valtp/rtg endif ! vals and valtp are arrays with 6 elements: G, G.T, G.P, G.T.T ... vals=vals+dx*valtp ! write(*,11)'3X dx: ',gz%iq(1),gz%iq(2),jdeg,vals(1),dx,valtp(1) 11 format(a,3i2,6(1pe11.3)) ! no composition derivative. if moded=0 only G, =1 G+G.Y, =2 all noder5: if(moded.gt.0) then ! first derivatives, qz=1: dG/dyA dG/dyB; qz=2: d2G/dTdy; qz=3: d3G/dPdy ! for iliqneut there should not be same -dx1 ... gz%iq(2) is neutral do qz=1,3 ! For interactions between Va and neutral in ionic liguid a power of yionva ! is required for the cation derivative as we have (y_cation*yionva-y_neutral) ! In all other cases dyvan1=unity dvals(qz,gz%iq(1))=dvals(qz,gz%iq(1))+ycat0*dx1*valtp(qz) dvals(qz,gz%iq(2))=dvals(qz,gz%iq(2))-dx1*valtp(qz) ! The handling of ionic liquid parameter derivatives can be simplified ... if(iliqva) then ! derivative with respect to vacancy fraction for (yc1-yc2)*yva: yc1-yc2 dvals(qz,ivax)=dvals(qz,ivax)+dvax1*valtp(qz) ! if(qz.eq.1) write(*,11)'3X iliqva: ',0,0,ivax,dvax1 elseif(iliqneut) then ! derivative with respect to cation (yc1*yva-yn): ! multiply with a power of y_Va dvals(qz,icat)=dvals(qz,icat)+yionva*dx1*valtp(qz) ! write(*,19)'3X mess:',qz,gz%iq(1),gz%iq(2),icat,yionva,ycat0,& ! valtp(qz),dx1 19 format(a,4i3,6(1pe12.4)) endif enddo ! write(*,11)'3X dx1:',gz%iq(1),gz%iq(2),jdeg,dvals(1,gz%iq(1)),& ! dvals(1,gz%iq(2)),dx1,valtp(1) ! second derivatives, d2G/dyAdyA d2G/dyAdyB d2G/dyBdyB if(moded.gt.1) then d2vals(ixsym(gz%iq(1),gz%iq(1)))=& d2vals(ixsym(gz%iq(1),gz%iq(1)))+dx2*valtp(1) d2vals(ixsym(gz%iq(1),gz%iq(2)))=& d2vals(ixsym(gz%iq(1),gz%iq(2)))-dx2*valtp(1) d2vals(ixsym(gz%iq(2),gz%iq(2)))=& d2vals(ixsym(gz%iq(2),gz%iq(2)))+dx2*valtp(1) ! if(iliqva) then ! UNFINISHED d2G/dyvdyv d2G/dyvdyA d2G/dyvdyB interactions two cations ! d2vals(ixsym(ivax,ivax))=& ! d2vals(ixsym(ivax,ivax))+dvax2*valtp(1) ! elseif(iliqneut) then ! UNFINISHED also for interactions Va-neutral ! continue ! endif endif endif noder5 ! next power of dx if(iliqva) then ! interaction between two cations, dx0=y_va*(y_c1 - y_c2) ! NO CHANGE HERE WHEN FIXING ERROR FOR Va-Neutal interaction ... dx2=(jdeg+1)*dx1 dvax2=(jdeg+1)*dvax1 if(jdeg.eq.0) then dx1=yionva dvax1=dvax0 else dx1=(jdeg+1)*dx1*dx0 dvax1=(jdeg+1)*dvax1*dx0 endif dx=dx*dx0 ! write(*,23)'3X iliqvb: ',jdeg,dx,dx1,dx2,dvax0,dvax1,dvax2 23 format(a,i2,6(1pe12.4)) elseif(iliqneut) then ! interaction between Va and neutral a bit more complicated ... NOT TESTED ! NOTE 2nd derivatives ignored ... dx2=(jdeg+1)*dx1 dvax2=dvax1 if(jdeg.eq.0) then dx1=one dvax1=dvax0 else dx1=(jdeg+1)*dx1*dx0 dvax1=(jdeg+1)*dvax0*dx1 endif dx=dx*dx0 else ! normal CEF model. Note negative sign taken care of when "added" dx2=(jdeg+1)*dx1 dx1=(jdeg+1)*dx dx=dx*dx0 endif enddo RK elseif(gz%intlevel.eq.2) then !intlev !---------------------------------------------------------------------- ! important to set ivax=0 here as tested below if not zero ivax=0 iliq3cat=.FALSE. ! it can be a ternary interaction in same sublattice or a reciprocal parameter ! write(*,*)'3X gz%intlat: ',gz%intlat ! write(*,*)'3X gz%intcon: ',gz%intcon if(ionicliq) then ! write(*,*)'3X Comp.dep ternary ionic liquid parameter: ',iliqva if(gz%intlat(1).eq.2) then ! Both interacting constituents in second sublattice, this should handle these: ! TAFID problem: (5):(33,37,56) is (CA+2):(ALO2-,SIO4-4,SIO2) !!! ! TAFID problem: (12):(33,37,56) is (MG+2):(ALO2-,SIO4-4,SIO2) !!! ! TAFID problem: (9):(38,39,41) is (Fe+2):(VA,B,C) !! ! not tested: (Fe+2):(S-2,Va,S) or similar ... but it should be OK continue elseif(iliqva) then ! the pair constituent in second sublattice is Va, no anions!! if(gz%intlat(1).eq.1 .and. gz%intlat(2).eq.1) then ! we have 3 cations interacting in first sublattice and Va in second ! with composition dependence .... require treatment of extra vacancy fraction ! TAFID not implemented: (Fe+2,Cr+2,Ni+1):(Va) for example .... ! ternary term: y_Va*(y_Cr*L;0 +y_Fe*L;1 +y_Ni*L;2) ! write(*,*)'3X unimplemented comp. dep. ternary cation',& ! 'interaction in liquid' ! gx%bmperr=4343; goto 1000 ! iliq3cat=.TRUE. ivax=gz%intcon(2) elseif(gz%intlat(1).eq.1 .and. gz%intlat(2).eq.2) then ! This is a reciprocal interaction, two cations, vacancy and neutral ivax=gz%endcon(2) endif elseif(gz%intcon(2).eq.phlista(lokph)%i2slx(1)) then ! reciprocal interaction between two cations in first sublattice and ! an anion and vacancy is the second sublattice ! write(*,*)'3X reciprocal with 2 cations and anion and Va' ivax=gz%intcon(2) yionva=gz%yfrint(2) else ! I do not know what kind of parameter this is ! THIS ERROR OCCUR ONLY IN PARALLEL ! write(*,28)'3X: unknown I2SL parameter on level: ',& ! gz%intlevel,gz%endcon(1),gz%intcon(1),gz%intcon(2),& ! gz%endcon(2),gz%iq,iliqva 28 format(a,i2,': ',i2,',',i2,',',i2,':',i2,5x,5i3,2x,l2) ! gx%bmperr=4342; goto 1000 goto 1000 endif ! other ternary parameters in ionic liquid OK, no extra vacancy fraction endif !................................................................ 300 continue ! ternary composition dependent interaction ternary: if(gz%intlat(1).eq.gz%intlat(2)) then ! Ternary composition dependent interaction in same sublattice, Hillert form. ! The idea is that the sum of vv is always unity even in higher order systems ! whereas the sum of the constituent frations are not ! If wildcard then any of the gz%iq would be negative, not allowed gz%iq(1)=gz%endcon(gz%intlat(1)) gz%iq(2)=gz%intcon(1) gz%iq(3)=gz%intcon(2) if(gz%iq(1).lt.0 .or. gz%iq(2).lt.0 .or. gz%iq(3).lt.0) then gx%bmperr=4031; goto 1000 endif vv(0)=gz%yfrem(gz%intlat(1)) vv(1)=gz%yfrint(1) vv(2)=gz%yfrint(2) ct=(one-vv(0)-vv(1)-vv(2))*onethird vv=vv+ct ! derivatives of vv w.r.t. the 3 constituents 0, 1 and 2 fvv(0)=two*onethird fvv(1)=-onethird fvv(2)=-onethird if(size(lokpty%degreelink).eq.2) then ! KRASCH if only two degrees of ternary parameter (3 MUST BE GIVEN) ! If only one it is composition independent! write(*,37)trim(phlista(lokph)%name),size(lokpty%degreelink) 37 format('3X Database error, ternary composition dependent',& ' parameter in ',a/'must have 3 degrees, has only ',i2) write(*,38)gz%endcon(1),gz%intcon(1),gz%intcon(2) 38 format('3X constituents: ',3i3) write(*,39)(lokpty%degreelink(jint),jint=0,2) 39 format('3X degreelinks: ',3i5) gx%bmperr=4342; goto 1000 endif terloop: do jint=0,2 ! calculate parameters, there are 3 of them, jint=0, 1 and 2 lfun=lokpty%degreelink(jint) call eval_tpfun(lfun,gz%tpv,valtp,ceq%eq_tpres) if(lokpty%proptype.eq.1) then valtp=valtp/rtg endif ! function value if(iliq3cat) then ! this is when there are 3 cations in ionic liquid, yionva is vacancy fraction ! NOTE vals and valtp both have dimension 6!! vals=vals+yionva*vv(jint)*valtp ! there are also a contrbution to df/dyva!, d2f/dyvadT ... calculated below ! ivax is the index of vacancy ! write(*,*)'3X ivax: ',ivax dvals(1,ivax)=dvals(1,ivax)+vv(jint)*valtp(1) dvals(2,ivax)=dvals(2,ivax)+vv(jint)*valtp(2) dvals(3,ivax)=dvals(3,ivax)+vv(jint)*valtp(3) else vals=vals+vv(jint)*valtp endif noder6: if(moded.gt.0) then ! first derivatives, qz=2 is for T and qz=3 is for P derivatives do qz=1,3 ! for interaction with 3 cations and Va in 2nd sublattice ! valtp(1) is G; valtp(2) is dG/dT; valtp(3) is dG/dP if(iliq3cat) then ! the first derivatives dvals(qz,gz%iq(1))=dvals(qz,gz%iq(1))+& yionva*fvv(0)*valtp(qz) dvals(qz,gz%iq(2))=dvals(qz,gz%iq(2))+& yionva*fvv(1)*valtp(qz) dvals(qz,gz%iq(3))=dvals(qz,gz%iq(3))+& yionva*fvv(2)*valtp(qz) else dvals(qz,gz%iq(1))=dvals(qz,gz%iq(1))+fvv(0)*valtp(qz) dvals(qz,gz%iq(2))=dvals(qz,gz%iq(2))+fvv(1)*valtp(qz) dvals(qz,gz%iq(3))=dvals(qz,gz%iq(3))+fvv(2)*valtp(qz) endif enddo endif noder6 if(iliq3cat) then ! with ionic liquid and 3 cations iteraction there are 2nd derivatives ! with respect to Va and the cation (but no T or P derivative)! ! gz%iq(1) is d2vals(ixsym(ivax,gz%iq(jint+1)))=& d2vals(ixsym(ivax,gz%iq(jint+1)))+fvv(0)*valtp(1) endif fvs=fvv(2) fvv(2)=fvv(1) fvv(1)=fvv(0) fvv(0)=fvs enddo terloop else !......................................................... ! composition dependent reciprocal interactions here only degree 1 and 2 if(lokpty%degree.gt.2) then write(*,*)'3X Composition dependent reciprocal degree max 2' gx%bmperr=4078; goto 1000 else ! write(*,32)lokph,lokpty%degree,gz%intlat(1),gz%intlat(2),& ! gz%iq(1),gz%iq(2),gz%iq(3),gz%iq(4) 32 format('3X Comp.dep. rec. param: ',i3,2x,i1,2x,2i2,4i5) endif ! Note the composition dependence is defined that ! L = y'_Ay'_By"_Cy"_D (0L + (y"_C-y"_D)*1L + (y'_A-y'_B)*2L) ! it is a bit strange that 2nd sublattice is 1L ... but that is the definition gz%iq(1)=gz%endcon(1) gz%iq(2)=gz%intcon(1) gz%iq(3)=gz%endcon(2) gz%iq(4)=gz%intcon(2) ! degree 0 not composition dependent, vals multiplied with pyq after return lfun=lokpty%degreelink(0) if(lfun.gt.0) then call eval_tpfun(lfun,gz%tpv,valtp,ceq%eq_tpres) if(gx%bmperr.ne.0) goto 1000 if(lokpty%proptype.eq.1) then valtp=valtp/rtg endif vals=vals+valtp endif ! lokpty%degree must be 1 or 2 otherwise we would not be here ! write(*,17)'3X composition dependent reciprocal',ivax lfun=lokpty%degreelink(1) recip1: if(lfun.gt.0) then ! degree 2 can be empty, otherwise multiplied with gz%iq(3)-gz%iq(4) ! no problem with ionic liquid except there may be values in dvals call eval_tpfun(lfun,gz%tpv,valtp,ceq%eq_tpres) if(gx%bmperr.ne.0) goto 1000 ! write(*,62)'3X rp: ',valtp(1),valtp(2) 62 format(a,6(1pe12.4)) if(lokpty%proptype.eq.1) then valtp=valtp/rtg endif vals=vals+(gz%yfrem(gz%intlat(2))-gz%yfrint(2))*valtp ! dvals(1,const) is the 1st derivative of the fun wrt const ! dvals(2,const) is the 2nd derivative of the fun wrt const and T ! dvals(3,const) is the 2nd derivative of the fun wrt const and P ! one dvals(*,ivax) could have been assigned a value above (for ionic liquid) do qz=1,3 ! write(*,63)'3X dvals: ',qz,gz%iq(3),dvals(qz,gz%iq(3)),& ! dvals(qz,gz%iq(4)),valtp(qz) dvals(qz,gz%iq(3))=dvals(qz,gz%iq(3))+valtp(qz) dvals(qz,gz%iq(4))=dvals(qz,gz%iq(4))-valtp(qz) ! write(*,63)'3X dvals: ',qz,gz%iq(4),dvals(qz,gz%iq(3)),dvals(qz,gz%iq(4)) enddo 63 format(a,2i3,6(1pe12.4)) endif recip1 ! degree 2 can be empty, otherwise multiplied with y(gz%iq(1))-y(gz%iq(2)) recip2: if(lokpty%degree.gt.1) then lfun=lokpty%degreelink(2) if(lfun.gt.0) then call eval_tpfun(lfun,gz%tpv,valtp,ceq%eq_tpres) if(gx%bmperr.ne.0) goto 1000 if(lokpty%proptype.eq.1) then valtp=valtp/rtg endif if(ivax.gt.0) then ! write(*,67)ivax,gz%iq(1),gz%iq(2),gz%iq(3),gz%iq(4),yionva !67 format('3X ion liq recip: ',i3,2x,4i3,1pe12.4) ! interaction in ionic liquid with vacancy as one constituent in 2nd subl. vals=vals+yionva*(gz%yfrem(gz%intlat(1))-gz%yfrint(1))*valtp do qz=1,3 dvals(qz,gz%iq(1))=+yionva*valtp(qz) dvals(qz,gz%iq(2))=-yionva*valtp(qz) enddo ! we have to take into account extra derivatives wrt vacancies if vacancy ! is a constituent in second sublattice do qz=1,3 dvals(qz,ivax)=& (gz%yfrem(gz%intlat(1))-gz%yfrint(1))*valtp(qz) enddo else ! not ionic liquid .... puuuh vals=vals+(gz%yfrem(gz%intlat(1))-gz%yfrint(1))*valtp do qz=1,3 dvals(qz,gz%iq(1))=+valtp(qz) dvals(qz,gz%iq(2))=-valtp(qz) enddo endif endif endif recip2 endif ternary !---------------------------------------------------------------------- elseif(gz%intlevel.ge.3) then !intlev ! higher interaction levels have no composition dependence write(*,999) 999 format('Composition dependence for parameters with >2 interacting ',& 'constituents'/'not implemented!') gx%bmperr=4078; goto 1000 endif intlev !---------------------------------------------------------------------- ! finished finally .... 1000 continue return end subroutine cgint !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine config_entropy !\begin{verbatim} subroutine config_entropy(moded,nsl,nkl,phvar,tval) ! calculates CEF configurational entropy/R for phase lokph implicit none integer moded,nsl integer, dimension(nsl) :: nkl TYPE(gtp_phase_varres), pointer :: phvar !\end{verbatim} integer ll,kk,kall,nk,jl double precision tval,ss,yfra,ylog ll=0 kall=0 sublatticeloop: do while (ll.lt.nsl) ll=ll+1 nk=nkl(ll) kk=0 ss=zero fractionloop: do while (kk.lt.nk) kk=kk+1 kall=kall+1 if(nk.eq.1) cycle sublatticeloop yfra=phvar%yfr(kall) if(yfra.lt.bmpymin) yfra=bmpymin if(yfra.gt.one) yfra=one ylog=log(yfra) ! gval(1:6,1) are G and derivator wrt T and P ! dgval(1,1:N,1) are derivatives of G wrt fraction 1:N ! dgval(2,1:N,1) are derivatives of G wrt fraction 1:N and T ! dgval(3,1:N,1) are derivatives of G wrt fraction 1:N and P ! d2dval(ixsym(N*(M+1)/2),1) are derivatives of G wrt fractions N and M ! this is a symmetric matrix and index givem by ixsym(M,N) ss=ss+yfra*ylog if(moded.gt.0) then phvar%dgval(1,kall,1)=phvar%sites(ll)*(one+ylog) ! phvar%d2gval(ixsym(kall,kall),1)=phvar%sites(ll)/yfra ! kxsym same as ixsym when first index is >= second index phvar%d2gval(kxsym(kall,kall),1)=phvar%sites(ll)/yfra endif enddo fractionloop phvar%gval(1,1)=phvar%gval(1,1)+phvar%sites(ll)*ss enddo sublatticeloop ! looking for error calculating 4 sublattice ordered FCC ! write(*,69)kall,(phvar%d2gval(ixsym(jl,jl),1),jl=1,kall) 69 format('3X d2G/dy2: ',i3,6(1pe12.4)) ! set temperature derivative of G and dG/dy phvar%gval(2,1)=phvar%gval(1,1)/tval if(moded.gt.0) then do jl=1,kall phvar%dgval(2,jl,1)=phvar%dgval(1,jl,1)/tval enddo endif 1000 continue return end subroutine config_entropy !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine config_entropy_ssro !\begin{verbatim} subroutine config_entropy_ssro(moded,lokph,phvar,tval) ! test calculates SSRO configurational entropy/R for phase lokph implicit none integer moded,lokph double precision tval TYPE(gtp_phase_varres), pointer :: phvar !\end{verbatim} ! CVM tetrahedron model with ONLY SRO, no sublattices integer ia,ib,ic,id,jj,jk,jl,jm,ne,nc,zz,pz ! this is multiplicities integer, allocatable :: mijkl(:) ! this is mole fractions and derivatives double precision, allocatable :: xf(:),dxf(:,:),d2xf(:,:) ! these are constituent fractions for entropy!!! double precision, allocatable :: ysro(:) ! these are site fractions, not needed when only SRO as y^s_i=x_i ! double precision, allocatable :: yf1(:),yf2(:),yf3(:),yf4(:) ! double precision, allocatable :: dyf1(:,:),dyf2(:,:),dyf3(:,:),yf4(:,:) ! these are pair fractions, same for all bonds! ! double precision, allocatable :: p12(:,:),p13(:,:),p14(:,:),& ! p23(:,:),p24(:,:),p34(:,:) ! double precision, allocatable :: dp12(:,:,:),dp13(:,:,:),dp14(:,:,:),& ! dp23(:,:,:),dp24(:,:,:),p34(:,:,:) double precision, allocatable :: pstij(:,:) double precision, allocatable :: dpstij(:,:,:),d2pstij(:,:,:) double precision, parameter :: f1=0.75D0, f2=0.5D0, f3=0.25D0 ! double precision, parameter :: f1=3.0D0, f2=2.0D0, f3=1.0D0 ! auxilliary character dummy*80 double precision pijx,fpf,ssumy,ssump,ssumx,ylog,yfra,ycorr,yrest double precision pstijtest,pstijsave ! debugging double precision ylog1(5),ylog2,ylog3 double precision sylog1,sylog2,sylog3 ! These factors should be 2.0, -6.0 and 5.0 according to Kikuchi ! I have no idea why I have to divide them by 10 ... double precision, parameter :: syfact=2.0D0, spfact=-6.0D0, sxfact=5.0D0 logical sdebug save pstijsave ! use phvar%volatile to initiate ycorr at first itertation ! sdebug=.TRUE. sdebug=.FALSE. ! write(*,*)'3X sdebug: ',sdebug if(phvar%volatile.eq.0) then ! phvar%volatile is set to zero in matsmin: meq_calceq at first iteration ! decrease ycorr when pstijsave constant phvar%volatile=phvar%volatile+1 ycorr=0.5D0 pstijsave=0.0D0 endif yrest=1.0D0-ycorr ! nc is number of constituent, ne is number of elements nc=phlista(lokph)%tnooffr ! using empirical rule to calcuöate ne from nc select case(nc) case default write(*,*)'3X SRO number of constituents not implemented',nc case(1) ne=1 write(*,*)'3X SRO entropy zero for single element' goto 1000 case(5) ! binary system ne=2 case(15) ne=3 case(35) ne=4 case(70) ! without merging AAAB etc there would be 625 clusters instead of just 70 ne=5 case(126) ne=6 case(210) ne=7 case(330) ! without merging AAAB etc there would be 4096 clusters ne=8 end select ! ! write(*,*)'3X CVMTFS model for configurational entropy',nc,ne ! allocate(mijkl(nc)) allocate(xf(ne)) allocate(dxf(ne,nc)) allocate(d2xf(ne,nc)) ! allocate(yf1(ne)) ! allocate(yf2(ne)) ! allocate(yf3(ne)) ! allocate(yf4(ne)) ! allocate(dyf1(ne,nc)) ! allocate(dyf2(ne,nc)) ! allocate(dyf3(ne,nc)) ! allocate(dyf4(ne,nc)) ! jj incremented for each cluster jj=0 mijkl=0 xf=zero dxf=zero ! site fractions same as mole fractions as no LRO ! yf1=zero ! yf2=zero ! yf3=zero ! yf4=zero ! dyf1=zero ! dyf2=zero ! dyf3=zero ! dyf4=zero ! extrahera mole fractions from constituent fractions do ia=1,ne jj=jj+1 ! this is AAAA or BBBB etc mijkl(jj)=1 xf(ia)=xf(ia)+phvar%yfr(jj) dxf(ia,jj)=1 do ib=ia+1,ne jj=jj+3 mijkl(jj-2)=4 mijkl(jj-1)=6 mijkl(jj)=4 ! jj-2 is A3B1, jj-1 is A2B2, jj is A1B3 including permutations in mijkl xf(ia)=xf(ia)+f1*phvar%yfr(jj-2)+f2*phvar%yfr(jj-1)+f3*phvar%yfr(jj) xf(ib)=xf(ib)+f3*phvar%yfr(jj-2)+f2*phvar%yfr(jj-1)+f1*phvar%yfr(jj) dxf(ia,jj-2)=f1; dxf(ia,jj-1)=f2; dxf(ia,jj)=f3; dxf(ib,jj-2)=f3; dxf(ib,jj-1)=f2; dxf(ib,jj)=f1; do ic=ib+1,ne jj=jj+3 mijkl(jj-2)=12 mijkl(jj-1)=12 mijkl(jj)=12 ! jj-2 is A2BC, jj-1 is AB2C, jj is ABC2 xf(ia)=xf(ia)+f2*phvar%yfr(jj-2)+f3*phvar%yfr(jj-1)+f3*phvar%yfr(jj) xf(ib)=xf(ib)+f3*phvar%yfr(jj-2)+f2*phvar%yfr(jj-1)+f3*phvar%yfr(jj) xf(ic)=xf(ic)+f3*phvar%yfr(jj-2)+f3*phvar%yfr(jj-1)+f2*phvar%yfr(jj) dxf(ia,jj-2)=f2; dxf(ia,jj-1)=f3; dxf(ia,jj)=f3; dxf(ib,jj-2)=f3; dxf(ib,jj-1)=f2; dxf(ib,jj)=f3; dxf(ic,jj-2)=f3; dxf(ic,jj-1)=f3; dxf(ic,jj)=f2; do id=ic+1,ne jj=jj+1 mijkl(jj-2)=24 ! jj is ABCD xf(ia)=xf(ia)+f3*phvar%yfr(jj) xf(ib)=xf(ib)+f3*phvar%yfr(jj) xf(ic)=xf(ic)+f3*phvar%yfr(jj) xf(id)=xf(id)+f3*phvar%yfr(jj) dxf(ia,jj)=f3; dxf(ib,jj)=f3; dxf(ic,jj)=f3; dxf(id,jj)=f3; enddo enddo enddo enddo ! Convergence problem, when pstij constant make rest approach 1.0 pstijtest=zero do ia=1,ne do ib=ia+1,ne if(xf(ia)*xf(ib).gt.pstijtest) pstijtest=xf(ia)*xf(ib) enddo enddo ! pstijtest is maximum pair fraction using mole fractions calculated ! from cluster fractions provided by the minimizer ! if almost the same as previous decrease ycorr if(abs(pstijtest-pstijsave).lt.1.0D-4) then ycorr=max(0.5D0*ycorr,1.0D-8) ! when yrest=1 we use the fractions from the minimizer else ycorr=min(0.5d0*ycorr,0.5D0) endif yrest=1.0D0-ycorr if(SDEBUG) write(*,'(a,1x,l,1x,12F6.3)')'3X corr: ',sdebug,& pstijtest,pstijsave,yrest,ycorr ! without this stupid dummy statement the calculations does not converge write(dummy,'(a,1x,l,1x,12F6.3)')'3X corr: ',sdebug,& pstijtest,pstijsave,yrest,ycorr ! save pstij for next iteration pstijsave=pstijtest ! IDEA ! We have no LRO, fractions on all sublattices same and equal to molefractions ! THUS recalculate the cluster fractions from the mole fractions .... allocate(ysro(jj)) jj=0 do ia=1,ne jj=jj+1 ysro(jj)=yrest*phvar%yfr(jj)+ycorr*xf(ia)**4 do ib=ia+1,ne jj=jj+1 ysro(jj)=yrest*phvar%yfr(jj)+ycorr*mijkl(jj)*xf(ib)*xf(ia)**3 jj=jj+1 ysro(jj)=yrest*phvar%yfr(jj)+ycorr*mijkl(jj)*xf(ib)**2*xf(ia)**2 jj=jj+1 ysro(jj)=yrest*phvar%yfr(jj)+ycorr*mijkl(jj)*xf(ib)**3*xf(ia) do ic=ib+1,ne jj=jj+1 ysro(jj)=yrest*phvar%yfr(jj)+ycorr*mijkl(jj)*xf(ia)**2*xf(ib)*xf(ic) jj=jj+1 ysro(jj)=yrest*phvar%yfr(jj)+ycorr*mijkl(jj)*xf(ia)*xf(ib)**2*xf(ic) jj=jj+1 ysro(jj)=yrest*phvar%yfr(jj)+ycorr*mijkl(jj)*xf(ia)*xf(ib)*xf(ic)**2 do id=ic+1,ne jj=jj+1 ysro(jj)=yrest*phvar%yfr(jj)+& ycorr*mijkl(jj)*xf(ia)*xf(ib)*xf(ic)*xf(id) enddo enddo enddo enddo ! if(SDEBUG) then write(*,'(a,12F7.4)')'3X yfr: ',(phvar%yfr(jj),jj=1,nc) write(*,'(a,12F6.3)')'3X ysro:',ysro endif ! ! write(*,'(a,F5.2,10F6.3)')'3X xf2: ',fpf,(xf(ia),ia=1,ne) ! calculate pair fractions using the site fractions ! allocate(p12(ne,ne)) ! allocate(p13(ne,ne)) ! allocate(p14(ne,ne)) ! allocate(p23(ne,ne)) ! allocate(p24(ne,ne)) ! allocate(p34(ne,ne)) allocate(pstij(ne,ne)) allocate(dpstij(ne,ne,nc)) allocate(d2pstij(ne,ne,nc*(nc+1)/2)) pstij=zero dpstij=zero d2pstij=zero ! calculation of pair fractions using mole fractions (same as site fractions) ! include AA, AB, AC, BB etc pairs but exclude BA, CA ?? do ia=1,ne do ib=1,ne ! If we had LRO we should need yf1, yf2, yf3 and yf4 ! but the site fractions are the same in all sublattces when no LRO (?) pstij(ia,ib)=xf(ia)*xf(ib) do jj=1,nc dpstij(ia,ib,jj)=dxf(ia,jj)*xf(ib)+dxf(ib,jj)*xf(ia) do jk=jj,nc zz=ixsym(jj,jk) ! write(*,'(a,2i4,2x,2i4,i7)')'3X d2pstij: ',ia,ib,jj,jk,zz ! d2pstij(ia,ib,zz)=d2pstij(ia,ib,zz)+& ! dxf(ia,jj)*dxf(ib,jk)+dxf(ib,jj)*dxf(ia,jk) enddo enddo enddo enddo ! All necessary fractions and derivatives calculated, now the entropy ! S = -2 \sum_ijkl y_ijkl\ln(y_ijkl) + ! 6 \sum_ij p_ij\ln(p_ij) - 5 \sum_j x_j\ln(x_j) ! As we calculate G the signs are inverse ! constituent fraction entropy ! entropy contribution from the constituent fractions ------------------ ! USE ysro fractions!!! not phvar%yfr or a mix ... ssumy=zero ! sylog1=zero do jj=1,nc ! yfra=phvar%yfr(jj) yfra=ysro(jj) if(yfra.lt.bmpymin) yfra=bmpymin if(yfra.gt.one) yfra=one ! yfra is divided by mijkl as it represent mijkl fractions ylog=log(yfra/mijkl(jj)) ! debugging ! if(jj.le.5) ylog1(jj)=ylog ! sylog1=sylog1+yfra*ylog ssumy=ssumy+syfact*yfra*ylog if(moded.gt.0) then ! dgval(1,1:nc,1) are derivative of G/RT wrt fraction 1:nc ! d2gval(ixsym(jj*(jk+1)/2,1) are 2nd derivarive of G/RT wrt fraction jj and jk ! dgval and d2gval are zero before this loop ! phvar%dgval(1,jj,1)=syfact*(mijkl(jj)+ylog) ! convergence problem test phvar%dgval(1,jj,1)=syfact*(one+ylog) ! ? T and y derivative phvar%dgval(2,jj,1)=syfact*(mijkl(jj)+ylog)/tval ! 2nd derivative, each term depend on a single y fraction phvar%d2gval(kxsym(jj,jj),1)=syfact*mijkl(jj)/yfra endif ! write(*,'(a,3(1pe12.4))')'3X ssumy: ',yfra,ylog,ssumy enddo phvar%gval(1,1)=ssumy phvar%gval(2,1)=ssumy/tval ! No convergence just using ysro ... change the phvar%yfr .... do jj=1,nc phvar%yfr(jj)=ysro(jj) enddo ! entropy contributions from the 6 pair fractions ----------------------- ssump=zero ! all pairs the same, no need to loop over sublattices fpf=spfact ! sylog2=zero do ia=1,ne ! do ib=ia+1,ne do ib=1,ne ! bond between atom ia and ib ylog=log(pstij(ia,ib)) ! debugging ! ylog2=ylog ! sylog2=sylog2+pstij(ia,ib)*ylog ! write(*,'(a,2i3,3(1pe12.4))')'3X ylogp: ',ia,ib,pstij(ia,ib),ylog,& ! pstij(ia,ib)*ylog ssump=ssump+fpf*pstij(ia,ib)*ylog if(moded.gt.0) then do jl=1,nc ! we need derivatives of pair fractions wrt constituent fractions phvar%dgval(1,jl,1)=phvar%dgval(1,jl,1)+& fpf*dpstij(ia,ib,jl)*(one+ylog) do jm=jl,nc zz=ixsym(jl,jm) phvar%d2gval(zz,1)=phvar%d2gval(zz,1)+& fpf*(d2pstij(ia,ib,zz)*(one+ylog)+& dpstij(ia,ib,jl)*dpstij(ia,ib,jm)/pstij(ia,ib)) enddo enddo endif ! write(*,'(a,2i3,4(1pe12.4))')'3X ssump: ',ia,ib,fpf,pstij(ia,ib),& ! ylog,ssump enddo enddo phvar%gval(1,1)=phvar%gval(1,1)+ssump phvar%gval(2,1)=phvar%gval(2,1)+ssump/tval ! entropy contributions from the mole fractions ----------------------- ssumx=zero ! sylog3=zero do ia=1,ne ! we need derivatives of mole fractions wrt constituent fractions ylog=log(xf(ia)) ! debugg ! ylog3=ylog ! sylog3=sylog3+xf(ia)*ylog ssumx=ssumx+sxfact*xf(ia)*ylog if(moded.gt.0) then do jl=1,nc ! we need derivatives of mole fractions wrt constituent fractions phvar%dgval(1,jl,1)=phvar%dgval(1,jl,1)+& sxfact*dxf(ia,jl)*(ylog+one) do jm=jl,nc ! note d2xf/dyidyj==0 zz=kxsym(jl,jm) phvar%d2gval(zz,1)=phvar%d2gval(zz,1)+& sxfact*dxf(ia,jl)*dxf(ia,jm)/xf(ia) enddo enddo endif enddo phvar%gval(1,1)=phvar%gval(1,1)+ssumx phvar%gval(2,1)=phvar%gval(2,1)+ssumx/tval ! All done if(SDEBUG) then write(*,900)'3X xf: ',(xf(ia),ia=1,ne) 900 format(a,6F7.3) write(*,910)'3X pstij: ',((pstij(ia,ib),ib=1,ne),ia=1,ne) 910 format(a,10F7.3) ! write(*,'(a,5(1pe12.4))')'3X sylog: ',sylog1,sylog2,sylog3 ! write(*,'(a,5(1pe12.4))')'3X ylog1: ',ylog1 ! write(*,'(a,5(1pe12.4))')'3X ylogx: ',ylog2,ylog3 write(*,'(a,5(1pe12.4))')'3X cvmtfs: ',ssumy,ssump,ssumx,& phvar%gval(1,1),8.31451*phvar%gval(1,1) ! write(*,*)'3X cvmtfs model not yet released' endif 1000 continue return end subroutine config_entropy_ssro !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine config_entropy_cvmtfl !\begin{verbatim} subroutine config_entropy_cvmtfl(moded,lokph,phvar,tval) ! CVM tetrahedron model for FCC with LRO and SRO, all constituents mix ! implicit none integer moded,lokph double precision tval TYPE(gtp_phase_varres), pointer :: phvar !\end{verbatim} !======================================== ! Current code 230308 if same as _SSRO, only SRO ordering ! Modified code 230311 works partially for SRO (not LRO) !======================================== integer ia,ib,ic,id,jj,jk,jl,jm,ne,nc,zz,pz,ja,jb ! this is multiplicities ! integer, allocatable :: mijkl(:) ! this is mole fractions and derivatives double precision, allocatable :: xf(:),dxf(:,:),d2xf(:,:) ! these are constituent fractions for entropy!!! ! double precision, allocatable :: ysro(:) double precision, allocatable :: ylro(:) ! these are site fractions, needed for LRO yf(1..4,*) double precision, allocatable :: yf(:,:) double precision, allocatable :: dyf(:,:,:) ! these are pair fractions, same for all bonds! double precision, allocatable :: pst(:,:,:) double precision, allocatable :: dpst(:,:,:,:) ! use this dqst to relate derivatives pf pair directly to cluster fractions double precision, allocatable :: dqst(:,:,:,:) double precision, allocatable :: d2pst(:,:,:,:) ! double precision, allocatable :: p12(:,:),p13(:,:),p14(:,:),& ! p23(:,:),p24(:,:),p34(:,:) ! double precision, allocatable :: dp12(:,:,:),dp13(:,:,:),dp14(:,:,:),& ! dp23(:,:,:),dp24(:,:,:),dp34(:,:,:) ! double precision, allocatable :: d2p12(:,:,:),d2p13(:,:,:),d2p14(:,:,:),& ! d2p23(:,:,:),d2p24(:,:,:),d2p34(:,:,:) ! to be removed ! double precision, allocatable :: pstij(:,:) ! double precision, allocatable :: dpstij(:,:,:),d2pstij(:,:,:) ! double precision, parameter :: f1=0.75D0, f2=0.5D0, f3=0.25D0 ! auxilliary character dummy*80 double precision pijx,ssumy,ssump,ssumx,ylog,yfra,pfra,ycorr,yrest,ybase double precision pstijtest,pstijsave ! reduce derivatives double precision, parameter :: dfdy=1.0D0 ! debugging double precision ylog1(5),ylog2,ylog3,mass double precision sylog1,sylog2,sylog3 integer ss,tt,mm,wb1,wb2,wa1,wa2,iphf character cluster*4, chel(2)*1, spname*24 ! Kikuchi factors, note we calculate dG/dT, not S, thus signs inverted ! spfact -6 not used as we calculate and add 6 pair, sxfact/4 as 4 sublattices double precision, parameter :: syfact=2.0D0, spfact=-6.0D0, sxfact=1.250D0 logical sdebug,s2debug save pstijsave ! use phvar%volatile to initiate ycorr at first itertation !======================================== write(*,*) write(*,*)'3X CVM tetrahedron FCC with LRO for testing only' ! gx%bmperr=4399 ! goto 1000 !======================================== ! sdebug=.TRUE. sdebug=.FALSE. ! s2debug=.TRUE. s2debug=.FALSE. ! write(*,*)'3X sdebug: ',sdebug if(phvar%volatile.eq.0) then ! phvar%volatile is set to zero in matsmin: meq_calceq at first iteration ! decrease ycorr when pstijsave constant phvar%volatile=phvar%volatile+1 ycorr=0.5D0 pstijsave=0.0D0 endif yrest=1.0D0-ycorr ! nc is number of constituent, ne is number of elements nc=phlista(lokph)%tnooffr ! using empirical rule to calcuöate ne from nc select case(nc) case default write(*,*)'3X SRO number of constituents not implemented',nc case(1) ne=1 write(*,*)'3X SRO entropy zero for single element' goto 1000 case(16) ! binary system 2*2*2*2=16 ne=2 case(81) write(*,*)'3X max 2 elements!'; gx%bmperr=4399; goto 1000 ne=3 case(256) write(*,*)'3X max 2 elements!'; gx%bmperr=4399; goto 1000 ne=4 ! case(625) ! ne=5 end select ! ! write(*,*)'3X CVMTFS model for configurational entropy',nc,ne ! allocate(xf(ne)) allocate(dxf(ne,nc)) allocate(d2xf(ne,nc)) allocate(yf(4,ne)) allocate(dyf(4,ne,nc)) allocate(dqst(6,ne,ne,nc)) ! jj incremented for each cluster xf=zero dxf=zero ! site fractions same as mole fractions as no LRO yf=zero dyf=zero ! derivative of pair fractions related to clusters dqst=zero ! for nice debug output ... chel(1)='A' chel(2)='B' ! phase number ... iphf=1 ! extrahera site fractions from cluster fractions ! order is always AAAA, AAAB_01.._04; AABB_01.._06; ABBB_01.._04, BBBB etc jj=0 ialoop: do ia=1,ne jj=jj+1 ! this is AAAA or BBBB etc do ss=1,4 yf(ss,ia)=yf(ss,ia)+phvar%yfr(jj) dyf(ss,ia,jj)=dfdy cluster(ss:ss)=chel(ia) enddo xf(ia)=xf(ia)+phvar%yfr(jj) dxf(ia,jj)=dfdy ! call get_constituent_name(iphf,jj,spname,mass) ! write(*,*)'3X cluster: ',cluster,' ',trim(spname),jj ! write(*,300)(xf(ss),ss=1,ne) ! write(*,310)((yf(ss,zz),ss=1,4),zz=1,ne) ! write(*,*)'3X done AAAA: ',jj ibloop: do ib=ia+1,ne ! handle 4 of AAAB, 6 of AABB and 4 of ABBB with elements in different order ! In first 4 there is one atom ib in sublattice 4, 3, 2 and 1 wb1=4 do jj=jj+1,jj+4 ! These are 4 clusters ordered AAAB, AAABA, ABAA, BAAA ! write(*,*)'3X site fractions in cluster: ',jj,phvar%yfr(jj) do ss=1,4 if(ss.eq.wb1) then yf(ss,ib)=yf(ss,ib)+phvar%yfr(jj) dyf(ss,ib,jj)=dfdy cluster(ss:ss)=chel(ib) else yf(ss,ia)=yf(ss,ia)+phvar%yfr(jj) dyf(ss,ia,jj)=dfdy cluster(ss:ss)=chel(ia) endif enddo ! call get_constituent_name(iphf,jj,spname,mass) ! write(*,*)'3X cluster: ',cluster,' ',trim(spname),jj wb1=wb1-1 xf(ia)=xf(ia)+0.75D0*phvar%yfr(jj) dxf(ia,jj)=0.75D0*dfdy xf(ib)=xf(ib)+0.25D0*phvar%yfr(jj) dxf(ib,jj)=0.25D0*dfdy ! derivative of pair fraction relative to cluster fractions, 3 AB bonds dqst(1,ia,ib,jj)=3.0d0 enddo ! after a loop the loop variable is one higher than max limit jj=jj-1 ! write(*,300)(xf(ss),ss=1,ne) ! write(*,310)((yf(ss,zz),ss=1,4),zz=1,ne) ! write(*,*)'3X done AAAB: ',jj ! there are 3 clusters ordered AABB, ABAB, ABBA, always A in first wa1=2 do jj=jj+1,jj+3 ! write(*,*)'3X site fractions in cluster: ',jj,phvar%yfr(jj) yf(1,ia)=yf(1,ia)+phvar%yfr(jj) dyf(1,ia,jj)=dfdy cluster(1:1)=chel(ia) do ss=2,4 if(ss.eq.wa1) then yf(ss,ia)=yf(ss,ia)+phvar%yfr(jj) dyf(ss,ia,jj)=dfdy cluster(ss:ss)=chel(ia) else yf(ss,ib)=yf(ss,ib)+phvar%yfr(jj) dyf(ss,ib,jj)=dfdy cluster(ss:ss)=chel(ib) endif enddo ! call get_constituent_name(iphf,jj,spname,mass) ! write(*,*)'3X cluster: ',cluster,' ',trim(spname),jj wa1=wa1+1 xf(ia)=xf(ia)+0.5D0*phvar%yfr(jj) dxf(ia,jj)=0.5d0*dfdy xf(ib)=xf(ib)+0.5D0*phvar%yfr(jj) dxf(ib,jj)=0.5D0*dfdy ! derivative of pair fraction relative to cluster fractions, 4 AB bonds dqst(1,ia,ib,jj)=4.0d0 enddo jj=jj-1 ! write(*,300)(xf(ss),ss=1,ne) ! write(*,310)((yf(ss,zz),ss=1,4),zz=1,ne) ! write(*,*)'3X done first half AABB: ',jj ! these are 3 clusters ordered BAAB, BABA, BBAA wb1=4 do jj=jj+1,jj+3 ! write(*,*)'3X site fractions in cluster: ',jj,phvar%yfr(jj) yf(1,ib)=yf(1,ib)+phvar%yfr(jj) dyf(1,ib,jj)=dfdy cluster(1:1)=chel(ib) do ss=2,4 if(ss.eq.wb1) then yf(ss,ib)=yf(ss,ib)+phvar%yfr(jj) dyf(ss,ib,jj)=dfdy cluster(ss:ss)=chel(ib) else yf(ss,ia)=yf(ss,ia)+phvar%yfr(jj) dyf(ss,ia,jj)=dfdy cluster(ss:ss)=chel(ia) endif enddo ! call get_constituent_name(iphf,jj,spname,mass) ! write(*,*)'3X cluster: ',cluster,' ',trim(spname),jj wb1=wb1-1 xf(ia)=xf(ia)+0.5D0*phvar%yfr(jj) dxf(ia,jj)=0.5D0*dfdy xf(ib)=xf(ib)+0.5D0*phvar%yfr(jj) dxf(ib,jj)=0.5D0*dfdy ! derivative of pair fraction relative to cluster fractions, 3 AB bonds dqst(1,ia,ib,jj)=4.0d0 enddo jj=jj-1 ! write(*,300)(xf(ss),ss=1,ne) ! write(*,310)((yf(ss,zz),ss=1,4),zz=1,ne) ! write(*,*)'3X done second half AABB: ',jj ! now 4 clusters ABBB, BABB, BBAB, BBBA ! These are 4 clusters ordered ABBB, BABB, BBAB, BBBA wa1=1 do jj=jj+1,jj+4 ! write(*,*)'3X site fractions in cluster: ',jj,phvar%yfr(jj) do ss=1,4 if(ss.eq.wa1) then yf(ss,ia)=yf(ss,ia)+phvar%yfr(jj) dyf(ss,ia,jj)=dfdy cluster(ss:ss)=chel(ia) else yf(ss,ib)=yf(ss,ib)+phvar%yfr(jj) dyf(ss,ib,jj)=dfdy cluster(ss:ss)=chel(ib) endif enddo ! call get_constituent_name(iphf,jj,spname,mass) ! write(*,*)'3X cluster: ',cluster,' ',trim(spname),jj wa1=wa1+1 xf(ia)=xf(ia)+0.25D0*phvar%yfr(jj) dxf(ia,jj)=0.25D0*dfdy xf(ib)=xf(ib)+0.75D0*phvar%yfr(jj) dxf(ib,jj)=0.75D0*dfdy ! derivative of pair fraction relative to cluster fractions, 3 AB bonds dqst(1,ia,ib,jj)=3.0d0 enddo jj=jj-1 ! write(*,300)(xf(ss),ss=1,ne) ! write(*,310)((yf(ss,zz),ss=1,4),zz=1,ne) ! write(*,*)'3X done ABBB: ',jj ! constitent list ! 3 Q01 A1A1A1A ! 4 Q02 A1A1A1B ! 5 Q03 A1A1B1A ! 6 Q04 A1B1A1A ! 7 Q05 B1A1A1A ! 8 Q06 A1A1B1B ! 9 Q07 A1B1A1B ! 10 Q08 A1B1B1A ! 11 Q09 B1A1A1B ! 12 Q10 B1A1B1A ! 13 Q11 B1B1A1A ! 14 Q12 A1B1B1B ! 15 Q13 B1A1B1B ! 16 Q14 B1B1A1B ! 17 Q15 B1B1B1A ! 18 Q16 B1B1B1B ! loop below not active when ne=2 ============================== icloop: do ic=ib+1,ne write(*,*)'3X LRO not implemented for 3 elements' gx%bmperr=4399; goto 1000 ! mijkl(jj-2)=12 ! mijkl(jj-1)=12 ! mijkl(jj)=12 ! jj-2 is A2BC, jj-1 is AB2C, jj is ABC2 ! xf(ia)=xf(ia)+f2*phvar%yfr(jj-2)+f3*phvar%yfr(jj-1)+f3*phvar%yfr(jj) ! xf(ib)=xf(ib)+f3*phvar%yfr(jj-2)+f2*phvar%yfr(jj-1)+f3*phvar%yfr(jj) ! xf(ic)=xf(ic)+f3*phvar%yfr(jj-2)+f3*phvar%yfr(jj-1)+f2*phvar%yfr(jj) ! dxf(ia,jj-2)=f2; dxf(ia,jj-1)=f3; dxf(ia,jj)=f3; ! dxf(ib,jj-2)=f3; dxf(ib,jj-1)=f2; dxf(ib,jj)=f3; ! dxf(ic,jj-2)=f3; dxf(ic,jj-1)=f3; dxf(ic,jj)=f2; idloop: do id=ic+1,ne jj=jj+1 ! mijkl(jj-2)=24 ! jj is ABCD ! xf(ia)=xf(ia)+f3*phvar%yfr(jj) ! xf(ib)=xf(ib)+f3*phvar%yfr(jj) ! xf(ic)=xf(ic)+f3*phvar%yfr(jj) ! xf(id)=xf(id)+f3*phvar%yfr(jj) ! dxf(ia,jj)=f3; dxf(ib,jj)=f3; dxf(ic,jj)=f3; dxf(id,jj)=f3; enddo idloop enddo icloop enddo ibloop enddo ialoop ! debug ! if(sdebug) then write(*,300)(xf(ia),ia=1,ne) do ia=1,ne write(*,290)chel(ia),(dxf(ia,jj),jj=1,8) write(*,291)chel(ia),(dxf(ia,jj),jj=9,16) enddo 290 format('3X dxf "',a,'" 1-8 : ',8F6.3) 291 format('3X dxf "',a,'" 9-16: ',8F6.3) write(*,310)((yf(ss,ia),ss=1,4),ia=1,ne) ! if(sdebug) then do ia=1,ne write(*,270)1,ia,(dyf(1,ia,jj),jj=1,16) write(*,270)2,ia,(dyf(2,ia,jj),jj=1,16) write(*,270)3,ia,(dyf(3,ia,jj),jj=1,16) write(*,270)4,ia,(dyf(4,ia,jj),jj=1,16) enddo 270 format('3X dyf: ',2i2,16F4.1) 280 format('3X dyf: ',2i2,8F6.3) 300 format('3X xf: ',8F6.3) 310 format('3X yf: A: ',4F6.3,' B: ',4F6.3,' C: ',4F6.3) ! endif !============================================== pair fractions allocate(pst(6,ne,ne)) allocate(dpst(6,ne,ne,nc)) allocate(d2pst(6,ne,ne,nc*(nc+1)/2)) pst=zero dpst=zero d2pst=zero zz=0 ploop: do ia=1,ne ! in ternary systems pst(ss,ia,ib) can be different from pst(ib,ia) etc do ib=1,ne ! assume only SRO, all pair frations the same (in a binary) ! pst(1,ia,ib)=xf(ia)*xf(ib) ! pst(2,ia,ib)=pst(1,ia,ib) ! pst(3,ia,ib)=pst(1,ia,ib) ! pst(4,ia,ib)=pst(1,ia,ib) ! pst(5,ia,ib)=pst(1,ia,ib) ! pst(6,ia,ib)=pst(1,ia,ib) pst(1,ia,ib)=yf(1,ia)*yf(2,ib) pst(2,ia,ib)=yf(1,ia)*yf(3,ib) pst(3,ia,ib)=yf(1,ia)*yf(4,ib) pst(4,ia,ib)=yf(2,ia)*yf(3,ib) pst(5,ia,ib)=yf(2,ia)*yf(4,ib) pst(6,ia,ib)=yf(3,ia)*yf(4,ib) ! Taking the average values here improve convergence. But not below 0.4 ... ! p12(ia,ib)=0.5*(yf(1,ia)*yf(2,ib)+yf(2,ia)*yf(1,ib)) ! p13(ia,ib)=0.5*(yf(1,ia)*yf(3,ib)+yf(3,ia)*yf(1,ib)) ! p14(ia,ib)=0.5*(yf(1,ia)*yf(4,ib)+yf(4,ia)*yf(1,ib)) ! p23(ia,ib)=0.5*(yf(2,ia)*yf(3,ib)+yf(3,ia)*yf(2,ib)) ! p24(ia,ib)=0.5*(yf(2,ia)*yf(4,ib)+yf(4,ia)*yf(2,ib)) ! p34(ia,ib)=0.5*(yf(3,ia)*yf(4,ib)+yf(4,ia)*yf(3,ib)) dploop: do jj=1,nc ! when ignoring LRO ! dpst(1,ia,ib,jj)=xf(ia)*dxf(ib,jj)+dxf(ia,jj)*dxf(ib,jj) ! dpst(2,ia,ib,jj)=dpst(1,ia,ib,jj) ! dpst(3,ia,ib,jj)=dpst(1,ia,ib,jj) ! dpst(4,ia,ib,jj)=dpst(1,ia,ib,jj) ! dpst(5,ia,ib,jj)=dpst(1,ia,ib,jj) ! dpst(6,ia,ib,jj)=dpst(1,ia,ib,jj) ! NOTE: Make use of the fact that pstij depend direcly on cluster fractions ! Just using relations to y^s_A fauvours z_AAAA and z_BBBB, i.e. no mixing ! IDEA: Use p_AB = 3z_AAAB + 4z_ABAB + 3z_ABBB ! dp_AB/d_AAAB = 3 etc., calculated above when extracting yf dpst(1,ia,ib,jj)=yf(1,ia)*dyf(2,ib,jj)+dyf(1,ia,jj)*yf(2,ib) dpst(2,ia,ib,jj)=yf(1,ia)*dyf(3,ib,jj)+dyf(1,ia,jj)*yf(3,ib) dpst(3,ia,ib,jj)=yf(1,ia)*dyf(4,ib,jj)+dyf(1,ia,jj)*yf(4,ib) dpst(4,ia,ib,jj)=yf(2,ia)*dyf(3,ib,jj)+dyf(2,ia,jj)*yf(3,ib) dpst(5,ia,ib,jj)=yf(2,ia)*dyf(4,ib,jj)+dyf(2,ia,jj)*yf(4,ib) dpst(6,ia,ib,jj)=yf(3,ia)*dyf(4,ib,jj)+dyf(3,ia,jj)*yf(4,ib) ! using average values ! dp12(ia,ib,jj)=0.5D0*(yf(1,ia)*dyf(2,ib,jj)+dyf(1,ia,jj)*yf(2,ib)+& ! dyf(1,ia,jj)*yf(2,ib)+yf(1,ia)*dyf(2,ib,jj)) ! dp13(ia,ib,jj)=0.5D0*(yf(1,ia)*dyf(3,ib,jj)+dyf(1,ia,jj)*yf(3,ib)+& ! dyf(1,ia,jj)*yf(3,ib)+yf(1,ia)*dyf(3,ib,jj)) ! dp14(ia,ib,jj)=0.5D0*(yf(1,ia)*dyf(4,ib,jj)+dyf(1,ia,jj)*yf(4,ib)+& ! dyf(1,ia,jj)*yf(4,ib)+yf(1,ia)*dyf(4,ib,jj)) ! dp23(ia,ib,jj)=0.5D0*(yf(2,ia)*dyf(3,ib,jj)+dyf(2,ia,jj)*yf(3,ib)+& ! dyf(2,ia,jj)*yf(3,ib)+yf(2,ia)*dyf(3,ib,jj)) ! dp24(ia,ib,jj)=0.5D0*(yf(2,ia)*dyf(4,ib,jj)+dyf(2,ia,jj)*yf(4,ib)+& ! dyf(2,ia,jj)*yf(4,ib)+yf(2,ia)*dyf(4,ib,jj)) ! dp34(ia,ib,jj)=0.5D0*(yf(3,ia)*dyf(4,ib,jj)+dyf(3,ia,jj)*yf(4,ib)+& ! dyf(3,ia,jj)*yf(4,ib)+yf(3,ia)*dyf(4,ib,jj)) ! Hm 2nd derivatives ... should check ... kxsym requires ib>ia ! zz=kxsym(ia,ib) 16*15/2=8*15=4*30=120 ! let second derivatives be zeo cycle dploop do mm=jj,nc zz=kxsym(jj,mm) d2pst(1,ia,ib,zz)=dyf(1,ia,jj)*dyf(2,ib,mm)+& dyf(1,ia,jj)*dyf(2,ib,mm) enddo enddo dploop enddo enddo ploop do ss=1,6 write(*,320)'3X pst:',ss,((pst(ss,ia,ib),ia=1,ne),ib=1,ne) 320 format(a,i2,8F7.4) enddo do ia=1,ne do ib=1,ne write(*,*)'3X pair ',chel(ia),'-',chel(ib) do ss=1,6 write(*,330)'3X dpst 1-8 : ',ss,(dpst(ss,ia,ib,jj),jj=1,8) write(*,330)'3X dpst 9-16: ',ss,(dpst(ss,ia,ib,jj),jj=9,16) enddo enddo enddo 330 format(a,i2,8F7.4) ! ! write(*,*)'3X calculation of pair fractions done' ! gx%bmperr=4399; goto 1000 ! ! Recalculate constituent fractions from the site fractions ! Note the ordering of the constituent important !!! allocate(ylro(nc)) ylro=zero jj=0 do ia=1,ne ! this is AAAA or BBBB etc ybase=yf(1,ia)*yf(2,ia)*yf(3,ia)*yf(4,ia) jj=jj+1 write(*,*)'3X ylro_',chel(ia)//chel(ia)//chel(ia)//chel(ia),& ' from yf(ss,ia): ',jj,ybase ylro(jj)=ybase do ib=ia+1,ne do ss=4,1,-1 jj=jj+1 ! to obtain 4 AAAB replace one yf(ss,ia) with yf(ss,ib) in sublattice ss ! NOTE it has to be in correct order: AAAB, AABA, ABAA and BAAA ylro(jj)=ybase*yf(ss,ib)/yf(ss,ia) enddo ! to obtain the 3 AABB in correct order: AABB, ABAB, ABBA jj=jj+1 ylro(jj)=yf(1,ia)*yf(2,ia)*yf(3,ib)*yf(4,ib) jj=jj+1 ylro(jj)=yf(1,ia)*yf(2,ib)*yf(3,ia)*yf(4,ib) jj=jj+1 ylro(jj)=yf(1,ia)*yf(2,ib)*yf(3,ib)*yf(4,ia) ! to obtain the 3 more variants: BAAB, BABA, BBAA jj=jj+1 ylro(jj)=yf(1,ib)*yf(2,ia)*yf(3,ia)*yf(4,ib) jj=jj+1 ylro(jj)=yf(1,ib)*yf(2,ia)*yf(3,ib)*yf(4,ia) jj=jj+1 ylro(jj)=yf(1,ib)*yf(2,ib)*yf(3,ia)*yf(4,ia) ! to obtain the 4 variants ABBB, similar to AAAB ybase=yf(1,ib)*yf(2,ib)*yf(3,ib)*yf(4,ib) do ss=1,4 jj=jj+1 ! to obtain 4 ABBB replace one yf(ss,ib) with yf(ss,ia) in sublattice ss ! NOTE it has to be in correct order: ABBB, BABB, BBAB and BBBA ylro(jj)=ybase*yf(ss,ia)/yf(ss,ib) enddo ! element C and D ... ! These lines not needed for binary systems ... NOT IMPLEMENTED do ic=ib+1,ne write(*,*)'3X ternary LRO not implemented' gx%bmperr=4399; goto 1000 jj=jj+1 ! ylro(jj)=yrest*phvar%yfr(jj)+ycorr*mijkl(jj)*xf(ia)**2*xf(ib)*xf(ic) ! jj=jj+1 ! ylro(jj)=yrest*phvar%yfr(jj)+ycorr*mijkl(jj)*xf(ia)*xf(ib)**2*xf(ic) ! jj=jj+1 ! ylro(jj)=yrest*phvar%yfr(jj)+ycorr*mijkl(jj)*xf(ia)*xf(ib)*xf(ic)**2 do id=ic+1,ne jj=jj+1 ! ylro(jj)=yrest*phvar%yfr(jj)+& ! ycorr*mijkl(jj)*xf(ia)*xf(ib)*xf(ic)*xf(id) enddo enddo enddo enddo ! ! handle only SRO, set all pst same write(*,'(a,3F10.7)')'3X >>>>>>>>>>>>> only SRO <<<<<<<<<',xf(1),xf(2) do ia=1,ne do ib=1,ne do ss=1,6 pst(ss,ia,ib)=xf(ia)*xf(ib) do jj=1,nc dpst(ss,ia,ib,jj)=dxf(ia,jj)*xf(ib)+xf(ia)*dxf(ib,jj) enddo enddo enddo enddo ! SKIP CORRECTION, then converges with (almost) exactly ideal start values ! pstijtest is maximum pair fraction using mole fractions calculated ! from cluster fractions provided by the minimizer ! if almost the same as previous decrease ycorr if(abs(pstijtest-pstijsave).lt.1.0D-4) then ycorr=max(0.5D0*ycorr,1.0D-8) ! when yrest=1 we use the fractions from the minimizer else ycorr=min(2.0d0*ycorr,0.5D0) endif ycorr=zero yrest=1.0D0-ycorr write(*,'(a,1x,l,1x,12F6.3)')'3X corr: ',sdebug,& pstijtest,pstijsave,yrest,ycorr ! without this stupid dummy statement the calculations does not converge SRO write(dummy,'(a,1x,l,1x,12F6.3)')'3X corr: ',sdebug,& pstijtest,pstijsave,yrest,ycorr ! save pstij for next iteration pstijsave=pstijtest ! We have LRO, fractions on sublattices can be different ! do jj=1,nc ! ylro(jj)=phvar%yfr(jj) ! enddo ! ! if(SDEBUG) then write(*,'(a,8F7.4)')'3X yfr: ',(phvar%yfr(jj),jj=1,8) write(*,'(a,8F7.4)')'3X ylro:',(ylro(jj),jj=1,8) write(*,'(a,8F7.4)')'3X yfr: ',(phvar%yfr(jj),jj=9,nc) write(*,'(a,8F7.4)')'3X ylro:',(ylro(jj),jj=9,16) ! endif ! ! write(*,*)'3X calculation of clusters from site fractions done' ! gx%bmperr=4399; goto 1000 ! ! All necessary fractions and derivatives calculated, now the entropy ! S = -2 \sum_ijkl y_ijkl\ln(y_ijkl) + ! 6 \sum_ij p_ij\ln(p_ij) - 5 \sum_j x_j\ln(x_j) ! As we calculate dG/dT the signs of Kikuchi are inverse ! entropy contribution from the constituent fractions ------------------ ssumy=zero ! sylog1=zero do jj=1,nc ! yfra=phvar%yfr(jj) ! use cluster factions recalculated from site fractions yfra=ylro(jj) if(yfra.lt.bmpymin) yfra=bmpymin if(yfra.gt.one) yfra=one ! yfra is divided by mijkl as it represent mijkl fractions ! ylog=log(yfra/mijkl(jj)) ylog=log(yfra) ! debugging ! if(jj.le.5) ylog1(jj)=ylog ! sylog1=sylog1+yfra*ylog ssumy=ssumy+syfact*yfra*ylog if(moded.gt.0) then ! dgval(1,1:nc,1) are derivative of G/RT wrt fraction 1:nc ! d2gval(ixsym(jj*(jk+1)/2,1) are 2nd derivarive of G/RT wrt fraction jj and jk ! dgval and d2gval are zero before this loop phvar%dgval(1,jj,1)=syfact*(one+ylog) ! ? T and y derivative ! phvar%dgval(2,jj,1)=syfact*(mijkl(jj)+ylog)/tval phvar%dgval(2,jj,1)=syfact*(one+ylog)/tval ! 2nd derivative, each term depend on a single y fraction phvar%d2gval(kxsym(jj,jj),1)=syfact/yfra endif enddo phvar%gval(1,1)=ssumy phvar%gval(2,1)=ssumy/tval ! do jj=1,nc ! use cluster fractions recalculated from site fractions !!! ! phvar%yfr(jj)=ylro(jj) ! enddo write(*,*)'3X calculation of cluster entropy term done',ssumy ! gx%bmperr=4399; goto 1000 ! entropy contributions from the 6 pair fractions ----------------------- ! each can be different pst(ss,ia,ib) can be different for each ss ssump=zero do ia=1,ne do ib=1,ne ssloop: do ss=1,6 ! bond between atom ia and ib in sublattice s,t, there are 6 such paris ! we must repeat this for all 6 pairs in each cluster ! Note this term is negative in the Kikuchi summation !!! pfra=pst(ss,ia,ib) if(pfra.lt.bmpymin) pfra=bmpymin if(pfra.gt.one) pfra=one ylog=log(pfra) ssump=ssump-pfra*ylog if(moded.gt.0) then do jl=1,nc ! we need derivatives of pair fractions wrt constituent fractions ! Note negative sign because this is part of the 6 pln(p) term ! NOTE: Make use of the fact that pstij depend direcly on cluster fractions ! Just using relations to y^s_A fauvours z_AAAA and z_BBBB, i.e. no mixing ! Use p_AB = 3z_AAAB + 4z_ABAB+3z_ABBB ! dp_AB/d_AAAB = 3 etc. if(ia.eq.ib) then phvar%dgval(1,jl,1)=phvar%dgval(1,jl,1)-& dpst(ss,ia,ib,jl)*(one+ylog) else ! this is derivative of AB pair related to clusters with ABBB, ABAB and ABBB phvar%dgval(1,jl,1)=phvar%dgval(1,jl,1)-& dqst(1,ia,ib,jl)*(one+ylog) endif do jm=jl,nc zz=ixsym(jl,jm) phvar%d2gval(zz,1)=phvar%d2gval(zz,1)-& d2pst(ss,ia,ib,zz)*(one+ylog)+& dpst(ss,ia,ib,jl)*dpst(ss,ia,ib,jm)/pst(ss,ia,ib) enddo enddo endif enddo ssloop ! done all 6 pairs for ia,ib enddo enddo ! done all pairs ia,ib ! We have changed the sign when we calculate 6*p*ln(p) terms above ! The derivatives have the negative sign already phvar%gval(1,1)=phvar%gval(1,1)+ssump phvar%gval(2,1)=phvar%gval(2,1)+ssump/tval write(*,*)'3X calculation of 6 pair fractions entropy term done',ssump ! entropy contributions from the site fractions, factor 5/4 = 1.25 ssumx=zero ! sylog3=zero do ss=1,4 do ia=1,ne ! we need derivatives of mole fractions wrt constituent fractions pfra=yf(ss,ia) if(pfra.lt.bmpymin) pfra=bmpymin if(pfra.gt.one) pfra=one ylog=log(pfra) ssumx=ssumx+sxfact*pfra*ylog if(moded.gt.0) then do jl=1,nc ! we need derivatives of site fractions wrt constituent fractions phvar%dgval(1,jl,1)=phvar%dgval(1,jl,1)+& sxfact*dyf(ss,ia,jl)*(ylog+one) do jm=jl,nc ! note d2xf/dyidyj==0 zz=kxsym(jl,jm) phvar%d2gval(zz,1)=phvar%d2gval(zz,1)+& sxfact*dyf(ss,ia,jl)*dyf(ss,ia,jm)/pfra enddo enddo endif enddo enddo ! the sxfact +5/4 is already included above phvar%gval(1,1)=phvar%gval(1,1)+ssumx phvar%gval(2,1)=phvar%gval(2,1)+ssumx/tval write(*,'(a,F12.4)')'3X calculation of site fraction entropy: ',ssumx ! write(*,*)'3X all entropy calculations made' ! All done ! if(SDEBUG) then write(*,900)'3X xf: ',(xf(ia),ia=1,ne) 900 format(a,6F10.7) do ss=1,6 write(*,320)'3X pst',ss,((pst(ss,ia,ib),ia=1,ne),ib=1,ne) enddo 910 format(a,10F7.3) write(*,310)((yf(ss,ia),ss=1,4),ia=1,ne) do ia=1,ne write(*,270)1,ia,(dyf(1,ia,jj),jj=1,16) write(*,270)2,ia,(dyf(2,ia,jj),jj=1,16) write(*,270)3,ia,(dyf(3,ia,jj),jj=1,16) write(*,270)4,ia,(dyf(4,ia,jj),jj=1,16) enddo write(*,'(a,8F7.4)')'3X yfr 1-8: ',(phvar%yfr(jj),jj=1,8) write(*,'(a,8F7.4)')'3X ylro 1-8: ',(ylro(jj),jj=1,8) write(*,'(a,8F7.4)')'3X yfr 9-16:',(phvar%yfr(jj),jj=9,nc) write(*,'(a,8F7.4)')'3X ylro 9-16:',(ylro(jj),jj=9,16) write(*,'(a,5(1pe12.4))')'3X cvmtfs: ',ssumy,ssump,ssumx,& phvar%gval(1,1),8.31451*phvar%gval(1,1) ! write(*,*)'3X cvmtfs model not yet released' ! endif 1000 continue return end subroutine config_entropy_cvmtfl !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine config_entropy_i2sl !\begin{verbatim} subroutine config_entropy_i2sl(moded,nsl,nkl,phvar,i2slx,tval) ! calculates configurational entropy/R for ionic liquid model ! Always 2 sublattices, the sites depend on composition ! P = \sum_j (-v_j) y_j + Q y_Va ! Q = \sum_i v_i y_i ! where v is the charge on the ions. P and Q calculated by set_constitution implicit none integer moded,nsl,i2slx(2) integer, dimension(nsl) :: nkl TYPE(gtp_phase_varres), pointer :: phvar !\end{verbatim} integer ll,kk,kall,nk,j1,j2,jxsym double precision tval,ss,yfra,ylog,yva,spart(2) ll=0 kall=0 spart=zero yva=zero sublatticeloop: do while (ll.lt.nsl) ll=ll+1 nk=nkl(ll) kk=0 ss=zero fractionloop: do while (kk.lt.nk) kk=kk+1 kall=kall+1 ! no cycle as we may need values of spart and yva ... ! if(nk.eq.1) cycle sublatticeloop yfra=phvar%yfr(kall) if(yfra.lt.bmpymin) yfra=bmpymin if(yfra.gt.one) yfra=one ! save current value of vacancy fraction if(kall.eq.i2slx(1)) yva=yfra ! write(*,2)'3X yva: ',kall,i2slx(1),yva,yfra !2 format(a,2i3,6(1pe12.4)) ylog=log(yfra) ! gval(1:6,1) are G and derivator wrt T and P ! dgval(1,1:N,1) are derivatives of G wrt fraction 1:N ! dgval(2,1:N,1) are derivatives of G wrt fraction 1:N and T ! dgval(3,1:N,1) are derivatives of G wrt fraction 1:N and P ! d2dval(ixsym(N*(N+1)/2),1) are derivatives of G wrt fractions N and M ! this is a symmetric matrix and index givem by ixsym(M,N) ss=ss+yfra*ylog if(moded.gt.0) then phvar%dgval(1,kall,1)=phvar%sites(ll)*(one+ylog) ! phvar%d2gval(ixsym(kall,kall),1)=phvar%sites(ll)/yfra phvar%d2gval(kxsym(kall,kall),1)=phvar%sites(ll)/yfra endif enddo fractionloop phvar%gval(1,1)=phvar%gval(1,1)+phvar%sites(ll)*ss if(ll.eq.1) then spart(1)=ss else spart(2)=ss endif enddo sublatticeloop if(moded.eq.0) goto 900 ! convergence problem with ionic liquid, skip contribution to 2nd derivatuves ! localmoded=moded ! if(moded.eq.2) localmoded=1 ! write(*,*)'3X ionic config_entropy: ',i2slx,kall ! additional derivatives as sublattice sites depend on composition ! -------------------------- derivatives of config entropy ! S = P*S1 + Q*S2 ! S1 = \sum_i y_i*ln(y_i) ! S2 = \sum_j y_j*ln(y_j)+y_Va*ln(y_Va)+\sum_k y_k*ln(Y_k)) ! P = \sum_j (-v_j)*y_j + Q*y_Va ! Q = \sum_i v_i*y_i ! term within [...] already calculated as part of normal config.entropy ! dS/dy_i = +v_i*S2 + v_i*y_Va*S1 + [P*(1+ln(y_i)] ..cation OK ! dS/dy_j = -v_j*S1 + [Q*(1+ln(y_j))] ..anion OK ! dS/dy_Va = Q*S1 + [Q*(1+ln(y_Va))] ..Va OK ! dS/dy_k = [Q*(1+ln(y_k)] ..neutral OK ! d2S/dy_i1dy_i2 = v_i1*y_Va*(1+ln(y_i2) + v_i2*y_Va*(1+ln(y_i1) + ! [P*(1/y_i1**2)] ..last term zero unless i1=i2 OK ! d2S/dy_idy_j = v_i*(1+ln(y_j)) + (-v_j)*(1+ln(y_i)) OK ! d2S/dy_idy_Va = v_i*(1+ln(y_Va)) + v_i*S1 + Q*(1+ln(y_i)) OK ! d2S/dy_idy_k = v_i*(1+ln(y_k)) OK ! d2S/dy_j1d_j2 = [only Q/y**2 if j1=j2] OK ! d2S/dy_jdy_Va = zero OK ! d2S/dy_jdy_k = zero OK ! d2S/dy_Va2 = [only Q/y_Va**2] OK ! d2S/dy_Vady_k = zero OK ! d2S/dy_k1dy_k2 = [only Q/y_k1**2 if k1=k2] OK ! ---------------------- ! the coding is not optimal for speed, all the 1/y**2 term calculated above ! i2slx(1) is index of vacancy, i2slx(2) is index of first neutral ! if either (or both) are missing their index is higher than last constituent ! write(*,102)'3X va+neutral: ',i2slx !102 format(a,10i3) ! dpqdy is calculated in gtp3X: set_constitution ?? ! write(*,108)'3X dpqdy: ',(phvar%dpqdy(j1),j1=1,nkl(1)+nkl(2)) 108 format(a,10F7.3) cation: do j1=1,nkl(1) ! to avoid calling ixsym ... jxsym=kxsym(j1,j1) cation2: do j2=j1,nkl(1) ! d2S/dy_i1dy_i2 = v_i1*y_Va*(1+ln(y_i2) + v_i2*y_Va*(1+ln(y_i1) + ! [P*(1/y_i1**2)] ..last term already calculated OK if(ixsym(j1,j2).ne.jxsym) then ! this ixsym test works and has run of few 1000 times, removed for speed!! write(*,*)'3X ISYM error 5',j1,j2,ixsym(j1,j2),jxsym stop "3X ixsym indexing error 17" endif ! phvar%d2gval(ixsym(j1,j2),1)=phvar%d2gval(ixsym(j1,j2),1)+& ! (phvar%dpqdy(j1)*phvar%dgval(1,j2,1)+& ! phvar%dpqdy(j2)*phvar%dgval(1,j1,1))*yva/phvar%sites(1) phvar%d2gval(jxsym,1)=phvar%d2gval(jxsym,1)+& (phvar%dpqdy(j1)*phvar%dgval(1,j2,1)+& phvar%dpqdy(j2)*phvar%dgval(1,j1,1))*yva/phvar%sites(1) jxsym=jxsym+j2 enddo cation2 anion2: do kk=1,nkl(2) j2=nkl(1)+kk jxsym=kxsym(j1,j2) if(j2.lt.min(i2slx(1),i2slx(2))) then ! d2S/dy_idy_j = v_i*(1+ln(y_j)) + (-v_j)*(1+ln(y_i)) ...cation+anion OK ! phvar%d2gval(ixsym(j1,j2),1)=& ! phvar%dpqdy(j1)*phvar%dgval(1,j2,1)/phvar%sites(2)+& ! phvar%dpqdy(j2)*phvar%dgval(1,j1,1)/phvar%sites(1) phvar%d2gval(jxsym,1)=& phvar%dpqdy(j1)*phvar%dgval(1,j2,1)/phvar%sites(2)+& phvar%dpqdy(j2)*phvar%dgval(1,j1,1)/phvar%sites(1) elseif(j2.eq.i2slx(1)) then ! d2S/dy_idy_Va = v_i*(1+ln(y_Va)) + v_i*S1 + Q*(1+ln(y_i)) ...cation+Va OK ! phvar%d2gval(ixsym(j1,j2),1)=& ! phvar%dpqdy(j1)*phvar%dgval(1,j2,1)/phvar%sites(2)+& ! phvar%dpqdy(j1)*spart(1)+& ! phvar%sites(2)*phvar%dgval(1,j1,1)/phvar%sites(1) phvar%d2gval(jxsym,1)=& phvar%dpqdy(j1)*phvar%dgval(1,j2,1)/phvar%sites(2)+& phvar%dpqdy(j1)*spart(1)+& phvar%sites(2)*phvar%dgval(1,j1,1)/phvar%sites(1) else ! d2S/dy_idy_k = v_i*(1+ln(y_k)) ...cation+neutral OK ! write(*,107)'3X i,va: ',j1,j2,phvar%dpqdy(j1),phvar%dgval(1,j2,1),& ! phvar%sites(2) !107 format(a,2i2,6(1pe12.4)) ! phvar%d2gval(ixsym(j1,j2),1)=& ! phvar%dpqdy(j1)*phvar%dgval(1,j2,1)/phvar%sites(2) phvar%d2gval(jxsym,1)=& phvar%dpqdy(j1)*phvar%dgval(1,j2,1)/phvar%sites(2) endif enddo anion2 109 continue ! this done at the end as original dgval(1,j1,1)=P*(1+ln(y_j1))/P used above ! dS/dy_i = +v_i*S2 + v_i*y_Va*S1 + [P*(1+ln(y_i)] ..cation OK ! write(*,19)'3X c: ',j1,phvar%dgval(1,j1,1),& ! phvar%dpqdy(j1),spart(2),phvar%dpqdy(j1),yva,spart(1) !19 format(a,i3,6(1pe12.4)) phvar%dgval(1,j1,1)=phvar%dgval(1,j1,1)+& phvar%dpqdy(j1)*spart(2)+phvar%dpqdy(j1)*yva*spart(1) enddo cation ! this done separately as original dgval(1,j2,1)=Q*(1+ln(y_j2))/Q used above ! kall here should be total number of constituents anion1: do j2=nkl(1)+1,min(i2slx(1),kall) if(j2.lt.min(i2slx(1),i2slx(2))) then ! dS/dy_j = -v_j*S1 + [Q*(1+ln(y_j))] ..anion OK ! write(*,*)'3X anion1 A: ',j2 phvar%dgval(1,j2,1)=phvar%dgval(1,j2,1)+phvar%dpqdy(j2)*spart(1) elseif(j2.eq.i2slx(1)) then ! dS/dy_Va = Q*S1 + [Q*(1+ln(y_Va))] ..Va OK ! write(*,*)'3X anion1 B: ',j2 phvar%dgval(1,j2,1)=phvar%dgval(1,j2,1)+phvar%sites(2)*spart(1) ! else ! dS/dy_k = nothing + [Q*(1+ln(y_k)] ..neutral OK endif ! write(*,*)'3X anion1 C: ',j2 enddo anion1 ! set temperature derivative of dG/dy do j1=1,kall phvar%dgval(2,j1,1)=phvar%dgval(1,j1,1)/tval enddo 900 continue ! phvar%gval(1,1)=phvar%gval(1,1)+phvar%sites(ll)*ss ! write(*,905)'3X parts: ',phvar%gval(1,1),phvar%sites,spart !905 format(a,6(1pe12.4)) ! set temperature derivative of G phvar%gval(2,1)=phvar%gval(1,1)/tval 1000 continue return end subroutine config_entropy_i2sl !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine config_entropy_qcwithlro !\begin{verbatim} subroutine config_entropy_qcwithlro(moded,ncon,phvar,phrec,tval) ! ! calculates configurational entropy/R for the quasichemial liquid with LRO ! ! moded=0 only G, =1 G and dG/dy, =2 G, dG/dy and d2G/dy1/dy2 ! ncon is number of constituents ! phvar is pointer to phase_varres record ! phrec is the phase record ! tval is current value of T implicit none integer moded,ncon TYPE(gtp_phase_varres), pointer :: phvar TYPE(gtp_phaserecord) :: phrec double precision tval !\end{verbatim} %+ ! First A=(z/2)*(\sum_i (y_ii*ln(y_ii) + \sum_(j>=i) y_ij*ln(y_ij/2)) ! and calculate all x_i = y_ii + \sum_j a/(a+b)*y_ij ! Then calculate the SRO: q_ij=(y_ij/(x_i*x_j)-1)*(x_i+x_j)**2 ! and B=\sum_i x_i*ln(x_i)*(1-z + \sum_(j>i) (z/2-1)*f(q_ij)) ! -S = A+B integer icon,loksp,lokel,iel,nqij,kqij,jxsym,infirst,lat2,i,j double precision zhalf,yfra,ylog,cluster,sbonds,scorr,stoi1,stoi2 double precision xp,xs,gamma,x1,x2,sumx(2),gamma2 double precision, allocatable, dimension(:) :: qij,ycluster,& dgamma,d2gamma double precision, allocatable, dimension(:,:) :: xval double precision, allocatable, dimension(:,:,:) :: dxval integer, allocatable, dimension(:,:) :: qxij logical iscluster double precision, parameter :: half=0.5D0 ! zhalf=half*phvar%qcbonds allocate(xval(noofel,2)) allocate(dxval(noofel,ncon,2)) ! allocate(ycluster(noofel)) xval=zero dxval=zero ! write(*,*)'3X classical qc with LRO!',zhalf ! gx%bmperr=4399; goto 1000 ! sbonds=zero nqij=0 sumx=zero ally: do icon=1,ncon yfra=phvar%yfr(icon) if(yfra.lt.bmpymin) yfra=bmpymin if(yfra.gt.one) yfra=one ! loksp is set to the index of the constituent in the species array loksp=phrec%constitlist(icon) ! if two elements it is an AB bond ! To identify if the cluster constituent is on the first or second sublattice ! use the alphabetical order of the species name. If first letter=i) y_ij*ln(y_ij/2)) ! and calculate all x_i = y_ii + \sum_j a/(a+b)*y_ij ! Then calculate the SRO: q_ij=(y_ij/(x_i*x_j)-1)*(x_i+x_j)**2 ! and B=\sum_i x_i*ln(x_i)*(1-z + \sum_(j>i) (z/2-1)*f(q_ij)) ! -S = A+B integer icon,loksp,lokel,iel,nqij,kqij,jxsym double precision zhalf,yfra,ylog,cluster,sbonds,scorr,stoi1,stoi2 double precision xp,xs,gamma,x1,x2 double precision, allocatable, dimension(:) :: xval,qij,ycluster,& dgamma,d2gamma double precision, allocatable, dimension(:,:) :: dxval,dqij integer, allocatable, dimension(:,:) :: qxij logical iscluster double precision, parameter :: half=0.5D0 ! ! qcmodel=1 is classical qc without LRO, 2 is q**2, 3 is 0.5*(1+q)*q**2 ! qcmodel=1 ! zhalf=half*phvar%qcbonds write(*,*)'3X classic cqc, zhalf: ',zhalf allocate(xval(noofel)) allocate(dxval(noofel,ncon)) ! allocate(ycluster(noofel)) xval=zero dxval=zero ! write(*,*)'3X classical quasichemical!',zhalf ! sbonds=zero nqij=0 do icon=1,ncon yfra=phvar%yfr(icon) if(yfra.lt.bmpymin) yfra=bmpymin if(yfra.gt.one) yfra=one ! if set the constituent is a binary cluster if(btest(phvar%constat(icon),CONQCBOND)) then cluster=half iscluster=.TRUE. ! write(*,*)'3X CQC classic 0: ',qcmodel,iscluster,yfra else cluster=one iscluster=.FALSE. endif ! entropy is y*ln(y) for single atoms, y*ln(y/2) for clusters ylog=log(cluster*yfra) ! gval(1:6,1) are G and derivator wrt T and P ! dgval(1,1:N,1) are derivatives of G wrt fraction 1:N ! dgval(2,1:N,1) are derivatives of G wrt fraction 1:N and T ! dgval(3,1:N,1) are derivatives of G wrt fraction 1:N and P ! d2dval(ixsym(N*(N+1)/2),1) are derivatives of G wrt fractions N and M ! this is a symmetric matrix and index givem by ixsym(M,N) sbonds=sbonds+zhalf*yfra*ylog if(moded.gt.0) then phvar%dgval(1,icon,1)=zhalf*(one+ylog) ! phvar%d2gval(ixsym(icon,icon),1)=zhalf/(yfra) phvar%d2gval(kxsym(icon,icon),1)=zhalf/(yfra) ! These should be the correct derivatives but with these it does not converge!! ! phvar%dgval(1,icon,1)=zhalf*(one/cluster+ylog) ! phvar%d2gval(ixsym(icon,icon),1)=zhalf/(cluster*yfra) ! DO NOT CHANGE ANYTHING!! endif ! loksp is set to the index of the species array loksp=phrec%constitlist(icon) lokel=splista(loksp)%ellinks(1) ! if(btest(phvar%constat(icon),CONQCBOND)) then if(iscluster) then nqij=nqij+1 ! ycluster(nqij)=yfra ! if a bond cluster there must be two elements ! lokel is index in ellista of first element, iel is its alphabetical index iel=ellista(lokel)%alphaindex stoi1=splista(loksp)%stoichiometry(1) stoi2=splista(loksp)%stoichiometry(2) xval(iel)=xval(iel)+stoi1/(stoi1+stoi2)*yfra dxval(iel,icon)=stoi1/(stoi1+stoi2) ! write(*,60)'3X qc 3A: ',iel,xval(iel),yfra lokel=splista(loksp)%ellinks(2) iel=ellista(lokel)%alphaindex xval(iel)=xval(iel)+stoi2/(stoi1+stoi2)*yfra dxval(iel,icon)=stoi2/(stoi1+stoi2) ! write(*,60)'3X qc 3B: ',iel,xval(iel),yfra else lokel=splista(loksp)%ellinks(1) iel=ellista(lokel)%alphaindex xval(iel)=xval(iel)+yfra dxval(iel,icon)=one ! write(*,60)'3X qc 3C: ',iel,xval(iel),yfra endif enddo !---------------------------------------- ! We do not need qij = y_ij/(2x_ix_j) - 1 ! The correction term is composition independent 1-z gamma=one-2.0D0*zhalf ! Some elements may not be dissolved in this phase ?? scorr=zero do iel=1,noofel yfra=xval(iel) if(yfra.le.bmpymin) yfra=bmpymin if(yfra.gt.one) yfra=one ylog=log(yfra) scorr=scorr+yfra*ylog ! WE MUST ALSO CALCULATE DERIVATIVES OF x_i USING CHAIN RULE ! DO NOT CHANGE ANYTHING!! if(moded.gt.0) then do icon=1,ncon phvar%dgval(1,icon,1)=phvar%dgval(1,icon,1)+& gamma*(one+ylog)*dxval(iel,icon) jxsym=kxsym(icon,icon) do loksp=icon,ncon ! phvar%d2gval(ixsym(icon,loksp),1)=& ! phvar%d2gval(ixsym(icon,loksp),1)+& ! gamma*dxval(iel,icon)*dxval(iel,loksp)/yfra if(ixsym(icon,loksp).ne.jxsym) then ! this ixsym test works and has run of few 1000 times, removed for speed!! write(*,*)'3X ISYM error 18',ixsym(icon,loksp),jxsym stop endif phvar%d2gval(jxsym,1)=& phvar%d2gval(jxsym,1)+& gamma*dxval(iel,icon)*dxval(iel,loksp)/yfra jxsym=jxsym+loksp enddo enddo endif enddo !- ixsym --------------- ixsym end modification ! now all is calculated gval(1,1)=G; gval(2,1)=S etc ! DO NOT CHANGE ANYTHING!! phvar%gval(1,1)=sbonds+gamma*scorr phvar%gval(2,1)=(sbonds+gamma*scorr)/tval write(*,12)'3X QC1: ',qcmodel,phvar%gval(1,1),phvar%gval(2,1),gamma,& zhalf,sbonds,scorr 12 format(a,i2,6(1pe11.3)) ! ! THIS ROUTINE NOT USED !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 1000 continue return end subroutine config_entropy_cqc_classicqc !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine config_entropy_qchillert !\begin{verbatim} subroutine config_entropy_qchillert(moded,ncon,phvar,phrec,tval) ! ! calculates configurational entropy/R for the corrected quasichemial liquid ! Hillert-Selleby-Sundman ! Rewritten 2019-01-12 based on cqc-classicqc which seems correct ! test1: qcmodel=1: OK for zhalf=1 and 3 ! test2: qcmodel=2: OK!! ! test3: qcmodel=3: OK for SRO, problmens for miscibility gap ! ! only question is the parameter, value of G = K*T*R/2; ! K=-10, T=600 means G= -10*600*R/2 = -3000*R gives same curves as in paper. ! ! moded=0 only G, =1 G and dG/dy, =2 G, dG/dy and d2G/dy1/dy2 ! ncon is number of constituents ! phvar is pointer to phase_varres record ! phrec is the phase record ! tval is current value of T implicit none integer moded,ncon TYPE(gtp_phase_varres), pointer :: phvar TYPE(gtp_phaserecord) :: phrec double precision tval !\end{verbatim} ! First A=(z/2)*(\sum_i (y_ii*ln(y_ii) + \sum_(j>=i) y_ij*ln(y_ij/2)) ! and calculate all x_i = y_ii + \sum_j (a_i/(a_1+a_j))*y_ij ! and calculate all x_j = y_jj + \sum_i (a_j/(a_1+a_j))*y_ij ! dx_i/dy_ii =1; dx_i/dy_ij = a_i/(a_i+a_j); dx_i/dy_jj =0 ! Then calculate normallized sro= q_ij=(y_ij/(x_i*x_j)-1)*(x_i+x_j)**2 ! gcmodel=1 : gamma = -(1-z) ! gcmodel=2 : gamma = -(1-z -(z/2-1)*sro**2) ! gamma is multiplied with B: ! and B=\sum_i x_i*ln(x_i) ! -S = dG/dT = A+gamma*B integer icon,loksp,lokel,iel,nqij,kqij,jcon,kcon,maxc double precision zhalf,yfra,ylog,cluster,sbonds,scorr,stoi1,stoi2,temp1 double precision xp,xs,gamma,x1,x2,sij,xnorm1,xnorm2,xprod double precision, allocatable, dimension(:) :: xval,qij,ycluster,& dgamma,d2gamma,sqz double precision, allocatable, dimension(:,:) :: dxval,dqij,d2qij integer, allocatable, dimension(:,:) :: qxij,jel integer, allocatable, dimension(:) :: jcluster logical iscluster double precision, parameter :: half=0.5D0 ! ! qcmodel=1 is classical qc without LRO, 2 is q**2, 3 is 0.5*(1+q)*q**2 ! qcmodel=1 ! gcmodel=2 ! gcmodel=3 ! zhalf=half*phvar%qcbonds ! ncon is number of constituents, noofel number of elements write(*,'(a,i2,F8.3,10i4)')'3X cqc6 start: ',qcmodel,zhalf,ncon,noofel allocate(xval(noofel)) allocate(dxval(noofel,ncon)) ! max antal binary cluster maxc=ncon*(ncon-1)/2 allocate(ycluster(maxc)) allocate(sqz(maxc)) allocate(jel(maxc,2)) ! this is used to indicate constituent index of a cluster allocate(jcluster(maxc)) xval=zero dxval=zero sqz=zero ! write(*,*)'3X classical quasichemical!',zhalf ! ! STEP 1: entropy for clusters sbonds=zero nqij=0 scluster: do icon=1,ncon yfra=phvar%yfr(icon) if(yfra.lt.bmpymin) yfra=bmpymin if(yfra.gt.one) yfra=one ! if set the constituent is a binary cluster if(btest(phvar%constat(icon),CONQCBOND)) then cluster=half iscluster=.TRUE. ! write(*,*)'3X CQC classic 0: ',qcmodel,iscluster,yfra else cluster=one iscluster=.FALSE. endif ! entropy is y*ln(y) for single atoms, y*ln(y/2) for clusters ylog=log(cluster*yfra) ! gval(1:6,1) are G, dG/dT, dG/dP, d2G/dT2, d2G/dTdP and d2G/dP2 ! dgval(1,1:N,1) are derivatives of G wrt fraction 1:N ! dgval(2,1:N,1) are derivatives of G wrt fraction 1:N and T ! dgval(3,1:N,1) are derivatives of G wrt fraction 1:N and P ! d2dval(ixsym(N*(N+1)/2),1) are derivatives of G wrt fractions N and M ! this is a symmetric matrix and index givem by ixsym(M,N) sbonds=sbonds+zhalf*yfra*ylog if(moded.gt.0) then ! first and second derivatives for \sum_i y_ii\ln(y_ii)+y_ij\ln(y_ij/2) phvar%dgval(1,icon,1)=zhalf*(one+ylog) phvar%d2gval(ixsym(icon,icon),1)=zhalf/(yfra) endif ! we have to calculate the mole fractions for the correction term ! loksp is set to the index of the species array loksp=phrec%constitlist(icon) lokel=splista(loksp)%ellinks(1) ! if(btest(phvar%constat(icon),CONQCBOND)) then if(iscluster) then nqij=nqij+1 ycluster(nqij)=yfra jcluster(nqij)=icon ! if a bond cluster there must be two elements ! lokel is index in ellista of first element, iel is its alphabetical index iel=ellista(lokel)%alphaindex stoi1=splista(loksp)%stoichiometry(1) stoi2=splista(loksp)%stoichiometry(2) xval(iel)=xval(iel)+stoi1/(stoi1+stoi2)*yfra dxval(iel,icon)=stoi1/(stoi1+stoi2) ! sqz=1 for equiatomic ordering sqz(nqij)=0.125/(stoi1*stoi2) jel(nqij,1)=iel ! write(*,60)'3X qc 3A: ',iel,xval(iel),yfra lokel=splista(loksp)%ellinks(2) iel=ellista(lokel)%alphaindex xval(iel)=xval(iel)+stoi2/(stoi1+stoi2)*yfra dxval(iel,icon)=stoi2/(stoi1+stoi2) jel(nqij,2)=iel ! write(*,60)'3X qc 3B: ',iel,xval(iel),yfra else lokel=splista(loksp)%ellinks(1) iel=ellista(lokel)%alphaindex xval(iel)=xval(iel)+yfra dxval(iel,icon)=one ! write(*,60)'3X qc 3C: ',iel,xval(iel),yfra endif enddo scluster ! check mole fractions sum up to unity xs=zero do icon=1,noofel xs=xs+xval(icon) enddo if(abs(xs-one).gt.1.0D-12) then write(*,*)'3X cqc6: sum of molefractions not unity: ',xs stop endif !---------------------------------------- ! step 2: correction factor gamma ! NOTE sign opposite eq. 11 as this is dG/dy = -S if(qcmodel.eq.1) then ! classic: composition independent gamma: 1-z gamma=one-2.0D0*zhalf else ! write(*,*)'3X qcmodel: ',qcmodel,nqij,maxc ! we must calculate the SRO for each cluster ij (more than one cluster!) ! s_ij = 0.5 y_ij - x_ix_j/(x_i+x_j)**2 ! q_ij= s_ij/x_ix_j ! and we can have ordering at other composition than equiatoic!! allocate(dgamma(ncon)) allocate(d2gamma(ncon*(ncon+1)/2)) allocate(qij(nqij)) allocate(dqij(nqij,ncon)) allocate(d2qij(nqij,ncon*(ncon+1)/2)) gamma=one-2.0D0*zhalf ! write(*,*)'3X loop to calculate gamma' gammaloop: do icon=1,nqij ! jel(icon,k) is element k in cluster icon xnorm1=xval(jel(icon,1))/(xval(jel(icon,1))+xval(jel(icon,2))) xnorm2=xval(jel(icon,2))/(xval(jel(icon,1))+xval(jel(icon,2))) xprod=xnorm1*xnorm2 ! NOTE p_AB is 0.5y_AB ! sij=0.5D0*ycluster(icon)/xprod sij=sqz(icon)*ycluster(icon)/xprod ! This is the variable "q" defined by eq. 9 in the 2009 paper ! qij(icon)=0.5D0*ycluster(icon)/xprod-one qij(icon)=sij-one do jcon=1,ncon ! first derivatives of qij with respect to y_ij temp1=zero if(jcluster(icon).eq.jcon) temp1=sqz(icon)/xprod temp1=temp1-sij*(dxval(jel(icon,1),jcon)/xval(jel(icon,1))-& dxval(jel(icon,2),jcon)/xval(jel(icon,2))) dqij(icon,jcon)=temp1 ! ignore 2nd derivatives ... ??? do kcon=jcon,ncon d2qij(icon,ixsym(icon,jcon))=zero enddo enddo if(qcmodel.eq.2) then ! this is the correction factor gamma=gamma+(zhalf-one)*qij(icon)**2 do jcon=1,ncon ! THIS LINE WAS MISSING!!! works (almost) dgamma(jcon)=2.0D0*(zhalf-one)*qij(icon)*dqij(icon,jcon) do kcon=jcon,ncon ! this is approximate, no d2qij.... d2gamma(ixsym(jcon,kcon))=2.0D0*(zhalf-one)*& dqij(icon,kcon)*dqij(icon,jcon) enddo enddo elseif(qcmodel.eq.3) then ! this is the correction factor for qcmodel=3 gamma=gamma+0.5D0*(zhalf-one)*(qij(icon)+one)*qij(icon)**2 ! write(*,*)'3X qcmodel=3: ',icon,phvar%phtupx,qij(icon),gamma do jcon=1,ncon dgamma(jcon)=(zhalf-one)*qij(icon)*& (1.5D0*qij(icon)+one)*dqij(icon,jcon) do kcon=jcon,ncon ! this is approximate, no d2qij.... d2gamma(ixsym(jcon,kcon))=0.5D0*(zhalf-one)*& (6.0D0*qij(icon)*dqij(icon,kcon)*dqij(icon,jcon)+& (3*qij(icon)+one)*d2qij(icon,ixsym(jcon,kcon))) enddo enddo else write(*,*)'3X no such qcmodel: ',qcmodel endif enddo gammaloop endif ! write(*,*)'3X qcmodel',qcmodel,gamma !---------------------------------------- ! Step 3: entropy for molefractions: scorr=\sum_i x_i ln(x_i) scorr=zero ! write(*,'(a,4(1pe12.4))')'3X loop scorr',sbonds,gamma,sqz smol: do iel=1,noofel yfra=xval(iel) if(yfra.le.bmpymin) yfra=bmpymin if(yfra.gt.one) yfra=one ylog=log(yfra) scorr=scorr+yfra*ylog ! WE MUST ALSO CALCULATE DERIVATIVES OF x_i, dx_i/dy_j USING CHAIN RULE ! at present ignore derivatives of gamma .... if(moded.gt.0) then do icon=1,ncon phvar%dgval(1,icon,1)=phvar%dgval(1,icon,1)+& gamma*(one+ylog)*dxval(iel,icon) ! derivative wrt T and icon phvar%dgval(2,icon,1)=phvar%dgval(2,icon,1)+& gamma*(one+ylog)*dxval(iel,icon)/tval do jcon=icon,ncon phvar%d2gval(ixsym(icon,jcon),1)=& phvar%d2gval(ixsym(icon,jcon),1)+& gamma*dxval(iel,icon)*dxval(iel,jcon)/yfra enddo enddo endif enddo smol ! write(*,*)'3X all done, save values in phvar' ! subtract the correction which depend on qcmodel ! now all is calculated gval(1,1)=G; gval(2,1)=S etc ! Second derivates for \usm_i y_i\ln(y_i) calculated above phvar%gval(1,1)=sbonds+gamma*scorr phvar%gval(2,1)=(sbonds+gamma*scorr)/tval if(qcmodel.gt.1) then ! include derivatives of gamma do icon=1,ncon phvar%dgval(1,icon,1)=phvar%dgval(1,icon,1)+dgamma(icon)*scorr phvar%dgval(2,icon,1)=phvar%dgval(2,icon,1)+dgamma(icon)*scorr/tval do jcon=icon,ncon ! approximate .... phvar%d2gval(ixsym(icon,jcon),1)=phvar%d2gval(ixsym(icon,jcon),1)+& d2gamma(ixsym(icon,jcon))*scorr enddo enddo endif ! ! write(*,12)'3X cqc6: ',qcmodel,sbonds,gamma,scorr,& ! phvar%gval(1,1),phvar%gval(2,1) 12 format(a,i2,6(1pe11.3)) ! 1000 continue return end subroutine config_entropy_qchillert !gamma, dgamma, d2gamma !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine config_entropy_cvmce !\begin{verbatim} subroutine config_entropy_cvmce(moded,ncon,phvar,phrec,tval) ! ! calculates the classical QC and CVM models sith LRO ! started 2021-02-17 ! ! moded=0 only G, =1 G and dG/dy, =2 G, dG/dy and d2G/dy1/dy2 ! ncon is number of constituents ! phvar is pointer to phase_varres record ! phrec is the phase record ! tval is current value of T implicit none integer moded,ncon TYPE(gtp_phase_varres), pointer :: phvar TYPE(gtp_phaserecord) :: phrec double precision tval !\end{verbatim} !---------------------------------------------------------------------------1 write(*,*)'3X classical QC model with LRO, not implemented yet' ! S = - \sum_i y_i ln(y_i) + z/2 \sum_k x_k ln(x_k) gx%bmperr=4399 1000 continue return end subroutine config_entropy_cvmce !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine config_entropy_tisr !\begin{verbatim} subroutine config_entropy_tisr(moded,ncon,phvar,phrec,tval) ! ! calculates configurational entropy/R for the Kremer liquid SRO model ! started 2021-02-12 ! ! moded=0 only G, =1 G and dG/dy, =2 G, dG/dy and d2G/dy1/dy2 ! ncon is number of constituents, each cell a constituent ! phvar is pointer to phase_varres record ! phrec is the phase record ! tval is current value of T implicit none integer moded,ncon ! to obtain current fractions and store results TYPE(gtp_phase_varres), pointer :: phvar ! to obtain phase and constituent inforamation TYPE(gtp_phaserecord) :: phrec double precision tval !\end{verbatim} integer ii,loksp double precision rtg !--------------------------------------------------------------------------- ! ! rtg is set to R*T rtg=globaldata%rgas*tval write(*,10)ncon,(trim(splista(phrec%constitlist(ii))%symbol),& phvar%yfr(ii),ii=1,ncon) 10 format('3X config_entropy_tisr with ',i2,' constituents, fractions:'/& 10(a,1x,F7.4,', ')) ! You can enter all calculations here, nothing will be added elsewhere write(*,'(a,1pe16.6)')'3X TISR not implemented yet, G=',phvar%gval(1,1) gx%bmperr=4399 ! Values returned should be: ! phvar%gval(1,1) Gibbs energy divided by RT (G/RT below) ! phvar%gval(2,1) derivative of G/RT wrt T ! phvar%dgval(1,ii,1) 1st derivative of G/RT wrt fraction ii ! phvar%dgval(2,ii,1) 2nd derivative of G/RT wrt T amd fraction ii ! phvar%d2gval(ixym(ii,jj),1) 2nd derivative of G/RT wrt fracton ii and jj ! Normally sufficient to set phvar%d2gval(ixsym(ii,ii))=one/phvar%yfr(ii) !----------------------------------- 1000 continue return end subroutine config_entropy_tisr !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine config_entropy_srot !\begin{verbatim} subroutine config_entropy_srot(moded,ncon,phvar,phrec,tval) ! ! calculates configurational entropy/R for tetrahedron SRO model ! I DO NOT THINK THIS IS USED ?? ! ! moded=0 only G, =1 G and dG/dy, =2 G, dG/dy and d2G/dy1/dy2 ! ncon is number of constituents, each cell a constituent ! phvar is pointer to phase_varres record ! phrec is the phase record ! tval is current value of T implicit none integer moded,ncon TYPE(gtp_phase_varres), pointer :: phvar TYPE(gtp_phaserecord) :: phrec double precision tval !\end{verbatim} !--------------------------------------------------------------------------- ! FOR A BINARY, with 5 SRO clusters as in tetrahedron FCC ! integer ia,ib,ja,jb,kk,mm,alpha,jxsym,loksp double precision rk,ggg,rtg ! double precision s1,s2,s11,s12,s21,s22 ! double precision s111,s112,s121,s122,s211,s212,s221,s222 ! model constants double precision escale double precision, allocatable, dimension(:) :: pij,xx double precision rrk(0:4) ! this is a scaling factor for the entropy escale=0.25D0 ! Coefficients to calculate the mole fractions from the clusters ! which must be ordered A, A0.75B0.25, A.5B.5, A.25B.75, B kk=4; rk=0.25D0 ! Tetrahedron in fcc lattice, z=12; m=4. The factors below are equal to ! 1/permutations of the clusters. Needed to obtain ideal ordering at high T rrk(0)=one; rrk(1)=0.25D0; rrk(2)=one/6.0D0; rrk(3)=0.25; rrk(4)=one if(ncon.ne.5) then ! ncon should be 5 for a binary system write(*,*)'3X constituents must be 5!',ncon gx%bmperr=4399; goto 1000 endif ! allocations allocate(xx(1:2)) allocate(pij(0:4)) rtg=globaldata%rgas*tval ! test without any ordering parameters, the system should be ideal ... !------------------------------------------------------------------- do alpha=0,4 ! these are the cluster fractions, for higher order systems must be identified pij(alpha)=phvar%yfr(alpha+1) enddo ! mole fractions, note "ia" is the number of B atoms!! xx=zero do ia=0,4 xx(1)=xx(1)+(kk-ia)*rk*pij(ia) xx(2)=xx(2)+ia*rk*pij(ia) enddo if(abs(xx(1)+xx(2)-one).gt.1.0e-8) stop '3X SROT mole fraction error' ! xx(1) is fraction of A, xx(2) fraction of B. NOT USED!! ggg=zero ! This is summing the SRO entropy part do ia=0,4 ggg=ggg+escale*pij(ia)*log(pij(ia)*rrk(ia)) enddo ! These are the configurational G/RT and S/R phvar%gval(1,1)=ggg phvar%gval(2,1)=ggg/tval do ia=0,4 ! d/pij ( x1*ln(x1)+x2*log(x2)+ ...+ pij*log(pij) ! note "ia" counts the B atoms phvar%dgval(1,ia+1,1)=escale*(one+log(pij(ia)*rrk(ia))) phvar%dgval(2,ia+1,1)=phvar%dgval(1,ia+1,1)/tval enddo !------------------------------------------------------ ! second derivatives, symmetric, stored only upper half ! approximate with 1/pij jxsym=0 jb=1 phvar%d2gval=zero do ia=1,ncon phvar%d2gval(ixsym(ia,ia),1)=escale/(rrk(ia-1)*pij(ia-1)) enddo !----------------------------------- 1000 continue return end subroutine config_entropy_srot !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine push_pyval !\begin{verbatim} subroutine push_pyval(pystack,intrec,pmq,pyq,dpyq,d2pyq,moded,iz) ! push data when entering an interaction record implicit none integer pmq,moded,iz double precision pyq,dpyq(iz),d2pyq(iz*(iz+1)/2) type(gtp_pystack), pointer :: pystack type(gtp_interaction), pointer :: intrec !\end{verbatim} %+ type(gtp_pystack), pointer :: new ! if(associated(pystack)) then allocate(new) new%previous=>pystack pystack=>new else allocate(pystack) nullify(pystack%previous) endif ! save data pystack%intrecsave=>intrec pystack%pmqsave=pmq pystack%pysave=pyq if(moded.ge.1) then ! if moded 0 there are no derivatives allocate(pystack%dpysave(iz)) pystack%dpysave=dpyq if(moded.eq.2) then ! if moded 1 there are no second derivatives allocate(pystack%d2pysave(iz*(iz+1)/2)) pystack%d2pysave=d2pyq endif endif 1000 continue return end subroutine push_pyval !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine pop_pyval !\begin{verbatim} subroutine pop_pyval(pystack,intrec,pmq,pyq,dpyq,d2pyq,moded,iz) ! pop data when entering an interaction record implicit none integer iz,pmq,moded double precision pyq,dpyq(iz),d2pyq(iz*(iz+1)/2) type(gtp_pystack), pointer :: pystack type(gtp_interaction), pointer :: intrec !\end{verbatim} type(gtp_pystack), pointer :: old if(.not.associated(pystack)) then ! write(*,*)'3X Tying to pop from an empty PY stack' gx%bmperr=4075; goto 1000 endif ! restore data intrec=>pystack%intrecsave pmq=pystack%pmqsave pyq=pystack%pysave if(moded.ge.1) then ! if moded >0 there are derivatives dpyq=pystack%dpysave if(moded.eq.2) then ! if moded 2 there are second derivatives d2pyq=pystack%d2pysave endif endif ! release memory old=>pystack pystack=>pystack%previous deallocate(old) 1000 continue return end subroutine pop_pyval !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_disfrac !\begin{verbatim} subroutine calc_disfrac(lokph,lokcs,ceq) ! calculate and set disordered set of fractions from sitefractions ! The first derivatives are dxidyj. There are no second derivatives ! TYPE(gtp_fraction_set), pointer :: disrec implicit none integer lokph,lokcs TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ ! TYPE(gtp_fraction_set), pointer :: disrec TYPE(gtp_phase_varres), pointer :: phord TYPE(gtp_phase_varres), pointer :: phdis ! logical ordered ! minimum difference in site fraction to be set as ordered ! double precision, parameter :: yminord=1.0D-10 integer lokdis,is ! ! write(*,*)'3X entering calc_disfrac',lokph,lokcs ! this is the record with the ordered constitution phord=>ceq%phase_varres(lokcs) ! disrec=phord%disfra ! lokdis=disrec%varreslink ! phdis=>disrec%phdapointer lokdis=ceq%phase_varres(lokcs)%disfra%varreslink phdis=>ceq%phase_varres(lokdis) ! this is a record within the ordered constitution record for disordered fracs ! disrec=>phord%disfra ! to find the varres record with disordered fractions use varreslink ! this is the index to the phase_varres record with the ordered fractions ??? lokdis=ceq%phase_varres(lokcs)%disfra%varreslink ! write(*,*)'3X in calc_disfrac',lokph,lokdis,& ! associated(phord),associated(phdis) ! write(*,*)'3X Calc disfra: ',lokph,lokcs,lokdis ! phdis=>ceq%phase_varres(lokdis) ! call calc_disfrac2(ceq%phase_varres(lokcs)%disfra,& ! call calc_disfrac2(ceq%phase_varres(lokcs),ceq%phase_varres(lokdis),ceq) call calc_disfrac2(phord,phdis,ceq) 1000 continue return end subroutine calc_disfrac !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_disfrac2 !\begin{verbatim} %- subroutine calc_disfrac2(phord,phdis,ceq) ! calculate and set disordered set of fractions from sitefractions ! The first derivatives are dxidyj. There are no second derivatives ! TYPE(gtp_fraction_set), pointer :: disrec implicit none TYPE(gtp_phase_varres), target :: phord TYPE(gtp_phase_varres), pointer :: phdis TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} TYPE(gtp_fraction_set), pointer :: disrec logical ordered ! minimum difference in site fraction to be set as ordered double precision, parameter :: yminord=1.0D-10 integer lokdis,is ! ! write(*,*)'3X entering calc_disfrac2' ! disrec=phord%disfra ! lokdis=disrec%varreslink ! phdis=>disrec%phdapointer ! this is the record with the ordered constitution ! phord=>ceq%phase_varres(lokcs) ! this is a record within the ordered constitution record for disordered fracs ! write(*,*)'3X entering calc_disfrac2' disrec=>phord%disfra ! write(*,*)'3X in calc_disfrac2 B',associated(disrec),associated(phdis) ! to find the varres record with disordered fractions use varreslink ! this is the index to the phase_varres record with the ordered fractions ??? ! lokdis=disrec%varreslink ! phdis=>ceq%phase_varres(lokdis) ! write(*,*)'3X calc_disfrac 1A' ! check that some values are accessable ! write(*,*)'3X calc_disfra phase index: ',phord%phlink ! write(*,*)'3X calc_disfra disordered sublattices: ',disrec%ndd ! write(*,*)'3X calc_disfra ordered and disordered records: ',lokcs,lokdis ! write(*,*)'3X calc_disfra phase index via disordred record: ',phdis%phlink ! write(*,*)'3X calc_disfrac 1B' ! write(*,*)'3X in calc_disfra2c B1: ',associated(phdis%yfr) ! Segmentation fault that phdis%yfr not always allocated !!! ! write(*,*)'3X in calc_disfra2c B1: ',allocated(phdis%yfr) phdis%yfr=zero ! write(*,*)'3X in calc_disfra2c A1: ',disrec%tnoofyfr do is=1,disrec%tnoofyfr phdis%yfr(disrec%y2x(is))=& phdis%yfr(disrec%y2x(is))+disrec%dxidyj(is)*phord%yfr(is) ! write(*,77)'3X disfrac 2: ',is,disrec%y2x(is),phdis%yfr(disrec%y2x(is)),& ! disrec%dxidyj(is),phord%yfr(is) 77 format(a,2i3,3(1pe12.4)) enddo ! write(*,*)'3X in calc_disfrac2 A2' ! check if phase is really ordered, meaning that the disordered fractions ! are equal to the ordered ones ordered=.false. do is=1,disrec%tnoofyfr if(abs(phdis%yfr(disrec%y2x(is))-& phord%yfr(is)).gt.yminord) ordered=.true. enddo ! write(*,*)'3X calc_disfrac2 A3' if(.not.ordered) then ! if this bit set one will not calculate the ordered part of the phase phord%status2=ibclr(phord%status2,csorder) else ! bit must be cleared as it might have been set at previous call phord%status2=ibset(phord%status2,csorder) endif ! write(*,*)'3X in calc_disfrac2 A4: ',phord%status2 ! copy these to the phase_varres record that belongs to this fraction set ! a derivative dGD/dyj = sum_i dGD/dxi * dxidyj ! where dGD/dxi is dgval(1,y2x(j),1) and dxidyj is disrec%dxidyj(j) ! because each y constituent contributes to only one disordered x fraction 1000 continue return ! G(tot) = GD(xdis)+(GO(yord)-GO(yord=xdis)) ! G(tot).yj = dGD(xdis).dxi*dxdyj + GO.yj - GO.yj ... end subroutine calc_disfrac2 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine disordery !\begin{verbatim} subroutine disordery(phvar,ceq) ! sets the ordered site fractions in FCC and other order/disordered phases ! equal to their disordered value in order to calculate and subtract this part ! phvar is pointer to phase_varres for ordered fractions implicit none TYPE(gtp_phase_varres), pointer :: phvar TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ TYPE(gtp_fraction_set), pointer :: disrec ! TYPE(gtp_phase_varres) :: phdis TYPE(gtp_phase_varres), pointer :: phdis integer lokdcs,ii,nofc1,nofc2 double precision xxx ! integer lokdcs,kk,ll,is,nis,nsl ! find disordered fractions ! lokdcs=phvar%disfra%varreslink ! disrec=>phvar%disfra ! write(*,*)'3X disordery: ',disrec%latd,disrec%nooffr(1),lokdcs ! phdis=ceq%phase_varres(lokdcs) ! write(*,*)'3X disordery: ',ceq%xconv ! write(*,*)'3X disordery: ',phdis%yfr(1) ! phdis=>ceq%disrec%phdapointer ! find disordered fractions disrec=>phvar%disfra lokdcs=phvar%disfra%varreslink ! write(*,9)trim(phlista(phvar%phlink)%name),lokdcs 9 format('3X diordery: ',a,i5) ! problem that this pointer is not always ok ....??? phdis=>ceq%phase_varres(lokdcs) call disordery2(lokdcs,phvar,disrec,ceq) ! write(*,11)'3X phvary: ',(phvar%yfr(ii),ii=1,nofc1) ! write(*,11)'3X phdisy: ',(phdis%yfr(ii),ii=1,nofc2) ! write(*,*)'3X Done disorder' ! 1000 continue return end subroutine disordery !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine disordery2 !\begin{verbatim} %- subroutine disordery2(lokdcs,phvar,disrec,ceq) ! subroutine disordery2(phdis,phvar,disrec,ceq) ! sets the ordered site fractions in FCC and other order/disordered phases ! equal to their disordered value in order to calculate and subtract this part ! phvar is pointer to phase_varres for ordered fractions ! phdis is pointer to phase_varres for disordered fractions implicit none TYPE(gtp_phase_varres), pointer :: phvar TYPE(gtp_fraction_set), pointer :: disrec TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer lokdcs,kk,ll,is,nis,nsl double precision xxx ! copy fractions, loop through all ordered sublattices in phvar ! and store fraction from lokdis ! write(*,*)'3X dis2: 1',lokdcs ! this was never assigned!! BOS 16.11.04 lokdcs=disrec%varreslink ! write(*,*)'3X lokdcs: ',ceq%eqno,lokdcs,disrec%latd,& ! allocated(ceq%phase_varres(lokdcs)%yfr) ! here copy: ! y(ord,1,1)=y(dis,1); y(ord,1,2)=y(dis,2); y(ord,1,3)=y(dis,3); ! y(ord,2,1)=y(dis,1); y(ord,2,2)=y(dis,2); y(ord,2,3)=y(dis,3); ! write(*,*)'3X dis2: 2',disrec%latd,disrec%nooffr(1) ! write(*,*)'3X dis2: 3',phdis%yfr(1) ! write(*,*)'3X disordery2: ',lokdcs kk=0 ! latd is the number of sublattices to be added to first disordered sublattice do ll=1,disrec%latd do is=1,disrec%nooffr(1) ! the number of constituents in first disordered sublattice same as in ordered kk=kk+1 ! phvar%yfr(kk)=phdis%yfr(is) ! xxx=phdis%yfr(is) xxx=ceq%phase_varres(lokdcs)%yfr(is) ! phvar is the phase_varres record of the ordered phase phvar%yfr(kk)=xxx enddo enddo ! write(*,*)'3X dis2: 4',disrec%ndd if(disrec%ndd.eq.2) then ! one can have 2 sets of ordered subl. like (Al,Fe)(Al,Fe)...(C,Va)(C,Va)... ! BUT NEVER TESTED nis=disrec%nooffr(1) nsl=size(phvar%sites) ! write(*,*)'3X dis2: 5',nis,nsl ! write(*,*)'3X dy: ',nis,kk,disrec%latd,nsl,disrec%nooffr(2) do ll=disrec%latd+1,nsl do is=1,disrec%nooffr(2) kk=kk+1 ! phvar%yfr(kk)=phdis%yfr(nis+is) phvar%yfr(kk)=ceq%phase_varres(lokdcs)%yfr(nis+is) enddo enddo endif 1000 continue return end subroutine disordery2 !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine uniquac_model !\begin{verbatim} subroutine uniquac_model(moded,ncon,phres,ceq) ! Calculate the Gibbs energy of the UNIQUAC model (Abrams et al 1975) ! Modified 2018/Oct, Nov, Dec ! It returns UNIQUAC G and first and second derivatives of G in phres%gval etc. ! The values of q_i and r_i are be stored in species record, not identifiers ! The residual term should be stored as a UQTAU identifier implicit none integer moded,ncon TYPE(gtp_equilibrium_data), pointer :: ceq TYPE(gtp_phase_varres), pointer :: phres !\end{verbatim} integer ia,ib,ic,id,ie,jj,nprop,nint,lokph,loksp,ii double precision, allocatable, dimension(:) :: theta,phi,qval,xfr,rval double precision, allocatable, dimension(:,:) :: tau,dtaudt double precision, allocatable, dimension(:) :: rho,kvottau double precision, allocatable, dimension(:) :: dgv,d2gv,sumdtaudt,d2gdydt double precision hzeta,gres,sumxq,sumxr,dgrdt,xxx,yyy,sumtt double precision gc,gr,term1,term2,dgr,dgc,d2gc,d2gr,sumxiqi ! we must have a property index "i" for each tau_ji integer, allocatable, dimension(:) :: unqtau ! if(moded.lt.2) then ! if moded=/=2 then some of the 2nd derivatives needed is not present ... ! moded=0 when calculating with the gridminimizer ! write(*,*)'Skipping uniquac phase as no derivatives' ! goto 1000 ! endif ! need theta = \sum_i q_i*x_i and Phi=\sum_i r_i*x_i ! write(*,*)'3X in uniquac 1' allocate(unqtau(ncon)) allocate(theta(ncon)) allocate(phi(ncon)) allocate(qval(ncon)) allocate(rval(ncon)) allocate(xfr(ncon)) allocate(dgv(ncon)) allocate(d2gdydt(ncon)) allocate(tau(ncon,ncon)) allocate(dtaudt(ncon,ncon)) allocate(rho(ncon)) allocate(kvottau(ncon)) allocate(sumdtaudt(ncon)) ! number of interactions nint=ncon*(ncon+1)/2 allocate(d2gv(nint)) ! we need some place to store these indices if we have no addition record ... ! UQT is a model parameter identifier with constituent index ! tau_ji is UQT&I(LIQ,J) call need_propertyid('UQT ',id) if(gx%bmperr.ne.0) goto 1000 nprop=phres%listprop(1)-1 ! unqq=0; unqr=0; unqt12=0; unqt21=0 unqtau=0 do ia=1,nprop if(phres%listprop(ia)/100.eq.id) then ! listprop is 2600+constituent index ! parameter syntax is UQT&UA(LIQUID,UB) for TAU_{UB,UA} ib=mod(phres%listprop(ia),100) unqtau(ib)=ia ! write(*,*)'3X found tau: ',phres%listprop(ia),ib,unqtau(ib) endif enddo ! copy mole fractions to xfr xfr=phres%yfr ! extract unqq and unqr from species record lokph=phres%phlink sumxq=zero sumxr=zero do ia=1,ncon ! values of q and r for each species is stored in species record loksp=phlista(lokph)%constitlist(ia) if(btest(splista(loksp)%status,SPUQC)) then qval(ia)=splista(loksp)%spextra(1) rval(ia)=splista(loksp)%spextra(2) else qval(ia)=one rval(ia)=one endif ! calculate the sum of q and r sumxq=sumxq+xfr(ia)*qval(ia) sumxr=sumxr+xfr(ia)*rval(ia) enddo ! extracting residual parameters complicated ... initiate to zero tau=one ! ! df/dx_k = ln(phi_k) + 1 - phi_k/x_k + ! z/2 q_k ( ln(theta_k/phi_k) + phi_k/theta_k-1 ) ! ! theta = UQQ = x_i*q_i(\sum_j q_j*x_j) ! Phi= UQR=x_i*r_i*(\sum_i r_j*x_j) ! write(*,*)'3 X Calculate Phi, theta and some invariants for the residual term' dtaudt=zero sumdtaudt=zero do ia=1,ncon theta(ia)=xfr(ia)*qval(ia)/sumxq phi(ia)=xfr(ia)*rval(ia)/sumxr ! write(*,'(a,i4,6(F7.4))')'3X theta and phi:',ia,xfr(ia),theta(ia),phi(ia) !----------------- residual term tau_ji, may not be present! ! write(*,'(a,2i3,3(1pe12.4))')'3X tau1: ',ia,unqtau(ia),& ! phres%gval(1,unqtau(ia)),phres%dgval(1,3-ia,unqtau(ia)) if(unqtau(ia).eq.0) then ! OK if zero, this means no residual parameter continue else ! there are some residual parameters, extract their values ! MODIFIED xfr(ib)*tau_(ib,ia) stored in phres%gval(1,unqtau(ia)) ! MODIFIED xfr(ia)*tau_(ia,ib) stored in phres%gval(1,unqtau(ib)) ! By JING: here you need to be careful!!! tauloop2: do ib=1,ncon if(ib.eq.ia) cycle tauloop2 ! This is the derivative wrt xfr(ib) of UQT&IA i.e. TAU_IB,IA term1=phres%dgval(1,ib,unqtau(ia)) ! NOTE, default value one set above, value must be larger than zero if(term1.ne.zero) then tau(ib,ia)=term1 ! The derivative wrt T is in phres%dgval(2,ib,unqtau(ia)) dtaudt(ib,ia)=phres%dgval(2,ib,unqtau(ia)) endif ! write(*,'(a,3i3,4(1pe12.4))')'3X tau2: ',ia,ib,unqtau(ia),& ! phres%dgval(1,ib,unqtau(ia)),phres%dgval(2,ib,unqtau(ia)) enddo tauloop2 endif enddo !----------------------- ! write(*,10)'3X q: ',qval,phres%gval(1,unqq) ! write(*,10)'3X UNIQUAC theta: ',xfr,theta ! write(*,10)'3X UNIQUAC tau: ',xfr,tau ! default value of tau is unity ! OK write(*,10)'3X tau: ',tau 10 format(a,6(1pe12.4)) ! here we calculate \sum_i \theta_i \tau_{ij} stored in rho do ia=1,ncon term1=zero term2=zero do ib=1,ncon ! this is \sum_j \theta_j \tau_{ji} term1=term1+theta(ib)*tau(ia,ib) term2=term2+theta(ib)*dtaudt(ia,ib) ! OK write(*,'(a,2i3,6(1pe12.4))')'3X rho1: ',ia,ib,theta(ib),tau(ia,ib) enddo ! these values are \sum_j \theta_j\tau_ji (and the T-derivative) rho(ia)=term1 sumdtaudt(ia)=term2 enddo ! OK write(*,10)'3X rho: ',rho ! gx%bmperr=4399; goto 1000 do ia=1,ncon ! need for the residual derivatives \sum_i (\theta_i \tau_ji)/\rho_i term1=zero do ib=1,ncon ! I am never sure if it should be tau(ia,ib) or tau(ib,ia) ... term1=term1+theta(ib)*tau(ib,ia)/rho(ib) enddo ! This is \sum_i (\theta_i \tau_ki)/\rho_i where index "ia" is subscript "k" kvottau(ia)=term1 enddo ! write(*,107)'3X tau:: ',kvottau,zero,xfr(1),ceq%tpval(1) ! gx%bmperr=4399; goto 1000 ! This is z/2 hzeta=5.0D0 ! Here the UNIQUAC GIBBS ENERGY and derivatives are calculated. ! phres%gval has the ideal configurational enntropy already ! and possibly any reference energy terms! gc=zero; gr=zero; dgrdt=zero gmloop: do ia=1,ncon ! The residual and configurational G ! ALL OK without residual term, rho_i is rho_i in abrams1-190107.pdf gr=gr-xfr(ia)*qval(ia)*log(rho(ia)) ! NOTE gc=zero if all qval and rval equal for all components !! gc=gc+xfr(ia)*log(phi(ia)/xfr(ia))+& hzeta*xfr(ia)*qval(ia)*log(theta(ia)/phi(ia)) ! write(*,210)'3X gci: ',ia,xfr(ia),phi(ia),xfr(ia)*log(phi(ia)/xfr(ia)),& ! qval(ia),theta(ia),hzeta*xfr(ia)*qval(ia)*log(theta(ia)/phi(ia)) 210 format(a,i2,6(1pe10.2)) ! The first T-derivative of residual (as in Abrams1.pdf 190105) dgrdt=dgrdt-xfr(ia)*qval(ia)*sumdtaudt(ia)/rho(ia) ! The second T-derivative ... NOT USED YET! ! d2grdt2=.... enddo gmloop ! write(*,211)'3X GC: ',0,gr,gc,gr+gc 211 format(a,i2,6(1pe12.4)) ! gx%bmperr=4399; goto 1000 dgv=zero d2gdydt=zero first: do ib=1,ncon ! first residual derivative with respect to component ! kvottau was calculated above dgr=qval(ib)*(one-log(rho(ib))-kvottau(ib)) ! derivative with respect to T and xfr(b) ! we must sum_i theta_i/rho_i (dtau_ki/dT) xxx=zero; yyy=zero sumtt=zero ! second derivative of residual do ia=1,ncon xxx=xxx+theta(ia)*dtaudt(ib,ia)/rho(ia) yyy=yyy+theta(ia)*tau(ib,ia)*sumdtaudt(ia)/rho(ia)**2 enddo d2gdydt(ib)=-qval(ib)*(sumdtaudt(ib)/rho(ib)+xxx-yyy) ! first derivative with respect to ib of configuration ! NOTE: 1+ln(x) already calculated, thus -log(xfr(ib)) dgc=log(phi(ib)/xfr(ib))+one-phi(ib)/xfr(ib)+& hzeta*qval(ib)*(log(theta(ib)/phi(ib))-one+phi(ib)/theta(ib)) ! write(*,'(a,i3,f10.6,1pe12.4)')'3X ib xfr dgc: ',ib,xfr(ib),dgc dgv(ib)=dgr+dgc ! write(*,212)'3X dgr: ',ib,qval(ib),rho(ib),kvottau(ib),dgc,dgv(ib) 212 format(a,i3,6(1pe12.4)) second: do ic=ib,ncon ! second derivative of configuration with respect to ib and ic ! APPROXIMATE not corrected!! do ii=1,ncon sumtt=sumtt+theta(ii)*tau(ib,ii)*tau(ic,ii)/rho(ii)**2 enddo d2gr=qval(ib)*qval(ic)/sumxq*(1-tau(ic,ib)/rho(ib)-& tau(ib,ic)/rho(ic)+sumtt) if(ic.eq.ib) then d2gc=-2.0D0*phi(ic)/xfr(ic)**2 ! else ! d2gc=zero ! d2gr=zero endif d2gv(ixsym(ib,ic))=d2gr+d2gc enddo second ! VERY APPROXIMATE SECOND DERIVATIVES enddo first ! write(*,300)'3X UQG: ',gr,gc,(dgv(ia),ia=1,ncon) ! do ib=1,ncon ! write(*,300)'3X D2UQG: ',(d2gv(ixsym(ia,ib)),ia=1,ncon) ! enddo ! copy results to global arrays ! phres%gval(1,1) is Gm, %gval(2,1) is dG/dT, %gval(3,1) is dG/dP, ! %gval(4,1) is d2G/dT2 ... ! IMPORTANT the ideal configurational entropy is in %gval(1,1) and %gval(2,1) ! phres%dgval(1,j,1) is dG/dx_j, phres%dgval(2,j,1) is d2G/dTdx_j ... ! phres%d2gval(ixsym(j,k),1) is d2G/dx_jdx_k stored as upper triangle ! all values divided by RT ! phres%gval(2,1)= no T dependence ! phres%gval(3,1)= no P dependence ! phres%d2gval(ixsym(j,k),1) is d2G/dx_j/dx_k ! write(*,300)'3X G/RT: ',phres%gval(1,1),gc,phres%gval(1,1)+gc ! write(*,'(a,i3,5(1pe12.4))')'3X UQG: ',moded,gr,gc,phres%gval(1,1),& ! gr+gc+phres%gval(1,1) phres%gval(1,1)=phres%gval(1,1)+gc+gr ! add dgc/dT and T-dependence of gr. NOTE gr is also multiplied with RT phres%gval(2,1)=phres%gval(2,1)+(gc+gr)/ceq%tpval(1)+dgrdt term1=phres%gval(2,1) ! write(*,'(a,i2,6(1pe12.4))')'3X dG/dT: ',phres%phtupx,term1,& ! phres%gval(2,1),gc/ceq%tpval(1),gr/ceq%tpval(1),dgrdt ! phres%gval(4,1)=phres%gval(2,1)+other terms T-dependent terms (Cp) do ia=1,ncon phres%dgval(1,ia,1)=phres%dgval(1,ia,1)+dgv(ia) ! write(*,212)'3X ddy: ',ia,phres%dgval(1,ia,1),dgv(ia) ! The T-dependence of the residual term affects d2G/dydT ! term1=phres%dgval(2,ia,1) ! phres%dgval(2,ia,1)=phres%dgval(2,ia,1)+d2gdydt(ia) ! write(*,'(a,i2,6(1pe12.4))')'3X d2G/dydT: ',ia,term1,& ! phres%dgval(2,ia,1),d2gdydt ! 2nd derivatives ************ skip for the moment ! do ib=ia,ncon ! phres%d2gval(ixsym(ia,ib),1)=phres%d2gval(ixsym(ia,ib),1)+& ! d2gv(ixsym(ia,ib)) ! write(*,'(a,2i3,6(1pe12.4))')'3X d2g:',ib,ic,d2gr,d2gc,& ! phres%d2gval(ixsym(ib,ic),1) ! enddo enddo ! check chemical potentials xxx=phres%gval(1,1)-xfr(1)*phres%dgval(1,1,1)-xfr(2)*phres%dgval(1,2,1) ! write(*,'(a,4(1pe12.4))')'3X mu: ',xxx,xxx+phres%dgval(1,1,1),& ! xxx+phres%dgval(1,2,1) ! write(*,300)'3X Gm, dG/dx: ',phres%gval(1,1),(phres%dgval(1,ia,1),ia=1,ncon) 300 format(a,6(1pe12.4)) ! do ia=1,ncon ! write(*,300)'3X d2G/dx2: ',(phres%d2gval(ixsym(ia,ib),1),ib=1,ncon) ! enddo 1000 continue return end subroutine uniquac_model !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine set_driving_force !\begin{verbatim} subroutine set_driving_force(iph,ics,dgm,ceq) ! set the driving force of a phase explicitly implicit none type(gtp_equilibrium_data), pointer :: ceq integer iph,ics double precision dgm !\end{verbatim} integer lokph,lokcs call get_phase_compset(iph,ics,lokph,lokcs) if(gx%bmperr.ne.0) goto 1000 ceq%phase_varres(lokcs)%dgm=dgm 1000 continue return end subroutine set_driving_force !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine extract_massbalcond !\begin{verbatim} subroutine extract_massbalcond(tpval,xknown,antot,ceq) ! extract T, P, mol fractions of all components and total number of moles ! for use when minimizing G for a closed system. Probably redundant implicit none double precision, dimension(*) :: tpval,xknown double precision antot TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} ! This routine MUST return error 4143 or 4144 (too few or too many conditions) ! if that is the fact. Other error codes can be returned if there are ! conditions which does not allow the grid minimizer. integer, dimension(4) :: indices double precision, dimension(maxel) :: ani,abi,xset,wset double precision mass,h298,s298,xxx,xsum,wsum double precision sumwdivm,anisum,abisum,restmass,divisor,dividend,abtot TYPE(gtp_condition), pointer :: current,last character encoded*16,actual_arg(1)*16,elsym*2,elname*16,refstat*16 integer nox,now,nc,jl,iref,iunit,ip,idf,ie,more,numberest,istv,localerr,zz logical allmassbal ! do ie=1,noel() xknown(ie)=zero enddo ! write(*,*)'3X in extract_massbal' ani=zero; abi=zero; xset=zero; wset=zero antot=zero; abtot=zero xsum=zero; wsum=zero anisum=zero; abisum=zero nox=0; now=0 localerr=0 ! ! write(*,*)"3X in extract massbalace 1" last=>ceq%lastcondition if(.not.associated(last)) then gx%bmperr=4143; goto 1000 endif ! write(*,*)"3X in extract massbalace 2" current=>last nc=0 allmassbal=.TRUE. 100 continue current=>current%next ! ignore inactive conditions if(current%active.ne.0) goto 300 ! if a conditions has several terms we cannot calculate x if(current%noofterms.gt.1) then ! write(*,*)'3X Grid minimizer cannot be used with expressions' localerr=4179 endif ! for debugging istv=current%statev do jl=1,4 indices(jl)=current%indices(jl,1) enddo iref=current%iref iunit=current%iunit ip=1 encoded=' ' actual_arg=' ' if(current%symlink1.gt.0) then ! the value is a symbol, the node to the expression is in ! svflista(current%symlink1)%linkpnode ! NOTE THIS IS NOT THE SAME AS meq_evaluate_svfun but OK as no derivative ! BUT WE HAVE TO BE CAREFUL IF THIS MUST NOT BE EVALUATED!! if(btest(svflista(current%symlink1)%status,SVFVAL)) then xxx=ceq%svfunres(current%symlink1) else xxx=evaluate_svfun_old(current%symlink1,actual_arg,1,ceq) endif else xxx=current%prescribed endif ! write(*,17)'3X massbal: ',encoded,istv,indices,iunit,iref,xxx 17 format(a,2x,a,2x,i3,2x,4i3,2x,2i3,1PE15.7) ! extract values of T, P, N, B, X and W if(current%statev.eq.1) then ! this is the temperature tpval(1)=xxx nc=nc+1 elseif(current%statev.eq.2) then ! this is the pressure tpval(2)=xxx nc=nc+1 elseif(current%statev.eq.110) then ! this is N=value or N(element)=value if(indices(2).gt.0) then ! this should mean the number of moles of a component in a phase, illegal here ! write(*,*)'3X N with 2 indices illegal in this case' localerr=4179 elseif(indices(1).gt.0) then ! N(i)=xxx ani(indices(1))=xxx anisum=anisum+xxx else ! N=xxx antot=xxx endif nc=nc+1 elseif(current%statev.eq.111) then if(indices(2).gt.0) then localerr=4179; goto 1000 endif ! this is X(index1)=value, CHECK UNIT if %!!! if(iunit.eq.100) xxx=1.0D-2*xxx xset(current%indices(1,1))=xxx xsum=xsum+xxx nc=nc+1 nox=nox+1 elseif(current%statev.eq.120) then ! this is B=value or B(i)=value if(indices(2).gt.0) then ! this should mean the mass of a component in a phase, illegal here write(*,*)'3X B with 2 indices illegal' localerr=4179 elseif(indices(1).gt.0) then ! B(i)=xxx abi(indices(1))=xxx abisum=abisum+xxx else ! B=xxx abtot=xxx endif nc=nc+1 elseif(current%statev.eq.122) then if(indices(2).gt.0) then localerr=4179 endif ! this is W(index1)=value, CHECK UNIT if %!!! end x2 if(iunit.eq.100) xxx=1.0D-2*xxx wset(current%indices(1,1))=xxx wsum=wsum+xxx nc=nc+1 now=now+1 else ! this is not a massbalance condition but continue just to check how many cond allmassbal=.FALSE. nc=nc+1 endif ! take next condition if we have not done all 300 continue if(ocv()) write(*,310)'3X massbal: ',current%prescribed,last%prescribed 310 format(a,6(1pe12.4)) if(.not.associated(current,last)) goto 100 !-------------------------------------- ! check if correct number of conditions found 500 continue idf=noofel+2-nc if(idf.ne.0) then ! if idf is not zero there are not enough conditions gx%bmperr=4144; goto 1000 elseif(.not.allmassbal) then ! some conditions are not massbalance localerr=4151 endif ! write(*,*)'3X extract_massbal: ',localerr ! We have correct number of conditions but if localerr set we do not have ! all as massbalance conditions. Return with that code set if(localerr.ne.0) then gx%bmperr=localerr; goto 1000 endif ! we have extracted all conditions N, B, X, W ! check that only one value per component do ie=1,noel() if(xset(ie).gt.zero) then if(wset(ie).gt.zero) goto 1100 if(ani(ie).gt.zero) goto 1100 if(abi(ie).gt.zero) goto 1100 elseif(wset(ie).gt.zero) then if(ani(ie).gt.zero) goto 1100 if(abi(ie).gt.zero) goto 1100 elseif(ani(ie).gt.zero) then if(abi(ie).gt.zero) goto 1100 elseif(abi(ie).le.zero) then ! this can be "the rest" ! write(*,*)'3X massbal',ie,abi(ie),antot,abtot if(.not.btest(globaldata%status,GSNOTELCOMP)) then if(antot.eq.zero .and. abtot.eq.zero) goto 1105 ! else ! write(*,*)'3X Other components then elements 1' endif endif enddo ! write(*,510)'N: ',(ani(i),i=1,noel()) ! write(*,510)'B: ',(abi(i),i=1,noel()) ! write(*,510)'x: ',(xset(i),i=1,noel()) ! write(*,510)'w: ',(wset(i),i=1,noel()) 510 format(a,7F9.6) bigif: if(antot.gt.zero) then ! we have a value for total number of moles, N, there must not be one for B if(abtot.ne.zero) goto 1110 more=0 numberest=0 sumwdivm=zero ! convert as much as possible to N(i). Sum also some data needed if there ! are conditions on mass fractions do ie=1,noel() call get_element_data(ie,elsym,elname,refstat,mass,h298,s298) if(xset(ie).gt.zero) then ani(ie)=antot*xset(ie) anisum=anisum+ani(ie) abisum=abisum+mass*ani(ie) elseif(abi(ie).gt.zero) then ani(ie)=abi(ie)/mass anisum=anisum+ani(ie) abisum=abisum+mass*ani(ie) elseif(wset(ie).gt.zero) then sumwdivm=sumwdivm+wset(ie)/mass more=1 elseif(ani(ie).eq.zero) then if(numberest.gt.0) then ! write(*,*)'3X Missing condition for two elements.' ! ?? gx%bmperr=0; goto 1000 gx%bmperr=4151; goto 1000 endif restmass=mass numberest=ie endif enddo if(numberest.eq.0) then write(*,*)'3X Error - condition on all elements and N??' gx%bmperr=0; goto 1000 endif if(more.gt.0) then ! there are some mass fractions, we have to calculate B ! but first we must determine the number of moles of "the rest" element divisor=antot-anisum-abisum/(one-wsum)*sumwdivm dividend=one+restmass/(one-wsum)*sumwdivm ani(numberest)=divisor/dividend abi(numberest)=restmass*ani(numberest) abisum=abisum+abi(numberest) ! now calculate B abtot=abisum/(one-wsum) ! write(*,520)'3X nrest: ',numberest,divisor,dividend,ani(numberest),& ! abi(numberest),abtot 520 format(a,i3,6(1pe12.4)) ! now calculate moles of elements with massfractions do ie=1,noel() if(wset(ie).gt.zero) then abi(ie)=abtot*wset(ie) call get_element_data(ie,elsym,elname,refstat,mass,h298,s298) ani(ie)=abi(ie)/mass endif enddo else ! all conditions are mole fractions, just set "the rest" ani(numberest)=antot-anisum endif do ie=1,noel() xset(ie)=ani(ie)/antot enddo elseif(abtot.gt.zero) then ! we have a value for total mass, B, not common and too complicated ! write(*,*)'3X Cannot handle condition on total mass' gx%bmperr=4180 elseif(xsum.eq.zero .and. wsum.eq.zero) then ! just N(i)= and B(i)=, no N= nor B= and no X nor W, No rest element ! write(*,520)'3X N(i): ',0,anisum,(ani(j),j=1,noel()) do ie=1,noel() if(abi(ie).gt.zero) then call get_element_data(ie,elsym,elname,refstat,mass,h298,s298) ani(ie)=abi(ie)/mass anisum=anisum+ani(ie) endif enddo antot=anisum do ie=1,noel() xset(ie)=ani(ie)/antot if(xset(ie).le.zero) then if(.not.btest(globaldata%status,GSNOTELCOMP)) then ! when other components than elements the mole fractions can be <0 or > 1 write(*,*)'3X mass balance error: ',ie gx%bmperr=4181; goto 1000 ! else ! write(*,*)'3X Other components than elements 2' endif endif enddo else ! any other combination of conditions .... write(*,*)'3X Cannot handle these massbalance conditions' gx%bmperr=4182 endif bigif ! copy fractions to arguments 900 continue do ie=1,noel() xknown(ie)=xset(ie) enddo 1000 continue return ! errors 1100 continue write(*,*)'3X Two mass balance conditions for same element',ie gx%bmperr=4183; goto 1000 1105 continue write(*,*)'3X One component without condition' gx%bmperr=4181; goto 1000 1110 continue write(*,*)'3X Both N and B cannot be set' gx%bmperr=4184; goto 1000 ! end subroutine extract_massbalcond !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine save_constitutions !\begin{verbatim} subroutine save_constitutions(ceq,copyofconst) ! copy the current phase amounts and constituitions to be restored ! if calculations fails during step/map ! DANGEROUS IF NEW COMPOSITION SETS CREATED implicit none TYPE(gtp_equilibrium_data), pointer :: ceq double precision, allocatable, dimension(:) :: copyofconst !\end{verbatim} %+ integer varresx,nz,ij,syfr,allsize ! calculate dimension of copyofconst nz=0 ! skippa varres with index 1, that is the reference phase ! do varresx=2,csfree-1 do varresx=2,highcs if(allocated(ceq%phase_varres(varresx)%yfr)) then ! NOTE size( ... ) can return reasonable value even if not allocated !!! ! BUT why is phas_varres(varresx)%yfr it not allocated ??? ! evidently the composition set for varresx is created ... maybe removed?? syfr=size(ceq%phase_varres(varresx)%yfr)+1 else syfr=1 endif ! write(*,12)'3X Varres record and size: ',varresx,1+syfr,nz 12 format(a,3i5) nz=nz+2+syfr enddo allsize=nz+1 ! write(*,*)'3X In save_constitution',highcs,allsize allocate(copyofconst(allsize)) ! modification due to problems, save allocated size in first word copyofconst(1)=allsize nz=2 ! do varresx=2,csfree-1 do varresx=2,highcs ! save 1+syfr values for each composition set ! segmentation fault in this loop for stepbug (>20 elements COST507) ! crash happends when higher composition sets are stored ... ! SAVE also the amount of the phase, DGM and the size of yfr!! copyofconst(nz)=ceq%phase_varres(varresx)%amfu copyofconst(nz+1)=ceq%phase_varres(varresx)%dgm ! varresx is 1 higher than phase index ! if(copyofconst(nz).gt.zero) & ! write(*,*)'3X saving amount: ',varresx-1,nz,copyofconst(nz) nz=nz+1 if(allocated(ceq%phase_varres(varresx)%yfr)) then syfr=size(ceq%phase_varres(varresx)%yfr) else ! write(*,*)'3X no fractions for: ',varresx-1,nz+1 syfr=0 endif ! write(*,16)'3X Storing varres record: ',varresx,syfr,size(copyofconst),nz 16 format(a,5i5) ! the segmentation fault seems not to be the allocation of copyofconst but ! rather that we cannot access the yfr in ceq%phase_varres(varresx) ! for the extra composition sets created by gridmin copyofconst(nz+1)=syfr nz=nz+1 do ij=1,syfr copyofconst(nz+ij)=ceq%phase_varres(varresx)%yfr(ij) enddo nz=nz+1+syfr enddo ! write(*,*)'3x saved size in word 1: ',highcs,allsize,nz-1 1000 continue return end subroutine save_constitutions !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine restore_constitutions !\begin{verbatim} %- subroutine restore_constitutions(ceq,copyofconst) ! restore the phase amounts and constitutions from copyofconst ! if calculations fails during step/map ! DANGEROUS IF NEW COMPOSITION SETS CREATED implicit none TYPE(gtp_equilibrium_data), pointer :: ceq double precision copyofconst(*) !\end{verbatim} integer nz,varresx,ij,syfr,savedsyfr,sizeofcopy ! size of copyofconst in first word ! segmentation fault from smp2A running step-epz.OCM sizeofcopy=int(copyofconst(1)) ! write(*,*)'3X restoring constitution: ',highcs,sizeofcopy ! skippa varres with index 1, that is the reference phase ! do varresx=2,csfree-1 nz=2 do varresx=2,highcs ! note varresx is index of phase_varres, always 1 bigger than phase index ! if(copyofconst(nz).gt.zero) & ! write(*,*)'3X restore amount: ',varresx-1,nz,copyofconst(nz) ceq%phase_varres(varresx)%amfu=copyofconst(nz) ceq%phase_varres(varresx)%dgm=copyofconst(nz+1) if(allocated(ceq%phase_varres(varresx)%yfr)) then syfr=size(ceq%phase_varres(varresx)%yfr) else syfr=0 endif ! fraction records may have been allocated!! use saved syfr nz=nz+2 savedsyfr=int(copyofconst(nz)) if(savedsyfr.eq.0 .or. savedsyfr.ne.syfr) then ceq%phase_varres(varresx)%dgm=-one ! write(*,12)'Restore saved size for phase: ',varresx-1,nz-2,syfr,& ! int(copyofconst(nz)),copyofconst(nz-2),& ! ceq%phase_varres(varresx)%dgm 12 format(a,4i5,2(1pe12.4)) syfr=savedsyfr endif do ij=1,syfr ceq%phase_varres(varresx)%yfr(ij)=copyofconst(nz+ij) enddo ! write(*,17)varresx-1,nz,syfr,ceq%phase_varres(varresx)%amfu,& ! (ceq%phase_varres(varresx)%yfr(ij),ij=1,syfr) 17 format('3X r:',i2,2i3,6(1pe12.4)) nz=nz+1+syfr if(nz-1.gt.sizeofcopy) write(*,*)'3X problem restore:',varresx,nz enddo 1000 continue ! gx%bmperr=4399 return end subroutine restore_constitutions !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine save_phase_constitutions !\begin{verbatim} subroutine save_phase_constitutions(rw,ceq,copyofconst) ! copy the current phase amounts and constituitions to be restored ! trying to fix problems with saving invariants ! compared to reoutines above here abnorm is also saved ... ! rw=0 if save, 1 if restore ! NOTE different ceq may be used for save and restore! implicit none integer rw TYPE(gtp_equilibrium_data), pointer :: ceq double precision, allocatable, dimension(:) :: copyofconst !\end{verbatim} %+ integer varresx,nz,ij,syfr,allsize,savedsyfr,sizeofcopy if(rw.eq.0) then ! calculate dimension of copyofconst nz=0 ! Calculate space needed ! All phases saved idependent of status ! skippa varres with index 1, that is the reference phase do varresx=2,highcs if(allocated(ceq%phase_varres(varresx)%yfr)) then syfr=size(ceq%phase_varres(varresx)%yfr)+1 else syfr=1 endif ! ionic liquid model require more data saved (see set_constitution) ij=ceq%phase_varres(varresx)%phlink if(btest(phlista(ij)%status1,PHIONLIQ)) then write(*,*)'3X cannot save ionic liquid constitutions' gx%bmperr=4399; goto 1000 endif ! we should save 5 reals in addition to the fractions nz=nz+5+syfr enddo allsize=nz+2 allocate(copyofconst(allsize)) ! modification due to problems, save allocated size in first word copyofconst(1)=allsize copyofconst(2)=highcs nz=3 do varresx=2,highcs ! save 1+syfr values for each composition set ! SAVE also the amount of the phase, DGM and the size of yfr!! copyofconst(nz)=ceq%phase_varres(varresx)%amfu copyofconst(nz+1)=ceq%phase_varres(varresx)%abnorm(1) copyofconst(nz+2)=ceq%phase_varres(varresx)%abnorm(2) copyofconst(nz+3)=ceq%phase_varres(varresx)%abnorm(3) copyofconst(nz+4)=ceq%phase_varres(varresx)%dgm if(allocated(ceq%phase_varres(varresx)%yfr)) then syfr=size(ceq%phase_varres(varresx)%yfr) else syfr=0 endif copyofconst(nz+5)=syfr nz=nz+5 do ij=1,syfr copyofconst(nz+ij)=ceq%phase_varres(varresx)%yfr(ij) enddo nz=nz+syfr+1 enddo write(*,*)'3X saved constitution: ',allsize,nz else ! restore saved amounts and fractions if(.not.allocated(copyofconst)) then write(*,*)'3X no constitutions saved!' gx%bmperr=4399; goto 1000 endif sizeofcopy=int(copyofconst(1)) if(copyofconst(2).ne.highcs) then write(*,*)'3X number of phase tuples not the same' gx%bmperr=4399; goto 1000 endif nz=3 do varresx=2,highcs ! note varresx is index of phase_varres, always 1 bigger than phase index ceq%phase_varres(varresx)%amfu=copyofconst(nz) ceq%phase_varres(varresx)%abnorm(1)=copyofconst(nz+1) ceq%phase_varres(varresx)%abnorm(2)=copyofconst(nz+2) ceq%phase_varres(varresx)%abnorm(3)=copyofconst(nz+3) ceq%phase_varres(varresx)%dgm=copyofconst(nz+4) if(allocated(ceq%phase_varres(varresx)%yfr)) then syfr=size(ceq%phase_varres(varresx)%yfr) else syfr=0 endif ! fraction records may have been allocated!! use saved syfr nz=nz+5 savedsyfr=int(copyofconst(nz)) if(savedsyfr.eq.0 .or. savedsyfr.ne.syfr) then write(*,*)'3X phase with zero saved fractions' ceq%phase_varres(varresx)%dgm=-one syfr=savedsyfr endif do ij=1,syfr ceq%phase_varres(varresx)%yfr(ij)=copyofconst(nz+ij) enddo nz=nz+1+syfr enddo if(nz-1.gt.sizeofcopy) write(*,*)'3X problem restore:',sizeofcopy,nz endif 1000 continue return end subroutine save_phase_constitutions !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine calc_eec_gibbsenergy !\begin{verbatim} subroutine calc_eec_gibbsenergy(phres,ceq) ! calculate an ideal Gibbs energy with just configurational entropy ! phres is pointer to phase_varres record for the phase ! for a solid phase with higher entropy than the liquid ! G = RT \sum_s a_s \sum_i y_si \ln(y_si) ! dG/dy_si = RT a_s (1+ln(y_si)) ! d2G/dy_si^2 = RT a_s/y_si all other 2nd derivatives zero implicit none TYPE(gtp_phase_varres), pointer :: phres TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer lokph,sl,i1,i2,kk double precision sconf,tval,as ! this is the index of the phase in phlista with phase structure lokph=phres%phlink ! zero all second derivatives of G, the diagonal added below kk=phlista(lokph)%tnooffr*(phlista(lokph)%tnooffr+1)/2 do i1=1,kk phres%d2gval(1,i1)=zero enddo kk=0 sconf=zero tval=ceq%tpval(1) do sl=1,phlista(lokph)%noofsubl as=phres%sites(sl) do i1=1,phlista(lokph)%nooffr(sl) kk=kk+1 sconf=sconf+as*phres%yfr(kk) phres%dgval(1,kk,1)=as*(one+log(phres%yfr(kk))) phres%dgval(2,kk,1)=phres%dgval(2,kk,1)/tval phres%d2gval(kxsym(kk,kk),1)=as/phres%yfr(kk) enddo enddo ! return values divided by RT phres%gval(1,1)=sconf 1000 continue end subroutine calc_eec_gibbsenergy !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine setendmemarr !\begin{verbatim} subroutine setendmemarr(lokph,ceq) ! stores the pointers to all ordered and disordered endmemners in arrays ! intended to allow parallel calculation of parameters ! UNUSED ?? implicit none integer lokph TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer ll,nz,noemr TYPE(gtp_endmember), pointer :: emrec TYPE(gtp_fraction_set), pointer :: disfraset if(allocated(phlista(lokph)%oendmemarr)) then deallocate(phlista(lokph)%oendmemarr) ! allways allocate place for maximum endmembers (product of constituents) nz=1 do ll=1,phlista(lokph)%noofsubl nz=nz*phlista(lokph)%nooffr(ll) enddo allocate(phlista(lokph)%oendmemarr(nz)) noemr=0 emrec=>phlista(lokph)%ordered do while(associated(emrec)) noemr=noemr+1 phlista(lokph)%oendmemarr(noemr)%p1=>emrec emrec=>emrec%nextem enddo phlista(lokph)%noemr=noemr endif ! same for disordered endmembers (if any) ! Data for this is stored in phase_varres record, same index as phlista !!! if(allocated(phlista(lokph)%dendmemarr)) then deallocate(phlista(lokph)%dendmemarr) ! allways allocate place for maximum endmembers (product of constituents) disfraset=>ceq%phase_varres(lokph)%disfra nz=1 do ll=1,disfraset%ndd nz=nz*disfraset%nooffr(ll) enddo allocate(phlista(lokph)%dendmemarr(nz)) noemr=0 emrec=>phlista(lokph)%disordered do while(associated(emrec)) noemr=noemr+1 phlista(lokph)%dendmemarr(noemr)%P1=>emrec emrec=>emrec%nextem enddo phlista(lokph)%ndemr=noemr endif 1000 continue return end subroutine setendmemarr !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine tabder !\begin{verbatim} subroutine tabder(iph,ics,times,ceq) ! tabulate derivatives of phase iph with current constitution and T and P implicit none integer iph,ics,times TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} character name*24 double precision kappa,napfu,t,p,rtg,g,v,s,h,u,f,cp,alpha,cpu1,cpu2 integer tnk,lokph,nsl,lokres,lokcs,ll,ll2,kk1,kk2,kk3,kk4,loksp ! ! For time measurements ! lokph=len(name) lokph=phases(iph) nsl=phlista(lokph)%noofsubl ! calculate G and derivatives, lokres returns index of phase_varres call cpu_time(cpu1) do loksp=1,times call calcg(iph,ics,2,lokres,ceq) if(gx%bmperr.ne.0) then goto 1000 endif enddo call cpu_time(cpu2) ! number of moles of atoms per formula unit napfu=ceq%phase_varres(lokres)%abnorm(1) T=ceq%tpval(1) P=ceq%tpval(2) rtg=globaldata%rgas*T lokcs=lokres ! returned values: G, G.T=-S, G.P=V, G.T.T=-Cp/T G.T.P=V*alpha, G.P.P=-V*kappa ! all divided by RT and per mole formula unit of phase ! G=H-TS, F=U-TS, H=U+PV, S=-G.T, V=G.P ! H=G+TS=G-T*G.T, U=H-PV=(G-T*G.T)-P*G.P, CP=-T*G.T.T ! alpha= 1/V*V.T = G.T.P/V, kappa = -1/V*V.P = -G.P.P/V G=rtg*ceq%phase_varres(lokcs)%gval(1,1) ! write(*,5)'3X tabder 2: ',rtg,G S=-rtg*ceq%phase_varres(lokcs)%gval(2,1) V=rtg*ceq%phase_varres(lokcs)%gval(3,1) H=G+T*S U=H-P*V F=U-T*S CP=-T*rtg*ceq%phase_varres(lokcs)%gval(4,1) if(V.ne.zero) then alpha=rtg*ceq%phase_varres(lokcs)%gval(5,1)/V kappa=rtg*ceq%phase_varres(lokcs)%gval(6,1)/V else alpha=zero kappa=zero endif write(kou,100)napfu,rtg,T,P,G,G/rtg 100 format(/'Per mole FORMULA UNIT of the phase, ',1pe12.4,' atoms/F.U., RT=',& 1pe15.7/& 'at T= ',0pF8.2,' K and P= ',1PE13.6,' Pa',8x,'SI units',9x,'/RT'/ & 'Gibbs energy J/FU ',28('.'),1Pe16.8,e16.7) write(kou,102)F,F/rtg,H,H/rtg,U,U/rtg,S,S/rtg,V,V/rtg,& CP,CP/rtg,alpha,alpha/rtg,kappa,kappa/rtg 102 format('Helmholtz energy J/FU ',24('.'),1PE16.8,e16.7 & /'Enthalpy J/FU ',32('.'),1PE16.8,e16.7 & /'Internal energy J/FU ',25('.'),1PE16.8,e16.7 & /'Entropy J/FU/K ',31('.'),1PE16.8,e16.7 & /'Volume m3/FU ',34('.'),1PE16.8,e16.7 & /'Heat capacity J/FU/K ',25('.'),1PE16.8,e16.7 & /'Thermal expansion 1/K ',25('.'),1PE16.8,e16.7 & /'Bulk modulus m2/N ',29('.'),1PE16.8,e16.7) tnk=phlista(lokph)%tnooffr ll=1 kk1=0 kk2=phlista(lokph)%nooffr(ll) dy1loop: do while(kk1.le.tnk) kk1=kk1+1 if(kk1.gt.kk2) then ! write(*,11)'3X tabder 2: ',kk1,kk2,ll,tnk,nsl !11 format(a,10i3) ll=ll+1 if(ll.gt.nsl) exit kk2=kk2+phlista(lokph)%nooffr(ll) endif if(phlista(lokph)%nooffr(ll).eq.1) then ! write(*,*)'3X tabder 1: ',kk1,kk2,ll,tnk ll=ll+1 if(ll.gt.nsl) exit kk2=kk2+phlista(lokph)%nooffr(ll) cycle endif loksp=phlista(lokph)%constitlist(kk1) name=splista(loksp)%symbol write(kou,110)name(1:len_trim(name)),ll 110 format('First partial derivative with respect to ',a,& ' in sublattice ',i2,' of') write(kou,120)rtg*ceq%phase_varres(lokcs)%dgval(1,kk1,1),& ceq%phase_varres(lokcs)%dgval(1,kk1,1),& rtg*(ceq%phase_varres(lokcs)%dgval(1,kk1,1)-& T*ceq%phase_varres(lokcs)%dgval(2,kk1,1)),& ceq%phase_varres(lokcs)%dgval(1,kk1,1)-& T*ceq%phase_varres(lokcs)%dgval(2,kk1,1),& rtg*ceq%phase_varres(lokcs)%dgval(2,kk1,1),& ceq%phase_varres(lokcs)%dgval(2,kk1,1),& rtg*ceq%phase_varres(lokcs)%dgval(3,kk1,1),& ceq%phase_varres(lokcs)%dgval(3,kk1,1) 120 format(5x,'G ',40('.'),1PE16.8,e16.7, & /5x,'H ',40('.'),1PE16.8,e16.7, & /5x,'G.T ',38('.'),1PE16.8,e16.7, & /5x,'G.P ',38('.'),1PE16.8,e16.7) kk3=kk1 kk4=kk2 ll2=ll write(kou,150) 150 format(5x,'Second partial derivative of Gibbs energy with respect to also') dy2loop: do while(kk3.le.tnk) if(phlista(lokph)%nooffr(ll2).gt.1) then ! write(kou,160)name(1:len_trim(name)),ll2, & write(kou,160)name,ll2, & rtg*ceq%phase_varres(lokcs)%d2gval(ixsym(kk1,kk3),1),& ceq%phase_varres(lokcs)%d2gval(ixsym(kk1,kk3),1) 160 format(10x,a,' in ',i2,5('.'),1PE16.8,e16.7) endif kk3=kk3+1 if(kk3.le.tnk) then loksp=phlista(lokph)%constitlist(kk3) name=splista(loksp)%symbol endif if(kk3.gt.kk4) then ll2=ll2+1 if(ll2.gt.nsl) exit kk4=kk4+phlista(lokph)%nooffr(ll2) endif enddo dy2loop ! write(*,*)'3X tabder 7A: ',kk1,kk2 enddo dy1loop 900 continue if(times.gt.1) then write(*,11)times,cpu2-cpu1,1.0D6*(cpu2-cpu1)/dble(times) 11 format('CPU times for ',i6,' calculations: ',1pe15.7,' s, ',1pe15.7,' ms') endif ! write(*,*)'3X tabder 7B: ',kk2 ! write(*,*)'3X tabder: ',rtg,rtg*phase_varres(lokcs)%gval(1,1) 1000 continue return end subroutine tabder !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/! ================================================ FILE: src/models/gtp3XQ.F90 ================================================ ! ! gtp3XQ for for MQMQA ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !> 15B. Section: calculate G and other things for MQMQA and Toop/Kohler !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! ! removed debug output !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine config_entropy_mqmqa !\begin{verbatim} subroutine config_entropy_mqmqa1(phvar,moded,lokph,tval) ! dummy implicit none type(gtp_phase_varres), pointer :: phvar integer moded,lokph double precision tval ! modified arguments for call integer ncon type(gtp_species) :: sprec ! fq is max number of quads ! fz max number of constituents on a sublattice ! f1s dimension for other arrays ceff1 etc ! integer, parameter :: fq=99, fz=20, f1=50 integer, parameter :: fq=20, fz=10, f1s=50 ! max allower error in sum ceqf1=1 and ceqf2=1 double precision, parameter :: ceqferr=1.0D-7 ! number of pairs and sublattice fractions integer noofpair,ncons1,ncons2 ! not needed .... ! integer loksp,nspel,ielno(10),nextra,ncation ! these are used to as index of species on sublatte 1 (ee,ff) and 2 (gg,hh) integer ee,ff,gg,hh ! loop variables integer s1,s2,s3,s4,em,c1 ! pointer? to mqmqaf record with all fraction records ! site fractions and amounts ! double precision yy1(fz),yy2(fz),nn1(fz),nn2(fz) double precision yy1(fz),yy2(fz) ! fractions in sublattices double precision sum1,sum2,sum3,sum4,half ! contyp(1-4,i) specify sublattice +/- of element and if alone or mixing 2/1 ! contyp(5,i) is is the pair index for a quadrupols that is a pair ! contyp(6-7,i) for a pair are species index ! contyp(8-9,i) for a pair are ZERO ! contyp(6-9,i) for other quadrupols are pair indices (2 or 4 indicies) ! contyp(10,i) should be i ... just as a check ! contyp(11,i) for a pair is constituent index in sublattice 1 ! contyp(12,i) for a pair is constituent index in sublattice 1 ! contyp(11-12,i) for other quadrupoles are zero integer em1,em2,em3,em4,mpj ! %pinq(pair) is index in %contyp for a pair ! cridx(pair_index) is the index of corresponding quad %contyp(5,q) is pair ! integer cridx(f1) REDUNDANT ! Index to the 2-4 sublattice fractions associated with a quad ! integer fyqix(2,fq),fyqix2(2,fq) ! pair and coord.equiv fractions for pairs in a quad double precision pair(fq),ceqf1(fq),ceqf2(fq) ! test correct way to calculate pair fraction double precision cpair(fq),dcpair(fq,fq),cpairsum,dcpairsum(fq),dp(fq,fq) double precision spair(fq) ! various factors double precision sm1,term,fffy,fff1,fff2 double precision ffem,ffceq1,ffceq2,once1,once2 ! indicate which species that are involved in a quadrupole ! integer involved(noofsp),stoix1,stoix2 ! species in sublatice 1 and 2 integer nspin(2),eesub,ggsub ! first and second derivatives wrt constituents ... ! double precision dma1 is coefficent of site fraction in subl 1 for quad ! double precision dms1 is sum of coefficents in subl 1 for a quad i ! sum each part separately double precision tsub,dvvv(fq,fq),lsub(fq),tend double precision ssub,dssub(fq),send,dsend(fq),squad,dsquad(fq) double precision d2ssub(fq*(fq+1)/2) ! first index is sublattice constituent, second is quad index double precision b1iA(fz,fq),b2iX(fz,fq),b1iAB(fq),b2iXY(fq),sum1AB,sum2XY ! this should give stoichiometry of (species,quad) on the two sublattices double precision dmy1(fz,fq),dmy2(fz,fq) ! second derivatives d2xx of site fractions ... double precision d2yy1(fz,fq*(fq+1)/2),d2yy2(fz,fq*(fq+1)/2) double precision dpair(f1s,fq),dceqf(f1s,fq),yfrac,dummy1,dq1,dq2,dq3 double precision dyy1(fz,fq),dyy2(fz,fq),dceqf1(f1s,fq),dceqf2(f1s,fq) double precision dsm1(fq),d2sm1(fq*(fq-1)/2),dterm(fq),ojoj,alone1,alone2 character conname*24,endname*24,spname1*24,spname2*24,connames(fq)*24 double precision endkvot(fq),dendkvot(fq,fq),d2endkvot(fq,fq*(fq+1)/2) double precision mulceq(f1s),dmulceq(f1s,fq*(fq+1)/2),divisor ! this is a scaling with total amount of atoms double precision invnorm,fqq,pairceq ! quad entropy rewritten ... integer pair1,pair2,pair3,pair4,e2,f2,g2,h2 ! save here the indices of constituents in sublattices of pairs ! needed for the charge equivalent fractions, ceqf1 and ceqf2 ! MAYBE NOT NEEDED when %contyp(11..12,quad) have constituent indices? integer eij(2,fq),nomix,all2,q1,s7,s8 ! modfied AB/XY loop requires, pq is pair indices, subcon is sublattices indices ! pqq is pair index in %contyp ... ! fq is index in corresponding %constoi integer pq(4),pqq(4),sq1(2),sq2(2),fq1(2),fq2(2) ! test of indexing problem integer line757 ! to avoid adding quadrupols twice logical done,ddebug ! ! This is a maybe a reasonable place to initiate csumx for excess parameters? ! if(allocated(mqmqa_data%csumx)) then ! this is used in calc_mqmqa to skip excess terms with very small fractions. ! write(*,*)'3XQ Maybe initiating csumx to FALSE' ! initiating here leads to failed convergece, initiated now in calcg_internal ! mqmqa_data%csumx=.FALSE. ! endif ncon=phlista(lokph)%tnooffr ddebug=.FALSE. ! ddebug=.TRUE. if(ddebug) write(*,*)'3X in config_entropy_mqmqa1',lokph,moded,ncon ! phrec=phlista(lokph) invnorm=phvar%abnorm(1) ! invnorm=one ! phvar%abnorm(1)=one ! phvar%abnorm(1)=one ! We should probably update abnorm(2) and (3) also ... ! phvar%abnorm(2)=invnorm*phvar%abnorm(2) ! phvar%abnorm(3)=invnorm*phvar%abnorm(3) ! ! write(*,'(a,i3,1pe12.3)')'3X in MQMQA, version 5: ',ncon,one/invnorm ! if(.not.allocated(mqmqa_data%contyp)) then write(*,*)'3X MQMQA missing constituent information' gx%bmperr=4399; goto 1000 endif if(ncon.ne.mqmqa_data%nconst) then write(*,*)'3Xncon, %nconst: ',ncon,mqmqa_data%nconst stop '3X constituent problems in mqmqa ...' endif 11 format(a,4(F5.2,2x)) ! write(*,*)'3X error return as unfinished' ! gx%bmperr=4399; goto 1000 ! if(.not.allocated(phvar%mqmqaf%yy1)) then ! THIS MOVED BELOW BUT SHOULD EVENTUALLY BE HERE ! allocating fraction arrayes for use in entropy an excess calculations ! write(*,*)'3X allocating phase_varres%mqmqaf arrays' ! allocate(phvar%mqmqaf%yy1(20)) ! allocate(phvar%mqmqaf%yy2(20)) !... add more ... ! endif ! to avoid typing too much (should mqmqaf be a target? no compiler error) ! problem allocating arrays to this pointer !!! ! mqf=>phvar%mqmqaf do s1=1,ncon ! wow, using phase constituent order to find quad name !! Keep it at present ! conname=splista(phrec%constitlist(mqmqa_data%contyp(10,s1)))%symbol conname=splista(phlista(lokph)%constitlist(mqmqa_data%contyp(10,s1)))%symbol connames(s1)=conname if(ddebug) write(*,3)s1,(mqmqa_data%contyp(s2,s1),s2=1,14),& (mqmqa_data%constoi(s2,s1),s2=1,4),phvar%yfr(s1),trim(conname) 3 format('3X mq:',i2,1x,4i2,1x,i3,1x,4i2,1x,i2,4i3,4F5.1,F5.2,1x,a) enddo if(ddebug) then do s1=1,ncon write(*,4)s1,(mqmqa_data%pp(s2,s1),s2=1,4),trim(connames(s1)) 4 format('3X pp:',i2,4(F8.5),2x,a) enddo endif ! write(*,'(a,20i3)')'3X pinq: ',(mqmqa_data%pinq(s1),s1=1,mqmqa_data%npair) ! write(*,6)phvar%yfr 6 format('3X y: ',9F7.4) ! maybe use mqf variables? Need allocation ! local variables can be replaced by those stored in phvar ! local fraction variables and derivatives yy1=zero; yy2=zero; pair=zero; ceqf1=zero; ceqf2=zero; b1iA=zero; b2iX=zero; dpair=zero; dceqf1=zero; dceqf2=zero b1iAB=zero; b2iXY=zero; dmy1=zero; dmy2=zero cpair=zero; dcpair=zero ! write(*,431)'3X d2S/Rx:',((phvar%d2gval(ixsym(s2,s3),1),s3=s2,ncon),s2=1,ncon) ! any species used below is indicated by a 1 or 2 depending on sublattice ! do s1=1,ncon ! if(mqmqa_data%contyp(5,s1).ne.s1) then ! write(*,*)'3X *** Warning %contyp index 10 not correct' ! endif ! enddo ! these count the sum of element and pair stoichiometries for a quad ! fyp=zero !---------------------------------------------------- ! the array species in each sublattice will have missing values !---------------------------------------------------- ! we must calculate a number of auxilliary fraction variables from the ! site fractions using mqmqa_data%contyp ! do s1=1,ncon ! write(*,14)'3X %%contyp: ',s1,(mqmqa_data%contyp(s7,s1),s7=1,14),& ! trim(connames(s1)) 14 format(a,i3,1x,4i2,1x,i3,1x,4i3,1x,i3,1x,4i3,1x,a) ! enddo mpj=mqmqa_data%npair if(ddebug) write(*,15)'3X pinq: ',mpj,(mqmqa_data%pinq(s1),s1=1,mpj) 15 format(a,i3,2x,20i4) nspin(1)=mqmqa_data%ncon1 nspin(2)=mqmqa_data%ncon2 ! noofpair=mqmqa_data%npair ! write(*,'(a,2i3,2x,i3)')'3X subl const and pairs: ',nspin,mpj noofpair=0 ! BIG LOOP OVER ALL QUADS, calculating fracions of pairs, sublattices etc sumfrac: do s1=1,ncon conname=connames(s1) if(mqmqa_data%contyp(10,s1).ne.s1) then write(*,212)s1,mqmqa_data%contyp(10,s1) 212 format('3XQ Warning: mqmqa_data%contyp(10,s1) =/= s1:',2i4) ! emergecy fix 17/12 2025 does not work ! mqmqa_data%contyp(10,s1)=s1 endif s3=mqmqa_data%contyp(5,s1) typ: if(s3.gt.0) then ! AN PAIR quadrupol AA:XX, increment the pair counter ! the index of the quadrupole fraction is in ALSO in contyp(10,s1) ! yfrac=phvar%yfr(mqmqa_data%contyp(10,s1)) yfrac=phvar%yfr(s1) ! Pair fractions has to be normallized later, here multiply with %pp noofpair=noofpair+1 pair(s3)=pair(s3)+yfrac dpair(s3,s1)=one cpair(s3)=cpair(s3)+yfrac*mqmqa_data%pp(1,s1) ! dcpair( pairindex, quadindex ) dcpair(s3,s1)=mqmqa_data%pp(1,s1) ! Calculating pairs ! write(*,'(a,2i3,7F8.4)')'3X pair1: ',s1,s3,one,yfrac,pair(s3),& ! mqmqa_data%pp(1,s1),cpair(s3),dcpair(s3,s1),dpair(s3,s1) ! all second derivatives of pair is zero ! the index of constituent in first sublattice is in %contyp(11,s1) ! ee is species index, eesub is index of species in sublattice ee=mqmqa_data%contyp(6,s1) eesub=mqmqa_data%contyp(11,s1) eij(1,noofpair)=eesub ! the index of constituent in second sublattice is in %contyp(12,s1) gg=mqmqa_data%contyp(7,s1) ggsub=mqmqa_data%contyp(12,s1) eij(2,noofpair)=ggsub ! ee and gg are pair indices, eesub and ggsub sublatice const. indices ! write(*,50)'3X decode1: ',s1,ee,gg,eesub,ggsub 50 format(a,i3,5x,2i4,5x,2i4) spname1=splista(ee)%symbol spname2=splista(gg)%symbol ! remember which species that are used by marking them (only needed for pairs) ! this is the stoichiometric factors of the species in the pair fff1=2.0d0/mqmqa_data%constoi(1,s1) fff2=2.0d0/mqmqa_data%constoi(2,s1) ! else ! write(*,*)'3X contyp error 1: ',mqmqa_data%contyp(1,s1) ! gx%bmperr=4399; goto 1000 ! endif ! SAVE the location in sublattice array of species eesub in quad s1 ! eesub and ggsub are sublattice indices ! >>>>>>>>>>>>>>>>>>>>>>> .............. EQUATION B15 part 1 yy1(eesub)=yy1(eesub)+fff1*yfrac b1iA(eesub,s1)=fff1 ! write(*,12)'3X yy1 add1:',s1,eesub,1,yy1(eesub),fff1,yfrac 12 format(a,3i3,5F10.6) ! there is a single contribution from this quad to the site fractions b1iAB(s1)=fff1 yy2(-ggsub)=yy2(-ggsub)+fff2*yfrac b2iX(-ggsub,s1)=fff2 b2iXY(s1)=fff2 ! write(*,12)'3X yy2 add1:',s1,ggsub,2,yy2(-ggsub),fff2,yfrac ! equivalent sublattice fraction for the sublattice constituents ! >>>>>>>>>>>>>>>>>>>>>>>> .............. EQUATION B19 part 1 ceqf1(eesub)=ceqf1(eesub)+yfrac ceqf2(-ggsub)=ceqf2(-ggsub)+yfrac dceqf1(eesub,s1)=one dceqf2(-ggsub,s1)=one ! Calculating ceq ! write(*,333)'3X ceqf1e:',s1,0,0,1,eesub,ceqf1(eesub),& ! yfrac,one,1,trim(spname1),trim(connames(s1)) ! write(*,333)'3X ceqf2e:',s1,0,0,2,ggsub,ceqf2(-ggsub),& ! yfrac,one,2,trim(spname2),trim(connames(s1)) 333 format(a,1x,5i3,3F10.6,' ceq',i1,'(',a,') ',a) ! end of pair summations else !-------------------------------------------------------------- ! this is a quadrupol AB:XY consisting of 2 or 4 pairs typ A:X and B:Y ! the pair indices in %contyp are indicated in contyp(6..9,s1) ! IT IS A BIT INVOLVED AND CAN (certainly) BE SIMPLIFIED .... ffem=0.5D0 fffy=one yfrac=phvar%yfr(s1) if(mqmqa_data%contyp(9,s1).gt.0) then ! contyp(9,s1) nonzero for quadrupoles with 4 pairs A:X, A:Y, B:X, B:Y ! set ffem=0.25 if 4 pairs ffem=0.25D0 ! set fffy=0.5 to avoid adding same fraction twice fffy=0.5D0 endif ! these refer to constituent species, ff, gg in first; gg hh in second ! ee=0; ff=0; gg=0; hh=0 ! s2 loops over the species involved in the quadrupol, it can be 3 or 4 ! in %contyp(1..4,s1) is indicated if same species twice (2) or not (1) ! in %constoi(1..4,s1) is the coordination number ! s2 loops positions 1..4 in contyp and constoi ! these are used to find correct stoichimetry index ! which constoi to use? AA:XY should have (1,2) and (1,3) for AA:XX and AA:YY ! which constoi to use? AB:XX should have (1,3) and (2,3) for AA:XX and BB:XX ! which constoi to use? AB:XY should have (1,3), (1,4), (2,3) and (2,4) for ... ! position 6, 7, 8, 9 are indices to pairs, s2 incremented at loop end ! in the pairs %contyp(11,pairindex) and %contyp(12,pairindex) and subl index once1=one; once2=one; alone1=2.0d0; alone2=2.0d0 ffceq1=0.5D0; ffceq2=0.5D0 pq=0; sq1=0; sq2=0 ! pq are the pair indices, 2 or 4 ! but below we use pq as indices to mqmqa_data ... we need pinq(pq(j)) pq(1)=mqmqa_data%contyp(6,s1) pq(2)=mqmqa_data%contyp(7,s1) pqq(1)=mqmqa_data%pinq(pq(2)) pqq(2)=mqmqa_data%pinq(pq(2)) ! here we saved A and X assuming mixing in first sublattice ! we must also save the stoichiometric factors of the sublattice species sq1(1)=mqmqa_data%contyp(11,pqq(1)) ! fq1 this is index to %constoi for this sublattice constituent fq1(1)=1 sq2(1)=mqmqa_data%contyp(12,pqq(1)) fq2(1)=3 if((mqmqa_data%contyp(1,s1).eq.2)) then ! quadruplet AA:XY, pairs AA:XX and AA:YY ! Same constituents in first sublattice, indices in %contyp(11, %contyp(6,s1)) ! and %contyp(12, %contyp(7,s1)) ! mixing in second sublattice, same constituent twice in first sq1(2)=sq1(1) fq1(2)=fq1(1) ! replace stoichiometric factor fq2(1)=2 sq2(2)=mqmqa_data%contyp(12,pqq(2)) fq2(2)=3 alone2=one nomix=1 ! write(*,'(a,2i3,2x,2i3)')'3X mixing in 2: ',sq1,sq2 elseif(abs(mqmqa_data%contyp(3,s1)).eq.2) then ! quadrupole AB:XX, first pair AA:XX, second BB:XX ! Same constituents in second sublattice, indices in %contyp(11, %contyp(6,s1)) ! and %contyp(12, %contyp(7,s1)) ! mixing in first sublattice, same constituent twice in second sq2(2)=sq2(1) fq2(2)=fq2(1) ! add second sublattice constituent twice sq1(2)=mqmqa_data%contyp(11,pqq(2)) fq1(2)=2 alone1=one nomix=2 ! write(*,'(a,2i3,2x,2i3)')'3X mixing in 1: ',sq1,sq2 else ! quadupole AB:XY, 4 pairs used, AA:XX; AA:YY; BB:XX BB:YY ! 4 pairs, we have to add 2 more pq(3)=mqmqa_data%contyp(8,s1) pq(4)=mqmqa_data%contyp(9,s1) pqq(3)=mqmqa_data%pinq(pq(3)) pqq(4)=mqmqa_data%pinq(pq(4)) sq1(2)=mqmqa_data%contyp(11,pqq(3)) ! fq1(2)=2 fq2(2)=4 ! I am not sure how the pairs are arranged ! but testing 3 pairs the sublattice constituent must be different if(sq1(2).eq.sq1(1)) sq1(2)=mqmqa_data%contyp(11,pqq(2)) sq2(2)=mqmqa_data%contyp(12,pqq(2)) if(sq2(2).eq.sq2(1)) sq2(2)=mqmqa_data%contyp(12,pqq(2)) alone1=one; alone2=one nomix=4 ! write(*,*)'3X reciprocal cluster',mqmqa_data%contyp(2,s1) endif ! write(*,313)'3X pq mm: ',s1,pq,pqq,sq1,sq2,fq1,fq2 313 format(a,i3,2x,4i2,2x,4i2,4x,2i2,2x,2i2,4x,2i2,2x,2i2) ! contribution from all pairs included in this quadruple, nonzero pq pqloop: do s2=1,4 ! write(*,'(a,2i3)')'3x pqloop: ',s2,pq(s2) if(pq(s2).eq.0) exit pqloop pair(pq(s2))=pair(pq(s2))+ffem*yfrac dpair(pq(s2),s1)=ffem ! EMERGENCY, how to know which %pp to use for each pair??? ! modified in gtp3B to ensure that pairs are correlated with %constoi ?? ! s2 is assumed to be %pp index, pq(s2) constittuent index ... cpair(pq(s2))=cpair(pq(s2))+yfrac*mqmqa_data%pp(s2,s1) ! dcpair( pairindex, quadindex ) dcpair(pq(s2),s1)=mqmqa_data%pp(s2,s1) ! write(*,'(a,3i3,2F10.7)')'3X dcpair2: ',pq(s2),s1,s2,& ! yfrac,dcpair(pq(s2),s1) ! Calculating pairs in SNN ! write(*,'(a,3i3,6F10.6)')'3X pair2: ',s1,s2,pq(s2),ffem,yfrac,& ! pair(pq(s2)),mqmqa_data%pp(s2,s1),cpair(pq(s2)),& ! dcpair(pq(s2),s1) enddo pqloop ! write(*,'(a,i3,2x,2i3,2x,2i3)')'3X sqi: ',s1,sq1,sq2 s7=0 subloop: do s2=1,2 ! For the site fractions and equivalent fraction ceqfi we have to ! extract all constituent species of the quadrupol s1 using the pair s3 ! divided by with the coordination factor in s2 for quadrupol s1 ! the species in first sublattice of the pair if(sq1(s2).le.0) then write(*,*)'3X no constituent in first sublattice!!!',s1,s2,sq1 stop else ! We have to use the correct sublattice index and coordination factor !! ! eesub should be in mqmqa_data%contyp(10+s2,s1) ?? What is sq1(s2)? eesub=sq1(s2) eesub=mqmqa_data%contyp(10+s2,s1) ! write(*,'(a,3i3,F8.3)')'3X sublattice index: ',& ! eesub,sq1(s2),fq1(s2),mqmqa_data%constoi(s2,s1) ! SAVE the sublattice location of species eesub for quad s1 fff1=fffy*alone1/mqmqa_data%constoi(fq1(s2),s1) yy1(eesub)=yy1(eesub)+fff1*yfrac b1iA(eesub,s1)=fff1 ! write(*,13)'3X yy1 add2:',s1,s2,eesub,yy1(eesub),fff1*yfrac,& ! fff1,yfrac,fffy,alone1,mqmqa_data%constoi(fq1(s2),s1) 13 format(a,3i3,3F10.6,5(F6.3)) ! there can be more than one contribution to site fraction from this quad ! nomix=1 if single in 1 if(nomix.ne.1) then b1iAB(s1)=b1iAB(s1)+fff1 else b1iAB(s1)=fff1 endif ceqf1(eesub)=ceqf1(eesub)+fffy*ffceq1*yfrac dceqf1(eesub,s1)=fffy*ffceq1 endif !---------- second sublattice if(sq2(s2).gt.0) then ! constituent index is negative in second sublattice!! write(*,*)'3X no constituent in second sublattice!!!',s1,s2,sq2 write(*,14)'3X %contyp: ',s1,(mqmqa_data%contyp(s7,s1),s7=1,14) gx%bmperr=4399; goto 1000 else ! NOW the species in second sublattice of the pair NOTE negative ggsub=sq2(s2) ! SAVE the sublattice location of species eesub and ggsub for quad s1 ! fq1(s2) specify stoichiometry index of const. in 1st sublattice in AB/XY ! the species indexing in %contyp(11..14) is the same as for %constoi(1..4) ! fq2(s2) specify stoichiometry index of const. in 2nd sublattice in AB/XY fff2=fffy*alone2/mqmqa_data%constoi(fq2(s2),s1) yy2(-ggsub)=yy2(-ggsub)+fff2*yfrac ! write(*,13)'3X yy2 add2:',s1,ggsub,s2,yy2(-ggsub),fff2,yfrac,& ! fffy,alone2,mqmqa_data%constoi(fq2(s2),s1) 52 format(a,i3,5F8.5) b2iX(-ggsub,s1)=fff2 ! nomix=2 if single in sublattice 2 if(nomix.ne.2) then b2iXY(s1)=b2iXY(s1)+fff2 else b2iXY(s1)=fff2 endif 331 format('3Xq n(',a2,'): ',3i3,2i3,4F7.4,2x,a) ! equivalent site fraction, each mixing element will be counted twice ! for quadrupole with 4 pairs fffy=0.25; otherwice 0.5 ! >>>>>>>>>>>>>>>>>>> ................ EQUATION B17 part 2 ceqf2(-ggsub)=ceqf2(-ggsub)+fffy*ffceq2*yfrac dceqf2(-ggsub,s1)=fffy*ffceq2 ! write(*,333)'3X ceqf1q:',s1,0,s3,1,eesub,ceqf1(eesub),& ! yfrac,fffy*ffceq1,1,trim(spname1),trim(connames(s1)) ! write(*,333)'3X ceqf2q:',s1,0,s3,2,ggsub,ceqf2(-ggsub),& ! yfrac,fffy*ffceq2,2,trim(spname2),trim(connames(s1)) ! increment s2 for next pair in quadrupole s1 endif enddo subloop endif typ ! problem with pair fractions ... ! do s3=1,mpj ! write(*,'(a,2i3,5F10.7)')'3X loop:',s1,s3,(dpair(s3,s2),s2=1,ncon) ! write(*,'(a,2i3,5F10.7)')'3X loop:',s1,s3,(dcpair(s3,s2),s2=1,ncon) ! enddo enddo sumfrac ! write(*,*)'3X sumfrac done' ! !------------------------------ end BIG LOOP over all quads ! do s3=1,nspin(1) ! write(*,342)'3X b1iA(m,n):',s3,s1,(b1iA(s3,s4),s4=1,ncon) ! enddo ! write(*,341)'3X b1iAB(n) :',s1,(b1iAB(s4),s4=1,ncon) ! do s3=1,nspin(2) ! write(*,342)'3X b2iX(m,n):',s3,s1,(b2iX(s3,s4),s4=1,ncon) ! enddo ! write(*,341)'3X b2iXY(n) :',s1,(b2iXY(s4),s4=1,ncon) ! write(*,340)'3X yy1: ',(yy1(s4),s4=1,3) ! write(*,340)'3X yy2: ',(yy2(s4),s4=1,3) 340 format(a,7F10.7) 342 format(a,2i2,7F7.4) 720 format(a,i3,4(4I3,2x)) ! debug listings: ! write(*,*)'3X summed all amounts, next normallize' ! write(*,720)'3X contyp: ',0,((mqmqa_data%contyp(s2,s1),s2=11,14),s1=1,ncon) ! write(*,200)'3X p_AB/XY:',(phvar%yfr(s1),s1=1,ncon) ! write(*,200)'3X n1 :',(yy1(s1),s1=1,nspin(1)) ! write(*,200)'3X n2 :',(yy2(s1),s1=1,nspin(2)) ! write(*,200)'3X pairs :',(pair(s1),s1=1,noofpair) ! write(*,200)'3X cpairs :',(cpair(s1),s1=1,noofpair) ! do s1=1,noofpair ! write(*,200)'3X dcpairs:',(dcpair(s1,s2),s2=1,ncon) ! enddo ! write(*,200)'3X ceqf1 :',(ceqf1(s1),s1=1,nspin(1)) ! write(*,200)'3X ceqf2 :',(ceqf2(s1),s1=1,nspin(2)) ! stop ! do s3=1,nspin(1) ! write(*,342)'3X b1iA(m,n):',s3,s1,(b1iA(s3,s4),s4=1,ncon) ! enddo ! write(*,341)'3X b1iAB(n) :',s1,(b1iAB(s4),s4=1,ncon) ! do s3=1,nspin(2) ! write(*,342)'3X b2iX(m,n):',s3,s1,(b2iX(s3,s4),s4=1,ncon) ! enddo ! write(*,341)'3X b2iXY(n) :',s1,(b2iXY(s4),s4=1,ncon) 341 format(a,i2,7F10.7) !-------------- we have extracted all comp.variables and their deriv wrt quads ! Now sum amounts and normallize ! ! NOTE in b1iA and b1iA the first index is subl.const, second is quad ! sometimes I mix them up ... ! ! write(*,*)'Sublattice fractions and detivatives: ! first sublattice sum1AB=zero ! write(*,*)'3X nspin: ',nspin do s1=1,nspin(1) sum1AB=sum1AB+yy1(s1) ! write(*,88)'3X subl: ',s1,yy1(s1),(b1iA(s1,s2),s2=1,ncon) enddo 88 format(a,i2,F7.3,2x,9(F8.4)) ! write(*,'(a,F7.3,a)')'3X sum1AB: ',sum1AB do s1=1,nspin(1) yy1(s1)=yy1(s1)/sum1AB enddo ! second sublattice sum2XY=zero do s1=1,nspin(2) sum2XY=sum2XY+yy2(s1) ! write(*,88)'3X sub2: ',s1,yy2(s1),(b2iX(s1,s2),s2=1,ncon) enddo do s1=1,nspin(2) yy2(s1)=yy2(s1)/sum2XY enddo ! write(*,*)'3X nspin2: ',nspin ! derivatives of sublattice fractions wrt quads all2=ncon*(ncon+1)/2 d2yy1=zero dummy1=one/sum1AB**2 ! ixsym finds the sequential storage place of (i,j) in a symmetrical array ! write(*,538)ncon,ixsym(ncon,ncon),ixsym(5,3),nspin 538 format('3XQ entropy: ',3i5,' nspin: ',20i3) ! ! write(*,*)'3X d2yy1 size: ',fz,fq*(fq+1)/2,fz*fq*(fq+1)/2,all2 yder1: do s1=1,nspin(1) do s2=1,ncon ! b1iAB may contain contributions from two constituents in same quad dyy1(s1,s2)=(b1iA(s1,s2)-yy1(s1)*b1iAB(s2))/sum1AB ! cycle yder1 ! this gives phase matrix singuler do s3=1,ncon d2yy1(s1,ixsym(s2,s3))=& (-b1iA(s1,s2)*b1iAB(s3)-b1iA(s1,s3)*b1iAB(s2)+& 2.0D0*yy1(s1)*b1iAB(s2)*b1iAB(s3))*dummy1 ! write(*,19)'3X dyy: ',s1,s2,s3,b1iA(s1,s2),b1iAB(s3),& ! b1iA(s1,s3),b1iAB(s2),2.0D0*yy1(s1),d2yy1(s1,ixsym(s2,s3)) 19 format(a,3i2,6(1pe10.2)) enddo ! try ... gives also phase matrix singular ... ! d2yy1(s1,s1)=one/yy1(s1) enddo enddo yder1 ! debug ! do s1=1,nspin(1) ! do s3=s1,all2 ! s8=ixsym(s3,s1) ! write(*,'(a,4i4,1pe12.4)')'3X mqmqa d2yy1: ',s1,s3,s8,all2,d2yy1(s1,s8) ! write(*,87)'3X d2yyj: ',1,s1,(d2yy1(s1,s2),s2=1,all2) ! enddo ! enddo 87 format(a,2i3,6(1pe10.2)) d2yy2=zero dummy1=one/sum1AB**2 yder2: do s1=1,nspin(2) ! the line below works when there are no SRO quads (species) ! dyy2(s1,s1)=one; cycle yder2 ! below needed when yy2 calculated from quads do s2=1,ncon ! b2iXY may contain contributions from two constituents in same quads dyy2(s1,s2)=(b2iX(s1,s2)-yy2(s1)*b2iXY(s2))/sum2XY cycle yder2 do s3=1,ncon if(nspin(2).eq.1) then ! single sublattice fractions should not have any second derivaties ?? d2yy2(s1,ixsym(s2,s3))=zero else ! appoximate ... d2yy2(s1,ixsym(s2,s3))=& (-b2iX(s1,s2)*b2iXY(s3)-b2iX(s1,s3)*b2iXY(s2)+& 2.0D0*yy2(s1)*b2iXY(s2)*b2iXY(s3))*dummy1 endif enddo enddo enddo yder2 ! do s1=1,nspin(2) ! write(*,87)'3X d2yyj: ',2,s1,(d2yy2(s1,s2),s2=1,all2) ! enddo ! ------------------------------------------ ! calculate sublattice sites related to formula units ! dummy1=invnorm/(sum1AB+sum2XY) ! sum1AB=sum1AB*dummy1 ! sum2XY=sum2XY*dummy1 ! sum1AB=invnorm*sum1AB ! sum2XY=invnorm*sum2XY ! We have to sum and normalize cpair cpairsum=zero dcpairsum=zero dp=zero do s1=1,noofpair spair(s1)=cpair(s1) cpairsum=cpairsum+cpair(s1) do s2=1,ncon dcpairsum(s2)=dcpairsum(s2)+dcpair(s1,s2) dp(s1,s2)=dcpair(s1,s2) enddo enddo ! write(*,'(a,F10.6,2x,10(F8.4))')'3X cpsum:',cpairsum,& ! (dcpairsum(s2),s2=1,ncon) do s1=1,noofpair cpair(s1)=cpair(s1)/cpairsum do s2=1,ncon dcpair(s1,s2)=(cpairsum*dp(s1,s2)-spair(s1)*dcpairsum(s2))/cpairsum**2 enddo ! replacing pair here creates problems .... do it later ! pair(s1)=cpair(s1) ! Calculate derivatives of pairs wrt quads, NEEDED FOR REFERENCE STATE enddo ! do s1=1,noofpair ! write(*,119)'3X cpair: ',s1,cpair(s1),(dcpair(s1,s2),s2=1,ncon) ! enddo 119 format(a,i2,F10.7,2x,8F10.6) ! ! check pairs are unity ... this pair fraction is wrong anyway ... ! write(*,*)'3X pair fractions and derivatives:' dummy1=zero ! loop over all pairs do s1=1,noofpair ! Check sum is unity dummy1=dummy1+pair(s1) ! write(*,120)s1,pair(s1),(dpair(s1,s2),s2=1,ncon) enddo 120 format('3X pairs:',i3,F7.4,1x,10F6.3) if(abs(dummy1-one).gt.1.0D-12) then write(*,*)'3X pair fractions does not add up to unity',dummy1 write(*,'(a,10F7.4)')'3X pf: ',(pair(s1),s1=1,noofpair) gx%bmperr=4399; goto 1000 endif ! ! NOW list the Charge Equivalent Fractions, related to sublattices ! write(*,*)'3X Charge Equivalent fractions and derivatives:' dummy1=zero do s1=1,nspin(1) ! Check sum is unity dummy1=dummy1+ceqf1(s1) ! write(*,81)'3X ceqf:',1,ceqf1(s1),(dceqf1(s1,s2),s2=1,ncon) enddo if(abs(dummy1-one).gt.ceqferr) then write(*,*)'3X Sum of charge equivalent fractions on subl 1 not 1:',dummy1 write(*,'(a,7(F10.7))')'3X ceqf1: ',(ceqf1(s2),s2=1,nspin(1)) ! assume this will be the fixed when converged .... ! gx%bmperr=4399; goto 1000 endif dummy1=zero do s1=1,nspin(2) ! Check sum is unity dummy1=dummy1+ceqf2(s1) ! write(*,81)'3X ceqf:',2,ceqf2(s1),(dceqf2(s1,s2),s2=1,ncon) enddo if(abs(dummy1-one).gt.ceqferr) then write(*,*)'3X Sum of charge equivalent fractions on subl 2 not 1',dummy1 write(*,'(a,7(F10.7))')'3X ceqf2: ',(ceqf2(s2),s2=1,nspin(2)) ! assume this will be the fixed when converged .... ! gx%bmperr=4399; goto 1000 endif 81 format(a,i2,F7.4,1x,(10F7.4)) ! write(*,*)'3X all normallized fractions calculated' ! write(*,*)'3X error return as unfinished' ! gx%bmperr=4399 ! goto 1000 !--------------------------------------------------------------------------- ! 2021.08.24 derivatives of site fractions wrt quadrupoles?? !--------------------------------------------------------------------------- ! write(*,*)'3X quitting as not finished below' ! gx%bmperr=4399 ! goto 1000 ! fraction listings ! write(*,200)'3X p_AB/XY:',(phvar%yfr(s1),s1=1,ncon) ! write(*,200)'3X sites/FU :',sum1AB,sum2XY ! write(*,200)'3X y1 :',(yy1(s1),s1=1,nspin(1)) ! write(*,200)'3X y2 :',(yy2(s1),s1=1,nspin(2)) ! do s1=1,nspin(1) ! write(*,202)'3X dy1/dpi:',s1,(dyy1(s1,s2),s2=1,ncon) ! enddo ! do s1=1,nspin(2) ! write(*,202)'3X dy2/dpi:',s1,(dyy2(s1,s2),s2=1,ncon) ! enddo ! same as above ! write(*,200)'3X x_A/B :',(pair(s1),s1=1,noofpair) ! write(*,200)'3X ceqf1 :',(ceqf1(s1),s1=1,nspin(1)) ! write(*,200)'3X ceqf2 :',(ceqf2(s1),s1=1,nspin(2)) 200 format(a,(10F7.4)) 202 format(a,i2,(10F7.4)) ! write(*,*)'3X now the entropy: >>>>>>>>>>>>>' !-------------------------------------------------------------------------- ! Problems here!! ! COPY ALL FRACTIONS VARIABLES AND DERIVATIVES TO MQMQAF for use in parameters ! allocate all arrays if(.not.allocated(phvar%mqmqaf%yy1)) then ! allocate first time only!! ! mqf is phvar%mqmqaf phvar%mqmqaf%nquad=ncon; phvar%mqmqaf%npair=noofpair; phvar%mqmqaf%ns1=nspin(1); phvar%mqmqaf%ns2=nspin(2) ! write(*,207)nspin(1),nspin(2),ncon,noofpair 207 format('3XQ allocating phvar%mqmqaf arrays',2i3,4i5) allocate(phvar%mqmqaf%yy1(nspin(1))) allocate(phvar%mqmqaf%yy2(nspin(2))) allocate(phvar%mqmqaf%dyy1(nspin(1),ncon)) allocate(phvar%mqmqaf%dyy2(nspin(2),ncon)) allocate(phvar%mqmqaf%d2yy1(nspin(1),ncon*(ncon+1)/2)) allocate(phvar%mqmqaf%d2yy2(nspin(2),ncon*(ncon+1)/2)) allocate(phvar%mqmqaf%ceqf1(nspin(1))) allocate(phvar%mqmqaf%ceqf2(nspin(2))) allocate(phvar%mqmqaf%dceqf1(nspin(1),ncon)) allocate(phvar%mqmqaf%dceqf2(nspin(2),ncon)) allocate(phvar%mqmqaf%pair(noofpair)) allocate(phvar%mqmqaf%dpair(noofpair,ncon)) ! write(*,*)'3XQ allocation of d2yy2:',size(phvar%mqmqaf%d2yy2) ! else ! write(*,*)'3X copying data to phvar%mqmqaf arrays' endif ! write(*,*)'3X mqf arrays allocated' ! mqf=>phvar%mqmqaf ! ! write(*,*)'3X d2yy1: ',nspin(1),all2,size(phvar%mqmqaf%d2yy1) ! write(*,*)'3X d2yy1: ',nspin(1),all2,nspin(1)*all2 phvar%mqmqaf%yy1(1)=yy1(1) do s1=1,nspin(1) phvar%mqmqaf%yy1(s1)=yy1(s1) phvar%mqmqaf%ceqf1(s1)=ceqf1(s1) do s2=1,ncon phvar%mqmqaf%dyy1(s1,s2)=dyy1(s1,s2) phvar%mqmqaf%dceqf1(s1,s2)=dceqf1(s1,s2) enddo do s3=s1,ncon s8=ixsym(s3,s1) ! write(*,'(a,2i3,3i4)')'3X mqmqa: ',s1,s3,s8,ncon*(ncon+1)/2,all2 ! phvar%mqmqaf%d2yy1(s1,ixsym(s3,s2))=d2yy1(s1,ixsym(s3,s2)) ! This statement kills whole subroutine phvar%mqmqaf%d2yy1(s1,s8)=d2yy1(s1,s8) enddo enddo ! ! write(*,771)nspin(1),nspin(2),ncon do s1=1,nspin(2) phvar%mqmqaf%yy2(s1)=yy2(s1) phvar%mqmqaf%ceqf2(s1)=ceqf2(s1) do s2=1,ncon phvar%mqmqaf%dyy2(s1,s2)=dyy2(s1,s2) phvar%mqmqaf%dceqf2(s1,s2)=dceqf2(s1,s2) enddo !**************************************************************** ! write(*,*)'3XQ line 757 skipping a 2nd derivative' !**************************************************************** do s3=s1,ncon s8=ixsym(s3,s1) ! large dimension problem here ixsym is a function to access a symetric array ! write(*,671)s1,s3,s8,ixsym(s1,s8),size(d2yy2) 671 format('3XQ accessing d2yy2: ',3i4,2i7) ! phvar%mqmqaf%d2yy2(s1,s8)=d2yy2(s1,ixsym(s1,s8)) line757=max(line757,s1*ixsym(s1,s8)) enddo enddo ! write(*,*)'3XQ line 771: ',line757,s1*ixsym(s1,s8) ! do s1=1,noofpair ! this will later be replaced by cpair!! for entropy the old pair works better ! phvar%mqmqaf%pair(s1)=pair(s1) ! do s2=1,ncon ! phvar%mqmqaf%dpair(s1,s2)=dcpair(s1,s2) ! try using dpair .... ! phvar%mqmqaf%dpair=dpair(s1,s2) ! enddo ! enddo ! write(*,777)'3X mqf sub1 1 copied:',(phvar%mqmqaf%yy1(s1),s1=1,nspin(1)) ! write(*,777)'3X mqf sub1 2 copied:',(phvar%mqmqaf%yy2(s1),s1=1,nspin(2)) ! write(*,777)'3X mqf pair copied:',(phvar%mqmqaf%pair(s1),s1=1,noofpair) ! do s1=1,noofpair ! write(*,777)'3X mqf dpair:',phvar%mqmqaf%pair(s1),& ! (phvar%mqmqaf%dpair(s1,s2),s2=1,ncon) ! enddo 777 format(a,F10.7,2x,5(F10.6),(/5x,6F10.6)) !--------------------------------------------------------------------------- ! ENTROPY CALCULATION !--------------------------------------------------------------------------- ! separate documentation, i,j in first subl, k,l in second subl ! p_ijkl is cluster fraction; x_i site fraction; v_ik pair fraction ! w_i coordination equivalent site fraction; ! \sum_i y'_i ln(y'_i) + \sum_j y"_j ln(y"_j)+ subattice fractions ! ! \sum_i\sum_k v_ik ln(v_ik/(w_i w_k))+ pair fractions ! ! \sum_i\sum_k p_iikk ln(p_iikk/((v^4_ik/(w^2_i w^2_k)))+ ! \sum_i\sum_j\sum_k p_ijkk ln(p_ijkk/(2(v^2_ik v^2_jk)/(w_i w_j w^2_k)))+ ! \sum_i\sum_k\sum_l p_iikl ln(p_iikl/(2(v^2_ik v^2_il)/(w^2_i w_k w_l)))+ ! \sum_i\sum_j\sum_k\sum_l p_ijkl ln( ! p_ijkl/(4(v_ik v_il v_jk v_jl)/(w_i w_j w_k w_l))) !--------------------------------------------------------------------------- ! Discovered 21/10/20 with help by Mac Poschmann: ! The entropy is distributed on the quads, dS/dquad is the sum of ! the entropy contribution from sublattices, pairs and the quads ! is related to each separate quad! Use the dyy1(*,quadindex) etc !----------------------------------------------------------------- ! Here we calculate for one formula unit (FU) of the phase ! at the end we multiply with current number of atomes/FU !----------------------------------------------------------------- ! ssub=zero; dssub=zero dvvv=zero ! write(*,'(a,6(1pe12.4))')'3X quads: ',(phvar%yfr(q1),q1=1,ncon) ! NEW CODE, loop over all quads qsub: do q1=1,ncon ! Entropy from sublattices tsub=zero ! replace dsub with dvvv s7=0 quady: do s1=1,4 ! Entropy contribution from sublattice constituents for the quad s7=s7+1 s2=mqmqa_data%contyp(10+s1,q1) fqq=one if(s2.gt.0) then ! Specie in first sublattice >0, if a single species fqq=2 if(mqmqa_data%contyp(1,q1).eq.2) fqq=2.0d0 tsub=tsub+fqq*log(yy1(s2))/mqmqa_data%constoi(s7,q1) ! write(*,700)'3X ssub1: ',q1,s1,s2,s7,tsub,& ! fqq*log(yy1(s2))/mqmqa_data%constoi(s7,q1),fqq,yy1(s2),& ! mqmqa_data%constoi(s7,q1) 700 format(a,4i3,2(1pe12.4),4(0PF10.6)) ! the derivative of fqq*log(yy1(s2))/mqmqa_data%constoi wrt all quads! do s3=1,ncon dvvv(s3,q1)=dvvv(s3,q1)+& fqq*dyy1(s2,s3)/(yy1(s2)*mqmqa_data%constoi(s7,q1)) ! write(*,706)'3X dvvv1: ',q1,s2,s3,dvvv(s3,q1) 706 format(a,3i3,4(1pe12.4)) enddo elseif(s2.lt.0) then ! if a single species in second sublattice fqq=2 if(mqmqa_data%contyp(s1,q1).eq.2) fqq=2.0d0 tsub=tsub+log(yy2(-s2))/mqmqa_data%constoi(s7,q1) ! the derivative of fqq*log(yy2(s2))/mqmqa_data%constoi wrt all quads! do s3=1,ncon dvvv(s3,q1)=dvvv(s3,q1)+& fqq*dyy2(-s2,s3)/(yy2(-s2)*mqmqa_data%constoi(s7,q1)) ! write(*,706)'3X dvvv2: ',q1,s2,s3,dvvv(s3,q1) enddo else ! no more sublattice constituents exit quady endif ! exit if this is a pair if(mqmqa_data%contyp(5,q1).gt.0) exit quady enddo quady ! first derivatives, dSsub/dquad lsub(q1)=tsub ssub=ssub+phvar%yfr(q1)*tsub ! write(*,702)'3X ssub2: ',q1,ssub,phvar%yfr(q1),tsub 702 format(a,i3,5(1pe12.4)) enddo qsub ! correct first derivatives with respect to quads using dvvv ! do q1=1,ncon ! write(*,701)'3X dvvv: ',(dvvv(s1,q1),s1=1,ncon) ! enddo do q1=1,ncon dssub(q1)=lsub(q1) ! add on all derivatives wrt q1 from other entropy terms do s1=1,ncon dssub(q1)=dssub(q1)+phvar%yfr(s1)*dvvv(s1,q1) enddo enddo ! OK here ! write(*,701)'3X dssub: ',(dssub(q1),q1=1,ncon) ! write(*,701)'3X SSUB:',ssub,ssub*phvar%amfu,phvar%amfu,phvar%abnorm(1),& ! phvar%amfu*phvar%abnorm(1) 701 format(a,6(1pe12.4)) ! stop 600 format(a,1pe12.4,2x,6(1pe10.2)) !=============== ! skip the pair and quad contributions ! write(*,*)'3X Done sublattice entropy, skipping rest',squad ! goto 900 ! !------------------------------------------------------- ! pair entropy send=zero; dsend=zero quadcef: do q1=1,ncon tend=zero ! loop of all pairs of this quad s1=5 ! allpairs: do while(.TRUE. .and. s1.lt.10) allpairs: do while(.TRUE. .and. s1.lt.9) ! mqmqa_data%contyp(5,q1) is nonzero if the quad is a pair s2=mqmqa_data%contyp(s1,q1) if(s1.eq.5 .and. s2.ne.0) then ! the quad q1 is a pair with index s2, only one calculation with s2=q1 fqq=4.0D0 s1=10 else s1=s1+1 s2=mqmqa_data%contyp(s1,q1) ! s2 is now the index a pair in this SNN quad is in %contyp(6..9,q1) ! exit here ifthere is no pair if(s2.eq.0) exit allpairs ! fqq depends on q1 fqq=1.0D0 if(mqmqa_data%contyp(1,q1).eq.2) then fqq=2.0D0 elseif(mqmqa_data%contyp(3,q1).eq.-2) then fqq=2.0D0 endif endif ! Here s2 is a pair of the quadrupole q1. The pair fraction is pair(s2) ! which should be divided by ceqf1(1,s2)*ceqf2(2,s2) ! The logarithm should be multiplied by qfnnsnn for the pair. no more?? ! Entropy: quadfrac*\sum_s2 fqq*ln( pair(s2)/v_s2k/(w_i w_k))/%qfnnsnn(s2) ! MAYBE save values of "pair/(ceqf1*ceqf2)" and derivaties for later use?? ! REMEMBER ceqf1 is equivalent sublattice fraction ... what is eij(1,s2)?? ! eij(1..2,s2) are species in first and second sublattice of the pair ! BUT they are now in %contype(11,s2) and %contyp(12,s2) ??? ! KEEP eij as it is used as link from pair to sublattice constituents ! write(*,'(a,i3,2x,2i3,2x,2i3)')'3X keep eij?: ',s2,eij(1,s2),& ! eij(2,s2),mqmqa_data%contyp(11,s2),mqmqa_data%contyp(12,s2) ee=eij(1,s2); gg=-eij(2,s2) dq1=ceqf1(ee)*ceqf2(gg) mulceq(s2)=dq1 endkvot(s2)=pair(s2)/dq1 fqq=fqq/mqmqa_data%qfnnsnn(s2) ! >>>>>>>>>>>>>>>> ............. EQUATION B21 2nd line first half ! This is the entropy contribution from a pair of this quad ! %qfnnsnn is read from database ! %dfnnsnn can be different for different pairs, composition dependence??? ! But it should be a sum? or is that taken care of by the sum over p_AB/XY ?? tend=tend+fqq*log(endkvot(s2)) ! write(*,421)'3X pairs: ',q1,s1,s2,tend,endkvot(s2),& ! fqq/mqmqa_data%qfnnsnn(s2),fqq,mqmqa_data%qfnnsnn(s2) 421 format(a,3i3,5(1pe11.3)) ! first derivatives, note multiplied by p_AB/XY .... do s3=1,ncon if(s3.eq.q1) dsend(s3)=dsend(s3)+fqq*log(endkvot(s2)) dsend(s3)=dsend(s3)+fqq/endkvot(s2)*(& dpair(s2,q1)/(mulceq(s2))**2-& 2.0d0*pair(s2)/mulceq(s2)**4*(& ceqf1(ee)*dceqf2(gg,q1)+dceqf1(ee,q1)*ceqf2(gg))) ! skip 2nd derivatives ... enddo enddo allpairs ! Finally we must multiply the tend with the quad fraction send=send+phvar%yfr(q1)*tend ! derivatives of send wrt quad enddo quadcef ! ! ternary error before this ! write(*,600)'3X SEND: ',send,(dsend(s1),s1=1,ncon) !======================================================================== ! skip quad entropies ! write(*,*)'3X done pair entropies' ! write(*,*)'3X skipping quad entropies' ! goto 900 !========================== begin loop for all quads ! write(*,*)'3X quadropole entropies:' ! do s1=1,noofpair ! write(*,440)'3X dpair/dq: ',q1,(dpair(s1,s2),s2=1,ncon) ! enddo 440 format(a,i2,6(1pe10.2),(/20x,6e10.2)) squad=zero; dsquad=zero ! replaced s1 by q1 quadloop: do q1=1,ncon if(q1.ne.mqmqa_data%contyp(10,q1)) then ! TEST: the value in contyp(10,q1) should be q1 ... 260111/BoS WHY?? write(*,441)q1,mqmqa_data%contyp(10,q1),mqmqa_data%contyp(14,q1) 441 format('3X problems in %contyp with quad indexing:',3i5) ! gx%bmperr=4399; goto 1000 endif lsub=zero ! New code for the general case ! p_i ! p_i * log( ------------------------------------) ! xi_A/X*xi_B/X*xi_B/X*xi_B/Y ! --------------------------- ! w_A * w_B * w_X * w_Y ! s1=mqmqa_data%contyp(5,q1) if(s1.gt.0) then ! this is a pair pair1=s1 pair2=pair1 pair3=pair1 pair4=pair1 ee=eij(1,pair1) ff=ee gg=-eij(2,pair1) hh=gg ! before adding this write statement hh was sometines not same as gg ! as it should be SUCK ! write(*,*)'3X gg hh: ',gg,hh,ceqf2(gg),ceqf2(hh) fqq=one ! write(*,'(a,10i3)')'3X quad1: ',q1,pair1,pair2,pair3,pair4,ee,ff,gg,hh elseif(mqmqa_data%contyp(9,q1).eq.0) then ! here either ee=ff or gg=hh pair1=mqmqa_data%contyp(6,q1) pair2=pair1 ee=eij(1,pair1) gg=-eij(2,pair1) pair3=mqmqa_data%contyp(7,q1) pair4=pair3 ff=eij(1,pair3) hh=-eij(2,pair3) fqq=2.0d0 ! write(*,'(a,10i3)')'3X quad2: ',q1,pair1,pair2,pair3,pair4,ee,ff,gg,hh else ! all ee, ff, gg, hh should be different, not certain if they are pair1=mqmqa_data%contyp(6,q1) ee=eij(1,pair1) gg=-eij(2,pair1) pair2=mqmqa_data%contyp(7,q1) ff=eij(1,pair2) hh=-eij(2,pair2) pair3=mqmqa_data%contyp(8,q1) if(ee.eq.ff) ff=eij(1,pair3) if(gg.eq.hh) hh=-eij(2,pair3) pair4=mqmqa_data%contyp(9,q1) fqq=4.0D0 ! write(*,'(a,10i3)')'3X quad4: ',q1,pair1,pair2,pair3,pair4,ee,ff,gg,hh endif ! ! write(*,'(a,8F8.4)')'3X quadx: ',pair(pair1),ceqf1(ee),& ! pair(pair2),ceqf1(ff),pair(pair3),ceqf2(gg),pair(pair4),ceqf2(hh) pairceq=fqq*pair(pair1)/ceqf1(ee)*pair(pair2)/ceqf1(ff)*& pair(pair3)/ceqf2(gg)*pair(pair4)/ceqf2(hh) ! write(*,'(a,9i3,1pe12.4)')'3X quadx: ',q1,pair1,pair2,pair3,pair4,& ! ee,ff,gg,hh,pairceq ! squad=squad+phvar%yfr(q1)*log(phvar%yfr(q1)/pairceq) ! write(*,440)'3X squad: ',q1,squad,phvar%yfr(q1),pairceq ! ! New code for the general case ! p_i ! p_i * log( ------------------------------------) ! xi_A/X*xi_B/X*xi_B/X*xi_B/Y ! --------------------------- ! w_A * w_B * w_X * w_Y ! ! loop for derivatives do s1=1,ncon if(s1.eq.q1) lsub(s1)=log(phvar%yfr(q1)/pairceq)+one if(s1.eq.q1) dsquad(s1)=dsquad(s1)+log(phvar%yfr(q1)/pairceq)+one ! derivative for just q1 is OK lsub(s1)=lsub(s1)-phvar%yfr(q1)*& (dpair(pair1,s1)/pair(pair1)+dpair(pair2,s1)/pair(pair2)+& dpair(pair3,s1)/pair(pair3)+dpair(pair4,s1)/pair(pair4)-& dceqf1(ee,s1)/ceqf1(ee)-dceqf1(ff,s1)/ceqf1(ff)-& dceqf2(gg,s1)/ceqf2(gg)-dceqf2(hh,s1)/ceqf2(hh)) ! Skipping this means I ignore effect of variable fracrion on pair and ceqf ! dsquad(s1)=dsquad(s1)-phvar%yfr(q1)*& ! (dpair(pair1,s1)/pair(pair1)+dpair(pair2,s1)/pair(pair2)+& ! dpair(pair3,s1)/pair(pair3)+dpair(pair4,s1)/pair(pair4)-& ! dceqf1(ee,s1)/ceqf1(ee)-dceqf1(ff,s1)/ceqf1(ff)-& ! dceqf2(gg,s1)/ceqf2(gg)-dceqf2(hh,s1)/ceqf2(hh)) ! skip 2nd derivatives ! write(*,440)'3X lsub: ',s1,(lsub(s2),s2=1,ncon) enddo ! write(*,440)'3X SQUAD: ',q1,squad,(dsquad(s1),s1=1,ncon) enddo quadloop ! ! write(*,600)'3X SQUAD: ',squad,(dsquad(s1),s1=1,ncon) ! first derivatives are wrong .... ! dsquad=zero ! write(*,*)'3X done quad derivatives' ! goto 900 ! !*********************************************************************** 900 continue ! we have multiplied with amounts above, (?) set invnorm=one ! write(*,*)'3X second derivatives are approximate. Atoms/FU: ',invnorm ! Values should be per formula unit! invnorm=one ! store results in appropriate places, values divided by RT ! This is G/RT phvar%gval(1,1)=phvar%gval(1,1)+invnorm*(ssub+send+squad) ! derivative of G wrt T, i.e. -S/R phvar%gval(2,1)=phvar%gval(2,1)+invnorm*(ssub+send+squad)/tval if(moded.gt.0) then ! This is if first derivatives are requested (must be exact) ! write(*,*)'3X start quad loop' do s1=1,ncon phvar%dgval(1,s1,1)=phvar%dgval(1,s1,1)+& invnorm*(dssub(s1)+dsend(s1)+dsquad(s1)) phvar%dgval(2,s1,1)=phvar%dgval(2,s1,1)+& invnorm*(dssub(s1)+dsend(s1)+dsquad(s1))/tval if(moded.gt.1) then ! this is if second derivatives are requested ! do s2=s1,ncon ! phvar%d2gval(ixsym(s1,s2),1)=phvar%d2gval(ixsym(s1,s2),1)+& ! invnorm*d2sm1(ixsym(s1,s2)) ! enddo ! We just set 1/quad dummy1=phvar%yfr(s1) if(dummy1.lt.1.0D-12) dummy1=1.0D-12 phvar%d2gval(ixsym(s1,s1),1)=one/dummy1 endif enddo ! write(*,*)'3X done quad loop' ! write(*,431)'3X dS/Rq :',(phvar%dgval(1,s1,1),s1=1,ncon) ! write(*,431)'3X d2S/Rq2:',(phvar%d2gval(s1,1),s1=1,all2) 431 format(a,6(1pe12.4),(/6x,6e12.4)) endif ! mqf=>phvar%mqmqaf ?? ! write(*,*)'3X pair do loop npair: ',phvar%mqmqaf%npair ! write(*,*)'3X pair do loop mqf%pair: ',allocated(phvar%mqmqaf%pair) ! write(*,'(a,3(1pe14.6))')'3X MQMQA:',phvar%gval(1,1),& ! phvar%gval(1,1)*8.31451,phvar%gval(1,1)*8.31451*phvar%amfu ! replace pair by cpair to handle endmembers ! Creates problems calculating the entropy in this routine ... SUCK ! write(*,*)'3X pair do loop mqf%dpair: ',allocated(phvar%mqmqaf%dpair) do s1=1,phvar%mqmqaf%npair phvar%mqmqaf%pair(s1)=cpair(s1) do s2=1,ncon phvar%mqmqaf%dpair(s1,s2)=dcpair(s1,s2) ! converge problems, maybe use dp? ! mqf%dpair(s1,s2)=dp(s1,s2) enddo enddo if(ddebug) write(*,*)'3X Done MQMQA configurational entropy' ! TEST temporary fix ! do s1=1,mqf%npair ! write(*,'(a,F9.6,2x,10F10.6)')'3X cpair: ',mqf%pair(s1),& ! (mqf%dpair(s1,s2),s2=1,mqf%nquad) ! enddo ! 1000 continue return end subroutine config_entropy_mqmqa1 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine calc_mqmqa !\begin{verbatim} subroutine calc_mqmqa(lokph,phres,ceq) ! Called from calcg_internal to calculate nonconfig G for the mqmqa phase ! another subroutine calculates the entropy using all data in phres%mqf implicit none integer lokph type(gtp_phase_varres), pointer :: phres type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} ! Most variables here are the same as in calcg_internal ... integer, parameter :: f1=50 integer mqmqj,kend,s1,s2,s3,id,nofc2,ipy,lokfun,typty,itp,zp,nrealem,mqendx double precision vals(6),pyq,rtg,aff double precision, dimension(:), allocatable :: dpyq(:),d2pyq(:),d2vals(:) double precision, dimension(:,:), allocatable :: dvals(:,:),affarr(:) ! for saving FNN reference energies double precision refg(f1,f1) double precision dummy1,dummy2 ! for MQMQA minimal fractions double precision, parameter :: MINMQMQA=1.0D-5 TYPE(gtp_parcalc) :: gz TYPE(gtp_property), pointer :: proprec TYPE(gtp_endmember), pointer :: endmemrec TYPE(gtp_interaction), pointer :: intrec TYPE(gtp_pystack), pointer :: pystack TYPE(gtp_phase_add), pointer :: addrec TYPE(gtp_mqmqa_var), pointer :: mqf TYPE(gtp_tooprec), pointer :: tooprec ! for handling excess parameters, just binary, use no mqmqa_data ksi arrays integer ij,jd,jq,qq1,qq2,ass,mpow,isumx,tsize,tch,iiz,mqmqcon,mqmqjy integer noofex,nqx,ncv,icv,dd double precision ksi,sumx,dsumx double precision dksi(3),d2ksi(3) ! logical calc_alldvkij ! logical ddebug logical :: oldmqmqa_model = .true. ! save oldmqmqa_model !------------------------------------- ! tch is level of debug output, 0=none, 3=max tch=0 noofex=0 ! calc_alldvkij=.TRUE. ! ddebug=.FALSE. ! ddebug=.TRUE. if(tch.ge.1) write(*,*)'3XQ in calc_mqmqa nonconfig G' gz%nofc=phlista(lokph)%tnooffr nofc2=gz%nofc*(gz%nofc+1)/2 ! write(*,*)'3X allocating:',gz%nofc,nofc2 allocate(dpyq(gz%nofc)) allocate(d2pyq(nofc2)) allocate(dvals(3,gz%nofc)) allocate(d2vals(nofc2)) ! this shortcut may be bad - but it works --------------------------------- ! write(*,*)'3XQ assigning mqf pointer' mqf=>phres%mqmqaf ! write(*,*)'3XQ assigning mqf pointer OK' !------------------- allocate(affarr(mqf%npair)) affarr=zero nullify(pystack) rtg=globaldata%rgas*ceq%tpval(1) ! do s1=1,mqmqa_data%nconst ! write(*,599)s1,(mqmqa_data%contyp(s2,s1),s2=1,14) !599 format('3XQ contyp 7: ',i2,1x,4i2,1x,i3,1x,4i2,1x,i2,4i3) ! enddo nrealem=0 ! refg=zero dummy2=zero ! list %pp ! %pp( quad , FNN index ) ! do mqmqj=1,mqmqa_data%nconst ! write(*,17)'3XQ %pp: ',mqmqj,(mqmqa_data%pp(s1,mqmqj),s1=1,4) ! enddo !17 format(a,i3,4(1pe12.4)) !-------------------------------------- ! Trying to understand the data structure. List all species and some data ! do mqmqj=1,noofsp ! write(*,13)mqmqj,splista(mqmqj)%symbol,splista(mqmqj)%alphaindex,& ! splista(mqmqj)%quadindex !13 format('3XQ specie: ',i3,2x,a,2x,5i5) ! enddo !-------------------------------------- ! debug output of varkappa mm moved to beginning of calc_mqmqa if(mqmqxcess .and. btest(phlista(lokph)%status1,PHMQMQX)) then write(*,*)'3XQ Debug output of quads, \varkappa_ij, \xi_ij and y_i/k' ! ! these variables are in the TYPE GTP_MQMQA_VAR nqx=mqmqa_data%nquad write(*,82)nqx 82 format('3XQ Quad fractions:',i3) write(*,84)(mqf%xquad(icv),icv=1,nqx) 84 format((8F8.5)) ncv=size(mqf%compvar) write(*,78)ncv 78 format('3XQ varkappa_ij varkappa_ji xi_ij xi_ji',i12) ! 123456789.123456123456789.123456.....123456789.123456123456789.123456 do icv=1,ncv write(*,80)mqf%compvar(icv)%vk_ij,mqf%compvar(icv)%vk_ji,& mqf%compvar(icv)%xi_ij,mqf%compvar(icv)%xi_ji 80 format(2x,2(1pe16.8),5x,2(1pe16.8)) enddo ! write(*,86)mqmqa_data%ncat,(mqf%y_ik(icv),icv=1,mqmqa_data%ncat) !86 format(/'3XQ y_i/k ',i2,': ',(7F9.6)) ! do icv=1,ncv ! write(*,80)mqf%compvar(icv)%vk_ij,mqf%compvar(icv)%vk_ji,& ! mqf%compvar(icv)%xi_ij,mqf%compvar(icv)%xi_ji !80 format(2x,2(1pe16.8),5x,2(1pe16.8)) ! enddo ! if(mqmqder) then write(*,*)'3XQ 2215 Derivatives of vk_ij relative to quads',ncv do icv=1,ncv write(*,79)'ij',(mqf%compvar(icv)%dvk_ij(dd),dd=1,nqx) write(*,79)'ji',(mqf%compvar(icv)%dvk_ji(dd),dd=1,nqx) 79 format('3XQ dvk',a,10(1pe12.4)) enddo write(*,86)mqmqa_data%ncat,(mqf%y_ik(icv),icv=1,mqmqa_data%ncat) 86 format(/'3XQ y_i/k:',i2,3x,7F9.6) endif endif !-------------------------------------- ! first loop over ALL endmembers mqmqj=0 endmemrec=>phlista(lokph)%ordered ! This should be number of atoms for scaling G ! dummy1=phres%abnorm(1)/rtg this was OK before ... dummy1=one/rtg ! %amfu * %abnorm(1) is number of moles in the liquid ! in the test case we have 6 atoms in the liquid phase ! dummy1=6.0D0/rtg ! dummy1=one/(phres%abnorm(1)*rtg) ! write(*,'(a,3(1pe14.6))')'3XQ mqmqa scaling: ',dummy1,& ! phres%amfu,phres%abnorm(1) ! This first loop: all endmember parameters ! this can give SRO contribution and excess from SNN parameters ! or it makes it possible to calculate the G for the FNN parameters endmemloop1: do while(associated(endmemrec)) mqmqj=mqmqj+1 if(mqmqj.gt.mqmqa_data%nconst) exit endmemloop1 ! We do not know if mqmqj is associated with this endmember!! ! there can be gaps in the endmember list?? ! we must take kend from the endmember record, it is sored in %antalem mqendx=endmemrec%antalem kend=mqmqa_data%contyp(5,mqendx) ! write(*,*)'3XQ endmemloop1A: ',mqmqj,mqendx,kend,nrealem if(kend.le.0) then ! This is an SNN parameter we calculate and add SNN energy and interactions ... ! write(*,*)'3XQ SNN endmember record found',mqmqj proprec=>endmemrec%propointer mqsnn: do while(associated(proprec)) ! This loop is not really necessay, in mqmqa the only property is G at present typty=proprec%proptype if(typty.ne.1) stop '3XQ illegal typty in mqmqa model' ipy=1 lokfun=proprec%degreelink(0) call eval_tpfun(lokfun,ceq%tpval,vals,ceq%eq_tpres) if(gx%bmperr.ne.0) goto 1000 ! write(*,'(a,2i3,2(1pe12.4))')'3XQ SNN endmember',mqmqj,kend,& ! pyq,vals(1) ! write(*,'(a,6(1Pe12.4))')'3XQ vals1:',vals if(ipy.eq.1) then vals=vals*dummy1 ! This is an SNN ordering parameter, reference state addel in second loop endif pyq=phres%yfr(mqmqj) ! Should I use any factor?? ! aff=mqmqa_data%pp(1,mqmqj) aff=one ! NOTE the reference state contribution to this SNN added in next loop ! for all quads!! do itp=1,3 phres%dgval(itp,mqmqj,ipy)=phres%dgval(itp,mqmqj,ipy)+vals(itp) enddo ! Initially ignore 2nd derivatives, d2G/dy2=1/y set by entropy calculation ! ipy is property, ipy=1 means G, ipy=2 means Curie T etc. ! %gval(1,1) is total G, %gval(2,1) is total dG/dT etc. do itp=1,6 phres%gval(itp,ipy)=phres%gval(itp,ipy)+pyq*vals(itp) enddo ! write(*,210)'3XQ SRO G, dG/dqi: ',mqmqj,mqmqj,pyq,aff,& ! phres%gval(1,1),(phres%dgval(1,s1,1),s1=1,gz%nofc) proprec=>proprec%nextpr enddo mqsnn !600 continue ! write(*,*)'3XQ any excess parameters will be handled in 3rd loop' endmemrec=>endmemrec%nextem cycle endmemloop1 endif ! This is an FNN parameter, we calculate and save the value for later use nrealem=nrealem+1 ! write(*,*)'3XQ endmemloop1B: ',mqmqj,kend,nrealem proprec=>endmemrec%propointer aff=one/mqmqa_data%pp(1,mqmqj) mq1: do while(associated(proprec)) typty=proprec%proptype if(typty.ne.1) stop 'illegal typty in mqmqa model' ipy=1 lokfun=proprec%degreelink(0) call eval_tpfun(lokfun,ceq%tpval,vals,ceq%eq_tpres) if(gx%bmperr.ne.0) goto 1000 ! write(*,'(a,i3,F7.4,3(1Pe10.2))')'3XQ refg:',mqmqj,aff,vals(1),vals(2) ! we should divide this by the aff of this pair and we will multiply this ! FNN same aff but SNN fractions linking to this pair use another aff ! write(*,'(a,2i3,2(1pe12.4))')'3XQ FNN endmember',mqmqj,kend,& ! pyq,vals(1) if(ipy.eq.1) then vals=vals*dummy1*aff ! save values of reference state for use with SNN parameters ?? ! kend is FNN (pair) index do s1=1,6 refg(kend,s1)=vals(s1) enddo endif ! next property record (should not be any ...) proprec=>proprec%nextpr if(associated(proprec)) then write(*,*)'3XQ Warning: ignoring second mqmqa property recotd!' endif ! write(*,200)'3XQ FNN G, dG/dqi: ',phres%gval(1,1),& ! (phres%dgval(1,s1,1),s1=1,gz%nofc) 200 format(a,1pe12.4,2x,6(1pe12.4)) enddo mq1 endmemrec=>endmemrec%nextem enddo endmemloop1 ! write(*,*)'3XQ finished endmemloop1' !--------------------------------------------------- end first endmember loop ! All endmembers with a single element in each sublattice must have a parameter ! these are counted above in endmemloop1 ! write(*,'(a,3i3)')'3XQ number of sublattice constituents and FNN: ',& ! mqf%ns1,mqf%ns2,nrealem if(nrealem.ne.mqf%ns1*mqf%ns2) then ! This test is not foolproof one can enter an interaction parameter ! which creates an empty endmember record but that seems crazy write(*,216)mqf%ns1*mqf%ns2,nrealem 216 format('Some FNN constituents (A/X) have no parameter!, should be',& i3,' found only ',i3) gx%bmperr=4399; goto 1000 endif ! second loop over all constutents (quads), ignore FNN endmember records ! but add reference state parameters to all SNN and reciprocal constituents ipy=1 if(tch.ge.3) write(*,*)'3XQ adding reference to SNN endmembers' qloop: do mqmqj=1,gz%nofc ! this is quad fraction, multiply with all FNN reference energies pyq=phres%yfr(mqmqj) zp=mqmqa_data%contyp(5,mqmqj) pair: if(zp.gt.0) then ! this is an FNN pair, reference energy in refg(zp,1..6), only one y derivative ! %pp(1..4,mqmqj) is stoichiometric factor for the pair aff=mqmqa_data%pp(1,mqmqj) do itp=1,3 phres%dgval(itp,mqmqj,ipy)=phres%dgval(itp,mqmqj,ipy)+& aff*refg(zp,itp) enddo ! Initially ignore 2nd derivatives, d2G/dy2=1/y set by entropy calculation do itp=1,6 phres%gval(itp,ipy)=phres%gval(itp,ipy)+pyq*aff*refg(zp,itp) enddo ! write(*,205)'3XQ FNN: qix, FNN, aff, pyq, fun, DG: ',mqmqj,zp,aff,& ! pyq,refg(zp,1),pyq*aff*refg(zp,1) 205 format(a,2i3,F8.5,2x,3(1pe12.4)) if(tch.ge.3) & write(*,210)'3XQ FNN G: ',mqmqj,mqmqj,pyq,aff,pyq,phres%gval(1,1) 210 format(a,2i3,2F8.5,1pe12.4,2x,6(1pe10.2)) else ! this is an SNN with two or more pairs ! For each SNN pair add the contribution to the FNN reference state ! %contyp(1..4,mqmqj) is index of FNN reference energy if(tch.ge.3) write(*,'(a,i3,1x,4i3,4F8.5)')'3XQ pp2: ',mqmqj,& (mqmqa_data%contyp(s1,mqmqj),s1=6,9),& (mqmqa_data%pp(s1,mqmqj),s1=1,4) snnloop: do s1=6,9 ! zp is index to an FNN record, there can be 2 or 4 FNN records zp=mqmqa_data%contyp(s1,mqmqj) if(zp.eq.0) exit snnloop ! %pp(1..4,mqmqj) is stoichiometric factor for the pair aff=mqmqa_data%pp(s1-5,mqmqj) ! write(*,211)1,mqmqj,ipy,phres%dgval(1,mqmqj,ipy) 211 format('3XQ SNN dG/dy:',3i3,1(1pe12.4)) do itp=1,3 phres%dgval(itp,mqmqj,ipy)=phres%dgval(itp,mqmqj,ipy)+& aff*refg(zp,itp) enddo ! write(*,212)zp,mqmqj,ipy,phres%dgval(1,mqmqj,ipy),aff,aff*refg(zp,1) 212 format('3XQ SNN dG/dy reference added:',3i3,3(1pe12.4)) ! Initially ignore 2nd derivatives, d2G/dy2=1/y set by entropy calculation if(tch.ge.3) write(*,213)s1,zp,mqmqj,ipy,pyq,aff,phres%gval(1,ipy) 213 format('3XQ SNN G ref:',4i3,2F10.5,1pe12.4) do itp=1,6 phres%gval(itp,ipy)=phres%gval(itp,ipy)+pyq*aff*refg(zp,itp) enddo ! write(*,214)zp,mqmqj,ipy,phres%gval(1,ipy),pyq,aff,aff*refg(zp,1) ! write(*,214)zp,mqmqj,ipy,phres%gval(1,ipy),pyq,aff,refg(zp,1)*rtg 214 format('3XQ SNN G ref added:',3i3,4(1pe12.4)) ! write(*,205)'3XQ SNN: qix, FNN, aff, pyq, fun, DG: ',mqmqj,zp,aff,& ! pyq,refg(zp,1),pyq*aff*refg(zp,1) ! (phres%dgval(1,s2,1),s2=1,gz%nofc) enddo snnloop endif pair enddo qloop if(tch.ge.3) write(*,*)'3XQ finished loop for endmembers' ! if this goto then excess is ignored and result correct ! write(kou,299) 299 format('3QX endmember energy and entropy calculated, excess to be done') ! goto 800 !--------------------------------------------------------------------- ! code below needed for excess parameters ONLY, all SNN FNN endmembers done ! NOTE some of them may not have a reference energy parameter ! This is to allocate csumx for handling quads with small fractions. isumx=0 ! debug output of G for check of excess if(mqmqxcess) then write(*,288)(phres%gval(itp,1),itp=1,4) 288 format(/'3XQ line 1439 before excess:'/'G, dG/dT dG/dP d2G/dT2:',& 4(1pe14.6)) endif ! mqmqj=0 endmemrec=>phlista(lokph)%ordered endmemloop2: do while(associated(endmemrec)) if(mqmqj.gt.0) endmemrec=>endmemrec%nextem mqmqj=mqmqj+1 if(tch.ge.3) write(*,*)'3XQ endmemloop2:',& mqmqj,mqmqa_data%nconst,associated(endmemrec) if(mqmqj.gt.mqmqa_data%nconst .or. .not.associated(endmemrec)) then exit endmemloop2 endif kend=mqmqa_data%contyp(5,mqmqj) if(tch.ge.3) write(*,311)mqmqj,mqmqa_data%nconst,kend,& associated(endmemrec%intpointer) 311 format(/'3XQ in loop for excess parameters: ',3i5,l2) intrec=>endmemrec%intpointer ! interaction parameters are NOT linked from SNN endmembers ?? really? ! They are stored in alphabetical order of the constituents ! write(*,*)'3XQ Check interaction parameters 1',associated(endmemrec),& ! associated(intrec),mqmqj,kend ! if we cycle here the results are the same as without excess parameters ! cycle endmemloop2 ! if(.not.associated(intrec)) then cycle endmemloop2 endif if(.not.btest(phlista(lokph)%status1,PHMQMQX)) then ! this is the first MQMQA implementation with correct reference energy and ! configurational entropy but very messy Toop/Kohler implementation goto 499 endif ! ! THIS IS NEW EXCESS MQMQA CODE ! ! if(mqmqxcess) then ! if parameter errors in interactions below these are the endmemberquads A/X ! write(*,313)(mqmqa_data%emquad(iiz),iiz=1,mqmqa_data%ncat) 313 format('3XQ endmember quads: ',15i3) ! endif ! ! mqmqj is NOT the mqmqa constituent index, it is just an endmember counter ! look for the constituent in fraction record, sublattice 1, constituent 1 ! WOW !!!! it does not crash mqmqjy=endmemrec%fraclinks(1,1) ! ! we must find its position in the quad list ! write(*,314)mqmqj,mqmqjy,size(phlista(lokph)%constitlist) ! associated(endmemrec%oendmemarr),associated(endmemrec%dendmemarr) 314 format(/'3XQ endmember data: ',3i3) ! write(*,315)phlista(lokph)%constitlist 315 format('3XQ constituents: ',20i3) ! if(mqmqxcess) write(*,318)phres%gval(1,ipy),& (phres%dgval(1,jq,ipy),jq=1,gz%nofc) ! ! if(calc_alldvkij) then ! calculate partial derivatives of all vk_ij etc ! call calc_newdvkij_values(phres,ceq) ! calc_alldvkij=.FALSE. ! endif ! noofex=noofex+1 if(mqmqxcess) write(*,*)'3XQ excess with endmember constituent: ',& mqmqjy,ipy ! write(*,316)mqmqjy,ipy call new_mqmqa_excess(lokph,intrec,mqmqjy,vals,dvals,d2vals,gz,ceq) if(gx%bmperr.ne.0) goto 1000 !------------- important -------------------- ! vals, dvals and d2vals is the SUM OF ALL EXCESS parameters for this endmember ! gz is pointer to gtp_parcalc .... for phases with parameter permutations !------------- important -------------------- if(mqmqxcess) write(*,316)mqmqjy,ipy,vals(1) 316 format('3XQ endmember excess: ', 2i5,' calculated: ',1pe12.4) ! intrec is nullified inside new_mqmqa_excess ! if(mqmqxcess) write(*,*)'3XQ back with excess from endmember ',mqmqjy,& ! associated(endmemrec) ! if(mqmqxcess) write(*,317)gz%nofc,vals(1),vals(2),& ! write(*,317)gz%nofc,rtg*vals(1),rtg*vals(2),& ! (rtg*dvals(1,jq),jq=1,gz%nofc) 317 format('3XQ Back from new_mqmqa: ',i3,2(1pe12.4)/6(1pe12.4)) ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! BIG STEP ... add vals, dvals to G and dG/dy ! what about aff? ! ! what is ipy? It is the property 1 is G, 2 is BMAGN or something else ipy=1 if(mqmqxcess) write(*,318)phres%gval(1,ipy),& (phres%dgval(1,jq,ipy),jq=1,gz%nofc) 318 format('3XQ G & G.y: ',1pe12.4/6(1pe12.4)) ! dvals(1,jq=1,gz%nofc) set here ! write(*,3181)gz%nofc,(dvals(1,jq),jq=1,gz%nofc) 3181 format('3XQ dex: ',i3,25(1pe12.4)) do itp=1,6 ! loop for G, G.T, G.P, G.T.T, G.T.P, G.P.P to add excess contribution phres%gval(itp,ipy)=phres%gval(itp,ipy)+vals(itp) enddo ! TEMPORARILY REMOVED SOME LOOPS if(mqmqder) write(*,3183)gz%nofc,(dvals(1,jq),jq=1,gz%nofc) 3183 format('3XQ dvals: ',i3,20(1pe12.4)) do jq=1,gz%nofc ! skip loop for dG/dy, d2G/dydT, d2G/dydP, only for constituents ! do itp=1,3 this skips 2nd derivative wrt T ?? ipy=1 is G if(mqmqder .and. abs(dvals(1,jq)).gt.1.0D-3) then ! this line is strange, supress it temporarily write(*,3182)jq,dvals(1,jq),phres%dgval(1,jq,1) endif do itp=1,3 phres%dgval(itp,jq,ipy)=phres%dgval(itp,jq,ipy)+dvals(itp,jq) enddo ! write(*,3182)jq,dvals(1,jq),phres%dgval(1,jq,1) enddo 3182 format('3XQ line 1567 addexcess: ',i3,2(1pe12.4)) ! ! ignore 2nd derivatives as not calculated for excess !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! ! write(*,289)(phres%gval(itp,1),itp=1,4) 289 format('3XQ line 1532 after excess:'/'G, dG/dT dG/dP d2G/dT2:',4(1pe14.6)) if(.not.associated(intrec)) cycle endmemloop2 ! !*************** remove all code below when excess code above OK ******* !******************* new code above should replace code below ******* ! ! There are excess parameters, any Tooprecords? ! ! THIS IS OLD CODE WHISH SHOULD NO LONGER BE USED ! !******************* new code above should replace code below ******* 499 continue if(oldmqmqa_model) then write(*,319) 319 format(/'3XQ *** this is the old mqmqa excess model **'/) ! stop "gtp3XQ line 1542" endif ! if(associated(intrec%tooprec)) then ! the allocatable arrays Toop1, Toop2 and Kohler have all same size ! equal to the number of binary combination of constituents ! tooprec=>intrec%tooprec if(tch.ge.3) then write(*,'(a,2i3,l2)')'3XQ A Toop/Kohler record, id:',& tooprec%toopid,tooprec%endmemel,associated(tooprec%binint) if(allocated(tooprec%toop1)) then tsize=size(tooprec%toop1) write(*,320)'Toop1 ',(tooprec%toop1(jd),jd=1,tsize) write(*,320)'Toop2 ',(tooprec%toop1(jd),jd=1,tsize) write(*,320)'Kohler ',(tooprec%kohler(jd),jd=1,tsize) 320 format('3XQ ',a,': ',10i3) endif endif ! this is an excess parameter with possible excess parameters ! write(*,'(a,2i3)')'3XQ endmember with excess parameter:',mqmqj ! just excess parameters, we must calculate product of fractions ! BRANCH for intrec%highlink and intrec%nexlink ! write(*,'(a,i2,F10.6,6(1pe12.4))')'3XQ SNN df/dy: ',id,pyq,& ! (dpyq(itp),itp=1,gz%nofc) !------------------------------------- ! content of %contyp and %pinq ! do jd=1,mqmqa_data%nconst ! write(*,599)jd,(mqmqa_data%contyp(id,jd),id=1,14) !599 format('3XQ contyp: ',i2,1x,4i2,1x,i3,1x,4i2,1x,i2,4i3) ! enddo ! write(*,*)'3XQ pinq: ',mqmqa_data%pinq ! extract fractions from the endmember and check if AB/X or A/XY or A/X end if !-------------------------------------- code below ignore Toop/Kohler id=endmemrec%fraclinks(1,1) ! jump back here for next interaction record (if any) 600 continue ! Note it is arbitrary if the cluster is endmember or interaction jd=intrec%fraclink(1) ! We must keep track of which endmember is separate!!! if(mqmqa_data%contyp(5,id).eq.0) then ! id is a cluster, jd is separate fraction, jq is additional salt OK ass=id ! %contyp(6,..9) are index of FNN, pairs, FNN pairs index in cintyp in PINQ jq=mqmqa_data%pinq(mqmqa_data%contyp(6,ass)) if(jq.eq.jd) jq=mqmqa_data%pinq(mqmqa_data%contyp(7,ass)) qq1=jd qq2=jq ! write(*,'(a,6i3)')'3XQ ass, sep, sum 1:',ass,qq1,qq2 elseif(mqmqa_data%contyp(5,jd).eq.0) then ! jd is the cluster, id is interaction endmember WRONG ass=jd jq=mqmqa_data%pinq(mqmqa_data%contyp(6,ass)) if(jq.eq.id) jq=mqmqa_data%pinq(mqmqa_data%contyp(7,ass)) qq1=id qq2=jq ! write(*,'(a,6i3)')'3XQ ass, sep, sum 2:',ass,qq1,qq2 else ! Interactions are only between clusters AB/X and endmembers A/X or B/X write(*,*)'3XQ interaction between two endmembers illegal' gx%bmperr=4399; goto 1000 endif ! write(*,428)phres%yfr 428 format('3XQ all yfr: ',20(1x,F8.6)) if(tch.ge.3) write(*,430)id,jd,jq,qq1,qq2,ass,& phres%yfr(id),phres%yfr(jd),phres%yfr(jq) 430 format('3XQ interaction: ',3i3,3x,3i3,3x,3(1x,F8.6)) !------------------------------------- extract parameter value proprec=>intrec%propointer typty=proprec%proptype if(typty.ne.1) stop 'illegal typty in mqmqa model' ipy=1 ! several powers we must loop here -------------- not yet done if(proprec%degree.gt.0) write(*,*)'3XQ degree: ',proprec%degree mpow=0 700 continue ! first power is in link 0 lokfun=proprec%degreelink(mpow) mpow=mpow+1 if(mpow.gt.9) then write(*,*)'3XQ too high interaction power' gx%bmperr=4399; goto 1000 endif ! some powers may not have a parameter, max 9. If no function loop if(lokfun.le.0) goto 700 call eval_tpfun(lokfun,ceq%tpval,vals,ceq%eq_tpres) if(gx%bmperr.ne.0) goto 1000 if(tch.ge.3) write(*,'(a,3i4/4x,6(1Pe12.4))')'3XQ excess1:',& lokfun,mqmqj,mpow,vals(1) if(ipy.eq.1) then ! Nath has implemented this half in the converter ! vals=0.5D0*vals/rtg vals=vals/rtg endif ! skip excess 1 ! cycle endmemloop2 !----------------------- multiply with fractions ! the parameter should be multiplied with cluster fractions and ! the separate endmember qq1 fraction normalized isumx=isumx+1 sumx=phres%yfr(qq1)+phres%yfr(qq2)+phres%yfr(ass) ksi=phres%yfr(qq1)/sumx if(mpow.eq.1) then pyq=phres%yfr(ass)*ksi ! most of the derivatives of pyq is zero dpyq=zero dsumx=-sumx**(-2) ! only those involving id, jd and jq are nonzero. ! the species qq1, qq2 and ass has one more term, qq2 is only in the sumx ! dpyq(qq1)=pyq*dsumx+phres%yfr(ass)/sumx ! dpyq(qq2)=pyq*dsumx ! dpyq(ass)=pyq*dsumx+ksi ! corrected derivatives ... dpyq(qq1)=(phres%yfr(ass)-pyq)/sumx dpyq(ass)=(phres%yfr(qq1)-pyq)/sumx dpyq(qq2)=-pyq/sumx else ! NOT CORRECTED THESE ... suck pyq=phres%yfr(ass)*(ksi**mpow) dpyq=zero dsumx=-mpow*sumx**(-mpow-1) dpyq(qq1)=pyq*dsumx+mpow*phres%yfr(ass)*ksi**(mpow-1) dpyq(qq2)=pyq*dsumx dpyq(ass)=pyq*dsumx+ksi*mpow endif ! here the fraction product is calculated ! write(*,650)ass,qq1,qq2,mpow,ksi,phres%yfr(ass),pyq,sumx,vals(1)*rtg 650 format('3XQ excess: ',4i3,4(1x,F8.6),1pe12.4) ! write(*,'(a,2(1pe14.6))')'3XQ excess G:',pyq,pyq*vals(1) ! skip excess 2 ! cycle endmemloop2 ! ! --------------------------------- ! add to G and first derivatives of G, ipy is property, ipy=1 is G ! 2nd derivatives ignored ! --------------------------------- do s1=1,gz%nofc do itp=1,3 phres%dgval(itp,s1,ipy)=phres%dgval(itp,s1,ipy)+& dpyq(s1)*vals(itp) enddo enddo do itp=1,6 phres%gval(itp,ipy)=phres%gval(itp,ipy)+pyq*vals(itp) enddo ! maybe several fraction powers of this property ! write(*,*)'3XQ several powers? ',mpow,proprec%degree if(mpow.lt.proprec%degree) goto 700 !------------- next property for same interaction, ! each property can have different number of powers ... not implemented proprec=>proprec%nextpr if(associated(proprec)) then ! more than one property ... not implemented write(*,*)'3XQ MQMQA parameter with several properties!',mqmqj endif if(associated(intrec%highlink)) then ! a higher interaction ... not allowed write(*,*)'3XQ ternary MQMQA parameters not implemented',mqmqj endif ! there can be more interactions on this level intrec=>intrec%nextlink if(associated(intrec)) then ! There can be more than one interaction linked from an endmember if(tch.ge.3) write(*,*)'3XQ more interaction for an endmember',mqmqj goto 600 endif ! write(*,*)'3XQ done excess for endmember',mqmqj ! next endmember .... is set at the beginning enddo endmemloop2 !----------------------------------------------------- end SNN loop 800 continue ! write(*,990)'3XQ exit calc_mqmqa G:',phres%gval(1,1),& ! (phres%dgval(1,s1,1),s1=1,gz%nofc) ! write(*,990)'3XQ exit calc_mqmqa G:',rtg*phres%gval(1,1),rtg*vals(1) ! (phres%dgval(1,s1,1),s1=1,gz%nofc) 990 format(a,5(1pe14.6)) 1000 continue return end subroutine calc_mqmqa !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine calc_toop ! called from cgint(lokph,lokpty,moded,vals,dvals,d2vals,gz,ceq) !\begin{verbatim} subroutine calc_toop(lokph,lokpty,moded,vals,dvals,d2vals,gz,TOOPX,ceq) ! NOT USED FOR MQMQA liquid model ... done in calc_mqmqa ! This routine replaces all calculations inside cgint for Toop/Kohler excess ! binary interaction parameter with Toop or Kohler extrapolation ! toopx is the pointer to the kohler-Toop record ! toopx%binint is pointer back to calling subroutine ! A single composition dependent binary parameter is calculated ! But in the Toop/Kohler we can have additional fraction variables implicit none integer moded,lokph TYPE(gtp_property), pointer :: lokpty TYPE(gtp_parcalc) :: gz ! all fraction variable can be involved in derivatives of vals ... double precision vals(6),dvals(3,gz%nofc) double precision d2vals(gz%nofc*(gz%nofc+1)/2) TYPE(gtp_tooprec), pointer :: toopx TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} ! we use this to save the pointer from toopx TYPE(gtp_phase_varres), pointer :: phres ! fraction values to be used in RK series double precision x12,x21,sigma,dxrk,dxrk0 double precision, allocatable, dimension(:) :: dsigma, dx12, dx21 ! ternary fraction index integer jj(3),j1,j2,j3,link,count,toopconst,limit,jdeg,lfun,nyfr,tkdeb ! loop veriables integer qz,ic,cc ! to avoid calculating derivatives if no constituents in toop1, toop2 or kohler logical not1,not2,nok ! for the RK calculation with Toop/Kohler fractions! double precision valtp(6) double precision dx,dx0,dx1,dx2,dxi,dxj,fff,rtg ! The first part here is to modify the fractions to be used in the RK series ! the gz record has information which elements involved ! gz%iq(1) and gz%iq(2) are index of the binary constituents ! We must also handle first and second derivatives wrt all fractions. ! as the binary fractions are modified by adding or subtractions ! we come here from a binary interaction record will only deal with this ! ! These are UNUSED arrays with additional fractions to calculate derivatives integer dtoop1(5),dtoop2(5),dkohler(10),ntp1,ntp2,nkh ! These are arrays to eliminate cases with duplicate fractions in Toop1/2/Kohler integer, allocatable, dimension(:) :: ctoop1,ctoop2,ckohler integer nz ! ! Use the phres passed on via toopx%phres if there are more toopx records ! this link to phres is copied to toopx%phres before the call. ! In gtp3X, subroutine calcg_internal around line 858. ! This makes it possible to have several composition sets (I hope) if(associated(toopx%phres)) then phres=>toopx%phres else write(*,*)'3QX phres pointer is not assigned entering calc_toop' gx%bmperr=4399; goto 1000 endif ! debug level 0 nothing, 1 minimum, 2 Toop, 5 all tkdeb=2 if(tkdeb.ge.2) write(*,*)'3XQ in calc_toop ',lokpty%degreelink(0) ! NOTE vals, dvals and d2vals set to zero in calcg before calling this routine rtg=gz%rgast if(lokpty%degree.eq.0) then ! quick exit if no composition dependence lfun=lokpty%degreelink(0) call eval_tpfun(lfun,gz%tpv,valtp,ceq%eq_tpres) if(gx%bmperr.ne.0) goto 1000 if(lokpty%proptype.eq.1) then valtp=valtp/rtg endif ! this is multiplied with y_i y_j (and their derivatives) at the return vals=vals+valtp goto 1000 endif ! we come here if there are RK terms >0 if(tkdeb.gt.0) then write(*,10)gz%iq(1),gz%iq(2),lokpty%degree 10 format(/'3XQ in calc_toop & Kohler with binary;',2i3,' degrees: ',i2) endif ! do nz=1,3 ! it seems that dvals are not properly initiatiad to zero? ! write(*,7)nz,(dvals(nz,ic),ic=1,gz%nofc) !7 format('3XQ initial dvals: ',i2,10(1pe12.4)) ! enddo ! We have to calculate the reduced fractions, it can involve many fractions nyfr=size(phres%yfr) allocate(dsigma(nyfr)) allocate(dx12(nyfr)) allocate(dx21(nyfr)) ! default value of sigma is unity sigma=one ! these are default zero, i.e. derivatives with respect to no extra fractions dx12=zero dx21=zero dsigma=zero ! constituents are ordered alphabetically, x12 is the first in the endmember x12=gz%yfrem(gz%intlat(1)) x21=gz%yfrint(1) if(tkdeb.ge.2) write(*,15)x12,x21,gz%iq(1),gz%iq(2) 15 format('3XQ initial fractions: ',2f8.4,2i5) ! We have a binary excess parameter which depend on x_A and x_B ! and a Redlich-Kister polynom (x_A -x_B)/sigma ! When the data for the system was entered some ternaries were ! specified as Toop or Kohler and the toopx record created with the ! information needed for the calculations below ! For all ternaries A-B-K where the composition of B is constant (Toop) ! the fraction of K should be added to A, i.e. x12 if(phlista(lokph)%toopfirst%endmemel.ne.0) then ! CHECK FOR DUPLICATE FRACTION INDICES, an add ternary may add same fraction!! ! phlista(lokph)%firsttoop%free=-1 in add_ternary... (in gtp3H.F90) ! if phlista(lokph)%firsttoop%free=-1 check and remove redundant fractions!! ! This phlista(lokph)%firsttoop%free=0 at the end of gcalc (in gtp3X.F90) if(tkdeb.ge.1) write(*,16)phlista(lokph)%toopfirst%endmemel 16 format('3XQ Checking duplicates as phlista(lokph)%toopfirst%endmemel:',i2) ! The check made only once, this value is zeroed at end of calcg subroutine allocate(ctoop1(phlista(lokph)%toopfirst%free)) allocate(ctoop2(phlista(lokph)%toopfirst%free)) allocate(ckohler(phlista(lokph)%toopfirst%free)) endif not1=.TRUE. if(tkdeb.ge.2) then write(*,8)toopx%free,nyfr 8 format('3XQ Number of Toop/Kohler ternaries: ',i3,& ' Total number of fractions: ',i3) write(*,12)phres%yfr 12 format('3XQ All yfr: ',20F7.4) endif ! toopx%free is last used index in %Toop1, %Toop2 and %Kohler not1=.TRUE.; not2=.TRUE.; nok=.TRUE. allcorr: do ic=1,toopx%free if(tkdeb.ge.2) & write(*,33)ic,toopx%toop1(ic),toopx%toop2(ic),toopx%kohler(ic) 33 format('3XQ List of Toop/Kohler constituents: ',i2,2x,3i3) !------------ Toop1 cc=toopx%toop1(ic) if(allocated(ctoop1)) then ! if ctoop1 allocated then check to eliminate duplicates if(tkdeb.ge.1) write(*,'(a)')'3XQ Check for duplicated fractions' do nz=1,ic-1 if(cc.gt.0 .and. cc.eq.toopx%toop1(nz)) then jdeg=toopx%toop1(ic); toopx%toop1(ic)=0; cc=0 write(*,69)'Toop1',nz,jdeg 69 format('3XQ eliminated duplicate ',a,' fraction',2i4) endif enddo endif if(cc.gt.0) then ! In this binary i-j with ternary k where i (endmember) is constant (Toop) ! Add the fraction of x_k to x_i x12=x12+phres%yfr(cc); dx12(cc)=one; not1=.FALSE. if(tkdeb.ge.2) & write(*,34)'x12 ',ic,cc,toopx%toop1(ic),phres%yfr(cc),x12 34 format('3XQ Added fraction to ',a,3i3,2E15.7) endif !------------ Toop2 cc=toopx%toop2(ic) if(allocated(ctoop2)) then ! if ctoop2 allocated check to eliminate duplicates do nz=1,ic-1 if(cc.gt.0 .and. cc.eq.toopx%toop2(nz)) then jdeg=toopx%toop2(ic); toopx%toop2(ic)=0; cc=0 write(*,69)'Toop2',nz,jdeg endif enddo endif if(cc.gt.0) then ! In this binary i-j with ternary k where i (interaction) is constant (Toop) ! Add the fraction of x_k to x_j x21=x21+phres%yfr(cc); dx21(cc)=one; not2=.FALSE. if(tkdeb.ge.2) & write(*,34)'x21 ',ic,cc,toopx%toop2(ic),phres%yfr(cc),x21 endif !------------ Kohler cc=toopx%Kohler(ic) if(allocated(ckohler)) then ! if ckohler allocated check to eliminate duplicates do nz=1,ic-1 if(cc.lt.0 .and. cc.eq.toopx%kohler(nz)) then jdeg=toopx%kohler(ic); toopx%kohler(ic)=0; cc=0 write(*,69)'3Kohler',nz,jdeg endif enddo endif if(cc.lt.0) then ! In this ternary i-j-k the i-j extrapolates as Kohler ! the composition of k should be subtracted from sigma (initiated to 1.0 above) sigma=sigma-phres%yfr(-cc); dsigma(-cc)=-one; nok=.FALSE. if(tkdeb.ge.2) write(*,35)ic,cc,toopx%kohler(ic),phres%yfr(-cc),sigma 35 format('3XQ subtracted fraction for sigma ',3i3,2E15.7) endif enddo allcorr if(x12.ge.one) then write(*,*)'3XQ Error: x12 larger than 1.0 in Toop/Kohler extrapolation!' gx%bmperr=4399; goto 1000 endif if(x21.ge.one) then write(*,*)'3XQ Error: x21 larger than 1.0 in Toop/Kohler extrapolation!' gx%bmperr=4399; goto 1000 endif if(sigma.le.zero) then write(*,*)'3XQ Error: negative sigma in Toop/Kohler extrapolation!' gx%bmperr=4399; goto 1000 endif ! This is the RK fraction difference, sigma is the Kohler divisor dxrk0=(x12-x21)/sigma ! dxrk is the Tredlich-Kister term, it is raised to powers jdeg=0...n ! The derivative of dxrk**n is: ! n*dxrk**((m-1)*[ (dx12-dx21)/sigma - (x12-x21)*dsigma/sigma**2 ] ! where dx12, dx21 be 0 or 1 and dsigma 0 or -1 for several fraction variables ! were set above. ! ! dxrk=1.0 for jdeg=0 dxrk=one if(tkdeb.ge.2) then write(*,17)'3XQ x12: ', x12,', dx12: ',dx12,dxrk0 write(*,17)'3XQ x21: ', x21,', dx21: ',dx21 write(*,17)'3XQ sigma: ', sigma,', dsigma: ',dsigma 17 format(a,F8.6,a,10F7.3)! endif !----------------------------------------------------------------- ! No documentation of code below (at present), see paper by Pelton 2001 !----------------------------------------------------------------- ! in toopx there are 3 arrays ! toop1 with toop constitunents to be added to iq(1) ! toop2 with toop constitunents to be added to iq(2) ! Kohler with constitunents to be subtracted from sigma ! Calculate the corrected the binary fractions x12 and x21 and sigma if(tkdeb.gt.0) write(*,20)x12,x21,sigma,dxrk,moded 20 format('3XQ fractions: ',2F8.4,' sigma,dxrk: ',2F8.4,' moded: ',i1) ! gz%iq(1) is first constitution, gz%iq(2) in interaction dx12(gz%iq(1))=one/sigma dx21(gz%iq(2))=one/sigma RK: do jdeg=0,lokpty%degree lfun=lokpty%degreelink(jdeg) call eval_tpfun(lfun,gz%tpv,valtp,ceq%eq_tpres) if(gx%bmperr.ne.0) goto 1000 if(lokpty%proptype.eq.1) then valtp=valtp/rtg endif vals=vals+dxrk*valtp if(tkdeb.ge.2) write(*,9)'3XQ vals1: ',jdeg,dxrk,valtp(1),rtg*valtp(1),& vals(1),rtg*vals(1) 9 format(a,i2,5(1PE13.5)) noder5: if(moded.gt.0) then ! moded=0 no derivative, =1 first, =2 second; gz%iq(1) is endmember ! derivatives with respect to original x12 and x12 ! qz=1 is parameter value, qz=2 is parameter derivative wrt T, qz(3) wrt P do qz=1,3 dvals(qz,gz%iq(1))=dvals(qz,gz%iq(1))+dx12(gz%iq(1))*valtp(qz) dvals(qz,gz%iq(2))=dvals(qz,gz%iq(2))-dx21(gz%iq(2))*valtp(qz) enddo ! derivatives wrt Toop1 constintuents, use dx12, dx21 and dsigma ! all approximate ....... negative sign of dx21 taken care of when "added" ! NOTE dx12, dx21 and sigma are arrays as any constituent can be involved dx12(gz%iq(1))=(jdeg+1)*dxrk dx21(gz%iq(2))=(jdeg+1)*dxrk ! This part takes care of derivatives wrt fractions "k" in x12, x21 and sigma ! They have dx12(k)=dx21(k)=1 and dsigma)k)=-1 ! dxrk**n * valtp is the Redlich-Kister term, valtp(1,2,3) is the parameter ! The derivative of dxrk**n * valtp is: ! n*dxrk**((n-1)*valtp*[ dx12/sigma -dx21/sigma -(x12-x21)*dsigma/sigma**2 ] ! valtp(1) is parameter value, valtp(2,3) is derivative wrt T and P respectivly ! where dx12, dx21 are 0 or 1 and dsigma is 0 or -1 for the fraction variables ! The fractions "k" involved have nonzero %toop1(ic), %toop2 or %kohler indices extraderivatives: do ic=1,toopx%free ! the arrays %toop1, %toop2 and %kohler have the same dimensions ! they have fraction indices in toop1, toop2 or kohler (most of which is 0) ! -------------------- derivatives for toop1 cc=toopx%toop1(ic) ltoop1: if(.not.not1) then ! there is a fraction added to x12, fraction index in toopx%toop1(ic) if(cc.gt.0) then do qz=1,3 ! this fraction is added to x12, dx12=1 but we have to divide with sigma dvals(qz,cc)=dvals(qz,cc)+(jdeg+1)*dxrk*valtp(qz)/sigma enddo if(tkdeb.ge.2) write(*,44)'Toop1 ',cc,dvals(1,cc) 44 format('3XQ ',a,' derivative: ',i2,1pe14.6) ! Any second derivatives is ignored (it may slow down convergence) endif endif ltoop1 !--------------------- derivatives for Toop2 cc=toopx%toop2(ic) ltoop2: if(.not.not2) then ! there is a fraction added to x21, fraction index in toopx%toop2(ic) if(cc.gt.0) then do qz=1,3 ! dx21(ic) is unity here but divide with sigma. OBS negative sign dvals(qz,cc)=dvals(qz,cc)-(jdeg+1)*dxrk*valtp(qz)/sigma enddo if(tkdeb.ge.2) write(*,44)'Toop2 ',cc,dvals(1,cc) ! Any second derivatives ignored (it may slow down convergence) endif endif ltoop2 !---------------------- derivatives for Kohler, negative index of fraction!!! cc=toopx%kohler(ic) lkohler: if(.not.nok) then ! there is a fraction subtracted from sigma, fraction -index in toopx%kohler(ic) if(cc.lt.0) then if(tkdeb.ge.2) write(*,54)cc,jdeg,dvals(1,-cc),& (jdeg+1)*dxrk*valtp(1)*(x12-x21)/sigma**2,& dxrk,valtp(1),(x12-x21),sigma 54 format('3XQ Kohler derivative: ',2i2,2(1pe12.4)/4x,4(1pe12.4)) do qz=1,3 ! dxrk**n * valtp is the Redlich-Kister term, valtp is the parameter ! n*dxrk**((n-1)*valtp*[ dx12/sigma -dx21/sigma -(x12-x21)*dsigma/sigma**2 ] ! dsigma is unity here but divide with sigma**2 dvals(qz,-cc)=dvals(qz,-cc)-& (jdeg+1)*dxrk*valtp(qz)*(x12-x21)/sigma**2 enddo ! Any second derivatives ignored (it may slow down convergence) endif endif lkohler enddo extraderivatives ! dxrk has one more power for next term dxrk=dxrk*dxrk0 endif noder5 enddo RK !--------- maybe almost finished ??? ! ! if(tkdeb.ge.1) write(*,30)'3XQ vals2: ',vals(1),rtg*vals(1),& ! gz%iq(1),gz%iq(2),rtg*dvals(1,gz%iq(1)),rtg*dvals(1,gz%iq(2)) 30 format(a,2F12.4,2i2,2F12.4) 1000 continue !------------------------------------------------------------------ ! this calculates the whole \sum_i (\xi_A - \xi_B)/sigma_AB)^i iL_AB ! and derivatives .... !------------------------------------------------------------------ ! The result is multiplied with the fractions x_A'x_B in the calling routine if(tkdeb.gt.0) write(*,'(a,2i3,F12.4)')'3XQ RT*vals: ',& gz%iq(1),gz%iq(2),rtg*vals(1) ! if(tkdeb.gt.0) write(*,'(a,i3,2x,5F8.5)')'3XQ dxrk mm:',& ! jdeg,rtg*vals(1),dxrk0,dxrk return end subroutine calc_toop !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! ! ! new MQMQA excess subroutines below ! using a separate data structury for asymmetries ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine new_mqmqa_excess ! called from calc_mqmqa line 1429. CALCULATES MQMQA excess !\begin{verbatim} ! subroutine new_mqmqa_excess(lokph,intrecin,mqmqj,vals,dvals,d2vals,gz,ceq) subroutine new_mqmqa_excess(lokph,intrecin,mqmqj,vals,dvals,d2vals,gz,ceq) ! vals(1..6) are G, dG.T, dG.P, d2G.T.T, d2G.T.P and d2G.P.P for parameter ! dvals(1,i) are first derivatives wrt fracton and 2nd wrt fraction, T or P ! dvals(1,i) is dG.yi, dval2(2,i) is d2G.yi.T, dvals(3,i) is d2G.yi.P ! d2vals(i,j) are second derivatives to 2 fractions, IGNORED HERE ! gz%nofc is number of fraction variables multiplied with this parameter(?) ! ! written using the gtp_allinone data structure for asymmetric excess implicit none ! mqmqj is index of first constituent in endmemberrecord integer lokph,mqmqj ! type(gtp_property), pointer :: lokpty type(gtp_parcalc) :: gz type(gtp_phase_varres), pointer :: phres TYPE(gtp_mqmqa_var), pointer :: mqf ! dvals(1,x) is derivative wrt constituent x, dvals(2,x) is d2G/dTdx ..... ! dvals(3,x) is derivative wrt d2G/dPdx double precision vals(6),dvals(3,gz%nofc) ! **** d2vals NOT USED double precision d2vals(gz%nofc*(gz%nofc+1)/2) ! pointer to first interaction record from an endmember ! intrecin is copied to intrec and then nullified. intrec may be updated below, TYPE(gtp_interaction), pointer :: intrecin,intrec,intrecfirst type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} ! needed locally? TYPE(gtp_intstack), dimension(:), allocatable :: savedint TYPE(gtp_pystack), pointer :: pystack TYPE(gtp_phase_add), pointer :: addrec TYPE(gtp_terdata), pointer :: ternaries TYPE(gtp_property), pointer :: proprec TYPE(gtp_interaction), pointer :: ternaryexcess ! type(gtp_allinone), pointer :: compvar ! character*120 text double precision :: rtg logical :: once=.true. integer ppow,qpow,rpow,intlev,iiz,jj,pairquad,jp integer, save :: proprecno=0 integer parquad(4),nprr,nfr,dd integer :: nex=0 integer, dimension(:), allocatable :: ylinks,qlinks integer ncv,icv,nqx,lokcs,lokfun,xq,cxq,mm double precision compprod,nomin,ternary,tpfun(6) ! logical, save :: ternaryonce=.true. ! ! composition derivatives are only relative to quads !!!!!!! ! the composition variables for a parameters are expressions using asymmetric ! y_ik, \xi or \varkappa which depend on quads ! we have to sort out how this affects the derivatives ! dy_ik are factors for y_ik relative to quads, can be 1 or less ! dxi_ij and dx_ji and dvk_ij and dvk_ji are 1 or less ! A parameter P multiplied with vk_ij(ij) has several contributions to the ! derivatives dP(zz), dvk_ij(ij,zz),zz=1,nquad integer idyix(5,mqmqa_data%nquad) integer zkij,nvkappa,ijx,nexrec,nooftps double precision term1,term2,dterm1,dterm2,dsum double precision haha,one1,dnomin,ddivisor,dternary double precision dyix(5,mqmqa_data%nquad),values(6) double precision dvalxq(mqmqa_data%nquad) ! pder(nquad) is the derivative of parameter wrt to each quad ij ! double precision pder(mqmqa_data%nquad*(mqmqa_data%nquad-1)/2 double precision debugder(mqmqa_data%nquad) ! for debug only ! dvkijz(1,*) are dvk_ij/dxquad and dvkijz(2,*) are dvk_ji/dxquad double precision dvkijz(2,mqmqa_data%nquad) ! These are short for the values of vk_ij and vk_ji double precision vk_ij,vk_ji ! partial derivative for one parameter contribution double precision d1vals(mqmqa_data%nquad) double precision dtvals(mqmqa_data%nquad) ! FactSage Factor ! double precision :: FSF=1.0d0 ! character*1 ptyp1 ! The previous MQMQA excess implementation arrive here ! If mqmqa_data%exlevel is zero we should return and old code will still work. ! write(*,*)'3XQ in new_mqmqa_excess',mqmqa_data%exlevel if(mqmqder) write(*,*)'3XQ in new_mqmqa_excess',mqmqa_data%exlevel if(mqmqa_data%exlevel.eq.0) then ! if(once) write(*,6)mqmqa_data%exlevel 6 format('3XQ *** this system use the old excess model ***',i5) goto 1000 endif !-------------------------------------------------------------- ! we are here because this endmember has an intercation link ! if(mqmqxcess .and. associated(intrecin)) write(*,5)mqmqj if(mqmqxcess) write(*,5)mqmqj ! write(*,5)mqmqj 5 format(/'3XQ in new_mqmqa_excess ',i3,' with intreraction record') ! initiate ylinks for this tree with the endmember fraction intrecfirst=>intrecin intrec=>intrecin ! this is needed to move to next endmemeber nullify(intrecin) ! ! below divide values with rtg? rtg=globaldata%rgas*ceq%tpval(1) !--------------------------------- ! not more than 10 interactions .... allocate(savedint(10)) allocate(ylinks(10)) allocate(qlinks(10)) ! this is the endmember constituent nfr=1 ylinks(1)=mqmqj ! there can only a one quad with two cations (pair) in an interaction pairquad=0 ! ifem: do jj=1,mqmqa_data%ncat ! if(ylinks(1).eq.mqmqa_data%emquad(jj)) goto 17 ! enddo ifem ! this quad is evidently a pair AB/X ! pairquad=ylinks(1) 17 continue ! ! THIS IS THE EXCESS CALCULATION ROUTINE WITH extensive DEBUG LISTING ADDED ! ! loop here until all excess records from this endmember calculated ! The new excess model implementation using allinone etc below ! The quad fractions and related composition variables such as ! quadfractions and asymmetrical variables have been set by set_constitution ! ! ceq%phase_varres(lokcs)%mqmqaf%compvar(icv)%vi_ij etc ! access to composition variables ! lokcs=phlista(lokph)%linktocs(1) mqf=>ceq%phase_varres(lokcs)%mqmqaf ! ! when we are here intrec must be associated ! All interaction records from a single endmember record will be calculated nexrec=0 intlev=0 nooftps=0 ! if no parameters return zero ! otherwise vals and dvals sums up all excess parameters for this endmember ! write(*,*)'3XQ line 2218: zero excess contribution' ! mqmqx_deltag=0.0d0 ! These values return sum of all excess parameters for this endmember vals=zero ! dvals has dimension dvals(3,mqmqa_data%nquad) dG/dy_i, d2G/dTdy_i, d2G/dPdy_i dvals=zero ! summing partial derivatives for each separate parameter, no P derivative ! d1vals=zero ! dtvals=zero ! intloop: do while(associated(intrec)) ! ! intrec must be associated here, nexrec just counts interaction records nexrec=nexrec+1 ! ! there is a single set of sites, save constituent first index ! We may come back here for another interaction with same endmember ! Set ylinks to be indices of the OC fractions ! write(*,88)intlev,associated(intrec%propointer),intrec%fraclink 88 format('3XQ Starting intloop with component ',i3,l2,5i4) ! save name of interacting constituent even if no property nfr=nfr+1 ylinks(nfr)=intrec%fraclink(1) proprec=>intrec%propointer ! loop for all property records for same set of constituents proplist: do while(associated(proprec)) ! we have found an excess parameter !!! lokfun=proprec%degreelink(0) if(lokfun.gt.0) nooftps=nooftps+1 call eval_tpfun(lokfun,ceq%tpval,tpfun,ceq%eq_tpres) if(gx%bmperr.ne.0) goto 1000 if(mqmqxcess) then write(*,114)ptyp1,lokfun,rtg,tpfun(1),tpfun(2) 114 format('3XQ tpfun: ',a,i4,6(1pe12.4)) endif if(tpfun(1).eq.0.0d0) then ! skip if there is no TP function (no TPFUN used during testing) proprec=>proprec%nextpr nex=nex+1 cycle proplist endif ! divide all parameter values with rtg!! tpfun=tpfun/rtg ! calculate all d(varkappa_ij)/dx_kl nvkappa=size(mqf%compvar) ! there can be several property record for the same set of constituents proprecno=proprecno+1 if(proprec%proptype.eq.34) ptyp1='G' if(proprec%proptype.eq.35) ptyp1='Q' if(proprec%proptype.eq.36) ptyp1='B' ! ternary=1.0D0 ppow=proprec%asymdata%ppow qpow=proprec%asymdata%qpow rpow=proprec%asymdata%rpow if(mqmqxcess) then ! LIST PARAMETER helps to understand what the parameter it is .... jp=1 text=' ' call mqmqa_excesspar_name(lokph,intlev,nfr,ylinks,text,jp) text(jp-1:)=';'//ptyp1//','//char(ichar('0')+ppow)//& ','//char(ichar('0')+qpow)//','//char(ichar('0')+rpow)//')' write(*,115)trim(text),ppow,qpow,rpow 115 format(/'3XQ param: ',a,', pqr:',3i2) ! extract the quad pointers endif ! ! lokfun=proprec%degreelink(0) ! can xq be zero here ?????? xq=proprec%asymdata%quad ! cxq transforms the quad index to an index in compvar (which as not diagonal) cxq=mqmqa_data%quad2compvar(xq) vk_ij=mqf%compvar(cxq)%vk_ij vk_ji=mqf%compvar(cxq)%vk_ji ! write(*,1160)xq,mqf%xquad(xq),vk_ij,vk_ji,mqf%compvar(cxq)%denominator 1160 format('3XQ xq etc: ',i3,4(1pe14.6)) !------------------------------------------------------------- ternary ternary=one par3: if(nfr.gt.3) then ! if(ternaryonce) write(*,116) write(*,116) 116 format(/'3XQ *** ternary parameters to be implemented ***'/) ! ternaryonce=.false. ! goto 1000 ! this is a dummy call call ternary_factor(xq,mqf%compvar(cxq)%cat1,mqf%compvar(cxq)%cat2,& ylinks,mm,ternary,proprec) if(gx%bmperr.ne.0) goto 1000 endif par3 !------------------------------------------------------------- end ternary ! Maybe a scaling difference with FactSage, multiply tpfun by FSF ! FSF=1.5D0 ! write(*,*)'3XQ Scaling with ',FSF ! tpfun(1)=FSF*tpfun(1) ! !-------------------------------------------------------------------- ! multiply the parameter with the composition variables ptyp: if(ptyp1.eq.'G') then ! ppow is for varkappa_ij, qpow is for varkappa_ji, term1 and term2 used below ! vk_ij and vk_ji are (sum of quands)/(sum of quads) term1=1.0d0 term2=1.0d0 ! if ppow or qpow is zero the term is unity if(ppow.gt.0) term1=vk_ij**ppow if(qpow.gt.0) term2=vk_ji**qpow nomin=term1*term2 ! ternary = 1.00, rtg=R*T compprod=mqf%xquad(xq)*nomin*ternary ! vals(1) is the sum of all excess parameters linked from this endmember vals(1)=vals(1)+compprod*tpfun(1) ! list 2 indices, 2 powers, 3 constitutions, tpfun, constituents*tpfun, vals if(xq.gt.0) then ! list value of excess parameter if(mqmqxcess) then write(*,991)xq,nexrec,ppow,qpow,& ! mqf%xquad(xq),vk_ij,vk_ji,& mqf%xquad(xq),term1,term2,& rtg*tpfun(1),compprod*tpfun(1),vals(1) 991 format('3XQ line 2357:',i3,3i2,3F7.4,3(1pE12.4)) endif else write(*,*)'3XQ no quad index!' stop endif !-------------------------------------------------------------------- ! BEGIN calculate partial derivatives ........... ! any quad can be involved in compvar(cxq)%vk_ij if(mqmqder) then write(*,992)xq,cxq,mqf%compvar(cxq)%cat1,mqf%compvar(cxq)%cat2 992 format('3XQ derivatives of quad: ',i2,', and vk_ij and vk_ji: ',& i3,2x,2i3) write(*,*)'3XQ calling dvkij_dzijkl for varkappa: ',cxq endif nqx=mqmqa_data%nquad ncv=size(mqf%compvar) ! ! cxq is varkappa involved with this parameter ! calculate all partial derivatives of this wrt nqx quad fractions ! The vk_ij/vk_ji are used for several parameters and their derivatives ! should calculated only once ! dvkijz(1, 1..nqx) are derivatives of vk_ij: dvk_ij/dxz ! dvkijz(2, 1..nqx) are derivatives of vk_ji: dvk_ji/dxz call dvkij_dzijk(mqf,cxq,dvkijz) if(gx%bmperr.ne.0) goto 1000 ! ! loop for derivatives of parameter for all quads zkijloop: do zkij=1,nqx ! ! EG = xq * (vk_ij**pp) * (vk_ji**qq) * param ! ! dEG/dxz = xq * pp*(vk_ij**(pp-1))*dvk_ij/dxz * (vk_ji**qq) * param + ! xq * (vk_ij**pp) * qq*(vk_ji**(qq-1))*dvk_ji/dxz * param + ! dxq/dxz * (vk_ij**pp) * (vk_ji**qq) * param ! if(ppow.eq.0) then dterm1=term2 elseif(ppow.eq.1) then dterm1=dvkijz(1,zkij) * term2 else dterm1=ppow*vk_ij**(ppow-1)*dvkijz(1,zkij)*term2 endif ! dvkijz(1,zkij) is dvk_ij/dxz and ! dvkijz(2,zkij) is dvk_ji/dxz if(qpow.eq.0) then dterm2=term1 elseif(qpow.eq.1) then dterm2=term1*dvkijz(2,zkij) else dterm2=term1*qpow*vk_ji**(qpow-1)*dvkijz(2,zkij) endif if(zkij.eq.xq) then dsum=(dterm1+dterm2)*mqf%xquad(xq)+term1*term2 else dsum=(dterm1+dterm2)*mqf%xquad(xq) endif ! dvkijz are the derivative of EG with respect to xqz ! dvals(1,...) is dG/dy, dvals(1,zkij)=dvals(1,zkij)+dsum*tpfun(1) ! dvals(2,...) is d2G/dydT, dvals(3,...) is d2G/dydP dvals(2,zkij)=dvals(2,zkij)+dsum*tpfun(2) ! this is just for debug output below debugder(zkij)=dsum enddo zkijloop ! debug output of all fraction product derivatives ! rtg&tpfun(1) and vals(1) listed at line 2357 ! write(*,997)rtg*tpfun(1),vals(1),(debugder(zkij),zkij=1,nqx) ! write(*,997)(debugder(zkij),zkij=1,nqx) 997 format('3XQ df/dx:',20(1pe11.3)) ! partial derivative end >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> if(mqmqder) write(*,122)(dvals(1,zkij),zkij=1,nqx) 122 format('3XQ dEG/dxz ',20(1pe11.3)) elseif(ptyp1.eq.'Q') then ! write(*,*)'3XQ the Q parameter not implemented yet',ptyp1 stop else write(*,*)'3XQ the B parameter not implemented: ',ptyp1 stop endif ptyp if(mqmqxcess) write(*,*)'3XQ end of a parameter: ',ptyp1,lokfun,nexrec ! 800 continue if(mqmqxcess .and. associated(proprec)) write(*,96)' more ',vals(1) 96 format('3XQ ',a,' Current Excess G: ',1pe12.4) proprec=>proprec%nextpr nex=nex+1 enddo proplist ! ! we have calculated all property records for one excess parameter ! there can be a ternary or more binary parameters ! ternaryexcess=>intrec%highlink ! All mqmqa parameters are "ternary" or higher ! write(*,811)associated(ternaryexcess) 811 format('3XQ is there a link to higher excess?',l2) ! if(ternaryexcess) then ! write(*,*)'3XQ this must be an error, not implemeneted' ! nullify(ternaryexcess) ! endif push_ornext: if(associated(intrec%highlink)) then ! go to higher level of interaction but save link to next for other parameters intlev=intlev+1 if(associated(intrec%nextlink)) then if(mqmqxcess) write(*,97)intlev,intrec%nextlink%fraclink 97 format('3XQ saved nextlink at intlev: ',2i3) if(intlev.gt.9) then write(*,*)'Interaction level record overflow',intlev gx%bmperr=4399; goto 1000 endif savedint(intlev)%saved=>intrec%nextlink else nullify(savedint(intlev)%saved) endif intrec=>intrec%highlink else if(mqmqxcess) write(*,*)'3XQ any more excess on level?',intlev,nexrec intrec=>intrec%nextlink ! too many constituents ... nfr=nfr-1 pop: do while(.not.associated(intrec)) ! write(*,*)'3XQ pop stack',intlev,nfr if(intlev.gt.0) then intrec=>savedint(intlev)%saved intlev=intlev-1 nfr=nfr-1 else exit intloop endif ! if(associated(intrec)) & ! write(*,*)'3XQ take nextlink ',intrec%fraclink(1) enddo pop if(.not.associated(intrec)) exit intloop ! why cycle? ! cycle intloop endif push_ornext enddo intloop ! !------------ return to next endmember 1000 continue if(mqmqxcess) then if(associated(intrecfirst)) then proprec=>intrecfirst%propointer write(*,1001)nexrec,vals(1) ! ,(dvals(1,mm),mm=1,mqmqa_data%nquad) 1001 format('3XQ exit new_mqmqa_excess, excess records: ',i5,2x,1pe12.4) endif endif ! write(*,1099)vals(1),nexrec,nooftps ! if(mqmqxcess) write(*,1099)vals(1),nexrec,nooftps 1099 format('3XQ exit new_mqmqa_excess with G=',1pe12.4,& ', ',i3,' parameters and ',i3,' TPFUNs') return end subroutine new_mqmqa_excess !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine dvkij_dzijk !\begin{verbatim} subroutine dvkij_dzijk(mqf,cxq,dvkijk) ! calculates all partial derivatives of a parameter multiplied with ! xquad * varkappa**ppow * varkappa**qpow implicit none ! type(gtp_phase_varres), pointer :: phres type(gtp_mqmqa_var), pointer :: mqf type(gtp_allinone), pointer :: box integer cxq ! there are mqmqa_data%nquad variable and derivatives double precision dvkijk(2,mqmqa_data%nquad) ! cxq is the varkappa index ! dvkijk is the the 2D array with derivatives of vk_ij and vk_ji with respect ! to all quad fractions. Many of them will be zero !\end{verbatim} ! ! Looking for errors in ternaries, suspect missing derivative wrt ! derivatives of quad fraction in denominator _kvk not included !!!??? ! df/dx = -nominator/denominator**2 = -g/h**2 ! integer ijkl,vkix,vkdenom,kk,mxq,dgij,dgji,dijk,cat1,cat2 double precision sumi, sumj, sumk, dvkij, dvkji, dvkdenom logical skip,dksum ! integer, allocatable :: qdone(:) ! integer, allocatable :: indenom integer denomx,qq,ii ! ! derivative of a quotient d(g/h) = 1/h*dg/dx - (g/h**2)*dh/dx = ! (h*dg/dx - g*dh/dx)/h**2 ! dgij=0 if no derivative of vkij ! dgji=0 if no derivative of vkji ! dijk=0 if no derivative of kvkall ? ! NOTE both vkij and vkji has the same denominator, specified by kvkijk !!! ! ! This routine calculates both d(vk_ij)/dx and d(vk_ji)/dx ! with respect to all quadrupole fractions ! dvkijk=0.0d0 ! mxq=mqmqa_data%nquad box=>mqf%compvar(cxq) denomx=size(box%all_ijk) cat1=box%cat1 cat2=box%cat2 ! initiate done with all quad indices ! allocate(qdone(denomx)) ! qdone=mqf%compvar(cxq)%all_ijk ! write(*,7)size(dvkijk),qdone 7 format('3XQ *** enter dvkij_dzijk, qdone: ',i5,2x,20i3) ! write(*,8)dvkijk 8 format('3XQ dvkijk:',6(1pe10.2)) ! ! set all partical derivatives to zero as default return if(mqmqder) then write(*,*)'3XQ *** entering dvkij_dzijkl',cxq,mxq ! write(*,*)'3XQ in dvkij_dzijkl',cxq,mxq ! write(*,10)mqf%compvar(cxq)%ivk_ij ! write(*,20)mqf%compvar(cxq)%jvk_ji ! write(*,30)mqf%compvar(cxq)%kvk_ijk ! write(*,30)mqf%compvar(cxq)%all_ijk write(*,10)box%ivk_ij write(*,20)box%jvk_ji write(*,30)box%kvk_ijk write(*,40)box%all_ijk 10 format('3XQ ivk_ij: ',10i3) 20 format('3XQ jvk_ji: ',10i3) 30 format('3XQ kvk_ijk:',10i3) 40 format('3XQ kvk_all:',10i3) endif ! initiate all partial derivaties to zero dksum=.true. sumi=zero sumj=zero ! ! vk_ij = \sum_i xquad(ivk_ij) / (\sum_k xquad(kvk_ijk)+\sum_k xquad(ivk_ij)) ! vk_ji = \sum_i xquad(jvk_ji) / (\sum_k xquad(kvk_ijk)+\sum_k xquad(jvk_ji)) ! ! This routine calculates derivatives of variables vk_ij does not depend on! ! ! quadloop: do ijkl=1,mxq ! The loop for ksum needed only once .................... ! do_dksum: if(dksum) then ! if derivative of sum_k xquad(kvk_ijk), if zero all derivatives zero ! the sumk include sum of all fractions in \sum_i and \sum_j ! sumk=zero ! derivative of denominator is zero or one ! dgij=0 ! dgji=0 ! dijk=0 ! skip=.true. ! sumk=0.0d0 denominator: do kk=1,size(box%all_ijk) ! a quad fraction term can only apper once vkix=box%all_ijk(kk) sumk=sumk+mqf%xquad(vkix) ! listing of derivative calculations ! 3XQ kloop for mqf%compvar( 1)%all_ijk( 1) 1 sum 3.5933E-02 1 1 1 ! 3XQ kloop for mqf%compvar( 1)%all_ijk( 2) 1 sum 6.7187E-01 1 3 1 ! 3XQ kloop for mqf%compvar( 1)%all_ijk( 3) 1 sum 1.0000E+00 1 2 1 ! 3XQ iloop for mqf%compvar( 1)%ivk_ij( 1) 1 sum 3.5933E-02 1 1 1 ! 3XQ jloop for mqf%compvar( 1)%jvk_ji( 1) 1 sum 6.3593E-01 0 3 1 ! 3XQ dvk: 1 1 0 3.5933E-02 6.3593E-01 1.0000E+00 9.6407E-01 -6.3593E-01 ! 3XQ kloop for mqf%compvar( 1)%all_ijk( 1) 2 sum 3.5933E-02 1 1 1 ! 1 2 3 4 ! if(mqmqder) write(*,50)'k',cxq, ')%all_ijk(', kk,') ',& ! ijkl,'k',sumk,1,vkix,ijkl ! 5 6 7 8 9 10 ! ! 1 2 3 4 !50 format('3XQ ',a,'loop for mqf%compvar(',i2, a, i2,a,& ! i4,' sum',a,': ',1pe12.4,2x,3i2) ! 5 6 7 8-10 ! mqf%compvar(cxq)%all_ijk(kk),ijkl, sumk ! ! skip=.false. ! write(*,*)'3XQ ********* ',kk,vkix,ijkl ! dijk=1 ! endif enddo denominator ! write(*,51)size(box%all_ijk),sumk,box%all_ijk 51 format('3XQ Summed ',i2,' quads in kvk_ijk ',1pe12.4,10i3) ! if sumk is zero there are no derivatives with respect to this quad ! this is not an error, just a message ! write(*,54)cxq,ijkl !54 format('3XQ vk(',i2,') does not depend on quad ',i2) ! ! below only if the vk_ij and vk_ji do not depend on ijkl ! ! The loop above summed all fraction variables of denominator, needed below ! We have to take care of the nominators if varkappa_ij and varkappa_ji ! sumi=zero ! sumi=0.0d0 nominator1: do kk=1,size(box%ivk_ij) ! dgij=0 vkix=box%ivk_ij(kk) sumi=sumi+mqf%xquad(vkix) ! if(mqf%compvar(cxq)%ivk_ij(kk).eq.ijkl) then ! if(box%ivk_ij(kk).eq.ijkl) then ! if(vkix.eq.ijkl) then ! dgij=1 ! endif ! 1 2 3 4 ! if(mqmqder) write(*,50)'i',cxq, ')%vk_ij(', kk,') ',& ! ijkl,'i',sumi,1,vkix,ijkl ! 5 6 7 8 9 10 enddo nominator1 ! write(*,55)size(box%ivk_ij),sumi,box%ivk_ij 55 format('3XQ Summed ',i2,' quads in ivk_ij',1pe12.4,10i3) ! ! note sumi and/or sumj can be zero ! sumj=0.0d0 nominator2: do kk=1,size(box%jvk_ji) ! dgji=0 vkix=box%jvk_ji(kk) sumj=sumj+mqf%xquad(vkix) ! if(mqf%compvar(cxq)%jvk_ji(kk).eq.ijkl) then ! if(box%jvk_ji(kk).eq.ijkl) then ! if(vkix.eq.ijkl) then ! dgji=1 ! endif ! 1 2 3 4 ! if(mqmqder) write(*,50)'j',cxq, ')%vk_ji(', kk,') ',& ! ijkl,'j',sumj,1,vkix,ijkl ! 5 6 7 8 9 10 enddo nominator2 ! write(*,56)size(box%jvk_ji),sumj,box%jvk_ji 56 format('3XQ Summed ',i2,' quads in jvk_ji',1pe12.4,10i3) ! ! derivative of a quotient d(g/h) = (1/h)*dg/dx - (g/h**2)*dh/dx = ! = (h*dg/dx - g*dh/dx)/h**2 ! ! the derivarive value g=sumi/sumk; h=sumj/sumk; di and dj can be zero ! the derivarive value dj*sumi-di*sumj ! if(sumk.eq.zero) then write(*,*)'3XQ line 2691, division by zero, check source code!!!' sumk=1.0d0 endif ! Attempt 2026.03.29 to fix problem derivatives wrt fractions in denomonator ! ! the derivatives are calculated here, dg/dx and dh/dx is 0 or 1 ! derivative of a quotient d(g/h) = 1/h*(dg/dx) - (g/h**2)*dh/dx ! ! the denominatorof a vk_ij contains all quads dijk=1.0d0 loopdenom: do kk=1,size(box%all_ijk) ! all quads in the vk are present in the denominator ijkl=box%all_ijk(kk) checknom1: do ii=1,size(box%ivk_ij) if(box%ivk_ij(ii).eq.ijkl) then dvkijk(1,ijkl)=(sumk - sumi*dijk)/sumk**2 else dvkijk(1,ijkl)= -sumi*dijk/sumk**2 endif enddo checknom1 checknom2: do ii=1,size(box%jvk_ji) ! do not use dgij and dgji are 0 or 1 depending on quads in vk_ij or vk_ji if(box%jvk_ji(ii).eq.ijkl) then dvkijk(2,ijkl)=(sumk - sumj*dijk)/sumk**2 else dvkijk(2,ijkl)= - sumj*dijk/sumk**2 endif enddo checknom2 ! ! write(*,69)cxq,ijkl,dvkijk(1,ijkl),dvkijk(2,ijkl) 69 format('3XQ dvk(',i2,')_ij&_ji/dq(',i2,') = ',2(1pe12.4)) enddo loopdenom if(mqmqder) then write(*,70)ijkl,sumi,sumj,sumk,& dvkijk(1,ijkl),dvkijk(2,ijkl) 70 format('3XQ dvk2: ',i2,3(1pe12.4),1x,2(1pe12.4)) endif !--------------------------------------------------------- ! return derivatives of dvarkappa(ceq)/dxquad for all quads ! 1000 continue if(mqmqder) then write(*,1090)cat1,cat2,(dvkijk(1,ijkl),ijkl=1,mxq) write(*,1090)cat2,cat1,(dvkijk(2,ijkl),ijkl=1,mxq) 1090 format('3XQ dvk(',i1,',',i1,')/dq: ',20(1pe10.2)) write(*,*)'3XQ *** exit dvkij_dzijk' endif return end subroutine dvkij_dzijk !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine calc_newdvkij_values(phres,ceq) !\begin{verbatim} subroutine calc_newdvkij_values(phres,ceq) ! calculates all partial derivatives of vk_ij wrt x_ij for use in excess param ! f_ij = xquad(xq) * vk_ij(vk)**ppow * vk_ji(vk)**qpow with terms as ! df_ij/dx_lm = ...ppow*vk_ij(vk)**(ppow-)*DVKIJ(ij,lm) ... ! implicit none type(gtp_phase_varres), pointer :: phres type(gtp_equilibrium_data), pointer :: ceq ! ! dvk_ij(ij,lm) is derivative of vk_ij with respect to x_lm ! using ivk_ij, jvk_ji and kvk_ijk ! and current values of x_ij ! values stored in local arrays ?? ! simplification: NO SECOND DERIVATIVES !!!!!!!! not even d2(prod * dL/dT) !!\end{verbatim} ! For the excess we need to calculate many derivatives of ! ! f_ij = x_ij * vk_ij(x_kl)**ppow * vk_ji(x_kl)**qpow * L ! ! which requires values of d(vk_ij(x_kl))/dx_mn ! many times. Calculate all now and store in mqf%compvar(ij)%dvk_ij(mn) ! ! mqf%compvar(ij)%vk_ij array of values of vk(ij) for current quad fractions ! mqf%compvar(ij)%vk_ji " values of vk(ji) ! mqf%compvar(ij)%ivk_ij " of quad indices for nominator of vk_ij (fixed) ! mqf%compvar(ij)%jvk_ji " indices for nominator of vk_ji ! mqf%compvar(ij)%kvk_ijk " indices for denominator of both ! mqf%compvar(ij)%dvk_ij " of derivatives of vk_ij for current quad fractions ! mqf%compvar(ij)%dvk_ji " of derivatives of vk_ij for current quad fractions ! type(gtp_mqmqa_var), pointer :: mqf integer ij,nquad,nvk !----------------------------------------------------------------- ! Calculate all derivatives of vk_ij with resp to all quadruplet x_ij ! ! vk_ij = ivk_ij / kvk_ijk = \sum_kl x_kl / \sum_mn x_mn ! vk_ji = jvk_ji / kvk_ijk = \sum_kl x_kl / \sum_mn x_mn ! ! ivk, jvk and kvk are stored in DVK_ij DVK_JI calculated where ??? ! ! divk, djvk and dkvk are note stored ! ! dvk_klm = d(ivk) * kvk - ivk * d(kvk) / kvk**2 ! ! ! NOTE j>i in x_ij but vk_ij can depend on all x_ii, etc. ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! mqf=>phres%mqmqaf ! ! do ij=1,mqf%npair ! mqf%compvar(ij)%dvk_ij=zero ! mqf%compvar(ij)%dvk_ji=zero ! enddo ! write(*,*)'3XQ remove any call to one_newdvkij_values' stop return end subroutine calc_newdvkij_values !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine convert_y2quadx !\begin{verbatim} subroutine mqmqa_excesspar_name(lokph,intlev,nfr,ylinks,text,jp) ! integer lokph,intlev,nfr integer ylinks(*),jp character text*(*) ! write the set of constituents, complex as ylinks are quadindex ! and ylinks are constiuent order (which may be the same but not always) !\end{verbatim} integer ii,jj,kk character*24, dimension(10) :: const ! strange intlev is 1 here, it is 0 in calling routine ... only endmember quad ! write(*,10)nfr,(ylinks(ii),ii=1,nfr) !10 format('3XQ *** no of const: ',i2,', ylinks: ',10i3) ! write(*,20)phlista(lokph)%constitlist !20 format('3XQ *** phase const: ',25i3) ! phlista(lokph)%constitlist is index in splista <<<<<<<<<<<<<<< ! write(*,30)trim(splista(phlista(lokph)%constitlist(1))%symbol) !30 format('3XQ *** phase const names: ',a) ! ! A useful excersize to remember how data in OC are stored!!! ! text='G(MSCL,'; jp=8 do jj=1,nfr text(jp:)=trim(splista(phlista(lokph)%constitlist(ylinks(jj)))%symbol)//',' jp=len_trim(text)+1 enddo ! write(*,40)(trim(splista(phlista(lokph)%constitlist(ylinks(jj)))%symbol),& ! jj=1,intlev) ! trim(splista(phlista(lokph)%constitlist(ylinks(3)))%symbol) !40 format('3XQ *** phase const name: ',10(a,',')) ! return end subroutine mqmqa_excesspar_name !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine ternary_factor !\begin{verbatim} subroutine ternary_factor(xq,cat1,cat2,ylinks,mm,hejhopp,proprec) ! calculates the ternary factor of a parameter integer xq,cat1,cat2,mm,ylinks(*) double precision hejhopp type(gtp_property), pointer :: proprec !\end{verbatim} ! xq is the AB/X quad index ! cxq in the index in compvar which gives 2 quad indices for A/X and B/X ! ylinks are the OC fraction indices ! mm is the unknown 4th quad ! hejhopp is the value to return, possibly 1.0D0 integer ii write(*,'(a,3i3,2x,10i3)')'3XQ trying to find mm',xq,cat1,cat2,& (ylinks(ii),ii=1,4) ! but ylinks are OC fraction indices, not necessarily same as quad indices ! BUT at present, check which one of the last 2 in ylinks that is an A/X quad do ii=1,size(mqmqa_data%emquad) if(ylinks(3).eq.mqmqa_data%emquad(ii)) goto 100 enddo do ii=1,size(mqmqa_data%emquad) if(ylinks(4).eq.mqmqa_data%emquad(ii)) goto 100 enddo write(*,*)'3XQ cannot find the ternary C/X quad' gx%bmperr=4399; goto 1000 ! return the index of the cation in the C/X quad 100 mm=ii 1000 continue write(*,*)'3XQ leaving ternary_factor',mm return end subroutine ternary_factor !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine convert_y2quadx !\begin{verbatim} subroutine convert_y2quadx(sem,nint,jord,pquad) ! This is to fix the constitution variables for an MQMQX excess parameter. ! It has one AB/X quad index and 2 A/X and B/X quads and possibly a C/X one ! convert y fraction indexed in sem and jord to quad indices in parquad ! ! I am really really fedup with this model ! implicit none integer sem,nint,jord(2,*),pquad(*) !\end{verbatim} integer ii,jj,nq3,kk,pair,qorder(4),lowa,highb,temp(4),nbx ! ! input data from database ! write(*,*)'3XQ *** fixing MQMQA parameter composition variables',& ! size(mqmqa_data%emquad),size(mqmqa_data%con2quad) ! write(*,5)sem,jord(2,1:nint) 5 format('3XQ fixing MQMQA parameter composition variables',10i3) ! write(*,20)'emquad',(mqmqa_data%emquad(jj),jj=1,mqmqa_data%ncat) ! write(*,20)'con2quad',(mqmqa_data%con2quad(jj),jj=1,mqmqa_data%nquad) 20 format('3XQ ',a,21i3) ! pquad(1) should be the pair quad AB/X among sem, jord(2,1..nint) temp(1)=mqmqa_data%con2quad(sem) ! pquad(2) should be the alphabetically first in quad AB/X, i.e A/X ! pquad(3) should be the alphabetically second in quad AB/X, i.e B/X ! pquad(4) should be the 4th quand, not including A or B temp(2)=mqmqa_data%con2quad(jord(2,1)) ! one may have jord(2,2)=0 here if vacancies if(jord(2,2).eq.0) then write(*,*)'3XQ Vacancy not allowed in MQMQA quad' gx%bmperr=4399; goto 1000 endif temp(3)=mqmqa_data%con2quad(jord(2,2)) ! the quad index related to temp(2) and temp(3) should be temp(1) ??? ! check: ! emquad have the quad indices of all A/X quads, there are ncat of them. ! The index of a quad (i,j) where j>i is emquad(i)+j-i ! write(*,*)'3XQ values temp: ',temp(1),temp(2),temp(3) if(temp(2).gt.temp(3)) then write(*,*)'3XQ parameter has wrong order of A/X and B/X quads' stop 76 ! else ! ii=mqmqa_data%emquad(temp(2))+temp(3)-temp(2) ! write(*,*)'3XQ values of mixed quad index: ',temp(1),temp(2),temp(3),ii ! if(temp(1).ne.ii) then ! write(*,*)'3XQ problems with quad indices' ! stop 77 ! endif endif nq3=3 if(nint.eq.3) then nq3=4; temp(4)=mqmqa_data%con2quad(jord(2,3)) endif ! write(*,10)'first',(temp(ii),pquad(ii),ii=1,nq3) 10 format('3XQ ',a,' quads ',2i3,', first ',2i3,', second ',2i3,', maybe ',2i3) ! find the AB/X quad and the arrange the others ! all but one of the quads in temp(1..nq3) should be A/X quads ! and temp(2) should have the lowest index of the AB/x quad and temp(3) ! the highest. Any temp(4) quad should not be A/X or B/X ! this code is horrible ! pair=0; lowa=0 loop4: do ii=1,nq3 pquad(ii)=temp(ii) qorder(ii)=ii ! ! qx is quad ! Calculate: quad(temp(1)*\xi(temp(3),temp(2)**ppow ! write(*,*)'3XQ is this the pair?',pquad(ii),qorder(ii) loopax: do jj=1,mqmqa_data%ncat ! ! cycle loop4 if temp(ii) is an A/X quad ! if(temp(ii).eq.mqmqa_data%emquad(jj)) cycle loop4 enddo loopax ! if we arrive here temp(ii) is a AB/X quad if(pair.eq.0) then ! do not exit as we want to check there is not a second pair ! pair=ii; lowa=jj-1 ! ERROR: we have to loop mequad again to find jj! Or program smarter pair=ii ! write(*,*)'3XQ loop to find the A/X quad index' notneeded: do jj=1,mqmqa_data%ncat if(temp(ii).lt.mqmqa_data%emquad(jj)) exit notneeded ! if(temp(ii).gt.mqmqa_data%emquad(jj)) then ! lowa=jj-1 ! exit notneeded ! endif enddo notneeded lowa=jj-1 ! lowa saves the quad index of the A/X quad for the AB/X quad ! write(*,*)'3XQ the pair is quad ',ii,lowa else write(*,*)'3XQ convert_y2quads found two pair fractions in a parameter' gx%bmperr=4399; goto 1000 endif enddo loop4 ! if lowa=0 we have not found the AB/X quad if(lowa.eq.0) then write(*,*)'3XQ cannot find the AB/X quad',(temp(ii),ii=1,nq3),& ', among ',(mqmqa_data%emquad(ii),ii=1,mqmqa_data%ncat) stop endif ! set the pair as first quad in pquad; maybe change qorder ! write(*,30)pair,lowa,(qorder(ii),ii=1,nq3) 30 format('3XQ we found the pair: ',i3,', lowa:',i3,', qorder:',15i3) ! write(*,40)'3XQ pquad before:',(pquad(ii),ii=1,nq3) ! write(*,40)'3XQ qorder before',(qorder(ii),ii=1,nq3) if(pair.ne.1) then ! shift positions jj=pquad(1); kk=qorder(1) pquad(1)=pquad(pair); qorder(1)=qorder(pair) pquad(pair)=jj; qorder(pair)=kk endif ! write(*,40)'3XQ pquad after:',(pquad(ii),ii=1,nq3) ! write(*,40)'3XQ qorder after',(qorder(ii),ii=1,nq3) 40 format(a,4i3) ! it seems OK here .................. ! now pquad(1) is the pair AB/X. make pquad(2) to be A/X and pquad(3) as B/X ! Probably there is a smart way but I am just fed up with this ! All other constituents must be single cations: A/X, B/X or C/X ! write(*,*)'3XQ value of nq3',nq3 if(nq3.eq.3) then ! It should be sufficient that temp(2) < temp(3) ! But if there is a 4th quad one has to eliminate the quad without A and B if(pquad(2).gt.pquad(3)) then if(pquad(3).ne.lowa) then write(*,*)'3XQ problems finding A/X quad',lowa,pquad(2) jj=pquad(2); pquad(2)=pquad(3); pquad(3)=jj endif endif ! write(*,*)'3XQ order of pquad:',(pquad(kk),kk=1,nq3) else ! lowa must be the A/X quad because AB/X must be after A/X ! the difference between quad AB/X and A/X must be related to the B/X ! pquad(1) is the index of AB/X quad, the A/X quad is lowa ! write(*,20)'emquad again',(mqmqa_data%emquad(jj),jj=1,mqmqa_data%ncat) highb=pquad(1)-mqmqa_data%emquad(lowa) ! write(*,*)'3XQ value of highb',pquad(1),mqmqa_data%emquad(lowa),highb ! the B/X quad should be highb indices in emquad higher than lowa nbx=mqmqa_data%emquad(lowa+highb) ! write(*,*)'3XQ tables are turning:',pquad(3),pquad(4),nbx if(pquad(3).ne.nbx) then if(pquad(4).ne.nbx) then write(*,*)'3XQ circles are square' stop endif jj=pquad(4); pquad(4)=jj; pquad(3)=jj endif ! write(*,*)'3XQ order of pquad:',(pquad(kk),kk=1,nq3) endif ! list everything ! write(*,20)'emquad again',(mqmqa_data%emquad(jj),jj=1,mqmqa_data%ncat) ! write(*,10)'final',(temp(ii),pquad(ii),ii=1,nq3) ! write(*,666)(pquad(ii),ii=1,nq3) 666 format('3XQ fixed MQMQA parameter, quad is ',i3,', asymmetrical: ',10i3) ! write(*,*)'3XQ hit return to handle next parameter' ! read(*,*) ! 1000 continue return end subroutine convert_y2quadx !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine convert_y2quadx_old !\begin{verbatim} subroutine convert_y2quadx_old(sem,nint,jord,pquad) ! This is to fix the constitution variables for an MQMQX excess parameter. ! It has one AB/X quad index and 2 A/X and B/X quads and possibly a C/X one ! convert y fraction indexed in sem and jord to quad indices in parquad ! ! I am really really fedup with this model ! implicit none integer sem,nint,jord(2,*),pquad(*) !\end{verbatim} integer ii,jj,nq3,kk,pair,qorder(4),lowa,highb,temp(4),nbx ! ! input data from database ! write(*,*)'3XQ *** fixing MQMQA parameter composition variables',& ! size(mqmqa_data%emquad),size(mqmqa_data%con2quad) ! write(*,5)sem,jord(2,1:nint) 5 format('3XQ fixing MQMQA parameter composition variables',10i3) ! write(*,20)'emquad',(mqmqa_data%emquad(jj),jj=1,mqmqa_data%ncat) ! write(*,20)'con2quad',(mqmqa_data%con2quad(jj),jj=1,mqmqa_data%nquad) 20 format('3XQ ',a,21i3) ! pquad(1) should be the pair quad AB/X among sem, jord(2,1..nint) temp(1)=mqmqa_data%con2quad(sem) ! pquad(2) should be the alphabetically first in quad AB/X, i.e A/X ! pquad(3) should be the alphabetically second in quad AB/X, i.e B/X ! pquad(4) should be the 4th quand, not including A or B temp(2)=mqmqa_data%con2quad(jord(2,1)) temp(3)=mqmqa_data%con2quad(jord(2,2)) ! the quad index related to temp(2) and temp(3) should be temp(1) ??? ! check: ! emquad have the quad indices of all A/X quads, there are ncat of them. ! The index of a quad (i,j) where j>i is emquad(i)+j-i write(*,*)'3XQ values temp: ',temp(1),temp(2),temp(3) if(temp(2).gt.temp(3)) then write(*,*)'3XQ parameter has wrong order of A/X and B/X quads' stop 76 else ii=mqmqa_data%emquad(temp(2))+temp(3)-temp(2) write(*,*)'3XQ values of mixed quad index: ',temp(1),temp(2),temp(3),ii if(temp(1).ne.ii) then write(*,*)'3XQ problems with quad indices' stop 77 endif endif nq3=3 if(nint.eq.3) then nq3=4; temp(4)=mqmqa_data%con2quad(jord(2,3)) endif ! write(*,10)'first',(temp(ii),pquad(ii),ii=1,nq3) 10 format('3XQ ',a,' quads ',2i3,', first ',2i3,', second ',2i3,', maybe ',2i3) ! find the AB/X quad and the arrange the others ! all but one of the quads in temp(1..nq3) should be A/X quads ! and temp(2) should have the lowest index of the AB/x quad and temp(3) ! the highest. Any temp(4) quad should not be A/X or B/X ! this code is horrible ! pair=0; lowa=0 loop4: do ii=1,nq3 pquad(ii)=temp(ii) qorder(ii)=ii ! ! qx is quad ! Calculate: quad(temp(1)*\xi(temp(3),temp(2)**ppow ! write(*,*)'3XQ is this the pair?',pquad(ii),qorder(ii) loopax: do jj=1,mqmqa_data%ncat ! ! cycle loop4 if temp(ii) is an A/X quad ! if(temp(ii).eq.mqmqa_data%emquad(jj)) cycle loop4 enddo loopax ! if we arrive here temp(ii) is a AB/X quad if(pair.eq.0) then ! do not exit as we want to check there is not a second pair ! pair=ii; lowa=jj-1 ! ERROR: we have to loop mequad again to find jj! Or program smarter pair=ii ! write(*,*)'3XQ loop to find the A/X quad index' notneeded: do jj=1,mqmqa_data%ncat if(temp(ii).lt.mqmqa_data%emquad(jj)) exit notneeded ! if(temp(ii).gt.mqmqa_data%emquad(jj)) then ! lowa=jj-1 ! exit notneeded ! endif enddo notneeded lowa=jj-1 ! lowa saves the quad index of the A/X quad for the AB/X quad ! write(*,*)'3XQ the pair is quad ',ii,lowa else write(*,*)'3XQ convert_y2quads found two pair fractions in a parameter' gx%bmperr=4399; goto 1000 endif enddo loop4 ! if lowa=0 we have not found the AB/X quad if(lowa.eq.0) then write(*,*)'3XQ cannot find the AB/X quad',(temp(ii),ii=1,nq3),& ', among ',(mqmqa_data%emquad(ii),ii=1,mqmqa_data%ncat) stop endif ! set the pair as first quad in pquad; maybe change qorder ! write(*,30)pair,lowa,(qorder(ii),ii=1,nq3) 30 format('3XQ we found the pair: ',i3,', lowa:',i3,', qorder:',15i3) ! write(*,40)'3XQ pquad before:',(pquad(ii),ii=1,nq3) ! write(*,40)'3XQ qorder before',(qorder(ii),ii=1,nq3) if(pair.ne.1) then ! shift positions jj=pquad(1); kk=qorder(1) pquad(1)=pquad(pair); qorder(1)=qorder(pair) pquad(pair)=jj; qorder(pair)=kk endif ! write(*,40)'3XQ pquad after:',(pquad(ii),ii=1,nq3) ! write(*,40)'3XQ qorder after',(qorder(ii),ii=1,nq3) 40 format(a,4i3) ! it seems OK here .................. ! now pquad(1) is the pair AB/X. make pquad(2) to be A/X and pquad(3) as B/X ! Probably there is a smart way but I am just fed up with this ! All other constituents must be single cations: A/X, B/X or C/X ! write(*,*)'3XQ value of nq3',nq3 if(nq3.eq.3) then ! It should be sufficient that temp(2) < temp(3) ! But if there is a 4th quad one has to eliminate the quad without A and B if(pquad(2).gt.pquad(3)) then if(pquad(3).ne.lowa) then write(*,*)'3XQ problems finding A/X quad',lowa,pquad(2) jj=pquad(2); pquad(2)=pquad(3); pquad(3)=jj endif endif ! write(*,*)'3XQ order of pquad:',(pquad(kk),kk=1,nq3) else ! lowa must be the A/X quad because AB/X must be after A/X ! the difference between quad AB/X and A/X must be related to the B/X ! pquad(1) is the index of AB/X quad, the A/X quad is lowa ! write(*,20)'emquad again',(mqmqa_data%emquad(jj),jj=1,mqmqa_data%ncat) highb=pquad(1)-mqmqa_data%emquad(lowa) write(*,*)'3XQ value of highb',pquad(1),mqmqa_data%emquad(lowa),highb ! the B/X quad should be highb indices in emquad higher than lowa nbx=mqmqa_data%emquad(lowa+highb) ! write(*,*)'3XQ tables are turning:',pquad(3),pquad(4),nbx if(pquad(3).ne.nbx) then if(pquad(4).ne.nbx) then write(*,*)'3XQ circles are square' stop endif jj=pquad(4); pquad(4)=jj; pquad(3)=jj endif ! write(*,*)'3XQ order of pquad:',(pquad(kk),kk=1,nq3) endif ! list everything ! write(*,20)'emquad again',(mqmqa_data%emquad(jj),jj=1,mqmqa_data%ncat) ! write(*,10)'final',(temp(ii),pquad(ii),ii=1,nq3) ! write(*,666)(pquad(ii),ii=1,nq3) 666 format('3XQ fixed MQMQA parameter, quad is ',i3,', asymmetrical: ',10i3) ! write(*,*)'3XQ hit return to handle next parameter' ! read(*,*) ! 1000 continue return end subroutine convert_y2quadx_old !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine set_quadfractions(phres,verbose,yfr) !\begin{verbatim} subroutine set_quadfractions(phres,verbose,yfra) ! copy values from yfr to xquad, y_ik etc using con2quad ! mqmqa_data%initaties phase variables for new mqmqa excess model ! the normal fractions, used by the config entropy, already set implicit none type(gtp_phase_varres), pointer :: phres type(gtp_mqmqa_var), pointer :: mqmqaf double precision yfra(*) logical verbose ! type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer ia,iq ! write(*,10) 10 format('3XQ in set_quadfractions, use con2quad for yfr to xquad'/& 'then call calcasymvar to set \varkappa, \xi and Y_ik.',& ' Latt som en platt') mqmqaf=>phres%mqmqaf if(.not.associated(mqmqaf)) then write(*,*)'3XQ there is no mqmqaf record for this phase' stop end if if(verbose) write(*,20)size(mqmqa_data%con2quad),& (mqmqa_data%con2quad(ia),ia=1,mqmqa_data%nquad) 20 format('3XQ mqmqaf%con2quad: ',i3,2x,20i3) do ia=1,mqmqa_data%nquad iq=mqmqa_data%con2quad(ia) ! I am not sure how to copy from yfr to mqmqaf%xquad mqmqaf%xquad(ia)=phres%yfr(iq) if(verbose) write(*,26)ia,phres%yfr(ia),iq,mqmqaf%xquad(iq) 26 format('3XQ the OC fraction: ',i3,1pe14.6,& ' is set to MQMQA quad: ',i3,1pe14.6) enddo ! if(verbose) write(*,*)'3XQ calling calcasymvar for \varkappa_ij, \xi_ij etc.' call calcasymvar(phres) ! if(verbose) write(*,*)'3XQ back from calcasymvar' ! 1000 continue return end subroutine set_quadfractions !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine init_excess_asymm !\begin{verbatim} subroutine init_excess_asymm(lokph) ! subroutine init_excess_asymm(lokph,ic,ia) ! initaties phase variables for new mqmqa excess model ! called from gtp3B create_asymmetry ! number of independent quads, ic cations, ia anions (max 1) implicit none ! ic is number of cations, ia number of anions, there are also avalable globally integer ic,ia,lokph ! type(gtp_phase_record), pointer :: phase type(gtp_ternary_asymmetry), pointer :: asym3rec ! there is a global mqmqa_data record to use!! <<<<<<<<<<<<<<<<<<, !\end{verbatim} integer i,j,k,nseq,mm,apos,nbinsys,ntercat ! integer i,j,k,nseq,mm,apos,lcat,lnan,nbinsys,ntercat ! how to create xquad mm when we need a pointer to gtp_phase_varres? type(gtp_equilibrium_data), pointer :: ceq type(gtp_phase_varres), pointer :: phres type(gtp_mqmqa_var), pointer :: mqf character*6 defasym ! Many properties are symmetric, for example xquad which has a single index ! and is indexed by ijkl(i,j,k,l) where ijkl(i,j,k,l)=ijkl(j,i,k,l) ! but other are unsymmetric such as varkappa and xi ! ! write(*,*)'3QX In init_excess_asymm <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<' ! ceq=>firsteq ! I have forgotten how OC works. When entering phases one can creat ! data structures in gtp_equilibrium_data (record pointer ceq) ! and these will be copied when new equilibrium records created ! (for example parallel calculations). When a second gtp_equilibium_data ! has been created one is not allowed to change this data_structure ! the line below creates a pointer to the gtp_mqmqa_var data inside ceq ! maybe problem with the array here ... i=1 5 continue i=i+1 ! this is very clumsy, but I have no better way phres=>ceq%phase_varres(i) ! write(*,*)'loop: ',i,lokph,phres%phlink if(phres%phlink.ne.lokph) goto 5 ! ! write(*,*)'Found phase_varres!',i mqf=>phres%mqmqaf ! xquad is declared globally in OC BUT maybe better if ! xquad is declared within the gtp3_phase_varres mqmqaf record ??????/ ! The mqf below is part of gtp_phase_varres ! initiate with equal amount ! The xquads in a sequental array and used ONLY to calculate excess parameters ! number of binary cation combination, in a binary 11-12-22 ! in xquad the order is sequential in the cation order ! 1 2 3 4 .. n ! n+1 n+2 .. 2n-1 ! 2n 2n+1 .. ! ... ! n(n+1)/2 ! 1/1 1/2 1/3 1/4 1/n ! 2/2 2/3 .. 2/n ! 3/3 3/4 .. ! ... ! n/n ! the function ijklx(i,j,k,l) calculates the sequential index ! we have to inititate con2quad below with the corresponding cation indices ! now we can create the xquad array and other things in mqf if(.not.allocated(mqf%xquad)) then ! write(*,*)'3XQ allocating xquad',mqmqa_data%nquad,mqmqa_data%nconst allocate(mqf%xquad(mqmqa_data%nquad)) mqf%xquad=1.0d0/mqmqa_data%nquad endif ! ! write(*,*)'3XQ *** Creation of cross indices for fractions and quads below' ! ! ncat=ic ! nan=ia ! write(*,10)trim(phlista(lokph)%name),mqmqa_data%ncat,mqmqa_data%nan 10 format(/'3XQ Initiating mqmqa model for ',a,' with ',i3,' cations and ',& i2,' anion') ! initiate also values in mqmqa_data ! write(*,*)'3XQ init_excess check:',mqmqa_data%ncon1,mqmqa_data%ncat,& ! mqmqa_data%ncon2,mqmqa_data%nan,mqmqa_data%lcat ! mqmqa_data%ncon1=ncat ! mqmqa_data%ncon2=nan ! mqmqa_data%lcat=ncat*(ncat+1)/2 ! FNN/SNN ratio same for all pairs ... in first work: qfnnsnn ! allocate(mqmqa_data%etafs(ncat*nan)) ! mqmqa_data%etafs=2.4D0 ! same as qfnnsnn ! the molefration xquad(1,2) is the same as xquad(2,1) and xquad ! lcat=ncat*(ncat+1)/2 ! lnan=1 if only one anion ! write(*,*)'3xq value of lnan: ',mqmqa_data%lnan ! lnan=nan*(nan+1)/2 ! total number of quads, !>>>>>>> nquad, ncat, nan, lcat and lnan are global variables !!!!!!!!!! ! CHANGE TO USE VALUES IN MQMQA_DATA!!! ! write(*,11)mqmqa_data%ncat,mqmqa_data%nan,mqmqa_data%nquad,& ! mqmqa_data%ncon1,mqmqa_data%ncon2 11 format('3XQ mqmqa_data: ',10i4) ! if(mqmqa_data%ncat.gt.1 .and. mqmqa%data%nan.gt.1) then ! cations 1 and 2 form quads 1/1 1/2 2/2 but xquad(2,1) same as xquad(1,2) ! 11, 12, 22 are separate quad fractions ! nquad=ncat*(ncat+1)/2*nan*(nan+1)/2 ! elseif(nan.eq.1) then ! frequantly there will be a single anion ! nquad=ncat*(ncat+1)/2 ! endif !! !------------------------------------------- ! now initate record with asymmetries ! write(*,*)'Allocating asymmetries',mqmqa_data%ncat nseq=0 if(mqmqa_data%nan.eq.1) then if(mqmqa_data%ncat.gt.1) then nbinsys=mqmqa_data%ncat*(mqmqa_data%ncat-1)/2 !...allocate ternary structure with asymmetry data if(mqmqa_data%ncat.gt.2) then ntercat=mqmqa_data%ncat*(mqmqa_data%ncat-1)*(mqmqa_data%ncat-2)/6 allocate(tersys(ntercat)) ! insert element indices mm=0 do i=1,mqmqa_data%ncat-2 do j=i+1,mqmqa_data%ncat-1 do k=j+1,mqmqa_data%ncat ! initiate all ternaries as symmetrical el(1) < el(2) < el(3) mm=mm+1 if(mm.gt.ntercat) then write(*,*)'wrong allocation of ntercat',mm,ntercat stop endif tersys(mm)%seq=mm tersys(mm)%el(1)=i tersys(mm)%el(2)=j tersys(mm)%el(3)=k tersys(mm)%asymm='KKK' tersys(mm)%isasym=0 enddo enddo enddo ! write(*,17)mm 17 format('init_excess_ asymm allocated ternary structures ',i3) if(mm.ne.ntercat) then stop 'ternary allocation error' endif ! else ! write(*,*)'3XQ No ternary data structures needed' endif else write(*,*)'A liquid with a single cation and anion not implemented' stop endif else write(*,*)'Systems with multiple anions not implemented' stop endif ! varkappa and xi_ijis now part of allinone ! ! if(mqmqa_data%ncat.eq.2) goto 80 ! write(*,67)mqmqa_data%ncat*(mqmqa_data%ncat-1)*mqmqa_data%nan/2 67 format('3XQ init_excess_asymm allocating asymmetrical compvar array: ',i5) ! we have to intitiate several variables in each compvar ! allocate(compvar(ncat*(ncat-1)*nan/2)) ! allocate(mqf%compvar(mqmqa_data%ncat*(mqmqa_data%ncat-1)/2*mqmqa_data%nan)) ! write(*,*)'3QX, initiating compvar for excess model variables',& ! mqmqa_data%ncat,size(mqf%compvar) if(allocated(mqmqa_data%el2ancat)) then ! write(*,69) 69 format('Heureca! el2ancat allocated') ! write(*,70)size(mqmqa_data%el2ancat),mqmqa_data%ncat,mqmqa_data%el2ancat 70 format('3XQ el2ancat: ',2i3,5x,20i3) else write(*,*)'3XQ line 2168: The array mqmqa_data%el2ancat not allocated!' write(*,*)'3XQ should have been done in correlate_const_and_quads' gx%bmperr=4399; goto 1000 endif ! nseq=0 mm=0 ! it would have been better allocate compvar as this ... allocate(mqmqa_data%quad2compvar(mqmqa_data%ncat*(mqmqa_data%ncat+1)/2)) dum1: do i=1,mqmqa_data%ncat dum2: do j=i,mqmqa_data%ncat nseq=nseq+1 if(i.ne.j) then mm=mm+1 mqmqa_data%quad2compvar(nseq)=mm else mqmqa_data%quad2compvar(nseq)=10000 endif enddo dum2 enddo dum1 ! write(*,71)mqmqa_data%quad2compvar 71 format('3XQ check quad2compvar',50i3) ! nseq=0 first: do i=1,mqmqa_data%ncat-1 second: do j=i+1,mqmqa_data%ncat ! initiallize allinone record, allocated as compvar array nseq=nseq+1 mqf%compvar(nseq)%seq=nseq ! these indices are from 1 to n-1 ignoring anions mqf%compvar(nseq)%cat1=i mqf%compvar(nseq)%cat2=j ! these are the element indices in OC if(i.gt.mqmqa_data%xanionalpha) mqf%compvar(nseq)%elcat1=i+1 if(j.gt.mqmqa_data%xanionalpha) mqf%compvar(nseq)%elcat2=j+1 ! note it is negative of element alphabetical index mqf%compvar(nseq)%elan=-mqmqa_data%xanionalpha mqf%compvar(nseq)%anion=1 mqf%compvar(nseq)%lastupdate=-1 ! ivk_ij, jvi_ji, kvk_ijk, xi_ij etc allocated at each calculation ! NOTE vk_ij, xi_ij are single variables in each box, no need to allocate mqf%compvar(nseq)%vk_ij=0.0d0 mqf%compvar(nseq)%vk_ji=0.0d0 mqf%compvar(nseq)%xi_ij=0.0d0 mqf%compvar(nseq)%xi_ji=0.0d0 ! For identifying m used in eq.25 or 26 in Max paper for ternary excess ! in varkappa1 allocate arrays for which quad fractions vk and xi depend ! they can be different for each compvar ! %dvk_ij and %vdk_ji are single variables, arrays for derivatives ! %dvkx_ij and %vdkx_ji are type(zquad) ??, alternative arrays for derivatives ! allocated at first calculation allocate(mqf%compvar(nseq)%dxi_ij(mqmqa_data%nquad)) ! dxi_ij/dquad_k allocate(mqf%compvar(nseq)%dxi_ji(mqmqa_data%nquad)) ! dxi_ji/dquad_k ! The arrays dxi_ij are allocated here but xi_ij are single values in compvar mqf%compvar(nseq)%dxi_ij=0.0d0 mqf%compvar(nseq)%dxi_ji=0.0d0 ! write(*,77)nseq,i,j 77 format(i4,2i5) enddo second enddo first 80 continue ! initiate newXupdate, there is a newupdate I do not know where it is declared ! write(*,*)'3XQ newXupdate for varkappa and xi ',newXupdate ! write(*,*)' *** Where is newupdate declared? ',newupdate newXupdate=0 ! allocate quadz with zi_ijkl, for a single anion ! There are some data for Zv_ij/kl declared in mqmqa_data, use that!! ! write(*,79)ncat*(ncat+1)/2 79 format('Allocating ',i3,' quadz array, for zv_ijkl data') ! allocate(quadz(ncat*(ncat+1)/2)) ! create crossreferences beween OC datastructure and MQMQX asymmetric ! write(*,*)'3qx **** init_excess_asymm calls correlate_const_and_quads' ! ! THIS ROUTINE CALLS THIS ONE call correlate_const_and_quads(lokph) ! if(gx%bmperr.ne.0) goto 1000 ! ! write(*,90)mqmqa_data%ncat*mqmqa_data%nan 90 format('Allocating pair fraction array y_i/k: ',i4) ! y_ik varies with the current constitution allocate(mqf%y_ik(mqmqa_data%ncat*mqmqa_data%nan)) ! with multiple anion derivatives add dimension nan also ! its content is set in varkappa1 ! write(*,*)'3XQ allocating mqf%dy_ik: ',ncat,nan,nquad, assume nan=1 ! dy_ik is a structure information, independent of current constitution allocate(mqmqa_data%dy_ik(mqmqa_data%ncat,mqmqa_data%nquad)) call pairfracs(.false.,mqf) ! 1000 continue ! ! REMOVE ncat from global data structure write(*,99)mqmqa_data%ncat,mqmqa_data%nquad,size(phres%yfr),size(mqf%compvar) 99 format(/'3QX **** leaving init_excess_asym : ',10i4/) ! return end subroutine init_excess_asymm !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine pairfracs !\begin{verbatim} subroutine pairfracs(list,mqf) ! calculate all pair fractions from a set of quad fractions ! pair fractions are y_v/x = \sum_ik/kl x_ij/kl*(delta_iv+delta_jv)/etafs ! if there is a single anion implicit none logical list type(gtp_mqmqa_var), pointer :: mqf !\end{verbatim} integer i,j,v,dd,seq ! double precision sum,nofs(ncat),yfs(ncat),sum1,sum2,zz double precision sum,sum1,sum2,zz double precision nofs(mqmqa_data%ncat) double precision yfs(mqmqa_data%ncat) ! how to move variables in the mqmqa_var record ?? ! mqf is a pointer!! ! seq=0 if(.not.allocated(mqf%xquad)) then write(*,*)'xquad not allocated' stop endif ! write(*,*)'3XQ In pairfracts ncat and nan: ',ncat,nan if(list) write(*,6) 6 format(/'Calculating pair fractions'/& 6x,'seq i j sum sum2 1 2 3 4 5 6') sum1=0.0d0 sum2=0.0d0 do i=1,mqmqa_data%ncat ! loop will count each quad once including 11, 22 etc. do j=i,mqmqa_data%ncat if(mqmqa_data%nan.ne.1) then write(*,*)'Cannot calculate pair fractions with 2 or more anions' stop endif seq=seq+1 zz=0.5d0*mqf%xquad(ijklx(i,j,1,1)) if(seq.ne.ijklx(i,j,1,1)) then ! test for bugs ... write(*,*)'In pairfracs, ijklx and seq does not agree',seq stop endif ! if i=j they are added here nofs(i)=nofs(i)+zz nofs(j)=nofs(j)+zz ! y_ik(i) is the sum of all quads fractions with element i divided by /etafs ! dy_ik(i,z) is 0.5/etafs(i) for quad z yfs(i)=yfs(i)+zz/mqmqa_data%qfnnsnn(i) yfs(j)=yfs(j)+zz/mqmqa_data%qfnnsnn(j) ! These are constants, only calculate once, seq is the quad index ! dy_ik(i,seq)=0.5d0/etafs(i) ! dy_ik(j,seq)=0.5d0/etafs(j) ! ignore etafs ... but we must take stoichiometry Zv_ijkl into account! if(i.eq.j) then mqmqa_data%dy_ik(i,seq)=1.0d0 else mqmqa_data%dy_ik(i,seq)=0.5d0 mqmqa_data%dy_ik(j,seq)=0.5d0 endif ! sum1=sum1+2*zz sum2=sum2+zz/mqmqa_data%qfnnsnn(i)+zz/mqmqa_data%qfnnsnn(j) if(list) then write(*,7)seq,i,j,sum1,sum2,nofs 7 format('y_ik: ',i3,2x,2i3,2F6.3,2x,(10F6.3/)) endif enddo enddo ! a lot of trouble but it seems to work now .... ! These y_ik are for symmetrical systems ....unsure if this fnnsnn used ??? do i=1,mqmqa_data%ncat mqf%y_ik(i)=yfs(i)/sum2 enddo ! write(*,*)'3XQ line 3179 Calculated y_i/k from quad fractions',mqf%y_ik(1) if(list) then write(*,10)'\etafs ',mqmqa_data%qfnnsnn,sum2 write(*,10)'y_i/k: ',mqf%y_ik,sum1 10 format(a,10F7.4) do i=1,mqmqa_data%ncat write(*,12)i,(mqmqa_data%dy_ik(i,dd),dd=1,mqmqa_data%nquad) 12 format('dy_ik/dq: ',i2,12F6.3) enddo endif end subroutine pairfracs !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable function ijklx(i,j,k,l) !\begin{verbatim} integer function ijklx(i,j,k,l) ! i and j are cations, the order irrelevant ! k and l are anions, the order irrelevant ! always use the lowest value of i and j as first index below ! always use the lowest value of k and lj as first index below implicit none integer i,j,k,l !\end{verbatim} integer iquad,kquad,a,b,x,y ! iquad=0 ! Important order!!! ! Note i,j same as j,i and k,l same as l,k, lowest index always first ! Index order: ! 1 2 ncat ncat+1 ncat+2 ! (1,1,1,1), (1,2,1,1), ... (1,ncat,1,1), (2,2,1,1) (2,3,1,1) ... ! (2,ncat,1,1), (3,3,1,1), ... (3,ncat,1,1), (4,4,1,1) ... (ncat,ncat,1,1) ! (1,1,1,2), (1,2,1,2), ... (1,ncat,1,2), ... (ncat,ncat,1,2), ! (1,1,2,2), (1,2,2,2), ... (ncat,ncat,2,2), (1,1,3,3), (1,2,3,3), ... ! (ncat,ncat,nan,nan) ! indices (2,1,1,1) is same as (1,2,1,1) ! !------------------------------ ! confusion where ncat,nan etc are stored ! write(*,*)'Calling ijklx with: ',i,j,k,l ! write(*,5)mqmqa_data%ncon1,mqmqa_data%ncon2,mqmqa_data%nconst,& ! mqmqa_data%npair,mqmqa_data%lcat !5 format('ijklx fixed values',2i4,2x,5i4) ! The cation index i,j order i<=j to find (i-1)*ncat-i*(i-1)/2+j ! The anion index k,l order k<=l to find (k-1)*nan-k*(k-1)/2+l ! For each set of anion indices there are lcat=ncat*(ncat+1)/2 cation fractions if(i.le.0 .or. i.gt.mqmqa_data%ncon1 .or. & j.le.0 .or. j.gt.mqmqa_data%ncon1) goto 2000 if(k.le.0 .or. k.gt.mqmqa_data%ncon2 .or. & l.le.0 .or. l.gt.mqmqa_data%ncon2) goto 2000 ! if(l.lt.k) then kquad=(l-1)*mqmqa_data%ncon2-l*(l-1)/2+k-1 ! write(*,10)l,k,mqmqa_data%ncon2,kquad else kquad=(k-1)*mqmqa_data%ncon2-k*(k-1)/2+l-1 ! write(*,10)k,l,mqmqa_data%ncon2,kquad endif 10 format('Anion index in ijklx: ',2i3,2i10) ! if(j.lt.i) then iquad=(j-1)*mqmqa_data%ncon1-j*(j-1)/2+i ! write(*,20)j,i,mqmqa_data%ncon1,kquad else iquad=(i-1)*mqmqa_data%ncon1-i*(i-1)/2+j ! write(*,20)i,j,mqmqa_data%ncon1,kquad endif 20 format('Cation index in ijklx: ',2i3,2i10) iquad=kquad*mqmqa_data%lcat+iquad ! write(*,30)iquad,kquad,lcat,i,j,k,l 30 format('Index in xquad: ',i5,5x,3i5,5x,2i5) if(iquad.gt.mqmqa_data%nconst) goto 1000 ijklx=iquad ! write(*,*)'Return from ijklx with:',iquad ! 77 continue return ! errors 1000 write(*,1010)i,j,k,l,mqmqa_data%ncon1,mqmqa_data%ncon2,mqmqa_data%lcat,& kquad,iquad 1010 format(' *** Indexing error in ijklx',4i4,2x,7i5,/'Stop!!!!') gx%bmperr=4399 goto 77 ! 2000 continue write(*,2010)i,j,k,l,mqmqa_data%ncon1,mqmqa_data%ncon2 2010 format('3XQ Quad indices outside limits',4i3,5x,2i3) gx%bmperr=4399 goto 77 end function ijklx !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine binsym ! calculates sequential index of a binary system !\begin{verbatim} integer function binsym(i,j) ! SEPARATE FOR CATIONS AND ANION BINARIES, maybe merge with gtp_allinone? ! The binary systems form a symmetric matrix where (i,j) is the same as (j,i) ! and data for this system is stored as a linear array where where i > j always ! This function return the sequantial index for the binary (i,j) ! it is essentially the same as ijklx but only one set of indices ! The dimension of the binary cation matrix is the global variable ncat ... ! ! i/j 1 2 3 4 5 6 end of previous row ncat*(ncat-1)/2 = 6*5/2 ! 1 0 1 2 3 4 5 0 (ncat-j)*(ncat-j-1)/2 10 4*5/2 = 10 ! 2 1 - 6 7 8 9 5 15 - (6-2)*(6-1)/2 = 15-4*5/2 = 5 ! 3 2 6 - 10 11 12 9 15 - (6-3)*(6-2)/2 = 15-3*4/2 = 9 ! 4 3 7 10 - 13 14 12 15 - (6-4)*(6-3)/2 = 15-2*3/2 = 12 ! 5 4 8 11 13 - 15 14 15 - (6-5)*(6-4)/2 = 15-1 =14 ! 6 5 9 12 14 15 - note (6,6) is not a binary!!! implicit none integer i,j !\end{verbatim} ! integer ix,iy if(i.le.0 .or. i.gt.mqmqa_data%ncat) goto 1100 if(j.le.0 .or. j.gt.mqmqa_data%ncat) goto 1100 ix=0 if(j.lt.i) then if(j.gt.1) then ix=mqmqa_data%ncat*(mqmqa_data%ncat-1)/2 -& (mqmqa_data%ncat-j)*(mqmqa_data%ncat-j+1)/2 endif iy=ix+i-j else ! j > i if(i.gt.1) then ix=mqmqa_data%ncat*(mqmqa_data%ncat-1)/2 - & (mqmqa_data%ncat-i+1)*(mqmqa_data%ncat-i)/2 endif iy=ix+j-i endif binsym=iy 1000 continue return 1100 write(*,*)'Indexing error in binsym ',i,j,iy iy=-1 goto 1000 end function binsym !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine order3 !\begin{verbatim} subroutine order3(i,j,v,a,b,c) ! subroutine to rearrange i, j, v in increasing order in a, b, c implicit none integer i,j,k,a,b,c,v !\end{verbatim} ! Return i, j, k ordered in a= j and v > j thus j is smallest a=j if(i.lt.v) then b=i; c=v elseif(v.lt.i) then b=v; c=i else write(*,10)'3: i=v',i,j,v goto 1100 endif elseif(v.lt.j) then ! here when i>j and j>v a=v; b=j; c=i else ! ! two or more numbers equal goto 1100 endif return ! 1100 continue write(*,*)' *** Error in call to order3: ',i,j,v a=-1 end subroutine order3 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine order3KKK !\begin{verbatim} subroutine order3KKK(i,j,v,a,b,c,kkk) ! subroutine to rearrange i, j, v in increasing order in a, b, c implicit none integer i,j,k,a,b,c,v,jj character kkk*3,kopia*3,ch1*1 !\end{verbatim} ! Return i, j, v ordered in a= j and v > j thus j is smallest a=j if(i.lt.v) then b=i; c=v elseif(v.lt.i) then b=v; c=i else write(*,10)'3: i=v',i,j,v goto 1100 endif elseif(v.lt.j) then ! here when i>j and j>v a=v; b=j; c=i else ! two or more numbers equal goto 1100 endif 1000 continue ! rearrange kkk to the new order of cations. ! KTK means the Toop element should be the second, TKK third and KKT first. ! programming this makes me sick Just for a single Toop element fix: do jj=1,3 ch1=kopia(jj:jj) if(ch1.ne.'T') cycle fix if(jj.eq.1) then ! Txx: the Toop element was originally third if(c.eq.v) then ! and still is, no change exit fix elseif(a.eq.v) then ! the first element is now the Toop element, change to xxT kkk='KKT'; exit fix else ! the Toop element must now be the second element kkk='KTK'; exit fix endif elseif(jj.eq.2) then ! xTx: the Toop element was the second if(a.eq.j) then ! the first element is now the Toop element, change to xxT kkk='KKT'; exit fix elseif(b.eq.j) then ! no change exit fix else ! it must be the third element kkk='TKK'; exit fix endif else ! xxT: the Toop element was the first ... exit if it still is if(a.eq.i) exit fix if(a.eq.j) then ! it is now the second kkk='KTK' else ! or finally it is now the third kkk='TKK' endif endif enddo fix ! ! write(*,3)kkk,kopia,a,b,c 3 format('3XQ rearranged? "',a,'" original "',a,'" ',3i3) return ! 1100 continue write(*,*)' *** Error in call to order3: ',i,j,v a=-1 goto 1000 end subroutine order3KKK !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable function terind !\begin{verbatim} integer function terind(i,j,v) ! integer function terind(i,j,v,ncat) ! find sequential index of ternary system i, j, k ! simplified version, SEPARATE FOR CATIONS AND ANION mixing ! The ternary systems form a symmetric matrix where (i,j,k) is same as (j,k,i) ! and data for the ternary is stored as a linear array where where i=1, ix is number of skipped ternary systems ix=mqmqa_data%ncat*(mqmqa_data%ncat-1)*(mqmqa_data%ncat-2)/6 - & (mqmqa_data%ncat-a+1)*(mqmqa_data%ncat-a)*(mqmqa_data%ncat-a-1)/6 ! we now have a binary matrix for i,v with dimension bin, indexed by (bp,cp) bin=mqmqa_data%ncat-a bp=b-a cp=c-a iy=bin*(bin-1)/2-(bin-bp+1)*(bin-bp)/2+cp-bp iz=ix+iy ! write(*,10)a,b,c,mqmqa_data%ncat,ix,bin,bp,cp,iy,iz 10 format('terind: ',4i4,8i6) 1000 continue terind=iz return 1100 write(*,*)'Indexing error in terind ',i,j,v iz=-1 goto 1000 end function terind !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine test_asymm !\begin{verbatim} integer function test_asymm(t,i,j,v) ! The ternary specified by t has 3 elements i-j-v. v is redundant ... ? ! return 0 if neither element i nor j are asymmetric elements in this ternary ! return 1 if element i is an asymmetric element ! return 2 if element j is an asymmetric element ! return 3 if element both i and j are asymmetric elements implicit none integer t,i,j,v !\end{verbatim} integer asymmetric1,asymmetric2,hejhopp ! EXAMPLE: a single ternary 1-2-3 with 2 as Toop ! Call i j v ! 1 1 2 1 ! 2 1 2 2 ! 3 2 3 3 integer a,selectij ! default hejhopp=0 ! we have to check %asymm, if %asymm(1:1) is not 'T' return 0 if(tersys(t)%asymm(1:1).eq.'T') then ! The asymmetry in tersys(t) is stored as 'Tx ' where x is 1, 2 or 3 ! very very clumsy but my brain rotates still ...... asymmetric1=ichar(tersys(t)%asymm(2:2))-ichar('0') ! asymmetric1 is 1, 2 or 3; change to the quad index in that position ! asymmetric2=tersys(t)%el(asymmetric1) ! write(*,8)t,tersys(t)%el,tersys(t)%isasym,asymmetric1 8 format('3XQ bug: ter: ',i3,' quads: ',3i3,', isasym: ',3i3,' asym: ',i3) asymmetric2=tersys(t)%el(asymmetric1) ! write(*,10)t,tersys(t)%isasym,i,j 10 format('3XQ In asymm: ternary ',i3,' asymmetry: ',3i3,' binary ',2i3,' OK') ! The i-j are the quads in the varkappa variable ! if i = asymmetric2 return 1 ! if j = asymmetric2 return 2 if(i.eq.asymmetric2) hejhopp=1 if(j.eq.asymmetric2) hejhopp=2 endif if(hejhopp.ne.0) then ! write(*,90)t,i,j,v,asymmetric1,asymmetric2,hejhopp 90 format('3XQ testasym: ',i3,3x,2i3,3x,i3,5x,2i3,5x,i3) endif test_asymm=hejhopp 100 continue return end function test_asymm !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine calcasymvar !\begin{verbatim} subroutine calcasymvar(phres) ! subroutine calcasymvar(mqmqavar) ! This must be called whenever the quad fractions has changed ! It updates varkappaij, xiij etc for the whole system ! and stores them in compvar(bin) datastructure ! Currently programmed ONLY for a single anion implicit none type(gtp_phase_varres), pointer :: phres ! type(gtp_mqmqa_var), pointer :: mqmqavar ! type(gtp_mqmqa_var), pointer :: mqmqavar !\end{verbatim} integer i,j,ia,seq,k,l,m,ny,abrakadabra type(gtp_mqmqa_var), pointer :: mqf character*3 asymmetry ! how to create xquad mm when we need a pointer to gtp_phase_varres? ! type(gtp_equilibrium_data), pointer :: ceq ! type(gtp_phase_varres), pointer :: phres ! type(gtp_mqmqa_var), pointer :: mqf type(gtp_allinone), pointer :: box ! attempt to move mqmqa variables into the mqmqa_var record ! phres=>ceq%phase_varres(lokvar) ! mqf=>phres%mqmqaf ! ! if(.not.allocated(mqmqavar%xquad)) then ! write(*,*)'3XQ No xquad array allocated' ! goto 1000 ! endif ! if(.not.allocated(mqmqavar%compvar)) then ! write(*,*)'3XQ No compvar array allocated' ! goto 1000 ! endif ! ia=1 ! if(allocated(phres%mqmqaf%compvar)) then ! write(*,*)'3XQ in calcasym: compvar: ',size(phres%mqmqaf%compvar) ! else ! write(*,*)'3XQ in calasym: phres%mqmqaf%compvar not allocated' ! endif ! the separate array of binaries redundant? ! when a change of ternary asymmetries is made the newXupdate is incremented seq=0 ! initiate all asymmetry 0, earlier in init_excess_asymm, line 3134 ! we set tersys(*)%isasym=0 do i=1,mqmqa_data%ncat-1 do j=i+1,mqmqa_data%ncat ! seq specifies a binary set of elements ! results are stored in compvar(seq) for use in Gibbs energy calculations seq=seq+1 ! write(*,*)'Calling varkappa1 ',i,j,seq ! call varkappa1(mqmqavar%compvar(seq)) ! call varkappa1(seq,mqmqavar) ! call varkappa1(seq,mqf) ! asymmetry is KKK or Tx where x=1, 2 or 3 if(mqmqder) write(*,*)'3XQ calcasymvar call varkappa1' ! write(*,*)'3XQ call varkappa1',seq ! the argument 0 means no asymmetry change or set all symmetrical call varkappa1(seq,phres,0) enddo enddo ! inside varkappa1 one adds quads to vk_ij and vk_ji and ! if one has ijklx(vz1,vz1,ia,ia) in vk_ij and ijklx(vz2,vz2,ia,ia) in vk_ij ! then the %kvk_ij needs an additional ijkl(vz1,vz2,ia,ia) ! Check that here .... (this is due to bad initial programming) ! write(*,790)1 790 format('3XQ **** DOUBLE CHECK KVK_IJK',i3) ! mqf=>phres%mqmqaf ! box%lastupdate=-1 ! write(*,*)'3XQ box%lastupdate: ',box%lastupdate ! write(*,790) ! if(box%lastupdate.ne.newXupdate) then ! box%lastupdate=newXupdate ! write(*,1001)box%seq,box%lastupdate,newXupdate !1001 format('3XQ allinone record ',i3,' updated to new asymmetries ',i5) ! else ! write(*,*)'3XQ line 3707: mixed asymmetries added' ! endif ! ! write(*,*)'3XQ code below skipped as moved to varkappa1' goto 1000 !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! Code below moved to varkappa1 ... but some problems persist ... write(*,790)2 write(*,791)mqmqa_data%emquad 791 format('3XQ THIS CODE SHOULD NOT BE USED: ',25i3) stop 'THIS CODE SHOULD NOT BE USED' ! do i=1,size(mqf%compvar) ! if in vk_ij one has added (vz1,vz1,ia,ia) ! and in vk_ji added (vz2,vz2,ia,ia) ! one must add (vz1,vz2,ia,ia) to the kvk_ij (now done in calling routine) ! BUT this quad may already be present !!!!!!!!!!! box=>mqf%compvar(i) write(*,792)box%seq,box%lastupdate,newXupdate 792 format('3XQ newXupdate: ',i3,2i5) ! write(*,800)i,box%cat1,box%cat2 ! write(*,805)'ivk_ij ',box%ivk_ij ! write(*,805)'jvk_ij ',box%jvk_ji ! write(*,805)'kvk_ijk ',box%kvk_ijk do j=2,size(box%ivk_ij) do k=1,size(mqmqa_data%emquad) if(box%ivk_ij(j).eq.mqmqa_data%emquad(k)) then ! we have an endmember quad in ivk_ij (in addition to the first) ! Check if we have another endmember quad in jvk_ji do l=1,size(box%jvk_ji) neverending: do m=1,size(mqmqa_data%emquad) if(box%jvk_ji(l).eq.mqmqa_data%emquad(m)) then if(k.ne.m) then ! we have 2 different endmember quads in ivk_ij and jvk_ji, ! if the mixed quad is not alreay present add it ny=ijklx(k,m,ia,ia) do abrakadabra=1,size(box%kvk_ijk) ! check if this quad not already in box_kvk_ijk enddo ! add this quad !!!!!!!!!!!!!!!!!!!!!!!!!!!!! box%kvk_ijk=[box%kvk_ijk, ijklx(k,m,ia,ia)] write(*,806)i,k,m,ijklx(k,m,ia,ia) write(*,805)'kvk_ijk ',box%kvk_ijk endif endif enddo neverending enddo endif enddo enddo ! a quad representing a vz,vz,ia,ia quad is part of emquad box%lastupdate=newXupdate enddo 800 format('3XQ compvar: ',i3,2x,2i3) 805 format(a,20i3) 806 format('3XQ adding mixed quad to kvk_ijk',i3,2x,2i3,2x,i3) ! 1000 continue return end subroutine calcasymvar !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine varkappa1 !\begin{verbatim} ! subroutine varkappa1(seq,phres,asymter) subroutine varkappa1(seq,phres,asymter) ! seq is the index of varkappa in mqf%compvar array of all varkappa ! phres is pointer to gtp_phase_varres for the mqmqa phase ! should phres it be a pointer? Does it matter? It seems to work ! *** phres is called parres in calling routine ! asymter is the index of integer array, if zero set all symmetrical ! if nonzero the asymmetric constituent ins already set in %asymm ! %asymm is 'Tx ' where x is 1, 2 or for the assymmetric constituent ! in varkappa the cations are ordered (1,1) (1,2) ... (2,2) ... (n,n) ! in tersys the cations are ordered (1,2,3) (1,2,4) ... (2,3,4) ... (n-2,n-1,n) ! box is a record of the type(gtp_allinone) ! tersym is a structure with all combination of 3 cations for the asymmetries ! tersym(tt)%el(1) %el(2) and %el(3) are cation indices in the ternary ! tersym(tt)%isasym(1) %isasym(2) %isasym(3) is 0 or asymmetric cation index ! tersym(tt)%asymm is a 3 character variable of asymmetry DO NOT USE ! this routine may initiate, calculate and store varkappa_ij, varkappa_ji, and ! xi_ij and xi_ji for symmetric and asymmetric systems with Kohler/Toop ! It is programmed for a single anion and just for the MQMQX phase! ! ! It will inintiate all data in box if box%lastupdate neq newXupdate ! ! I do not think updating asymmetry of one ternary will change all varkappa? ! implicit none integer seq,asymter ! integer seq,asymter,new_toop type(gtp_phase_varres), pointer :: phres ! type(gtp_mqmqa_var), pointer :: !\end{verbatim} ! ! replaced original i and j by icat and jcat below!! integer i,j,ia,bin ! ! these are quad indices of i,i, i,j abd j,j integer mii,mij,mjj,ia type(gtp_allinone), pointer :: box type(gtp_mqmqa_var), pointer :: mqf ! ! ia represent the single anion ! varkappa_ij and varkappa_ji are the 2 composition variables to be multiplied ! with a binary i-j parameter or ternary. ! It is modified depending on the types of ! extrapolations for each ternary it is involved: Kohler or Toop. ! initially varkappaij=x_ii and varkappaji=x_jj and sum=x_ij ! for the Kohler (Muggianu not implemented) ! and nugamma is set to zero ! - if element i is Toop in j-i-v the x_iv is added to nugamma ! - if element j is Toop in i-j-v the x_jv is added to nugamma ! for those involved in asymmetric ternaries the divison must include \nu\gamma ! At the end both varkappaij and varkappaji are divided by sum where ! sum = sum+varkappaij+varkappaji+\nu\gamma ! CHECK if \nu\gamma already included in sum ... ! integer i,ii,vz,v,w,vv,ternary,ll,lasthope,di,icat,jcat,nnn double precision varkappaij,varkappaji,sum,initialij,initialji,nugamma double precision xi_ij,xi_ji,sum1,sum2 logical asymmetric ! added nov 3/2025. See this date below ! in mixnugamma all vz that have asymmetric ternary with icat or jcat are saved ! because their mixed quad fractions should be added to kvk_ijk integer, dimension(:), allocatable :: mixnugamma integer selectij,qz1,qz2 ! mixed update integer j,k,l,m,ny,abrakadabra ! If a binary i-j is part of 2 or more asymmetric ternaries i-j-\nu, i-j-\gamma ! the quad fraction x_\nu\gamma should be added to kvk_ijk (the denomonator) ! of kvk_ijk ! saving multiple asymmetrical cations for a binary ! integer, dimension(:), allocatable :: savevz integer, dimension(:), allocatable :: savenu integer, dimension(:), allocatable :: savegamma ! debug output integer nn1,nn2,nn3,nn4,nn5,nn6,nn7,gg,thisasym logical nysym ! character*3 nyasym ! local variables used for updating quad indices for iasymm, jasymm, etc ! integer, dimension(:), allocatable :: vk_ij,vk_ji,vk_ijk,xi_ij,xi_ji ! all asymmetric quad indices needed are stored in each separate gtp_allinone ! integer nvk_ij,nvk_ji,nvk_ijk,nxi_ij,nxi_ji ! ! how to create xquad mm when we need a pointer to gtp_phase_varres? ! type(gtp_equilibrium_data), pointer :: ceq ! type(gtp_phase_varres), pointer :: phres ! type(gtp_mqmqa_var), pointer :: mqf ! attempt to move mqmqa variables into the mqmqa_var record ! ceq=>firsteq ! ! Check if y_ik set ...!!!! if(asymter.ne.0) then if(mqmqder) write(*,2)asymter 2 format(/'3XQ in varkappa1, updating asymmetries: ',2i5) ! else ! write(*,1) 1 format('3XQ initiating varkappa 1') endif mqf=>phres%mqmqaf if(mqmqder) & write(*,*)'3XQ line 4462 vk_ij, xi_ij and y_ik with new quad fracs' ! write(*,10)'3XQ old',(mqf%y_ik(v),v=1,mqmqa_data%ncat) 10 format(a,15(f8.5)) do v=1,mqmqa_data%ncat mqf%y_ik(v)=0.0d0 ! write(*,20)'3XQ dy_ik',(mqmqa_data%dy_ik(v,w),w=1,mqmqa_data%nquad) 20 format(a,(20F5.2)) do w=1,mqmqa_data%nquad mqf%y_ik(v)=mqf%y_ik(v)+mqmqa_data%dy_ik(v,w)*mqf%xquad(w) enddo enddo ! ! 2026.04.08: When a ternary asymmetry is changed, all varkappa must be updated ! A ternary asymmetri can be KKK, TKK, KTK or KKT where the asymmetric ! constituent is the first, second or third constituent. ! I do not remember how this is indicated in the loop below ! But obviously there is some error as KTK and KKT is not registered correctly ! I do not remember how one identifies the asymmetric constituent below ! ! write(*,10)'3XQ line 3731 y_ik:',(mqf%y_ik(v),v=1,mqmqa_data%ncat) ! if(.not.allocated(mqf%compvar)) then write(*,*)'3XQ line 3076 in varkappa: compvar not allocated, problems' gx%bmperr=4399; goto 1000 ! else ! write(*,*)'3XQ varkappa allocated OK' endif box=>mqf%compvar(seq) ! icat and jcat represent cations ... duplicated here (and many other places) icat=box%cat1 jcat=box%cat2 ia=box%anion ! write(*,'(a,4i4,5x,a)')'3XQ varkappa1 line 4267: ',seq,icat,jcat,ia ! the xquad values i,j and j,i are the same but for varkappa they are different if(icat.gt.jcat) then write(*,3)icat,jcat 3 format(/'In varkappa1: wrong order of elements ',2i4) stop endif ! set default quads mii=ijklx(icat,icat,ia,ia) mij=ijklx(icat,jcat,ia,ia) mjj=ijklx(jcat,jcat,ia,ia) ! how to deallocate box%asymm_nu and box%asymm_gamma? ! deallocate(box%asymm_nu) ! deallocate(box%asymm_gamma) ! nysym=.false. ! deafult is 0, to update set box%lastupdate to -1 ! ! below is code to update asymmetry ! and after that the code to calculate varkappa for current molefractions if(box%lastupdate.ne.newXupdate) then if(asymter.eq.0) then ! write(*,4) 4 format('3XQ initiating varkappa 2') else ! write(*,5)box%lastupdate,newXupdate if(mqmqder) write(*,5)box%lastupdate,newXupdate 5 format('3XQ *** Updating allinone record from ',i5,' to ',i5,' new: ',2i5) endif endif vzloopupdate:if(newXupdate.gt.box%lastupdate) then ! *** this if ... endif code part needed only when new asymmetries defined ! Below the arrays below are allocated, the initial 0 is overwritten if used ! This makes use of the new Fortran 2003 facility using [ ] ! Setting an allocatable array to single value means previous values deleted ! box%ivk_ij=[0]; box%jvk_ji=[0]; box%kvk_ijk=[0] ! ! new asymmetry defined ! if(asymter.lt.0 .or. asymter.gt.size(tersys)) then ! write(*,*)'Illegal ternary ',asymter ! goto 1000 ! else if(asymter.gt.0) then ! write(*,77)asymter,tersys(asymter)%isasym,tersys(asymter)%asymm 77 format('3XQ new asymmetry: ',i3,3x,3i2,5x,a) ! else ! write(*,*)'3XQ sorry may not work' ! tersys(asymter)%asymm='KKK' endif ! write(*,*)'3XQ varkappa1 new asymmetry in ternary: ',asymter ! repeating Max equations for vakappa_AB in ternary A-B-C ! -----------if A is asymmetric, \gamma in documentation ! v_AB x_AA ! v_BA x_BB+x_BC+x_CC ! denom= x_AA+x_BB+x_AB+x_BC+x_AC+x_CC (=1 if only one ternary) ! ----------- if B is asymmetric, \nu in documentation ! v_AB x_AA+x_AC+x_CC ! v_BA x_BB ! denom= x_AA+x_BB+x_AB+x_BC+x_AC+x_CC (=1 if only one ternary) !------------ if C is asymmetric .........ignore ! if A and B are asymmetric in several ternaries the v_AB and v_BA ! can include more quadruplets. One has to update all ternary asymmetries ! at the same time because it is complicated to remove things in the [ ... ] ! ! if(allocated(savevz)) deallocate(savevz) box%lastupdate=newXupdate ! default nyasym is KKK, no asymmetry ! if(asymter.gt.0) write(*,381)asymter,new_toop !381 format('3XQ in varkappa1 new asymmetry: ',i2) if(allocated(savenu)) deallocate(savenu) if(allocated(savegamma)) deallocate(savegamma) ! vk derivatives are quad indices, also denominator (same vk_ij and vk_ji) ! the statements below allocate and assign initial quad index box%ivk_ij=[mii]; box%jvk_ji=[mjj]; box%kvk_ijk=[mij] ! to simplify handling derivatives the denominator is summed separately box%all_ijk=[mii, mjj, mij] ! xi are the Y_i/k fractions, for derivatives save quad indices in dxi_ij ! do di=1,mqmqa_data%nquad ! the derivatives of xi_ relative to quad index di ! The derivatives involves several quads, given by dy_ik(icat) box%dxi_ij(di)=mqmqa_data%dy_ik(icat,di) box%dxi_ji(di)=mqmqa_data%dy_ik(jcat,di) enddo ! calculate xi_ ... why?? box%xi_ij=0.0d0; box%xi_ji=0.0d0 do di=1,mqmqa_data%nquad box%xi_ij=box%xi_ij+box%dxi_ij(di)*mqf%xquad(di) box%xi_ji=box%xi_ji+box%dxi_ji(di)*mqf%xquad(di) enddo ! *** end of symmetric initialization of vk_ij, vk_ji, xi_ij and xi_ji ! ! if in vk_ij one has added (vz1,vz1,ia,ia) ! and in vk_ji added (vz2,vz2,ia,ia) ! Now take care of asymmetries and update for later use ! Asymmetric vk and xi are updated in the vz loop AND at the end of the loop !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> ! if(mqmqder) write(*,*)'3XQ in varkappa1',icat,jcat ! ! below vz loops through all ternaries ... ! and below that ! ! write(*,*)'3XQ with asymmetric cation ',thisasym ! this subroutine is called with the sequentially ordered box%icat,box%jcat ! it must create the basic Kohler model and possibly Toop asymmetries ! ! write(*,*)'3XQ unfinished varkappa1 code around line 4384' ! ! The loop below is for all pairs of varkappa records identifying Toop cations ! in ternaries i-j-vz ! and adjusting the expression to calculate varkappa_ij and varkappa_ji ! vzloop: do vz=1,mqmqa_data%ncat ! loop for all ternary systems to find those with asymmetric i-j-vz and j-i-vz ! write(*,403)icat,jcat,vz,thisasym 403 format('3XQ in vzloop A: ',2i3,2x,i3,2x,i3,2x,5i3) ! if vz is icat or jcat it is not a ternary if(vz.eq.icat .or. vz.eq.jcat) cycle vzloop ! find the sequential order of the ternary icat-jcat-vz ternary=terind(icat,jcat,vz) ! write(*,402)'3XQ in vzloop B: ',icat,jcat,vz,thisasym,ternary 402 format(a,2i3,2x,i3,2x,i3,2x,5i3) ! error if ternary not >0 if(ternary.le.0) goto 1100 ! if icat is Toop in this ternary add quadfractions of x_ivz to varkappa_ij ! if jcat is Toop in this ternary add quadfractions of x_jvz to varkappa_ji ! ********* selectij=0 means no asymmetry in this ternary*************** selectij=test_asymm(ternary,icat,jcat,vz) ! if(vz.eq.thisasym) then ! ! write(*,404)icat,jcat,vz,thisasym,ternary,selectij 404 format('3XQ in vzloop C: ',2i3,2x,i3,2x,i3,2x,5i3) ! ********* selectij=0 means no asymmetry in this ternary*************** ! asymm returns 1 if icat is an asymmetric element in icat-jcat-vz (gamma) ! asymm returns 2 if jcat is an asymmetric element in icat-jcat-vz (nu) ! asymm returns 3 if both icat and jcat are asymmetric in icat-jcat-vz ! to be considered: asymmetric i-j-nu and i-j-gamma requires x_\nu\gamma ! in the denominator. For this the savenu/gamma is used ! ! cycle vzloop if(selectij.eq.0) cycle vzloop ! if(.not.asymmetric) then ! the asymmetric logical is to just for debug output of initial varkappa values ! asymmetric=.true. ! endif ! write(*,*)'An asymmetric ternary, how to handle it?' ! write(*,*)'We must also set tersys(ternary)%asymm' ! write(*,*)'Only icat asymmetry found above' ! ! !******************** asymmetric ternary ***************************** ! write(*,420)selectij,icat,jcat,vz 420 format('3XQ set varkappa ternary asymmetry typ:',i2,' cations: ',3i3) asymmetry: select case(selectij) ! case default write(*,*)'Illegal asymmetry ',selectij stop !------------------------------------------------------------------- case(1) ! ************************************************* ! vz is asymmetric, save in jvk_ij and in savenu ! icat is asymmetric, save in jvk_ij and in savenu ! an elegant Fortran assignment of an additional items in an allocatable box%jvk_ji=[box%jvk_ji, ijklx(jcat,vz,ia,ia), ijklx(vz,vz,ia,ia)] ! Below quad fractions added to jvk_ij added to denominator, add ijklx(icat,vz box%kvk_ijk=[box%kvk_ijk, ijklx(icat,vz,ia,ia)] box%all_ijk=[box%all_ijk, ijklx(jcat,vz,ia,ia), & ijklx(icat,vz,ia,ia), ijklx(vz,vz,ia,ia)] ! savenu is related to ij, savegamma to ji if(allocated(savenu)) then ! write(*,373)'case 1 use \nu',size(savenu),savenu 373 format('3XQ ',a,' mixed asymmetry terms',i3,': ',10i3) 374 format(a,' x_',2i1) do gg=1,size(savenu) ! the mixed terms with \nu should should be added to jvk_ji box%all_ijk=[box%all_ijk, ijklx(vz,savenu(gg),ia,ia)] ! write(*,374)'3XQ added ji',savenu(gg),vz ! write(*,375)'jvk_ji ',box%jvk_ji 375 format('3XQ ',a,'=',10i4) enddo savenu=[savenu, vz ] else ! otherwize just add vz to savenu savenu=[vz] ! write(*,373)'3XQ line 4377 savednu i ',size(savenu),savenu endif ! savegamma is related to ji, maybe add denominator terms if(allocated(savegamma)) then ! write(*,373)'case 1 use \gamma',size(savegamma),savegamma do gg=1,size(savegamma) ! the mixed terms with \gamma should should be added to kvk_ijk box%kvk_ijk=[box%kvk_ijk, ijklx(vz,savegamma(gg),ia,ia)] box%all_ijk=[box%all_ijk, ijklx(vz,savegamma(gg),ia,ia)] ! write(*,374)'3XQ added kvk_ijk',savegamma(gg),vz ! write(*,375)'kvk_ji ',box%kvk_ijk enddo ! do not save vz as it does no relates to ij ! savegamma=[savegamma, vz ] ! else ! and we must add vz to savegamma ! savegamma=[vz] ! write(*,373)'saved i ',size(savevz),savevz endif ! The asymmetric xi is depend on y_ik update dxi_ij and dxi_ji do nnn=1,mqmqa_data%nquad ! box%dxi_ij(nnn)=box%dxi_ij(nnn)+dy_ik(icat,nnn) box%dxi_ji(nnn)=box%dxi_ji(nnn)+mqmqa_data%dy_ik(vz,nnn) enddo ! !--------------------------------------------------------------------- case(2) ! *************************************************** ! jcat is asymmetric, same as for icat just change icat to jcat!!!! ! and save in jvk_ji ... box%ivk_ij=[box%ivk_ij, ijklx(icat,vz,ia,ia), ijklx(vz,vz,ia,ia)] ! Nath noted missing ijklx(vz1,vz2,ia,ia) if icat and jcat are asymmetrical box%kvk_ijk=[box%kvk_ijk, ijklx(jcat,vz,ia,ia)] box%all_ijk=[box%all_ijk, ijklx(icat,vz,ia,ia), & ijklx(jcat,vz,ia,ia), ijklx(vz,vz,ia,ia)] ! if savegamma allocated we must add terms to jvk_ijk if(allocated(savegamma)) then ! write(*,373)'case 2 use \gamma',size(savegamma),savegamma do gg=1,size(savegamma) box%ivk_ij=[box%ivk_ij, ijklx(vz,savegamma(gg),ia,ia)] box%all_ijk=[box%all_ijk, ijklx(vz,savegamma(gg),ia,ia)] ! write(*,374)'3XQ added ij',savegamma(gg),vz ! write(*,375)'ivk_ij ',box%ivk_ij enddo savegamma=[savegamma, vz ] else ! and we must add vz to savevz savegamma=[ vz ] ! write(*,373)'savedgamma j ',size(savegamma),savegamma endif ! savenu is related to ij, maybe add denominator terms if(allocated(savenu)) then ! write(*,373)'case 2 use \nu',size(savenu),savenu do gg=1,size(savegamma) ! the mixed terms with \nu should should be added to kvk_ijk box%kvk_ijk=[box%kvk_ijk, ijklx(vz,savenu(gg),ia,ia)] box%all_ijk=[box%all_ijk, ijklx(vz,savenu(gg),ia,ia)] ! write(*,374)'3XQ added kvk_ijk',savenu(gg),vz ! write(*,375)'jvk_ji ',box%kvk_ijk enddo endif ! The asymmetric xi is depend on y_ik update dxi_ij and dxi_ji do nnn=1,mqmqa_data%nquad ! box%dxi_ij(nnn)=box%dxi_ij(nnn)+dy_ik(jcat,nnn) box%dxi_ij(nnn)=box%dxi_ij(nnn)+mqmqa_data%dy_ik(vz,nnn) enddo ! !--------------------------------------------------------------------- case(3) ! ************************************************** ! Both icat and jcat are asymmetric NOT IMPLEMENTED write(*,788)icat,jcat,vz 788 format('3XQ *** Illegal with 2 asymmetric cations ',2i3,' with ',i3) gx%bmperr=4399; goto 1000 ! tentative code below box%ivk_ij=[box%ivk_ij, ijklx(icat,vz,ia,ia), ijklx(vz,vz,ia,ia)] box%jvk_ji=[box%jvk_ji, ijklx(jcat,vz,ia,ia), ijklx(vz,vz,ia,ia)] ! This is complicated, do not add ijklx(icat,vz,ia,ia), ijklx(jcat,vz,ia,ia) ! and only once ijkl(vz,vz,ia,ia) ..... ! maybe not at all ????????????? ! box%kvk_ijk=[box%kvk_ijk, ijklx(vz,vz,ia,ia)] ! box%kvk_ijk=[box%kvk_ijk, ijklx(icat,vz,ia,ia), & ! ijklx(jcat,vz,ia,ia), ijklx(vz,vz,ia,ia)] ! BUT x_(vz,vz,ia,ia) appears twice in the denominator ....(and twice on top) box%all_ijk=[box%all_ijk, ijklx(icat,vz,ia,ia), & ijklx(jcat,vz,ia,ia), ijklx(vz,vz,ia,ia)] ! The asymmetric xi is depend on y_ik update dxi_ij and dxu_ji do nnn=1,mqmqa_data%nquad box%dxi_ij(nnn)=box%dxi_ij(nnn)+mqmqa_data%dy_ik(icat,nnn) box%dxi_ji(nnn)=box%dxi_ji(nnn)+mqmqa_data%dy_ik(jcat,nnn) enddo ! end select asymmetry !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! write(*,778)icat,jcat,vz 778 format('3XQ asymmetry set ',3i3,' box%all: ',10i3) goto 747 ! ! loops below now redundant when we added savevz loops above ..... ???? ! code handling kvk_ijk terms due to extra x_ii and x_jj in ivk_ij and jvk_ji ! copied from end of calcasymvar to avoid it is repeted at all calculations ! skip first ivk_ij addkvkterm: do j=2,size(box%ivk_ij) do k=1,size(mqmqa_data%emquad) if(box%ivk_ij(j).eq.mqmqa_data%emquad(k)) then ! we have an endmember quad in ivk_ij (in addition to the first) ! Check if we have another endmember quad in jvk_ji, skip first jvk_ji ! do l=1,size(box%jvk_ji) do l=2,size(box%jvk_ji) neverending: do m=1,size(mqmqa_data%emquad) if(box%jvk_ji(l).eq.mqmqa_data%emquad(m)) then if(k.ne.m) then ! we have 2 different endmember quads in ivk_ij and jvk_ji, ! if the mixed quad is not alreay present add it ny=ijklx(k,m,ia,ia) do abrakadabra=1,size(box%kvk_ijk) ! check if this quad not already in box_kvk_ijk write(*,*)'3XQ check duplicate line 4041 !!' enddo ! add this quad !!!!!!!!!!!!!!!!!!!!!!!!!!!!! box%kvk_ijk=[box%kvk_ijk, ijklx(k,m,ia,ia)] ! write(*,806)i,k,m,ijklx(k,m,ia,ia) ! write(*,805)'kvk_ijk ',box%kvk_ijk endif endif enddo neverending enddo endif enddo enddo addkvkterm 805 format(a,20i3) 806 format('3XQ adding mixed quad to kvk_ijk',i3,2x,2i3,2x,i3) ! end copied code !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 747 continue enddo vzloop ! the vzloop above should be done whenever the asymmetry changes ! ! write(*,748)box%cat1,box%cat2 748 format('3XQ Asymmetry updated for varkappa_ij: ',2i3) !-------------------------------------------------------------------- ! end of asymmetry detection loop !-------------------------------------------------------------------- ! endif vzloopupdate ! !-------------------------------------------------------------------- ! Below arrays box%ivk_ij, box%jvk_ji, box%dxi_ij are used to ! calculate \varkappa and \xi and their derivatives !-------------------------------------------------------------------- ! ! Now use the structures ivk_ij, jvk_ji, kvk_ijk and dxi_ij, dxi_ji ! write(*,*)'3QX in varkappa1 line 3900',allocated(box%ivk_ij),& ! allocated(box%dvk_ij) varkappaij=0.0d0; varkappaji=0.0d0; sum=0.0d0; nugamma=0.0d0 do ii=1,size(box%ivk_ij) varkappaij=varkappaij+mqf%xquad(box%ivk_ij(ii)) ! write(*,697)'ivk_ij',ii,box%ivk_ij(ii),varkappaij,xquad(box%ivk_ij(ii)) 697 format('Summing ',a,': ',2i3,2(1pe14.6)) enddo 600 format('Partial sum: ',i3,a,1pe12.4,' quad: ',5i3) do ii=1,size(box%jvk_ji) varkappaji=varkappaji+mqf%xquad(box%jvk_ji(ii)) ! write(*,697)'jvk_ji',ii,box%jvk_ji(ii),varkappaji,xquad(box%jvk_ji(ii)) enddo do ii=1,size(box%kvk_ijk) sum=sum+mqf%xquad(box%kvk_ijk(ii)) ! write(*,697)'sum',ii,box%kvk_ijk(ii),sum,xquad(box%kvk_ijk(ii)) enddo ! all quad indices ! write(*,696)' all_ijk: ',box%all_ijk 696 format('Quad indices in',a,': ',20i4) sum=sum+varkappaij+varkappaji+nugamma ! write(*,601)sum,nugamma 601 format('Total value Denominator: ',1pe12.4,' nugamma: ',1pe12.4) ! save normalized values and save also sum for use with derivatives ! at initiation sum=0.0, fix that if(sum.eq.0.0d0) sum=1.0d0 box%vk_ij=varkappaij/sum box%vk_ji=varkappaji/sum ! the denominantor needed for derivatives box%denominator=sum ! write(*,605)' vk_ij and vk_ji: ',box%vk_ij,box%vk_ji 605 format(' ** Normalized values of ',a,2(1pe12.4)) ! and the derivatives .... ! ! Calculation of xi_ij using dxi sum1=0.0d0; sum2=0.0d0 do di=1,mqmqa_data%nquad sum1=sum1+box%dxi_ij(di)*mqf%xquad(di) sum2=sum2+box%dxi_ji(di)*mqf%xquad(di) enddo box%xi_ij=sum1 box%xi_ji=sum2 ! ! debug output, ivk_ij, jvk_ji, kvk_ijk, dxi_ij, dxi_ji --------------------- ! if(mqmqdebug .or. mqmqxcess) then nn1=size(box%ivk_ij); nn2=size(box%jvk_ji); nn3=size(box%kvk_ijk) nn4=mqmqa_data%nquad; nn5=mqmqa_data%nquad; if(allocated(box%asymm_nu)) then nn6=size(box%asymm_nu) else nn6=0 endif if(allocated(box%asymm_gamma)) then nn7=size(box%asymm_gamma) else nn7=0 endif write(*,700)2,nn1,nn2,nn3,nn4,nn5,nn6,nn7,nugamma 700 format('3XQ Sizes: ',i1,': ',7i3,1pe12.4) write(*,710)'ivk_ij ',(box%ivk_ij(i),i=1,nn1) write(*,710)'jvk_ji ',(box%jvk_ji(i),i=1,nn2) write(*,710)'kvk_ijk ',(box%kvk_ijk(i),i=1,nn3) write(*,709)'dxi_ij ',(box%dxi_ij(i),i=1,nn4) write(*,709)'dxi_ji ',(box%dxi_ji(i),i=1,nn5) if(nn6.gt.0) write(*,708)'nu ',(box%asymm_nu(i),i=1,nn6) if(nn7.gt.0) write(*,708)'gamma ',(box%asymm_gamma(i),i=1,nn7) 709 format('Factors ',a,': ',10f6.3) 708 format('Ternary quad asymmetry ',a,': ',5i4) 710 format('Quad in ',a,': ',5i4) ! write(*,607)3,box%vk_ij,box%vk_ji 607 format('Current values of vk_ij, vk_ji ',i2,2x,2(1pe15.5)) endif ! end debug output ---------------------------------------------------------- ! The asymmetric information collected as saved as quad index in local ! ivk_ij, jvk_ji, kvk_ijk for the \varkappa variables ! These are needed for calculating derivatives dvk_ij !---------also for xi ! dxi_ij and dxi_ji for the \xi variables ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! this code use the updated data structure to calculate quickly ! This should be called by set constitution!! ! write(*,*)'In varkappa1 calling dexcess_dq to allocate and set %dvk_ij?' ! call dexcess_dq(box) ! write(*,800)allocated(box%dvk_ij) !800 format(' *** Back from dexcess_dq to allocate %dvk_ij etc',l2) goto 900 ! 500 continue !!!!!!!!!! here we use the asymmetry saved in box%asym1 and %asym2 !------------------------------------------------ ! Here we calculate the derivatives using %asym1 and %asym2 ??? ! ?? 900 continue !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! if(box%lastupdate.ne.newXupdate) then box%lastupdate=newXupdate ! write(*,1001)box%seq,box%lastupdate 1001 format('3XQ allinone record ',i3,' updated to new asymmetries ',i5) endif ! 1000 continue if(mqmqder) write(*,*)'3XQ Leaving varkappa1' return ! 1100 continue write(*,1105)icat,jcat,v 1105 format('Error return from tersym for elements: ',3i4) goto 1000 end subroutine varkappa1 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine dexcess_dq(mqf) !\begin{verbatim} subroutine dexcess_skip_dq(nvkappa,mqf) ! calculate the partial derivatives of a \varkappa or \xi variable ! box(ij) is mqf%varkappa(ij) implicit none ! type(gtp_allinone) :: box integer nvkappa type(gtp_mqmqa_var), pointer :: mqf ! in ivk_ij, jvk_ji etc specify the indices of quad fractions involved for vk_ij ! A derivative wrt to a quad fractions included means it is 1, otherwise 0 ! vk_ij has a numerator and a denominator, both are sums of quad fractions ! dvk_ij/dq_k is the result of the derivative of both ! use type(zquad) for storing derivatives of ivk_ij, jvk_ji .. ??? ! if_ij, if_ji, if_ijk are 0/1 depeding on the quad indices in each term ! integer k,v,dtij,dtji,dtdiv !\end{verbatim} integer k,v,d_ij,d_ji,d_ijk,some double precision numerator, denominator type(gtp_allinone), pointer :: box ! write(*,*)'3XQ in dexcess_dq',nvkappa,size(mqf%compvar) goto 1000 ! allbox: do some=1,nvkappa box=>mqf%compvar(some) if(.not.allocated(box%dvk_ij)) then ! first time inititate arrays allocate(box%dvk_ij(mqmqa_data%nquad)) allocate(box%dvk_ji(mqmqa_data%nquad)) ! below the arrays are initiated to zero endif ! ! calculate the derivatives of all vk_ij, vk_ji with respect to quads ! The quad indices are stored in ivk_ij, jvk_ji and kvk_ijk ! ! \sum x_i numerator ivk_ij ! f=vk_i = --------- = ---------- = ------------------- \delta_mv=1 if m=k ! \sum x_k denominator ivkij+jvkji+kvk_ijk ! ! denominator*\delta_iv - numerator*\delta_ijkv ! df/dx_v = --------------------------------------------- \delta_mv=1 if m=k ! denominator**2 ! note value of numerator stored in vk_ij etc is already divided by denominator, ! \delta_iv (numerator/denominator)*\delta_ijkv ! thus df/dx_v = ------------ - ----------------------------------- ! denominator denominator ! ! many df/dx_v are zero ... trying to be smart? save only non-zero df/dx_v !---------------------------------------------------------- ! the arrays ivk_ij have only indices for the quads q they depend on ! vk_ij is the sum of those quads. Many dvk_ij should be zero ! the denominator always depend on the same fractions as the numerator box%dvk_ij=0.0d0 box%dvk_ji=0.0d0 write(*,10)box%seq,box%all_ijk 10 format('3XQ In dexcess_dq: allinone ',i3,' depend on quads: ',2x,20i3) kloop: do k=1,mqmqa_data%nquad ! we have to check all_ijk if vk depend on quad k ! dvk_ij(k)=(if_ij/denominator_ij - if_ijk*numerator_ij)/denominator_ij ! denominator_ijk and numerator_ij are sum of quad fractions ! d_ijk=0; d_ij=0; d_ji=0 ! write(*,15)box%all_ijk 15 format('kvk%ijk',20i3) tdloop: do v=1,size(box%all_ijk) if(k.eq.box%all_ijk(v)) then ! k is part of v_ij, this assignment actually redundant d_ijk=1; goto 17 endif enddo tdloop ! varkappa independent of quad k box%dvk_ij(k)=0.0d0 box%dvk_ji(k)=0.0d0 cycle kloop ! ! nonzero: if(d_ijk.eq.1) then 17 continue ! this varkappa depend on quad fraction k, calculate derivative ! write(*,20)'vk_ij ',v,box%denominator 20 format('Denominator of ',a,' wrt quad ',i3,2x,1pe12.4) t1loop: do v=1,size(box%ivk_ij) if(k.eq.box%ivk_ij(v)) then d_ij=1; exit t1loop endif enddo t1loop ! if(d_ij.eq.1) write(*,30)'ivk_ij loop ',v,box%vk_ij 30 format('Numerator ',a,' wrt quad ',i3,1pe12.4) t2loop: do v=1,size(box%jvk_ji) if(k.eq.box%jvk_ji(v)) then d_ji=1; exit t2loop endif enddo t2loop ! write(*,35)v,d_ijk,d_ij,d_ji 35 format('All d_xyz: ',i3,4i4) ! if(d_ji.eq.1) write(*,30)'jvk_ji loop ',v,box%vk_ji ! Note that vk_ij and vk_ji are already divided by denominator box%dvk_ij(k)=(d_ij - box%vk_ij)/box%denominator box%dvk_ji(k)=(d_ji - box%vk_ji)/box%denominator enddo kloop ! debug output of the derivatives if(mqmqdebug) then do k=1,mqmqa_data%nquad write(*,100)k,box%dvk_ij(k),box%dvk_ji(k) enddo 100 format('3XQ In dexcess_dq: dvk_ij, dvk_ji wrt quad: ',i3,2(1pe14.6)) endif enddo allbox ! now derivatives of xi with respect to quads NOT DONE ??????? ! 1000 continue write(*,*)'3XQ exit dexcess_dg' return end subroutine dexcess_skip_dq !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine set_ternary_asymmetry(line) !\begin{verbatim} subroutine set_ternary_asymmetry(line) implicit none character*(*) line ! to set asymmetries in a text !\end{verbatim} integer i,j,ip,iq,ia,ib,ic,mm,icc(3),nc,kk,vz,toop(3) integer missasym integer iph,ics,icon,ipm double precision mass character missingcon*60 character phase*24,const(3)*24,asymcode*6,asymoc*3 type(gtp_phaserecord), pointer :: phrec ! phase=' ' missasym=0 ! called from gtp3E around line 5493 if(mqmqdebug) write(*,10)trim(line) 10 format('3XQ set_ternary_asymmetry called from gtp3E: "',a,'"') ! write(*,*)'3E set_ternary_asymmetry to be fixed' ! extract constituent indices and call setsym' ! text is extacted from frist nonblank position ip to first space ! first the phase, then 3 constituents finally the asymcode ip=0 call getext(line,ip,2,phase,' ',iq) ! write(*,20)trim(phase),iq 20 format('3XQ Phase name: ',a,5x,i3) if(phase(1:1).ne.' ') then call find_phase_by_name(phase,iph,ics) if(gx%bmperr.ne.0) then write(*,21)trim(phase) 21 format(/'3XQ Ternary asymmetries for phase "',a,& '" ignored as phase not selected') gx%bmperr=0 goto 1000 endif else goto 1100 endif nc=size(phlista(iph)%constitlist) ! write(*,*)'3XQ in set_ternary_asymmetry, found phase ',iph,nc ! ! debug listing of mqmqa_data%contyp ! do vz=1,nc ! write(*,33)(mqmqa_data%contyp(i,vz),i=1,14) ! 4 5=FNN 6-7 8-9 same 11-12 13-14 33 format('3XQ: ',4i3,2x,i3, 2x,2i3,2x,2i3,2x,i3,2x,2i3,2x,2i3) ! enddo ! extract_asymmetries: do while(ip.lt.len(line)) ! save constituent indices in icc icc=0 asymcode=' '; const=' '; missingcon=' ' ipm=1 find3: do i=1,3 call getext(line,ip,2,const(i),' ',iq) if(gx%bmperr.ne.0) goto 1000 ! The terminator is usually "!" or "/" if(const(i).eq.'!' .or. const(i).eq.'/') goto 1000 ! we have to go through the list of constituents of the phase to find the ! constituents as we need their sequental index .... SUCK ! mm=len_trim(const(i))+1 as constituents in MQMQA the name has suffix ! A small risk that it is an abbreviation ... mm=len_trim(const(i)) if(mm.le.1) goto 1000 compare: do j=1,nc ! the names of the constituents are in the species structure! kk=phlista(iph)%constitlist(j) ! write(*,50)const(i)(1:mm),splista(kk)%symbol(1:mm) 50 format('Comparing "',a,'" and "',a,'" ',i3) if(const(i)(1:mm).eq.splista(kk)%symbol(1:mm)) then ! Hmmmmm, it is not species index we want, we want the number of the ! this species is phase constituent i, use mqmqa_data%contyp(5,i) !! ! in mqmqa_data%contyp(5,j) is the pair index !!?? vz=mqmqa_data%contyp(5,j) ! write(*,53)'3XQ Found asymmetric: ',i,splista(kk)%symbol,j,vz 53 format(a,i3,2x,a,5i4) icc(i)=vz ! write(*,60)i,const(i),vz 60 format('3XQ cation index: ',i3,2x,a,2x,i4) cycle find3 endif enddo compare ! write(*,*)'3XQ Asymmetric constituent not found',i,const(i)(1:mm) missingcon(ipm:)=const(i) ipm=len_trim(missingcon)+2 ! we have to read all constituents becaise some asymmetries may involve ! constitutents not selected enddo find3 ! error if end of line if(ip.ge.len_trim(line)) goto 1100 call getext(line,ip,2,asymcode,' ',iq) ! TKK means the third quad has the Toop element ! KTK means the second quad has the Toop element ! KKT means the first quad has the Toop element ! convert for example T3KT3 to TKK related to the 3 elements in the quads ! the value to be saved is the element index of the first, second or third quad ! write(*,*)'3XQ Asymmetric code: ',asymcode ! if any icc is 0 skip do j=1,3 if(icc(j).eq.0) then ! write(*,*)'3XQ missing asymmetry constituents: ',trim(missingcon) missasym=missasym+1 cycle extract_asymmetries endif enddo ! write(*,100)trim(phase),icc(1),icc(2),icc(3),trim(asymcode) 100 format('3XQ asymmetric ternary in ',a,' elements ',3i4,5x,a) ! convert full asymmetry to OC call convert_asymm(asymcode,asymoc,icc,toop) ! output from convert_asymm seems OK but with some redundat data ! there can be several asymmetric ternaries ! write(*,*)'3XQ Arrange actual order of cations in setasym' ! do we need toop? ! call setasym(iph,icc,toop,nquad,asymoc) call setasym(iph,icc,toop,asymoc) if(gx%bmperr.ne.0) goto 1000 ! stop 'debug' enddo extract_asymmetries ! newXupdate=newXupdate+1 ! tersym is declared globally, it should be within a phase record ! as each phase can have ternary symmetries ! 1000 continue if(missasym.gt.0) then write(*,1010)trim(phase),missasym 1010 format('3XQ Phase ',a,& ' has ',i3,' ternary asymmetries for nonselected constituents') endif ! phase return 1100 write(*,1110)line(min(1,ip-10):ip+10) 1110 format('Problem extracting ternary asymmetry: ',a) gx%bmperr=4499 goto 1000 end subroutine set_ternary_asymmetry !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine convert_asymm !\begin{verbatim} subroutine convert_asymm(code1,code2,icc,toop) ! convert from 6 to 3 letters implicit none character code1*6,code2*3 ! icc are the 3 cations in the ternary ... toop is ? integer icc(3),toop(3) !\end{verbatim} character cha*1,chb*1 integer ia,ib,iv,iw,ntoop code2='KKK' iw=0 ntoop=0 toop=0 do iv=1,3 iw=iw+1 if(code1(iw:iw).eq.'T') then ntoop=ntoop+1 ia=ichar(code1(iw+1:iw+1))-ichar('0') if(ia.gt.0 .and. ia.le.3) then ! The T is followed by a digit indicating the constituent, 1, 2 or 3 toop(ntoop)=iv code2(4-ia:4-ia)='T' ! skip one position in code1 iw=iw+1 else ! toop elementet is indicated by the 3 cation positions toop(ntoop)=iv code2(4-iv:4-iv)='T' endif ! write(*,*)'3XQ Toop cation is: ',icc(ia),' position ',toop(ntoop) endif ! write(*,10)code1,code2,iv,icc enddo write(*,10)code1,code2,icc,toop 10 format('3XQ convert_asymm: "',a,'" to "',a,'" cations: ',3i2,' Toop: ',3i3) return end subroutine convert_asymm !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine setasym !\begin{verbatim} subroutine setasym(iph,icc,toop,kkk) ! set asymmetry of a ternary ! the cation indices can be in any order, must be ordered. implicit none integer iph,icc(3), toop(3) character*3 kkk ! ! REDUNDANT AS INTEGRATED IN PMON6.F90 ! !\end{verbatim} integer i,j,k,dim3,ntercat integer a,b,c,mm,v ! default is 'KKK' which is symmetrical for the 3 binaries 1-2, 1-3 and 2-3 ! 'TKK' means element 3 is asymmetrical for 1-2 ! 'TKT' means element 3 is asymmetrical for 1-2 and element 1 for 2-3 ! ! icc are the cation indices, toop is zero unless one or more toop cations ! write(*,60)icc,toop,kkk 60 format('3XQ ENTERING SETASYM: icc: ',3i3,' toop: ',3i3,' kkk: ',a) ! format(a,3i3,3x,3i3,2x,a) ! i=icc(1); j=icc(2); k=icc(3) ! ! write(*,*)'3XQ calling order3KKK ' ! call order3KKK(i,j,k,a,b,c,kkk) ! if(a.lt.0) then write(*,*)'Problems 10 in order3 ',i,j,k,a,b,c stop endif ! rearranged i, j, k ! write(*,70)a,b,c,kkk 70 format('3XQ rearranged order in setasym: ',3i4,5x,a) ! ! if order changed, change KKK, assume only one T ! ! any phase may have asymmetric ternaries but at present only MQMQA ! if(.not.allocated(phlista(iph)%tersys)) then ! stop ! endif ! ! emergency ... should be checked, a system with 3 constituent has 1 ternary ! dim3=size(tersys) ! write(*,333)a,b,c,mqmqa_data%ncat,mm,size(tersys) 333 format('3XQ In setasym: ',8i4) mm=terind(a,b,c) if(mm.le.0) then write(*,*)'3XQ terind cannot find this system',a,b,c stop end if ! write(*,333)a,b,c,mqmqa_data%ncat,mm,size(tersys) ! newXupdate=newXupdate+1 ! tersym is declared globally, it should be within a phase record ! as each phase can have ternary symmetries ! write(*,511)mm,' old ',tersys(mm)%asymm,tersys(mm)%isasym,a,b,c 511 format('3XQ in setasym ternary: ',i4,a,' asymmetry <',a,'> ',3i3,2x,3i3) tersys(mm)%asymm=kkk tersys(mm)%isasym=0 ! or should one use i, j, k ??? ! the indices in tersys(mm)%el are the 3 element indices of the ternary ! write(*,300)mm,tersys(mm)%el 300 format('Element numbers in ternary ',i3,' are ',3i3) if(kkk(1:1).eq.'T') tersys(mm)%isasym(1)=tersys(mm)%el(3) if(kkk(2:2).eq.'T') tersys(mm)%isasym(2)=tersys(mm)%el(2) if(kkk(3:3).eq.'T') tersys(mm)%isasym(3)=tersys(mm)%el(1) write(*,511)mm,' new ',tersys(mm)%asymm,tersys(mm)%isasym,a,b,c ! ! for debugging list whole array ! write(*,310)dim3 310 format(/'Listing of the ',i3,' ternary systems and their asymmetry',& /' i seq cat1 cat2 cat3 T/0 T/0 T/0 asymmetry code') ! ntercat=mqmqa_data%ncat*(mqmqa_data%ncat-1)*(mqmqma_data%ncat-2)/6 ! do i=1,ntercat ! write(*,320)i,tersys(i)%seq,(tersys(i)%el(j),j=1,3),& ! tersys(i)%isasym,tersys(i)%asymm 320 format(i3,i5,2x,3(1x,i4),5x,3i4,5x,a) ! enddo ! write(*,330) 330 format(/'Number in T/0 column is actual asymmetric element') ! return end subroutine setasym !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine correlate_const_and_quads !\begin{verbatim} subroutine correlate_const_and_quads(lokph) ! this subroutine should for each mqmqa constituent create their ! quad index element order for handling asymmetric variables in compvar ! el1 1 1 1 .. 1 ! 2 2 .. 2 ! 3 .. ! n-1 ! el2 1 2 3 .. n-1 ! 2 3 .. n-1 ! 3 .. ! n-1 ! quad 1 2 3 n ! n+1 n+2 2n-1 ! 2n ! (n-1)n/2 ! With n elements and one anion there are n-1 cations ! The anion element index can be any value from 1 to n ! ! i=el2ancat(j) is cation index of element j, a negative value mean anion ! i=con2quad(j) is index in quad fraction array of constituent j ! it is populated using ijklx(cat1,cat2,1,1) where the 1 is the anion ! OC saves fractions in phase_varres%yfr(1..n) for a single sublattice ! there is no need to transfer fractions from quad to phase_varres%yfr ! A quad has 1 or 2 cations ALWAYS indexed from 1 .. n-1 (no anion fraction) ! i=el2ancat(j) is the cation index element j. If j is anion a negative value ! i=quadofel(j) is the cation index of an element i ! The anion element index is not used ! ... but its elllink is saved in xanione and element index in xanionalpha ! implicit none integer iph,lokph,loksp,lokcs,nfr,isp,iel,jp,el1,el2,icon,endmem,mm integer cat1,cat2 integer missing,ll,nocon logical noanion integer, allocatable, dimension(:) :: invert,inverse integer, allocatable, dimension(:) :: findan character*24 quadname ! ! called from create_asymmetry in gtp3B ! write(*,7)lokph,nfr,noofel 7 format(/'3XQ In correlate_const_and_quad',3i5//) ! nfr=phlista(lokph)%nooffr(1) allocate(findan(noofel)) ! lokcs=phlista(lokph)%linktocs(1) composition set? ! note element numbers are not in order, the anion may be anywhere ! ! first step, find anion, it is present in all constituents ! Stupid to do this here, it has already been found but lost findan=0 do isp=1,nfr loksp=phlista(lokph)%constitlist(isp) iel=size(splista(loksp)%ellinks) ! if(iel.eq.3) then ! write(*,3)isp,loksp,iel,splista(loksp)%symbol,& ! (ellista(splista(loksp)%ellinks(jp))%symbol,jp=1,iel),& ! (ellista(splista(loksp)%ellinks(jp))%alphaindex,jp=1,iel),& ! (splista(loksp)%ellinks(jp),jp=1,iel) ! else ! write(*,2)isp,loksp,iel,splista(loksp)%symbol,& ! (ellista(splista(loksp)%ellinks(jp))%symbol,jp=1,iel),& ! (ellista(splista(loksp)%ellinks(jp))%alphaindex,jp=1,iel),& ! (splista(loksp)%ellinks(jp),jp=1,iel) ! endif !2 format('3XQ const: ',3i3,2x,a12,2x,2(a,2x),4x,2(i3),5x,2(i3)) !3 format('3XQ const: ',3i3,2x,a12,2x,3(a,2x),3(i3),2x,3(i3)) do jp=1,iel el1=splista(loksp)%ellinks(jp) findan(el1)=findan(el1)+1 enddo enddo ! write(*,4)'3XQ elements: ',findan 4 format(a,20i3) ! count the number of times an element occurs ! write(*,22)(jp,elements(jp),ellista(jp)%alphaindex,ellista(jp)%symbol,& ! jp=1,noofel) 22 format(/'3XQ elements :',10(3i2,1x,a,';')/) el1=0 ! The anion should be present in all quads! do jp=1,noofel if(findan(jp).gt.el1) then el1=findan(jp); el2=jp; endif enddo ! el2 is the element index is in ellista, el1 is the alphabetical order ! write(*,*)'3QX anion is element: ',el1,el2,findan(el2) ! mqmqa_data%xanione=el2 mqmqa_data%xanionalpha=ellista(el2)%alphaindex ! write(*,6)ellista(mqmqa_data%xanione)%symbol,& ! mqmqa_data%xanione,mqmqa_data%xanionalpha 6 format(/'3XQ line 3383 anion: ',a,' ellink: ',i3,' alphabetically: ',i3/) ! ! set up translation table for cations from ellink to 1..ncat ! the anion has a negative value in el2ancat, the cations index 1..ncat ! write(*,*)'3XQ in correlate_const_and_quads ... allocating el2ancat' ! mqmqa_data is not allocated ... suck ! if(allocated(mqmqa_data%el2ancat(noofel))) & ! deallocate(mqmqa_data%el2ancat(noofel)) allocate(mqmqa_data%el2ancat(noofel)) ! write(*,*)'Size of mqmqa_data%el2ancat ',size(mqmqa_data%el2ancat) do jp=1,noofel if(jp.lt.mqmqa_data%xanionalpha) then ! if(jp.lt.mqmqa_data%xanione) then mqmqa_data%el2ancat(jp)=jp elseif(jp.gt.mqmqa_data%xanionalpha) then ! elseif(jp.gt.mqmqa_data%xanione) then mqmqa_data%el2ancat(jp)=jp-1 else mqmqa_data%el2ancat(jp)=-jp endif ! write(*,*)'3xq mqmqa_data%el2cat: ',jp,mqmqa_data%el2ancat(jp) enddo ! write(*,16)'3XQ Elements alphabetically: ',& ! ((ellista(elements(jp))%symbol),jp=1,noofel) ! write(*,17)'3XQ Elements in ellista order:',(elements(jp),jp=1,noofel) ! write(*,17)'3XQ Element alpha indices: ',(jp,jp=1,noofel) ! write(*,17)'3XQ Cation alpha indices: ',& ! (mqmqa_data%el2ancat(jp),jp=1,noofel) 15 format(a,20(i2,a2)) 16 format(a,20(1x,a2)) 17 format(a,20i3) ! ! We need to know how to transfer compositions from phase_varres%yfr to xquad allocate(mqmqa_data%con2quad(nfr)) ! loop though all constituents in the %constitlist, extract cations and ! calculate its index in the xquad. Only done once! con2quad: do isp=1,nfr loksp=phlista(lokph)%constitlist(isp) ! there are 2 or 3 element links, one of which is an anion el1=ellista(splista(loksp)%ellinks(1))%alphaindex cat1=mqmqa_data%el2ancat(el1) ! cat1=mqmqa_data%el2ancat(splista(loksp)%ellinks(1)) ! write(*,18)'First: ',el1,cat1,cat1,splista(loksp)%symbol 18 format(a,3i4,5x,a) first: if(cat1.lt.0) then ! first link was to the anion, next must be a cation el1=ellista(splista(loksp)%ellinks(2))%alphaindex cat1=mqmqa_data%el2ancat(el1) ! write(*,18)'Second: ',el1,& ! mqmqa_data%el2ancat(splista(loksp)%ellinks(2)),cat1 more1: if(size(splista(loksp)%ellinks).gt.2) then ! there can be 1 or 2 cations, the first ellink was to an anion el1=ellista(splista(loksp)%ellinks(3))%alphaindex cat2=mqmqa_data%el2ancat(el1) ! write(*,18)'Third: ',splista(loksp)%ellinks(3),& ! mqmqa_data%el2ancat(splista(loksp)%ellinks(3)),cat2 else ! if there is no third element the single cation is doubled cat2=cat1 endif more1 else ! we found one cation, the next ellink can be an anion or cation el1=ellista(splista(loksp)%ellinks(2))%alphaindex cat2=mqmqa_data%el2ancat(el1) ! write(*,18)'Fourth: ',el1,& ! mqmqa_data%el2ancat(el1),cat2 second: if(cat2.lt.0) then more2:if(size(splista(loksp)%ellinks).gt.2) then ! there can be 1 or 2 cations, the second ellink can be to the anion el1=ellista(splista(loksp)%ellinks(3))%alphaindex cat2=mqmqa_data%el2ancat(el1) ! write(*,18)'Fifth: ',el1,& ! mqmqa_data%el2ancat(el1),cat2 else ! the single cation is doubled cat2=cat1 endif more2 endif second endif first ! when we come here we hav one or two cations mqmqa_data%con2quad(isp)=ijklx(cat1,cat2,1,1) ! write(*,55)isp,cat1,cat2,mqmqa_data%con2quad(isp) 55 format('3xq loop: ',i3,2x,2i3,2x,i5) enddo con2quad ! allocate also array with all A/X quads allocate(mqmqa_data%emquad(mqmqa_data%ncat)) ! enter data in emquad cat1=1 cat2=mqmqa_data%ncat do isp=1,mqmqa_data%ncat mqmqa_data%emquad(isp)=cat1; cat1=cat1+cat2; cat2=cat2-1 enddo ! list quads (why?) write(*,68)(mm,mm=1,mqmqa_data%nquad) 68 format('3XQ quads: ',21i3) write(*,57)'3XQ emquads:',(mqmqa_data%emquad(isp),isp=1,mqmqa_data%ncat) 57 format(a,25i4) ! ! loop for all constituents of the mqmqa phase ! we should populate all structures of the %alphaindex of the element ! skipping the alphaindex of the anion ! write(*,60)'3XQ constituents :',(jp,jp=1,nfr),& ! 'mqmqa_data%con2quad:',(mqmqa_data%con2quad(jp),jp=1,nfr) 60 format(/a,10(i3,1x)/a,10(i3,1x)) ! icon is index of constituent in phase 1..n ! splista(icon)%symbol is species symbol ! write(*,65) 65 format(/'3XQ Constituents in alphabetical order:') ! write(*,70)(trim(splista(phlista(lokph)%constitlist(jp))%symbol),jp=1,nfr) ! ! write(*,*)'3XQ Constituents in quad order:' ! write(*,70)(trim(splista(phlista(lokph)%constitlist(mqmqa_data%con2quad(jp)))%symbol),jp=1,nfr) ! !70 format('3XQ: ',10(a,', ')) !71 format('3XQ: ',2i3,3x,a) ! allocate(inverse(nfr)) ! write(*,87) 87 format(/'3XQ OC fraction order MQMQA quad order') do jp=1,nfr qqq: do el1=1,nfr cat1=mqmqa_data%con2quad(el1) if(cat1.eq.jp) then quadname=splista(phlista(lokph)%constitlist(el1))%symbol inverse(jp)=el1 exit qqq endif enddo qqq ! write(*,88)jp,trim(splista(phlista(lokph)%constitlist(jp))%symbol),& ! el1,trim(quadname) 88 format('Order ',i3,3x,a12,i5,2x,a) enddo ! ! this is if we need to convert from xquad array to yfr ! write(*,89)(inverse(jp),jp=1,nfr) 89 format('3XQ Quad2con: ',20i3) 1000 continue return end subroutine correlate_const_and_quads !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine list_quads(kk) !\begin{verbatim} subroutine list_quads(kk) ! emergency subroutine because phlista protected in pmon6 implicit none integer kk !\end{verbatim} integer nel ! kk=0 ! negative is anion write(*,2)(ellista(elements(nel))%symbol,nel=1,noofel) 2 format(/'Element names: ',20(a2,1x)) do nel=1,noofel if(mqmqa_data%el2ancat(nel).lt.0) kk=nel enddo ! elements as quad numbers write(*,3)size(mqmqa_data%el2ancat),mqmqa_data%el2ancat 3 format('Cation indices:',i2,2x,20i3) !3 format('3XQ el2ancat: ',i3,2x,20i3) if(kk.eq.0) then write(*,*)'You have a strange MQMQA system without any anion' else write(*,4)ellista(elements(kk))%symbol,mqmqa_data%xanionalpha,& mqmqa_data%xanione 4 format('The anion element name, index and link: ',a,2i3) endif ! return end subroutine list_quads !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine listconst !\begin{verbatim} subroutine listconst(iph) ! emergency subroutine because phlista protected in pmon6 implicit none integer iph !\end{verbatim} type(gtp_phase_varres), pointer :: phres integer lokph,lokcs,isp,iel,elx(4),elxx(4),jp,j1,j4,nel,cations(2),jj,kk character :: elsym(noofel)*2 elsym=' ' kk=0 do nel=1,noofel elsym(nel)=ellista(elements(nel))%symbol if(mqmqa_data%el2ancat(nel).lt.0) kk=nel enddo write(*,2)(elsym(jj),jj=1,noofel) 2 format(/'Element names: ',20(a2,1x)) write(*,3)size(mqmqa_data%el2ancat),mqmqa_data%el2ancat 3 format('3XQ el2ancat: ',i3,2x,20i3) if(kk.eq.0) then write(*,*)'You have a strange MQMQA system without any anion' endif write(*,4)elsym(kk),mqmqa_data%xanionalpha,& mqmqa_data%xanione 4 format('3XQ The anion element name, index and link: ',a,2i3) ! lokph=phases(iph) lokcs=phlista(lokph)%linktocs(1) isp=0 ! mqmqa_data%xanione=splista(j4)%ellinks(nel) ! write(kou,5)lokcs,mqmqa_data%xanione,mqmqa_data%xanionalpha write(kou,5) 5 format(/'Con Quad Nel Elements Elem index',2x,'Species name',& 15x,'Cations') specie: do jp=1,phlista(lokph)%nooffr(1) isp=isp+1 j4=phlista(lokph)%constitlist(jp) nel=size(splista(j4)%ellinks) elsym=' ' elxx=1000 jj=0 element: do iel=1,nel elx(iel)=splista(j4)%ellinks(iel) elsym(iel)=ellista(elx(iel))%symbol elxx(iel)=ellista(splista(j4)%ellinks(iel))%alphaindex j1=mqmqa_data%el2ancat(elxx(iel)) if(j1.gt.0) then ! con2cat(i) is the cation index of i, negative if anion jj=jj+1 cations(jj)=j1 endif enddo element if(jj.eq.1) cations(2)=cations(1) if(noofel.le.3) then write(kou,19)isp,mqmqa_data%con2quad(isp),nel,(elsym(kk),kk=1,3),& elxx,splista(j4)%symbol,cations 19 format(i3,i4,2x,i4,1x,3(a,2x),4(1x,i2),2x,a,2x,2i3) else write(kou,20)isp,mqmqa_data%con2quad(isp),nel,(elsym(kk),kk=1,4),& elxx,splista(j4)%symbol,cations 20 format(i3,i4,2x,i4,1x,4(a,2x),4(1x,i2),2x,a,2x,2i3) endif enddo specie write(*,*)'The quads are in the alphabetical order of the quad elements' return end subroutine listconst !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !\addtotable subroutine listpartree !\begin{verbatim} subroutine listpartree(lokph) ! list all endmembers and excess parameter records for a phase ! in order to understand the MQMQX phase implicit none integer lokph !\end{verbatim} !\end{verbatim} type (gtp_endmember), pointer :: endmemrec,em type (gtp_interaction), pointer :: intrec type (gtp_property), pointer :: proprec type (gtp_asymprop), pointer :: asymdata integer intlevel,nofr,fracs(10),npr,intsave,ii,nint,powers(3) ! double precision vals(6) character*3 tab1 character*6 tab2 character*9 tab3 ! type stack type(gtp_interaction), pointer :: current end type stack type(stack), dimension(:), allocatable :: intstack ! intlevel=0; fracs=0 tab1='---' tab2='------' tab3='---------' allocate(intstack(5)) write(*,5) 5 format('3XQ list of the excess parameter tree') ! endmemrec=>phlista(lokph)%ordered ! if(associated(endmemrec)) write(*,*)'3XQ there is an endmember' emloop: do while(associated(endmemrec)) nofr=1 fracs(nofr)=endmemrec%fraclinks(1,1) intrec=>endmemrec%intpointer ! if(associated(intrec)) write(*,10)fracs(1) 10 format('3XQ interactions from endmember ',i3) intsave=0 nofr=nofr+1 intloop:do while(associated(intrec)) fracs(nofr)=intrec%fraclink(1) proprec=>intrec%propointer if(.not.associated(proprec)) then write(*,20)intsave+1,fracs(nofr) 20 format('3XQ interaction record level',i3,', constituent',i3) else proploop: do while(associated(proprec)) if(.not.associated(proprec%asymdata)) then powers=0 else powers(1)=proprec%asymdata%ppow powers(2)=proprec%asymdata%qpow powers(3)=proprec%asymdata%rpow endif npr=proprec%antalprop if(intsave.eq.0) then write(*,100)' ',intsave+1,npr,powers,(fracs(ii),ii=1,nofr) elseif(intsave.eq.1) then write(*,100)tab1,intsave+1,npr,powers,(fracs(ii),ii=1,nofr) elseif(intsave.eq.2) then write(*,100)tab2,intsave+1,npr,powers,(fracs(ii),ii=1,nofr) elseif(intsave.eq.3) then write(*,100)tab3,intsave+1,npr,powers,(fracs(ii),ii=1,nofr) else write(*,100)'---',intsave+1,npr,powers,(fracs(ii),ii=1,nofr) endif 100 format('3XQ ',a,' at level ',i1,', func: ',i2,& ', powers: ',3i2,', constituents ',9i3) proprec=>proprec%nextpr enddo proploop endif if(associated(intrec%highlink)) then ! save intrec%nextlink and jump to higher level intsave=intsave+1 intstack(intsave)%current=>intrec%nextlink intrec=>intrec%highlink nofr=nofr+1 fracs(nofr)=intrec%fraclink(1) else ! check the nextlink, pop saved if empty intrec=>intrec%nextlink pop: do while(.not.associated(intrec)) write(*,*)'3XQ pop stack' if(intsave.gt.0) then intrec=>intstack(intsave)%current intsave=intsave-1 nofr=nofr-1 else exit intloop endif enddo pop cycle intloop endif ! if we come here there are no more interaction records for this endmember enddo intloop ! ! write(*,*)'3XQ next endmember' endmemrec=>endmemrec%nextem ! enddo emloop write(*,*)'No more parameters' 1000 continue return end subroutine listpartree !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !addtotable subroutine toop_ternary !\begin(verbatim} subroutine toop_ternary subroutine toop_ternary(text,toop) ! subroutine to detect a Toop cation, if toop=0 there is no Toop element character text*(*) integer toop !\end{verbatim} character*1 toopindex integer ipos ! this returns a number 1, 2 or 3 after the first T in text ! No test if there are several Toop elemenets (with same or another number) ipos=index(text,'T') if(ipos.le.0 .or. ipos.eq.len(text)) then toop=0 else toop=ichar(text(ipos+1:ipos+1)) if(toop.lt.1 .or. toop.gt.3) then ! the letter after the T must be a digit 1, 2 or 3 write(*,*)'3XQ warning, ternary asymmetry error: "'//trim(text)//'"' toop=0 endif endif 1000 continue return end subroutine toop_ternary !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! !addtotable subroutine varkappadefs !\begin(verbatim} subroutine varkappadefs ! subroutine varkappadefs(phres) subroutine varkappadefs(phres) ! subroutine to list \varkappa, \xi and y_ik definitions type(gtp_phase_varres), pointer :: phres ! type(gtp_phase_varres), pointer :: mqmqavar !\end{verbatim} integer nv,cat1,cat2,i,j,k,ip,i0,jp ! type(gtp_mqmqa_var), pointer :: mqf type(gtp_allinone), pointer :: box character*300 line1,line2,qline character*2, dimension(:), allocatable :: quadcat type(gtp_mqmqa_var), pointer :: mqf ! mqf=>phres%mqmqaf ! copied from pmon ! write(kou,4124)mqmqa_data%nquad,mqmqa_data%ncat 4124 format('Listing of quads and asymmetries using varkappadefs:'/& 'The ',i3,' quads for ',i2,' cations are arranged ',& 'in order of the n cations:'/& 'Quad ',9x,'1 2 ... n | n+1 n+2 ... 2n-1 | 2n .. | n(n+1)/2'/& 'Cation',9x,'1 1 ... 1 | 2 2 ... 2 | 3 .. | n'/& 'Cation',9x,'1 2 ... n | 2 3 ... n | 3 .. | n') ! ! identify the actual cations in all quads as above ! write(*,50)(i,i=1,mqmqa_data%nquad) ! create the quadcat indices used for the vk_ij quad dependences allocate(quadcat(mqmqa_data%nquad)) line1='Cat1:' ip=6 i0=ichar('0') k=1 ! To fix problems here see around line 4100 about box%ivk_ij, %jvk_ji %kvk_ijk do i=1,mqmqa_data%ncat do j=i,mqmqa_data%ncat line1(ip:ip+2)=' '//char(i0+i) quadcat(k)(1:1)=char(i0+i) k=k+1 ip=ip+3 enddo ip=ip+1 enddo 51 format(a) line2='Cat2:' qline='Quad:' ip=6 k=1 i0=ichar('0') do i=1,mqmqa_data%ncat do j=i,mqmqa_data%ncat line2(ip:ip+2)=' '//char(i0+j) quadcat(k)(2:2)=char(i0+j) if(k.lt.10) then qline(ip:ip+2)=' '//char(i0+k) else qline(ip:ip+2)=' 1'//char(i0+k-10) endif ip=ip+3 k=k+1 enddo ip=ip+1 enddo ! nice output of quads and cation dependencies write(*,51)trim(qline) write(*,51)trim(line1) write(*,51)trim(line2) ! ! quadcat(k)(1:2) are the 2 cation indices (as characters) in quad k ! ivk_ij, ivk_ji, kvk_ijk arrays of quad indices indices ! vkloop: do nv=1,size(mqf%compvar) ! box=>mqf%compvar(nv) ! box%ivk_ij(1..n) are indices of quads to be added ! write(*,100)'vk_ij',(box%ivk_ij(cat1),cat1=1,size(box%ivk_ij)) ! write(*,100)'vk_ji',(box%jvk_ji(cat1),cat1=1,size(box%jvk_ji)) ! write(*,100)'denom',(box%kvk_ijk(cat1),cat1=1,size(box%kvk_ijk)) !100 format(a,10i3) ! enddo vkloop write(*,99)size(mqf%compvar) 99 format('3XQ some ternary asymmetries may still be wrong',i3) ! vkloop2: do nv=1,size(mqf%compvar) ! _ij box=>mqf%compvar(nv) write(*,103)nv,size(box%ivk_ij),size(box%jvk_ji),& size(box%all_ijk),size(box%kvk_ijk) 103 format('Varkappa index: ',i3,', summing quads: ',4i4) line1='x_'//quadcat(box%ivk_ij(1)) ip=len_trim(line1)+1 k=2 do while(k.le.size(box%ivk_ij)) ! write(*,*)'3XQ bug here?',k,size(box%ivk_ij),ip line1(ip:)='+x_'//quadcat(box%ivk_ij(k)) k=k+1 ip=ip+5 enddo ! To fix problems here see around line 4100 about box%ivk_ij, %jvk_ji %kvk_ijk write(*,105)' nomin: vk_'//char(i0+box%cat1)//char(i0+box%cat2)//& ' = '//trim(line1) ! _ji line2='x_'//quadcat(box%jvk_ji(1)) ip=len_trim(line2)+1 k=2 do while(k.le.size(box%jvk_ji)) line2(ip:)='+x_'//quadcat(box%jvk_ji(k)) k=k+1 ip=ip+5 enddo write(*,105)' nomin: vk_'//char(i0+box%cat2)//char(i0+box%cat1)//& ' = '//trim(line2) ! _denom ! NOTE some quad fractions appear twice!! should be removed qline=trim(line1)//'+'//trim(line2)//' +x_'//quadcat(box%kvk_ijk(1)) ip=len_trim(qline)+1 k=2 do while(k.le.size(box%kvk_ijk)) qline(ip:)='+x_'//quadcat(box%kvk_ijk(k)) k=k+1 ip=ip+5 enddo write(*,105)' denom: = '//trim(qline) 105 format(a) ! ! write(*,110)'vk_',box%cat1,box%cat2,quadcat(box%ivk_ij(1)), ! ((quadcat(box%jvk_ji(cat1)),cat1=2,size(box%jvk_ji)) ! ! write(*,110)'vk_',box%cat1,box%cat2,& ! (quadcat(box%jvk_ji(cat1)),cat1=1,size(box%jvk_ji)) ! write(*,120)'denom = vk_ij+vk_ji + ',& ! (quadcat(box%kvk_ijk(cat1)),cat1=1,size(box%kvk_ijk)) !110 format(a,2i1,' = x_',a,'+')) !120 format(a,20('x_',a,'+')) enddo vkloop2 1000 continue return end subroutine varkappadefs !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! ! asymmetry code ! j is the Toop element in i-j-\nu ! i is the Toop element in i-j-\gamma ! ! \sum_a=(i,\nu) \sum_b=(i,\nu) x_ab/kk ivk_ij ! vk_ij/kk = ------------------------------------------------------- = ------- ! \sum_a=(i,j,\nu,\gamma) \sum_b=(i,j,\nu,\gamma) x_ab/kk denom_ij ! ! \sum_a=(j,\gamma) \sum_b=(j,\gamma) x_ab/kk jvk_ji ! vk_ji/kk = ------------------------------------------------------- = ------ ! \sum_a=(i,j,\nu,\gamma) \sum_b=(i,j,\nu,\gamma) x_ab/kk denom_ij ! ! NOTE x_ij = x_ji and occures only once in sums !!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ivk_ij = x_i,i + x_i,\nu + x_\nu,\nu ! jvk_ji = x_j,j + x_j,\gamma + x_\gamma,\gamma ! denom = x_i,j + x_i,\nu+x_j,\gamma+x_\nu,\nu+x_\nu,\gamma+x_gamma,gamma ! ! initiate: ivk_ij=[x_ii]; jvk_ji=[x_jj]; denom=[x_ij] ! ! extradenom=[ ] ! binary loop vk: do i-j ! ternary loop: do g=1,n ------------------ g can be \nu, \gamma or both ! if(g=i or g=j) cycle ternary loop ! if(i is Toop in i-j-g) then ...............g is \gamma ! jvk_ij=[ jvk_ij , x_gg, x_jg ] ! denom will at the end have jvk_ji and ivk_ij added. Add only x_ig ! denom_ij = [ denom_ij, x_ig] ! if(j is Toop in i-j-g) then ..............g is both \nu and \gamma ! ivj_ji=[ ivk_ij, x_gg, x_ig, x_jg ] ! endif ! there can have been previous \gamma or \nu, add extra x_\gamma,\nu ! do h=1,size(extradenom) ! denom_ij = [ denom_ij, x_gh ] ! enddo ! extradenom = [extradenom, g ] !----------- ! elseif(j is Toop in i-j-g) then ...........g is \nu ! ivj_ji= [ ivk_ij, x_gg, x_jg ] ! denom_ij = [ denom_ij, x_gg, x_jg, x_ig ] ! endif ! enddo ternary loop ! enddo binary loop ================================================ FILE: src/models/gtp3Y.F90 ================================================ ! ! gtp3Y included in gtp3.F90 ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !> 16. Section: grid minimizer !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine global_gridmin !\begin{verbatim} subroutine global_gridmin(what,tp,xknown,nvsph,iphl,icsl,aphl,& nyphl,cmu,ceq) ! ! Starting rewriting 2017-02-01 ! ! finds a set of phasey cons that is a global start point for an equilibrium ! calculation at T and P values in tp and known mole fraction in xknown ! It is intentional that this routine is independent of current conditions ! It returns: nvsph stable phases, list of phases in iphl, amounts in aphl, ! nyphl(i) is redundant, cmu are element chemical potentials of solution ! WHAT determine what to do with the results, 0=just return solution, ! 1=enter stable set and constitution of all phases in gtp datastructure ! and create composition sets if necessary (and allowed) ! what=-1 will check if any gridpoint is below current calculated equilibrium ! ?? removed what -1 170428/BoS implicit none ! nyphl(j) is the start position of the constitiuent fractions of phase j in integer, dimension(*) :: iphl,nyphl,icsl integer what,nvsph TYPE(gtp_equilibrium_data), pointer :: ceq double precision, dimension(2) :: tp ! cmu(1..nrel) is the chemical potentials of the solution double precision, dimension(*) :: xknown,aphl,cmu !\end{verbatim} ! yarr is used for fractions in the call to generate_grid double precision, dimension(maxconst) :: yarr integer, parameter :: maxgrid=400000,maxy=2000,maxph=500 integer :: starttid,endoftime real finish2 ! removed yphl as argument as it not needed outside global_gridmin ! dimensioning can be problematic if many phases with many constituents as it ! contains all constituent fractions of all gridpoints (before merge) ! double precision, dimension(10* amounts of maxconst) :: yphl double precision, dimension(10*maxconst) :: yphl double precision amount,sum,gmax integer ibias,ics,ics2,icsno,icsx,ie,iph,iv,j1,j2,jp,kkz,kp,kph,jbias integer lokcs,lokph,mode,ng,nocsets,noofgridpoints,nr,nrel,nrph,ny,nyz integer preveq ! nphl(iph) is last gridpoint that belongs to phase iph, nphl(0)=0 ! xarr(nrel,i) is the composition of gridpoint i ! garr(i) is the Gibbs energy of gridpoint i ! jgrid(j) is a gridpoint in the solution ! phfrac(j) is the amount of the phase of that gridpoint ! ngrid deleted integer, dimension(0:maxph) :: nphl integer, dimension(maxel) :: jgrid real garr(maxgrid),starting,finished real, dimension (:,:), allocatable :: xarr real, dimension (maxel,maxel) :: xsol double precision, dimension(maxel) :: phfrac,phsave,xdum double precision qq(5),savetp(2),xbase,totam integer, dimension(maxph) :: iphx character name1*24 ! integer idum(*) ! debug logical trace,toomany ! sort phases depending on number of gridpoints integer, dimension(:), allocatable :: gridpoints,phord,starttup ! pph is set to number of phases participating, some may be suspended integer pph,zph,nystph,order(maxel),tbase,qbase,wbase,jj,zz,errall,eecliq ! ! write(*,*)'3Y in global_gridmin' ! nystph=0 if(btest(globaldata%status,GSNOGLOB)) then write(*,*)'3Y Grid minimization not allowed' gx%bmperr=4173; goto 1000 endif call cpu_time(starting) call system_clock(count=starttid) nphl=0 ! Trace turn on output of grid on a file ocgrid.dat ! trace=.true. toomany=.false. trace=.FALSE. ! trace=.TRUE. if(trace) write(*,*)'3Y Trace set TRUE' savetp=ceq%tpval ceq%tpval=tp nrph=noph() if(nrph.gt.maxph) then ! too many phases write(*,*)'3Y Too many phases for gridmin' gx%bmperr=4344; goto 1000 endif nrel=noel() sum=zero ! problem that extract_massbalcond did not object to condition x(fcc,a)= do ie=1,nrel if(xknown(ie).le.zero .or. xknown(ie).ge.one) then if(.not.btest(globaldata%status,GSNOTELCOMP)) then write(*,*)'3Y Gridmin cannot handle these composition conditions' gx%bmperr=4174; goto 1000 else ! we have other components than elements, fractions can be negative and >1 write(kou,10) 10 format('3Y Trying to use gridmininmizer whith other components',& ' than the elements'/' Can give warnings and error messages') gx%bmperr=4174; goto 1000 endif endif sum=sum+xknown(ie) enddo if(ocv()) write(*,12)'3Y gridmin: ',sum,(xknown(ie),ie=1,nrel) 12 format(a,1pe12.4,10(f8.4)) if(abs(sum-one).gt.1.0D-8) then write(*,*)'3Y Sum of fractions not unity when calling global_gridmin' gx%bmperr=4174; goto 1000 endif kp=1 pph=0 ! write(*,*)'3Y allocating gridpoints 1',nrph allocate(gridpoints(nrph),stat=errall) allocate(phord(nrph),stat=errall) if(errall.ne.0) then write(*,*)'3Y allocation error 1: ',errall gx%bmperr=4370; goto 1100 endif eecliq=0 if(globaldata%sysreal(1).gt.one) then ! we must initiate EEC data for the liquid sliqmin=zero; sliqmax=zero; gliqeec=zero endif ! write(*,*)'3Y loop for all phases',nrph,globaldata%sysreal(1) ggloop: do iph=1,nrph ! include all phases with any composition set entered (but only once!) ! EXCLUDE the MQMQA phase if(test_phase_status_bit(iph,PHMQMQA)) then write(*,*)'3Y The MQMQA phase excluded from gridminimizer' cycle ggloop endif do ics=1,noofcs(iph) ! new: -3 suspended, -2 dormant, -1,0,1 entered, 2 fixed ! ignore phases whith no entered composition sets ! If a phase+compset FIX one should never be here as conditions wrong if(test_phase_status(iph,ics,amount,ceq).gt.PHDORM) then pph=pph+1 iphx(pph)=iph if(eecliq.eq.0 .and. globaldata%sysreal(1).gt.one) then ! write(*,*)'3Y looking for liquid: ',pph,iph if(btest(phlista(iph)%status1,PHLIQ)) then eecliq=phlista(iph)%alphaindex endif endif cycle ggloop endif enddo enddo ggloop !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ! if lutbug>0 open a file for grid graphics !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ! lutbug=37 ! There is some other gridoutput associated with trace if(lutbug.gt.0) then write(*,*)'3Y Opening gridmap.dat' open(lutbug,file='gridmap.dat',access='sequential',status='unknown') endif ! we will generate a grid for pph phases, the phase index for phase 1..pph ! is in iphx(1..pph) ! always allocate a grid for maxgrid points ! write(*,*)'3Y allocating gridpoints 2',nrel,maxgrid allocate(xarr(nrel,maxgrid),stat=errall) if(errall.ne.0) then write(*,*)'3Y allocation error 2: ',errall gx%bmperr=4370; goto 1000 endif gmax=zero ! write(*,11)'3Y gp1:',pph,(iphx(iph),iph=1,pph) ! just to be sure nphl(0)=0 ! !------------------------------------------------------ ! For EEC we must always calculate the liquid phase first ! it means its grid will be calculated twice because I do not want to change eec: if(eecliq.gt.0) then ! if eecliq=1 the liquid is first and this is not needed ! ng should be set to number of remaining points, ny and yphl is not used iv=1 ng=maxgrid ! possible output on gridmap.dat ! if(lutbug.gt.0) then ! lokph=phases(iphx(zph)) ! write(lutbug,16)trim(phlista(lokph)%name),zph,lokph,ng !16 format(/'Phase: ',a,3i7) ! endif ! write(*,*)'3Y calculate EEC data for liquid',eecliq,iphx(eecliq),iv,ng if(btest(globaldata%status,GSOGRID)) then ! The possibility to use the old grid tested call generate_grid(0,eecliq,ng,nrel,& xarr(1,iv),garr(iv),ny,yarr,gmax,ceq) else call generic_grid_generator(0,eecliq,ng,nrel,& xarr(1,iv),garr(iv),ny,yarr,gmax,ceq) endif if(gx%bmperr.ne.0) then write(*,*)'3Y grid error ',eecliq,gx%bmperr exit eec endif ! write(*,*)'3Y sliqmax: ',sliqmax elseif(globaldata%sysreal(1).gt.one) then write(*,*)'3Y EEC will not work because there is no liquid' endif eec ! !---------------------------------------------------------- phloop: do zph=1,pph ! for phase iphx(zph) the gridpoints will be stored from position nphl(zph-1)+1 ! ng should be set to number of remaining points, ny and yphl is not used iv=nphl(zph-1)+1 ng=maxgrid-iv ! write(*,*)'3Y generating grid for phase ',zph ! possible output on gridmap.dat if(lutbug.gt.0) then lokph=phases(iphx(zph)) write(lutbug,16)trim(phlista(lokph)%name),zph,lokph,ng 16 format(/'Phase: ',a,3i7) endif ! write(*,*)'3Y gridgen ',zph,iv,ng ! this call will calculate gridpoints in phase zph, that may take time ... ! ng is set to remaining dimension of garr, on return the number of generated ! gridpoints, returned as xarr composition of these and ! ny and yarr not used here !>>>>>>> important: changes here must be made also in global_equil_check ! write(*,*)'3Y grid for phase:',zph,phlista(phases(iphx(zph)))%name,& ! btest(globaldata%status,GSOGRID) if(btest(globaldata%status,GSOGRID)) then ! The possibility to use the old grid tested call generate_grid(0,iphx(zph),ng,nrel,xarr(1,iv),garr(iv),& ny,yarr,gmax,ceq) else ! write(*,*)'3Y calling generic',iphx(zph),ng call generic_grid_generator(0,iphx(zph),ng,nrel,xarr(1,iv),garr(iv),& ny,yarr,gmax,ceq) endif !>>>>>>>> impportant end! ! write(*,*)'3Y grid done' if(gx%bmperr.ne.0) then write(*,*)'3Y grid error ',iphx(zph),gx%bmperr exit phloop endif ! nphl(zph) is last gridpoint in phase zph nphl(zph)=nphl(zph-1)+ng ! write(*,*)'3Y gridpoint range for ',iphx(zph),nphl(zph-1)+1,nphl(zph) enddo phloop !---------------------------------------------------------- ! if lutbug>0 close it if(lutbug.gt.0) then close(lutbug) write(*,*)'3Y closed gridmap.dat with gridpoints' endif !++ write(*,11)'3Y gp2:',(nphl(iph),iph=1,nrph) 11 format(a,10i7/(7x,10i7)) if(gx%bmperr.ne.0) goto 1000 ! We should add the current set of stable phases in the grid if we have made ! a successful calculation ! if(.not.btest(ceq%status,EQNOEQCAL)) then ! add the current set of stable phases and their constitution as gridpoints ! write(*,*)'3Y Not yet adding current stable phases as gridpoints',& ! what preveq=0 ! endif ! we may be generating a list with all gridpoints ... if(trace) then write(*,*)'3Y Closing gridgen.dat' close(33) endif call system_clock(count=endoftime) call cpu_time(finished) ! kp set to total number of grispoints in all phases kp=nphl(pph) noofgridpoints=kp ! If WHAT is -1 then just compare all gridpoints with plane defined by ! the chemical potentials cmu to see if any is below. ! If so insert the gridpoint furtherst below the plane and set WHAT 10*iph+ics ! write(*,*)'3Y global_gridmin what: ',what if(what.eq.-1) then write(*,*)'3Y Calling global_grimin with -1 no longer supported' stop goto 1000 endif !----------------------------------------------- ! write(*,109)ngrid(pph),finished-starting,endoftime-starttid 109 format('3Y Gridmin Calculated ',i6,' gridpoints in ',1pe12.4,' seconds, ',& i7,' clockcycles') ! find the minimum of nrel gridpoints among the kp-1 gridpoint ! for current overall composition, xknown ! write(*,*)'3Y globm 4: ',kp,garr(kp),xarr(1,kp) ! phfrac=zero ! start with all elements having chemical potential equal to gmax cmu(1)=gmax if(ocv()) write(*,*)'3Y Finding the gridpoints for the minimum: ',kp ! write(*,*)'3Y Finding the gridpoints for the minimum: ',kp call find_gridmin(kp,nrel,xarr,garr,xknown,jgrid,phfrac,cmu,trace) if(gx%bmperr.ne.0) goto 1000 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! write(*,*)'3Y total gridpoints: ',kp ! gx%bmperr=4399; goto 1000 ! The solution with nrel gridpoints are in jgrid, the amount of each in phfrac ! We later want the phases in ascending order and as the gridpoints are ! in ascending order of the phases we sort the gridpoints (and amounts) ! There must be one gridpoint per component (element) ! write(*,62)(jgrid(jp),jp=1,nrel) 62 format('3Y Gridp: ',10i6) call sortin(jgrid,nrel,order) do nyz=1,nrel phsave(nyz)=phfrac(order(nyz)) enddo phfrac=phsave ! get the phase and constitution for each nyz=1 ! Extracting constititution of the gridpoints in the solution if(trace) then write(31,745) 745 format(/'Solution: ') endif do jp=1,nrel iphl(jp)=0 enddo solloop: do jp=1,nrel ! jgrid(jp) is a grid point in the solution, find which phase it is ! and its constituent fractions mode=jgrid(jp) 713 continue do zph=1,pph ! write(*,*)'3Y mode and ibias 1: ',mode,ibias ! nphl(zph) is the last gridpoint of phase zph, nphl(0) is 0 if(mode.le.nphl(zph)) then mode=mode-nphl(zph-1) ibias=nphl(zph-1) goto 315 else endif enddo ! nphl(pph) is number of generated gridpoints if(mode-nphl(pph).le.preveq) then ! gridpoint outside generated gridpoints, should be from previous solution write(*,*)'3Y previous stable phase included in solution',mode,preveq endif ! gridpoint outside range should never occur write(*,*)'3Y gridpoint outside range ',jgrid(jp),nphl(pph) ! It means element je=jgrid(jp)-nphl(pph) has no chemical potential ! and possibly no composition. Find the gripoint with max of with this ! component and add a small amont if it to avoid that an element has ! no phase in which is can dissolve ... qbase=jgrid(jp)-nphl(pph) xbase=zero wbase=0 do tbase=1,nphl(pph) if(xarr(qbase,tbase).gt.xbase) wbase=tbase enddo if(wbase.eq.0) then ! we have failed to find a gridpoint with this element gx%bmperr=4147; goto 1000 else write(*,*)'3Y using point: ',wbase phfrac(jp)=1.0D-4 mode=wbase goto 713 endif 315 continue jbias=ibias ! this call is to obtain the constitution of a phase in the solution ! mode gives in grid point index in phase iphx(zph), ibias irrelevant (?) ! NOTE jbias is changed by subroutine ?? ! ny is number of constituent fractions, yarr have the constituent fractions ! write(*,317)'3Y point: ',mode,jp,iphl(jp),(iphl(nr),nr=1,jp) if(btest(globaldata%status,GSOGRID)) then ! The possibility to use the old grid tested call generate_grid(mode,iphx(zph),ng,nrel,xarr(1,iv),garr(iv),& ny,yarr,gmax,ceq) else ! write(*,*)'3Y phase, jbias: ',iphx(zph),jbias call generic_grid_generator(mode,iphx(zph),jbias,nrel,xarr,garr,& ny,yarr,gmax,ceq) endif if(gx%bmperr.ne.0) goto 1000 ! write(*,317)'3Y after0: ',mode,jp,nyz,ibias,jbias,iphl(jp),& ! (iphl(nr),nr=1,jp) iphl(jp)=iphx(zph) aphl(jp)=phfrac(jp) nyphl(jp)=ny ! copy the constitution of all gridpoints to yphl, needed for possible merge do ie=1,ny yphl(nyz+ie-1)=yarr(ie) enddo nyz=nyz+ny ! write(*,317)'3Y after1: ',mode,jp,nyz,ibias,jbias,iphl(jp),& ! (iphl(nr),nr=1,jp) 317 format(a,i6,4i4,i3,20i3) ! finally copy the mole fractions to xsol, needed for possible merging do ie=1,nrel xsol(ie,jp)=xarr(ie,mode+ibias) enddo if(trace) then write(31,750)jp,jgrid(jp),iphl(jp),aphl(jp),(xsol(ie,jp),ie=1,nrel) write(31,760)(yphl(ie),ie=nyz-ny,nyz-1) 750 format('Point: ',i2,', gridpoint: ',i5,' phase ',i3,& ' amount: ',1pe12.4,', Mole fractions:'/9(0pF8.5)) 760 format('Constitution:'/9(0pF8.5)) endif enddo solloop ! we have now start values from the gridminimizer if(trace) then write(*,*)'3Y Closing ocgrid.dat file' close(31) endif ! there must be as many gridpoints (phases) as there are elements nvsph=nrel nr=nrel ! write(*,*)'3Y merge in global?',btest(globaldata%status,GSNOMERGE) if(.not.btest(globaldata%status,GSNOMERGE)) then ! For the moment we will only merge grid points in the gas phase call merge_gridpoints(nr,iphl,aphl,nyphl,yphl,trace,nrel,xsol,cmu,ceq) if(gx%bmperr.ne.0) goto 1000 endif !------------------------------------------- ! number of gridpoints, nr, may have changed ! write(*,*)'3Y After merge_gripoints: ',nr,nvsph nvsph=nr ! if what=-1 or 0 do nothing more, just exit if(what.le.0) goto 1000 !------------------------------------------------------------ ! prepare for storing result in the ceq data structure ! zero all phase amounts and driving forces do iph=1,nrph lokph=phases(iph) ! lokcs=phlista(lokph)%cslink do ics=1,phlista(lokph)%noofcs lokcs=phlista(lokph)%linktocs(ics) ceq%phase_varres(lokcs)%dgm=zero ceq%phase_varres(lokcs)%amfu=zero ceq%phase_varres(lokcs)%netcharge=zero if(ceq%phase_varres(lokcs)%phstate.eq.phentstab) then ! reset status of "entered and stable" to just "entered" ceq%phase_varres(lokcs)%phstate=phentered endif enddo enddo ! store chemical potentials multiplied with RT if what not -1 ceq%rtn=globaldata%rgas*ceq%tpval(1) do ie=1,nrel ! write(*,*)'3Y grid chemical potential: ',ie,cmu(ie)*ceq%rtn ! do not care about reference state for chempot(2) ceq%complist(ie)%chempot(1)=cmu(ie)*ceq%rtn ceq%complist(ie)%chempot(2)=cmu(ie)*ceq%rtn enddo ! set driving force 0 for stable phases do ie=1,nvsph call set_driving_force(iphl(ie),1,zero,ceq) if(gx%bmperr.ne.0) goto 1000 enddo ! store the most favourable constitution of the metastable phase ! write(*,29)'3Y set constitution of metastable phases',pph,(iphx(ie),ie=1,pph) ! write(*,29)'3Y gps: ',(nphl(ie),ie=0,pph) 29 format(a,(20i5)) call set_metastable_constitutions2(pph,nrel,nphl,iphx,xarr,garr,& nvsph,iphl,cmu,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'3Y Constitution of metastable phases set' ! maybe more composition sets needed do ie=1,nvsph icsl(ie)=0 enddo nocsets=0 ! write(*,*)'3Y before loop1: ',nvsph,ceq%eqname ! loop for all gripoints to store them in composition sets loop1: do j1=1,nvsph if(icsl(j1).eq.0) then ! if non-zero a composition set has already been assigned in loop2 icsl(j1)=1 icsx=1 loop2: do j2=j1+1,nvsph nextgridp: if(iphl(j1).eq.iphl(j2)) then ! one more composition set needed, does it exist? icsx=icsx+1 ics2=icsx ! write(*,31)'3Y compset needed for phase ',j1,j2,iphl(j1),ics2 31 format(a,10i4) call get_phase_compset(iphl(j1),ics2,lokph,lokcs) newset: if(gx%bmperr.ne.0) then ! there is no such composition set, is automatic creation allowed? ! NOTE: there is a EQNOACS bit also??? if(btest(globaldata%status,GSNOACS) .or. & btest(ceq%status,EQNOACS)) then write(*,*)'3Y Not allowed to create composition sets' gx%bmperr=4177; goto 1000 endif gx%bmperr=0 ! >>>>>>>>>>>>>>>>>>>< ! BEWARE >>> not only must this be done in all threads at the same time ! one must also avoid that it is done when some thread is working on a set ! of phase+composition sets transformed to EQCALC arrays. If so the ! indices to lokcs etc will be incorrect ... ??? ! I think OMP has "secure" points where the treads can be stopped to wait ! <<<<<<<<<<<<<<<<<<<<<< kph=iphl(j1) ! write(*,*)'3Y extra composition set for phase: ',kph,j1,j2 ! It must be done in all equilibrium records, no equilibrium record needed!!! ! one must be careful with the status word when creating comp.sets call enter_composition_set(kph,' ','AUTO',icsno) if(gx%bmperr.ne.0) then ! write(*,*)'3Y Error entering composition set ',j1,gx%bmperr if(gx%bmperr.eq.4092) then ! skip entering this set, it may work anyway ... if(.not.toomany) then write(kou,298)iphl(j1) 298 format('Cannot enter enough composition sets',& ' for phase',i4,' but gridmin struggles on') toomany=.true. endif gx%bmperr=0 ! to avoid later trouble we should mark there is no compset for this gridp!! iphl(j2)=-kph icsl(j2)=-1 cycle loop2 else goto 1000 endif endif call get_phase_compset(kph,icsno,lokph,lokcs) if(gx%bmperr.ne.0) goto 1000 ceq%phase_varres(lokcs)%status2=& ibset(ceq%phase_varres(lokcs)%status2,CSAUTO) nocsets=nocsets+1 icsl(j2)=icsno else ! here we should check which composition set that should have which ! constitution for example one fcc is metallic and another is cubic carbide call get_phase_name(iphl(j1),ics2,name1) icsl(j2)=ics2 ! check if the composition set is fix (2), dormant (2) or suspended (3) kkz=test_phase_status(iphl(j1),ics2,amount,ceq) ! old kkz=2 means fix if(kkz.eq.PHFIXED) then write(*,*)'3Y Global minimization with fix phase!' gx%bmperr=4346; goto 1000 elseif(kkz.lt.PHENTUNST) then write(*,*)'3Y Changing status for phase ',name1 endif ! this means status entered and unknown state. PHSTATE ceq%phase_varres(lokcs)%phstate=0 endif newset endif nextgridp enddo loop2 endif enddo loop1 if(nocsets.gt.0) then if(.not.btest(globaldata%status,GSSILENT)) then write(*,*)'3Y Composition set(s) created: ',nocsets endif endif ! Above one should consider if some user created compsets are dedicated to ! certain cases (MC carbides or L1_2 ordered). These should have ! a default constitution and CSDEFCON set) ! finally store stable phase amounts and constitutions into ceq%phase_varres j1=1 ! write(*,*)'3Y allocating startup 3',nvsph allocate(starttup(nvsph),stat=errall) if(errall.ne.0) then write(*,*)'3Y allocation error 3: ',errall gx%bmperr=4370; goto 1000 endif call extract_massbalcond(ceq%tpval,xdum,totam,ceq) if(gx%bmperr.ne.0) goto 1000 sum=zero do iph=1,nvsph sum=sum+aphl(iph) enddo gmax=zero ! write(*,*)'3Y no segmentation fault 1' ! If there is a gas nvsph may be less than number of elements ceqstore: do iph=1,nvsph ! write(*,*)'3Y no segmentation fault 2',iph if(iphl(iph).lt.0) then ! this gripoint has no composition set because too many gridpoints in same phase starttup(iph)=0 continue ! write(*,*)'3Y no segmentation fault 3',iph else ! write(*,*)'3Y segmentation fault 5',iph,iphl(iph),icsl(iph),j1 call set_constitution(iphl(iph),icsl(iph),yphl(j1),qq,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'3Y no segmentation fault 6',lokph,lokcs call get_phase_compset(iphl(iph),icsl(iph),lokph,lokcs) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'3Y no segmentation fault 7' ! This is a bit quiestionable but seems to work amount=aphl(iph)/ceq%phase_varres(lokcs)%abnorm(1) gmax=gmax+amount aphl(iph)=amount 1789 format(a,2i4,5(1pe12.4)) ! write(*,*)'3Y no segmentation fault 8',lokcs,iph ceq%phase_varres(lokcs)%amfu=aphl(iph) ceq%phase_varres(lokcs)%phstate=PHENTSTAB starttup(iph)=ceq%phase_varres(lokcs)%phtupx j1=j1+nyphl(iph) endif ! write(*,*)'3Y no segmentation fault 9',iph,nvsph enddo ceqstore !----------------------------------------------------------------------- ! debug listing of tuples at gridpoints ! write(*,*)'3Y no segmentation fault 10' ! write(*,1411)(starttup(iph),iph=1,nvsph) !1411 format('3Y tupl:',18i4) !----------------------------------------------------------------------- ! iv is total number of constituent fractions iv=j1 ! For safty, if any iphl is negative shift all values down for all gridpoints ! I do not think yphl is used any more but ... j1=1 iph=1 870 continue if(iphl(iph).lt.0) then 880 format(a,(20i4)) do kph=iph,nvsph-1 iphl(kph)=iphl(kph+1) icsl(kph)=icsl(kph+1) aphl(kph)=aphl(kph+1) kkz=nyphl(kph) nyphl(kph)=nyphl(kph+1) enddo iphl(nvsph)=-9 ! write(*,880)'3Y After: ',(iphl(j2),j2=1,nvsph) if(kph.lt.nvsph) then do j2=j1,iv yphl(j2)=yphl(j2+kkz) enddo iv=iv-kkz endif ! we shifted all down, fewer gridpoints and do not increment iph below iph=iph-1 nvsph=nvsph-1 endif j1=j1+nyphl(iph) iph=iph+1 if(iph.le.nvsph) goto 870 !--------------------------------------- ! write(*,*)'3Y gridpoints: ',nvsph,iph 1000 continue ! write(*,*)'3Y no segmentation fault 20' ! write(*,*)'3Y at 1000: ',phlista(1)%noofcs ! restore tpval in ceq ceq%tpval=savetp call cpu_time(finish2) if(allocated(xarr)) deallocate(xarr) if(gx%bmperr.ne.0) then ceq%status=ibset(ceq%status,EQFAIL) ! calling gridmin with what=-1 no longer supported ! elseif(what.eq.-1) then ! if(nystph.gt.0) what=nystph elseif(.not.btest(globaldata%status,GSSILENT)) then write(*,1010)noofgridpoints,finish2-starting,& endoftime-starttid,ceq%tpval(1) 1010 format('Gridmin: ',i7,' points ',1pe10.2,' s and ',& i7,' clockcycles, T=',0pF8.2) ! set the global bit that this is not a full equilibrium ceq%status=ibset(ceq%status,EQGRIDCAL) endif ! deallocate if(allocated(gridpoints)) then deallocate(gridpoints) deallocate(phord) endif 1100 continue if(ocv()) write(*,*)'3Y leaving global_gridmin' write(*,*)'3Y leaving global_gridmin' return end subroutine global_gridmin !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine generate_grid !\begin{verbatim} subroutine generate_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq) ! Different action depending of the value of mode, ! for mode<0: (will no longer be used ... ) ! return the number of gridpoints that will be generated for phase iph in ngg ! for mode=0: ! on entry ngg is dimension of garr ! on exit ngg is number of generated gridpoints ... ! return garr(i) gibbs energy and xarr(1,i) the compositions of gridpoint i ! for mode>0: ! return site fractions of gridpoint mode in yarr, number of fractions in ny ! iph is phase number, ngg is number of gridpoints, nrel number of elements, ! if mode=0: ! return xarr mole fractions of gridpoints, garr Gibbs energy of gridpoints, ! ngg is dimension of garr, gmax maximum G (start value for chem.pot) ! if mode>0: ! "mode" is a gridpoint of this phase in solution, return number of ! constituent fractions in ny and fractions in yarr for this gridpoint ! The current constitution is restored at the end of the subroutine implicit none TYPE(gtp_equilibrium_data), pointer :: ceq integer mode,iph,ngg,nrel,ny real xarr(nrel,*),garr(*) double precision yarr(*),gmax !\end{verbatim} %+ ! ! integer idum(*) integer lokph,errsave double precision, parameter :: yzero=1.0D-12 integer abrakadabra,i,ibas,ibin,iend,is,iter,je,jend,kend,ll,ls,nend,nsl ! used to save and restore constituent fractions double precision ydum(maxconst) integer nkl(maxsubl),knr(maxconst),inkl(0:maxsubl),nofy double precision, dimension(:), allocatable :: yfra double precision sites(maxsubl),qq(5) ! endm(i,j) has constituent indices in i=1..nsl for endmember j integer, dimension(:,:), allocatable :: endm integer maxdim !-------------------------------- ! grid is generated by combining end endmembers ! Number of endmemers is N ! For endmember E=1..N set fraction of enmember ! 0.99*Y_E + 0.01*Y_all N of these ! 0.89*Y_E + 0.10*Y_F,F=/=E + 0.01*Y_all N*(N-1) ! 0.74*Y_E + 0.25*Y_F,F=/=E + 0.01*Y_all N*(N-1)+N*(N-1)*(N-2) ! + 0.15*Y_F + 0.1*Y_G,G=/=(E,F) + 0.01*Y_all (3 or more endmemb) ! 0.61*Y_E + 0.38*Y_F,F=/=E + 0.01*Y_all ! + 0.25*Y_F + 0.13*Y_G,G=/=(E,F) + 0.01*Y_all (3 or more endmemb) ! added: ! 0.45*Y_E + 0.35*Y_F + 0.19*Y_G + 0.01*Y_all N*(N-1)*(N-2) (4 or more) !----- N=2: total 2+2+2+2=8 !----- N>2: total N*(1+(N-1)*(3+2*(N-2))); N=3:33, N=20: ! with 2 endmembers: 2*(1+3)=2*4=8 ! (1.00,0.00) ! (0.89,0.11) (0.74,0.26) (0.61,39) ! (0.00,1.00) ... ! with 3 endmembers: 3*11=33 gridpoints ! (1.00,0.00,0.00) ! (0.89,0.11,0.00)(0.89,0.00,0.11) ! (0.74,0.26,0.00)(0.74,0.00.0.26)(0.74,0.15,0.11)(0.74,0.11,0.15) ! (0.61,0.38,0.00)(0.61,0.00,0.38)(0.61,0.25,0.14)(0.61,0.14,0.25) ! (0.00,1.00,0.00) ! (0.11,0.89,0.00)(0.00,0.89.0.11) ! with 4 endmembers: ! (0.9925,0.0025,0.0025.0.0025) ! (0.8925,0.1025,0.0025,0.0025) (-,0.0025,0.1025,-) (-,.0025,.0025,.1025) ... !--------- ! for n>50 only endmember: 51:51, N:N ! for n=31-50 only one binary combination: ! for n=26-30 only two binary combinations: ! for n=2 and n=15-25 three binary cobinations: ! for n=11-14 three binary and one ternary combination ! for n<=10 use full grid: 2 binar and 2 ternar combinarions ! NOTE for ybas=0.45 never add same endmember !!! double precision, dimension(5), parameter:: ybas=& [1.0D0,0.89D0,0.74D0,0.61D0,0.45D0] double precision, dimension(4), parameter :: ybin=& [0.11D0,0.26D0,0.39D0,0.15D0] double precision, dimension(3), parameter :: yter=[0.0D0,0.11D0,0.13D0] ! added: not here ... just for the dense grid ! double precision, dimension(2), parameter :: yqrt=[0.35D0,0.19D0] ! for output of gridpoints integer jbas,sumngg,loksp,wrongngg,errall logical trace,isendmem save sumngg,wrongngg ! ! write(*,*)'Illegal call to generate_grid: ',mode ! stop ! if(mode.gt.0) write(*,*)'3Y entering generate_grid: ',mode,iph,ngg !--------------------------------------------------------- ! save current constitution in ydum call get_phase_data(iph,1,nsl,nkl,knr,ydum,sites,qq,ceq) if(gx%bmperr.ne.0) goto 1020 !--------------------------------------------------------- if(test_phase_status_bit(iph,PHEXCB)) then ! This phase has charged endmembers, generate neutral gridpoints (also dense) call generate_charged_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq) goto 1000 elseif(test_phase_status_bit(iph,PHIONLIQ)) then ! This is the ionic liquid, requires a special grid, also used for dense ! if(mode.gt.0) write(*,*)'3Y gridpoint in the liquid',mode call generate_ionliq_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq) ! if(mode.le.0) write(*,*)'3Y exit ionliq ',mode,ngg,ny if(mode.eq.-1) then wrongngg=ngg elseif(mode.eq.0) then ! ionliq -1 makes a bad estimate of the number of gridpoints generated ! give a warning if it may be too wrong ... if(ngg-wrongngg.gt.1000) then write(*,*)'3Y warning: ionic liquid gridpoints: ',ngg,wrongngg endif endif goto 1000 elseif(test_phase_status_bit(iph,PHFORD) .or. & test_phase_status_bit(iph,PHBORD)) then ! this phase has 4 sublattice fcc/hcp tetrahedral ordering, ! this reduces the number of gridpoints UNFINISHED: NOT IMPLEMENTED YET ! write(*,*)'3Y calling ordered grid 1' call generate_fccord_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq) ! do not jump to 1000 until the fccord routine implemented correctly ! write(*,*)'3Y back from fccord_grid 1, jump to 1000',ngg ! This routine return gx%bmperr=-1 if if cannot handle the gridgenerating if(gx%bmperr.eq.-1) then gx%bmperr=0 else goto 1000 endif elseif((btest(globaldata%status,GSXGRID) .or. & test_phase_status_bit(iph,PHXGRID)) .and. & .not.test_phase_status_bit(iph,PHGAS)) then ! Generate extra gridpoints for all phases or a special phase but never for gas call generate_dense_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq) goto 1000 endif ! ! mode=0 means generate grid (-1 means estimate size of grid for allocation), ! >0 means find constituent fractions for gridpoint in solution) ! if(mode.eq.0) then ! write(*,*)'3Y Generating grid for phase: ',iph ! trace TRUE means generate outpt for each gridpoint ! trace=.TRUE. trace=.FALSE. if(iph.eq.1 .and. trace) then ! unit 33 is opened before calling this routine sumngg=0 write(33,43) 43 format('The constituent fractions, y, enclosed within parentheses',& 'for each sublattice'/'Mole fractions after x:, Gibbs energies',& ' after G:'/) endif if(trace) then call get_phase_record(iph,lokph) write(33,44)iph,phlista(lokph)%name 44 format('Endmembers (EM) and gridpoints (GP) for phase: ',i3,1x,a) endif else trace=.FALSE. endif !--------------------------------------------------------- ! calculate the number of endmembers and index of first constituent in subl ll nend=1 inkl(0)=0 do ll=1,nsl nend=nend*nkl(ll) inkl(ll)=inkl(ll-1)+nkl(ll) enddo ! iliqneut=0 ! ionic liquids with neutrals .... ! if(test_phase_status_bit(iph,PHIONLIQ)) then ! loksp=0 ! do ny=nkl(1)+1,inkl(2) ! loksp=knr(ny) ! write(*,63)'3Y species: ',ny,knr(ny),loksp,& ! splista(loksp)%charge,splista(loksp)%symbol 63 format(a,3i4,F10.5,2x,a) ! if(.not.btest(splista(loksp)%status,SPVA) .and. & ! abs(splista(loksp)%charge).eq.zero) then ! we have a neutral (vacancies has no mass), add an endmember for that ! iliqneut=iliqneut+1 ! write(*,*)'3Y check for neutral: ',ny,iliqneut ! endif ! enddo ! endif ! ny=inkl(nsl) ! write(*,1010)'3Y Saved ',iph,(ydum(i),i=1,ny) ! ! mode<0 means calculate size of arrays to allocate ! negmode: if(mode.lt.0) then !--------------------------------------------------------- ! just determine the number of gridpoints for this phase for global minimimum ! ideal gases should just have the endmembers .... ngg=nend lokph=phases(iph) if(nend.eq.1 .or. nend.gt.50 .or. & btest(phlista(lokph)%status1,PHID)) then ! >50 or 1 endmember or ideal phase: only endmembers ngg=nend elseif(nend.gt.30) then ! 31-50: only one binary combination ngg=nend*nend elseif(nend.gt.25) then ! 26-30: two binary combinations ngg=nend*(1+2*(nend-1)) elseif(nend.eq.2 .or. nend.ge.15) then ! 2 or 15-25: three binary combinarions ngg=nend*(1+3*(nend-1)) elseif(nend.gt.10) then ! 11-14: three binary and one ternary combinarion ! ngg=nend*(1+(nend-1)*(3+nend-2)) ! (ternary combination skipped) ! ny=ngg ngg=nend*(1+3*(nend-1)) ! added yqrt ! je=nend*(nend-1)*(nend-2) ! write(*,*)'3Y endmemers, ngg and je: ',nend,ngg,je else ! 3-10: three binary and two ternary combinarions (all) ! and the added (quaternary) combinatin ! ngg=nend*(1+(nend-1)*(3+2*(nend-2))) ! (ternary combinations skipped) ! ny=ngg ngg=nend*(1+3*(nend-1)) ! added ygrt je=nend*(nend-1)*(nend-2) ! write(*,*)'3Y endmemers, ngg and je: ',nend,ngg,je endif ! write(*,*)'3Y endmembers and gridpoints: ',nend,ngg ! read(*,11)ch1 11 format(a) ! ngg=ngg+iliqneut ! ngg=ngg if(ocv()) write(*,*)'3Y Generate grid: ',nend,ngg ny=nend goto 1001 endif negmode !------------------------------------------------------------ ! for mode=0: ! set gridpoint sitefractions and calculate G ! for mode>0: ! return sitefractions (for mode=gridpoint number (part of the solution)) ! BUT: The only way to find the site fraction of a gripoint is to generate ! all gridpoints up the one specified by the value of mode (no G calculation) ! write(*,*)'3Y ggy: ',mode,iph,nsl,nend,inkl(nsl) ! if(mode.gt.0) then ! write(*,*)'3Y looking for allocate error: ',nsl,nend,inkl(nsl) ! endif ! write(*,*)'3Y allocating endmem: ',nsl,nend,inkl(nsl) allocate(endm(nsl,nend),stat=errall) allocate(yfra(inkl(nsl)),stat=errall) if(errall.ne.0) then write(*,*)'3Y allocation error 4: ',errall gx%bmperr=4370; goto 1001 endif nofy=inkl(nsl) ! generate endmembers, endm(ll,ie) is set to consituent index in sublattice ll je=1 do ll=1,nsl endm(ll,je)=inkl(ll-1)+1 enddo 100 continue je=je+1 if(je.gt.nend) goto 120 do ls=1,nsl endm(ls,je)=endm(ls,je-1) enddo ll=0 110 ll=ll+1 if(endm(ll,je).lt.inkl(ll)) then endm(ll,je)=endm(ll,je)+1 elseif(ll.lt.nsl) then endm(ll,je)=inkl(ll-1)+1 goto 110 else gx%bmperr=4148; goto 1000 endif goto 100 120 continue ! if(trace) then ! do i=1,nend ! write(33,125)i,(endm(ls,i),ls=1,nsl) !125 format('endmem: ',i4,2x,10i3) ! enddo ! endif 150 continue !--------------------------------------- ! jump here from generate_fccord_grid ... not any more ... 170 continue ! now generate all combinations of endmembers ! write(*,*)'3Y endmembers and gridpoints: ',nend,ngg ! read(*,11)ch1 ngg=0 lokph=phases(iph) endmem: do iend=1,nend yfra=yzero do ls=1,nsl yfra(endm(ls,iend))=ybas(1) enddo ! write(*,180)'3Y yfra: ',1,iend,nkl(1),endm(1,iend),yfra(endm(1,iend)) 180 format(a,4i3,6(1pe16.7)) isendmem=.TRUE. ! initiate the loop variables below for endmembers and fractions ibas=2 ibin=1 iter=1 jend=0 kend=0 200 continue ngg=ngg+1 if(mode.gt.0) then ! if ngg=mode we have found the gridpoint! store y and x and quit if(ngg.eq.mode) goto 500 else ! calculate G and composition and save ! write(*,201)ibas,ngg,(yfra(is),is=1,inkl(nsl)) 201 format('3Y ggz: ',i2,i4,5(F10.6)) if(ocv()) write(*,*)'3Y Calculating gridpoint: ',ngg if(ngg.gt.0 .and. mod(ngg,30000).eq.0) & write(*,*)'3Y Calculates gridpoint ',ngg,' for ',& trim(phlista(lokph)%name) call calc_gridpoint(iph,yfra,nrel,xarr(1,ngg),garr(ngg),ceq) if(gx%bmperr.ne.0) goto 1000 if(garr(ngg).gt.gmax) gmax=garr(ngg) ! if(ngg.eq.15) then ! write(*,520)'3Y cgx: ',(xarr(is,ngg),is=1,nrel) ! endif if(trace) then if(isendmem) then write(33,153,advance='no')sumngg+ngg 153 format('EM:',i4,' y: ') else write(33,154,advance='no')sumngg+ngg 154 format('GP:',i4,' y: ') endif jbas=0 do ls=1,nsl write(33,155,advance='no')(yfra(jbas+is),is=1,nkl(ls)-1) 155 format('(',10(F4.2,',')) write(33,156,advance='no')yfra(jbas+nkl(ls)) 156 format(F4.2,')') jbas=jbas+nkl(ls) enddo write(33,157,advance='no')(xarr(is,ngg),is=1,nrel) 157 format(' x:',8(f8.5)) write(33,158)garr(ngg) 158 format(' G:',1pe12.4) endif isendmem=.FALSE. endif ! depending on nend value or ideal generate combinations if(nend.eq.1 .or. nend.gt.50 .or. & btest(phlista(lokph)%status1,PHID)) cycle yfra=yzero combend: if(nend.gt.30) then ! if nend=31..50, one binary combination, 961-2500 ! 0.89*Y_E + 0.11*Y_F,F=/=E jend=jend+1 if(jend.eq.iend) jend=jend+1 if(jend.gt.nend) cycle do ls=1,nsl yfra(endm(ls,iend))=ybas(ibas) yfra(endm(ls,jend))=yfra(endm(ls,jend))+ybin(ibin) enddo ! write(*,180)'3Y yfra: ',ibas,iend,nkl(1),endm(1,jend),yfra(endm(1,jend)) goto 200 elseif(nend.gt.25) then ! nend=26..30 two binary combinations, 1326-1770 ! 0.89*Y_E + 0.11*Y_F,F=/=E ! 0.74*Y_E + 0.26*Y_F,F=/=E jend=jend+1 if(jend.eq.iend) jend=jend+1 if(jend.gt.nend) then if(ibas.eq.3) cycle jend=1 ibas=3; ibin=2 endif do ls=1,nsl yfra(endm(ls,iend))=ybas(ibas) yfra(endm(ls,jend))=yfra(endm(ls,jend))+ybin(ibin) enddo ! write(*,180)'3Y yfra: ',ibas,jend,nkl(1),endm(1,jend),yfra(endm(1,jend)) goto 200 elseif(nend.eq.2 .or. nend.ge.15) then ! nend=2 or nend=15..25, three binary combinations, ??-1825 ! 0.89*Y_E + 0.11*Y_F,F=/=E ! 0.74*Y_E + 0.25*Y_F,F=/=E ! 0.61*Y_E + 0.39*Y_F,F=/=E jend=jend+1 if(jend.eq.iend) jend=jend+1 if(jend.gt.nend) then if(ibas.eq.4) cycle ibas=ibas+1; ibin=ibin+1 jend=1 if(jend.eq.iend) jend=jend+1 endif do ls=1,nsl yfra(endm(ls,iend))=ybas(ibas) yfra(endm(ls,jend))=yfra(endm(ls,jend))+ybin(ibin) enddo ! write(*,180)'3Y yfra: ',ibas,jend,nkl(1),endm(1,jend),yfra(endm(1,jend)) goto 200 elseif(nend.gt.10) then ! complicated here, iterating in both binary and ternary combinations .... ! nend=11..14, 3 binary and one ternary combination, 1331-2744 ! 0.89*Y_E + 0.11*Y_F,F=/=E ! 0.74*Y_E + 0.26*Y_F,F=/=E ! + 0.15*Y_F + 0.11*Y_G,G=/=(E,F) ! 0.61*Y_E + 0.39*Y_F,F=/=E if(iter.eq.2) then ! we are interating in the ternary endmember stop 'no ternary for 100 return constitution for gridpoint number mode in yarr ! iph is returned as phase index for gripoint mode ! xarr(1..,nrel) the composition at the gripoint, garr not nused ! ny is number of constituent fractions ! yarr are the constituent fractions ! gmax not used ?? ! implicit none integer mode,iph,ngg,nrel,ny real xarr(nrel,*),garr(*) double precision yarr(*),gmax type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ ! local loop variables etc integer ii,ij,ik,il,im,in,is,ie,iz,incl(0:maxsubl),maxng,ng,ncon integer nend,nendj,nendk,nendl,nendm integer ijs,iks,ils,ims,lokph,errall,disng,ngdis ! these are for call of get_phase_data integer orddis1,orddis2,zz,nsl,nkl(maxsubl),knr(maxconst) double precision ydum(maxconst),sites(maxsubl),qq(5) ! this is for generating endmembers integer, dimension(:,:), allocatable :: endm ! these are for generating the constituion of gridpoint double precision, dimension(:,:), allocatable :: yendm double precision, dimension(:), allocatable :: yfra,ydis double precision aa integer :: warning1const=0 character phname*24,ch1*1 save warning1const ! ---------------------------------------------------------------- ! these are the factors to generate gridpoints from endmember fractions double precision, dimension(5), parameter :: & ! yf=[0.33D0,0.28D0,0.18D0,0.08D0,0.03D0] ! yf=[0.33D0,0.28D0,0.18D0,0.08D0,0.03D0] to test with map3 ! ok yf=[0.33D0,0.28D0,0.18D0,0.14D0,0.11D0] ! better but fails Fe-C at 1100 K and w(c)=0.03 ! yf=[0.11D0,0.33D0,0.14D0,0.28D0,0.18D0] ! include a small factor ! yf=[0.11D0,0.37D0,0.04D0,0.30D0,0.18D0] ! Try to avoid several identical compositions, sum should be unity?? yf=[0.07D0,0.28D0,0.16D0,0.45D0,0.04D0] ! used for 10 years ... ! yf=[0.04D0,0.07D0,0.16D0,0.27D0,0.46D0] ! HEA OK, not map7 ! yf=[0.07D0,0.46D0,0.16D0,0.04D0,0.27D0] ! yf=[0.28D0,0.07D0,0.45D0,0.16D0,0.04D0] ! yf=[0.33D0,0.28D0,0.18D0,0.14D0,0.11D0] OK for fuel ! yf=[0.11D0,0.13D0,0.18D0,0.23D0,0.35D0] ! these are used for a phase with order/disorder but no permutations double precision, dimension(5), parameter :: & yf2=[0.10D0,0.20D0,0.30D0,0.25D0,0.15D0] ! not good ... !------------------------------------------------------------------ ! verydense not implemented logical gas,dense,verydense,gles,trace,orddis3 ! bugfix by Clement Instroini 18.02.14 if(iph.lt.1 .or. iph.gt.noofph) then gx%bmperr=4050; goto 1000 else lokph=phases(iph) endif ! ngdis is normally 0, nonzero for phases with order/disorer transitions ngdis=0 ! disng counts the number of disordered constitutions disng=0 ! handle special phases like ionic crystals, ionic liquids and order/disorder ! write(*,*)'3Y in generic_grid_generator',iph,ngg gas=.FALSE. ! to have some output ! if(mode.gt.0 .and. ny.eq.-100) then ! if(mode.gt.0) then ! write(*,*)'3Y turn on trace',mode,iph,ngg,ny ! trace=.TRUE. ! else ! write(*,*)'3Y searching for y: ',mode,iph,ngg,ny ! endif if(test_phase_status_bit(iph,PHEXCB)) then ! crystalline phase with charged endmembers ! write(*,*)'3Y charged grid ngg: ',ngg call generate_charged_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq) goto 1000 elseif(test_phase_status_bit(iph,PHIONLIQ)) then ! This is the ionic liquid, requires a special grid, also used for dense call generate_ionliq_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq) goto 1000 elseif(test_phase_status_bit(iph,PHGAS)) then gas=.TRUE. elseif(test_phase_status_bit(iph,PHFORD) .or. & test_phase_status_bit(iph,PHBORD)) then ! write(*,*)'3Y calling ordered grid 2' call generate_fccord_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq) ! write(*,*)'3Y back from fccord_grid 2, jump to 1000',ngg ! goto 200 if(gx%bmperr.eq.-1) then ! if gx%bmperr is -1 means problems in fccord_grid, use default grindgenerator gx%bmperr=0 else goto 1000 endif elseif((btest(globaldata%status,GSXGRID) .or. & test_phase_status_bit(iph,PHXGRID)) .and. & .not.test_phase_status_bit(iph,PHGAS)) then ! Generate extra gridpoints for all phases or a special phase but never for gas ! call generate_dense_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq) dense=.TRUE. else dense=.FALSE. endif ! goto 1000 !---------------- ! get phase model call get_phase_data(iph,1,nsl,nkl,knr,ydum,sites,qq,ceq) if(gx%bmperr.ne.0) goto 1000 ! max number of gridpoints allowed, ngg returned as number of gridpoints... maxng=ngg ngg=0 ! incl(ii) set to number of constituents up to including sublattice ii incl(0)=0 nend=1 do ii=1,nsl nend=nend*nkl(ii) incl(ii)=incl(ii-1)+nkl(ii) enddo ncon=incl(nsl) ! nend is number of endmembers, endm(1..nsl,ii) are constituent index of ii ! yendm(1..nsl,ii) has the constituent fractions for endmember ii ! yfra is used to generate a constitutuon from a combination of endmembers ! write(*,*)'3Y allocating endmem 2',nsl,nend,ncon,nend allocate(endm(nsl,nend),stat=errall) allocate(yendm(ncon,nend),stat=errall) allocate(yfra(ncon)) if(errall.ne.0) then write(*,*)'3Y allocation error 5: ',errall gx%bmperr=4370; goto 1000 endif yendm=1.0D-12 ! set endm(1..nsl,1) to first constituent index for each sublattice do ij=1,nsl endm(ij,1)=incl(ij-1)+1 yendm(endm(ij,1),1)=one enddo ! loop to increment the constituents to generate all endmembers newend: do ii=2,nend ij=1 ! copy previous endmember do ij=1,nsl endm(ij,ii)=endm(ij,ii-1) enddo ! increment one constituent starting from first sublattice do ij=1,nsl if(endm(ij,ii).lt.incl(ij)) then endm(ij,ii)=endm(ij,ii)+1 do ik=1,nsl yendm(endm(ik,ii),ii)=one enddo cycle newend else endm(ij,ii)=endm(ij,1) endif enddo enddo newend ! output seems OK here ! write(*,20)'3Y gend1: ',iph,nsl,(nkl(ii),ii=1,nsl) 20 format(a,2i3,2x,10i3) ! write(*,20)'3Y gend2: ',ncon,nend,(incl(ii),ii=0,nsl) ! do ii=1,nsl ! write(*,21)(endm(ii,ij),ij=1,nend) !21 format(26i3) ! enddo ! do ii=1,nend ! write(*,22)ii,(yendm(ij,ii),ij=1,incl(nsl)) !22 format(i3,20F4.1) ! enddo ! jump here from generate_fccord_grid ... not any longer ... 200 continue ! now generate an grid depending on nend mixing up to 5 different endmembers. ! up to for 4 endmembers 4*4*4*4*4=1024 ! 5 to 7 endmembers 7*7*7*7 =2401 ! 7 to 13 endmembers 13*13*13=2197 ! max 50 endmembers 50*50 = 2500 ! for N>50 endmembers = N ! FOR DENSE about 10 times more ! up to 7 endmembers 7*7*7*7*7 = 16807 ! 8 to 12 endmembers 12*12*12*12 = 20736 ! 13 to 15 endmembers 15*15*15 =33750 ! max 150 endmembers 150*150 = 22500 ! for N>150 = N !-------------------------------------- ng=0 if(gas) then do ii=1,nend do is=1,ncon yfra(is)=yendm(is,ii) enddo ng=ng+1 if(mode.eq.0) then if(ng.gt.maxng) then write(*,*)'3Y Too many gridpoints 7',ng,maxng,iph gx%bmperr=4399; goto 1000 endif if(ng.gt.0 .and. mod(ng,30000).eq.0) then lokph=phases(iph) write(*,*)'3Y Calculates grid point ',ng,' for phase ',& trim(phlista(lokph)%name) endif call calc_gridpoint(iph,yfra,nrel,xarr(1,ng),garr(ng),ceq) if(gx%bmperr.ne.0) then write(*,*)'3Y error calculating gridpoint: ',& iph,gx%bmperr goto 1000 endif elseif(mode.eq.ng) then ! when mode>0 we just want to know the constituent fractions goto 900 endif enddo goto 800 endif ! skip attempt to inlcude disordered gridpoints orddis1=0; orddis2=0 ! goto 150 !================================================================== ! For phases that can have order/disorder transition maybe generate ! a few more gridpoints corresponing to the disordered state, for a ! case with Li-Mg the disordered BCC with equal Li and Mg fractions ! was not found and the ordered Li:Mg was not enough stable to be included ! in the grid. call get_phase_name(iph,1,phname) two: if(nsl.eq.2 .or. nsl.eq.3) then ! note: phases with 2 or 4 sublattice with permutations never come here ij=nkl(1) if(mode.eq.0) then ! write(*,88)trim(phname),nsl,(nkl(ii),ii=1,nsl) ! write(*,89)trim(phname),nsl,(sites(ii),ii=1,nsl) 88 format('3Y grid1: ',a,i3,9i3) 89 format('3Y grid2: ',a,i3,9F8.4) endif if(ij.gt.1 .and. nkl(2).eq.ij .and.& abs(sites(1)-sites(2)).lt.1.0D-12) then do ik=1,nkl(1) if(knr(ik).ne.knr(ik+ij)) exit two enddo else exit two endif ! A phase with 2 (plus 1) or 4 (plus 1) and same set of constituents ! on first two sublattices should have some additional gridpoints. ! representing the disordered state. Note phases with permutations ! calculated with a separate grid but that may be missing this also. orddis1=2 orddis2=nkl(1) call get_phase_name(iph,1,phname) ! if(mode.eq.0) then ! write(*,101)trim(phname),nkl(1),nkl(2),orddis1,orddis2,& ! sites(1),sites(2) 101 format('3Y orddis2 ',a,4i3,2F6.3) ! write(*,111)trim(phname),orddis2,nend,iph,orddis1,orddis2 !111 format(/'3Y *** Warning ',a,' may be stable as disordered ',5i3) ! For exampe: (A,B,C)(A,B,C)(D, E) ! 1 2 3 ! ordered endmembers: AAD ABD ACD BAD, BBD BCD CAD CBD CCD ...(only D=Va?) ! disordered endmem: AAD BBD CCD ! do ij=1,nend ! write(*,112)(endm(ii,ij),ii=1,nsl) !112 format('3Y endm: ',9i3) ! enddo ! endif allocate(ydis(ncon)) ydis=zero ! this is selected as the value of loop variable ii for disordering ! ngdis=ncon ! ngdis=1 ngdis=nkl(1) ! read(*,10)ch1 endif two ! continue four: if(nsl.eq.4 .or. nsl.eq.5) then ij=nkl(1) ! note: phases with 2 or 4 sublattice with permutations never come here ! write(*,*)'3Y order/disorder? ',nsl,nkl(1) if(ij.gt.1 .and. nkl(2).eq.ij .and. nkl(3).eq.ij .and. nkl(4).eq.ij) then if(mode.eq.0) then ! write(*,88)trim(phname),nsl,(nkl(ii),ii=1,nsl) ! write(*,89)trim(phname),nsl,(sites(ii),ii=1,nsl) endif aa=sites(1) if(abs(aa-sites(2)).lt.1.0D-12 & .and. abs(aa-sites(3)).lt.1.0D-12 & .and. abs(aa-sites(4)).lt.1.0D-12) then do ik=1,ij if(knr(ik).ne.knr(ik+ij) .or. & knr(ik).ne.knr(ik+2*ij) .or. & knr(ik).ne.knr(ik+3*ij)) exit four enddo endif orddis1=4 orddis2=nkl(1) ! write(*,102)trim(phname),nkl(1),nkl(2),sites(1),sites(2),sites(3),& ! sites(4) 102 format('3Y orddis4 ',a,4i3,4F6.3) ! if(mode.eq.0) write(*,111)trim(phname),orddis2,nend,orddis1,orddis2 endif allocate(ydis(ncon)) ydis=zero ! this is selected as the value of loop variable ii for disordering ! ngdis=ncon ! ngdis=1 ngdis=nkl(1) ! read(*,10)ch1 10 format(a) endif four !----------------------- 150 continue gles=.not.dense ! write(*,*)'3Y grid1: ',nend,mode,dense,gles iiloop: do ii=1,nend ijs=1 nendj=nend if(nend.gt.150 .or. (gles .and. nend.gt.50)) then nendj=ii ijs=ii endif ! write(*,*)'3Y ii:',ii,ijs,nendj ijloop: do ij=ijs,nendj iks=1 nendk=nend if(nend.gt.15 .or. (gles .and. nend.gt.13)) then nendk=ij iks=ij endif ikloop: do ik=iks,nendk ils=1 nendl=nend if(nend.gt.12 .or. (gles .and. nend.gt.7)) then nendl=ik ils=ik endif illoop: do il=ils,nendl ims=1 nendm=nend if(nend.gt.7 .or. (gles .and. nend.gt.4)) then ! with 4 endmembers 1024 gridpoints nendm=il ims=il endif imloop: do im=ims,nendm ! sum up the weighted fractions from the different endmembers do is=1,ncon yfra(is)=yf(1)*yendm(is,ii)+yf(2)*yendm(is,ij)+& yf(3)*yendm(is,ik)+yf(4)*yendm(is,il)+& yf(5)*yendm(is,im) enddo orddis3=.TRUE. ! if orddis1 is nonzero below return here to calculate for disordered state 300 continue ng=ng+1 ! write(*,310)'3Y Y1:',ng,ii,ij,ik,il,im,yfra if(mode.eq.0) then ! strange bug in map3, maxng was zero sometimes ... if(ng.gt.maxng) then if(maxng.lt.100) then if(warning1const.ne.iph) then write(*,*)'3Y max gripoints wrong 6: ',& maxng,iph,mode warning1const=iph endif else write(*,*)'3Y Too many gridpoints 6',ng,maxng,iph gx%bmperr=4399; goto 1000 endif endif if(ng.gt.0 .and. mod(ng,30000).eq.0) & write(*,*)'3Y Calculate gridpoint ',ng,' for ',& trim(phlista(lokph)%name) ! for debugging grid minimizer with MQMQA ! write(*,*)'3Y Calculate grid point ',ng,' for phase ',& ! trim(phlista(lokph)%name) call calc_gridpoint(iph,yfra,nrel,xarr(1,ng),garr(ng),ceq) ! generate a GNUPLOT graph for dense grid ! write(*,*)'3Y back from calc_gridpoint',ng,garr(ng) if(lutbug.gt.0) then ! write(*,710)ng,nrel,garr(ng),(xarr(iz,ng),iz=1,nrel) write(lutbug,710)ng,nrel,garr(ng),& (xarr(iz,ng),iz=1,nrel) 710 format(i5,i3,1pe10.2,10(0pF6.3)) endif if(gx%bmperr.ne.0) then write(*,*)'3Y error calculating gridpoint: ',& iph,gx%bmperr goto 1000 endif ! write(*,*)'3Y orddis:',ng,orddis1,orddis3,ngdis ! The code below is to add some disordered constititutions to order/disorder ! I tried several values of ii and this worked best. I do not know why if(ii.le.ngdis .and. orddis1.gt.0 .and. orddis3) then ! generate an additional gridpoint as disordered ! But only for the first loop of ii=1, otherwise too many gridpoints ! write(*,310)'3Y YO:',ng,ii,ij,ik,il,im,yfra ! orddis1 is 2 or 4; orddis2 is number of constituent in these sublattices ! use fractions in yf2 !!! do is=1,ncon yfra(is)=yf2(1)*yendm(is,ii)+yf2(2)*yendm(is,ij)+& yf2(3)*yendm(is,ik)+yf2(4)*yendm(is,il)+& yf2(5)*yendm(is,im) enddo if(orddis1.eq.2) then disloop2: do zz=1,orddis2 ydis(zz)=0.5D0*(yfra(zz)+yfra(zz+orddis2)) enddo disloop2 ! write(*,310)'3Y YS1:',ng,ii,ij,ik,il,im,ydis ! same fractions in both sublattice, disordered do zz=1,orddis2 yfra(zz)=ydis(zz) yfra(zz+orddis2)=ydis(zz) enddo ! fractions in 3rd sublattice not affected ! write(*,310)'3Y YS1:',ng,ii,ij,ik,il,im,yfra else disloop4: do zz=1,orddis2 ydis(zz)=0.25D0*(yfra(zz)+yfra(zz+orddis2)+& yfra(zz+2*orddis2)+yfra(zz+3*orddis2)) enddo disloop4 ! same fractions in both sublattice, disordered do zz=1,orddis2 yfra(zz)=ydis(zz) yfra(zz+orddis2)=ydis(zz) yfra(zz+2*orddis2)=ydis(zz) yfra(zz+3*orddis2)=ydis(zz) enddo endif ! this should be made only once for each set of fractions disng=disng+1 orddis3=.FALSE. ! write(*,310)'3Y YD:',ng,disng,ii,ij,ik,il,im,yfra 310 format(a,i4,i3,1x,5i2,11F5.2) ! jump back to calculate this!! goto 300 endif ! write(*,323)'3Y imloop2: ',ng,ii,ij,ik,il,im,garr(ng),yfra elseif(mode.eq.ng) then ! when mode>0 we just want to know the constituent fractions ! write(*,*)'3Y found fractions for gridpoint',ng goto 900 elseif(ii.le.ngdis .and. orddis1.gt.0 .and. orddis3) then if(mode.eq.ng+1) then ! the gridpoint found is a disordered one, we have to disorder yfra as above if(orddis1.eq.2) then disloop2b: do zz=1,orddis2 ydis(zz)=0.5D0*(yfra(zz)+yfra(zz+orddis2)) enddo disloop2b do zz=1,orddis2 yfra(zz)=ydis(zz) yfra(zz+orddis2)=ydis(zz) enddo ! fractions in 3rd sublattice not affected else disloop4b: do zz=1,orddis2 ydis(zz)=0.25D0*(yfra(zz)+yfra(zz+orddis2)+& yfra(zz+2*orddis2)+yfra(zz+3*orddis2)) enddo disloop4b ! same fractions in both sublattice, disordered do zz=1,orddis2 yfra(zz)=ydis(zz) yfra(zz+orddis2)=ydis(zz) yfra(zz+2*orddis2)=ydis(zz) yfra(zz+3*orddis2)=ydis(zz) enddo endif ! we have regenerated the disordered fractions for this gridpoint write(*,*)'3Y found disordered state for gridpoint',ng ! write(*,310)'3Y YD:',ng,disng,ii,ij,ik,il,im,yfra goto 900 else ! we have to increment ng as we skip a gridpoint with a disordered fraction ng=ng+1 endif !------------------------ endif enddo imloop enddo illoop enddo ikloop enddo ijloop enddo iiloop ! extra output for order/disordered phases if(orddis1.ne.0 .and. gx%bmperr.eq.0 .and. mode.eq.0) then call get_phase_name(iph,1,phname) write(*,790)trim(phname),disng 790 format('3Y For ',a,i5,' additional disordered gridpoints calculated') endif ! jump here for gas 800 continue if(mode.gt.0) then write(*,*)'3Y Could not find gridpoint ',mode,' in phase ',iph,ng gx%bmperr=4399 else ngg=ng endif goto 1000 !-------------------------------------------- ! we found the gridpoint we were looking for 900 continue ny=ncon do ii=1,ny yarr(ii)=yfra(ii) enddo 1000 continue ! write(*,*)'3Y finished generic mode ',mode,iph,ngg return end subroutine generic_grid_generator !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine generate_dense_grid !\begin{verbatim} %- subroutine generate_dense_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq) ! generates more gridpoints than default generate_grid ! Different action depending of the value of mode, ! for mode<0: ! return the number of gridpoints that will be generated for phase iph in ngg ! for mode=0: ! return garr(i) gibbs energy and xarr(1,i) the compositions of gridpoint i ! for mode>0: ! return site fractions of gridpoint mode in yarr, number of fractions in ny ! iph is phase number, ngg is number of gridpoints, nrel number of elements, ! if mode=0: ! return xarr mole fractions of gridpoints, garr Gibbs energy of gridpoints, ! ngg is dimension of garr ! if mode>0: ! "mode" is a gridpoint of this phase in solution, return number of ! constituent fractions in ny and fractions in yarr for this gridpoint ! The current constitution is restored at the end of the subroutine implicit none TYPE(gtp_equilibrium_data), pointer :: ceq integer mode,iph,ngg,nrel,ny real xarr(nrel,*),garr(*) double precision yarr(*),gmax !\end{verbatim} %+ ! integer lokph,errsave double precision, parameter :: yzero=1.0D-12 integer abrakadabra,i,ibas,ibin,iend,is,iter,je,jend,kend,ll,ls,nend double precision ydum(maxconst) integer ngdim,nsl integer nkl(maxsubl),knr(maxconst),inkl(0:maxsubl),nofy double precision, dimension(:), allocatable :: yfra double precision sites(maxsubl),qq(5) real, allocatable :: xbrr(:) ! endm(i,j) has constituent indices in i=1..nsl for endmember j integer, dimension(:,:), allocatable :: endm !-------------------------------- ! grid is generated by combining end endmembers ! Number of endmemers is N ! For endmember E=1..N set fraction of enmember ! 0.99*Y_E + 0.01*Y_all N*N of these ! 0.95*Y_E + 0.03*Y_F + 0.01*Y_all, F.ne.E N*N*(N-1) ! 0.91*Y_E + 0.07*Y_F + 0.02*Y_all, F.ne.E N*N*(N-1) ! 0.80*Y_E + 0.15*Y_F + 0.05*Y_all, F.ne.E N*N*(N-1) ! 0.68*Y_E + 0.25*Y_F + 0.07*Y_all, F.ne.E N*N*(N-1) ! or 0.68*Y_E + 0.16*Y_F + 0.16*Y_all, F.ne.E N*N*(N-1) ! 0.54*Y_E + 0.36*Y_F + 0.10*Y_all, F.ne.E N*N*(N-1) ! 0.42*Y_E + 0.35*Y_F + 0.23*Y_G, F.ne.E.ne.G N*(N-1)*(N-2) ! or 0.42*Y_E + 0.40*Y_F + 0.18*Y_G, F.ne.E.ne.G N*(N-1)*(N-2) ! or 0.48*Y_E + 0.40*Y_F + 0.12*Y_G, F.ne.E.ne.G N*(N-1)*(N-2) ! with 2 endmembers: 24 gridpoints ! (1.00,0.00) (0.99,0.01) (0.01,0.99) (0.00,1.00) ! (0.96,0.04) (0.04,0.96) *2 ! (0.93,0.07) (0.91,0.09) *2 ! (0.85,0.15) (0.80,0.20) *2 ! (0.75,0.25) (0.68,0.32) *2 ! (0.64,0.36) (0.57,0.43) *2 ! with 3 endmembers: 9+5*9*2+6=15+90=105 ! (1.00,0,0) (0.99,0.01,0) (0.99,0,0.01) *3 ! (0.97,0.03,0) (0.96,0.04,0) (0.96,0.03,0.01) *3 <50 ! (0.92,0.08,0) (0.90,0.10,0) (0.90,0.08,0.02) <25 ! (0.75,0.25,0) (0.68,0.32.0) (0.68,0.25,0.07) <20 ! (0.85,0.15,0) (0.80,0.20,0) (0.80,0,15,0.05) <15 ! (0.64,0.36,0) (0.54,0.46,0) (0.54,0.36,0.10) <11 ! (0.42,0.35,0.23) (0.42,0.23,0.35) (0.35,0.42,0.23) ... 6 !---------- ! M= N*N + 5*N*N*(N-1) + N*(N-1)*(N-2) ! N=10 100 + 5*100*9 + 10*9*8 = 4600+720 = 5320 ! N=20 400 + 400*19 + 0 >8000 ! ... integer, parameter :: breaks6=50 integer, parameter, dimension(5) :: breaks=[9,12,15,18,21] ! integer, parameter, dimension(5) :: breaks=[9,12,15,18,55] double precision, dimension(-1:6), parameter:: ybas=& [1.00D0,0.99D0,0.96D0,0.91D0,0.68D0,0.80D0,0.54D0,0.44D0] double precision, dimension(6), parameter :: ybin=& [0.03D0,0.07D0,0.16D0,0.15D0,0.36D0,0.44D0] ! [0.03D0,0.07D0,0.25D0,0.15D0,0.36D0,0.35D0] double precision, dimension(6), parameter :: yter=& [0.01D0,0.02D0,0.16D0,0.05D0,0.10D0,0.12D0] ! [0.01D0,0.02D0,0.07D0,0.05D0,0.10D0,0.23D0] ! for output of gridpoints integer jbas,sumngg,loksp,l0,l1,ncon,jj,anion,isp,errall logical trace,isendmem double precision ysum save sumngg character ch1*1 ! ! write(*,17)mode,iph,ngg 17 format('3Y entering generate_dense_grid: ',i2,i3,i10) if(mode.eq.0) then ! write(*,*)'3Y Generating grid for phase: ',iph ! trace TRUE means generate outpt for each gridpoint ! trace=.TRUE. trace=.FALSE. if(iph.eq.1 .and. trace) then ! unit 33 is opened before calling this routine sumngg=0 write(33,43) 43 format('The constituent fractions, y, enclosed within parentheses',& 'for each sublattice'/'Mole fractions after x:, Gibbs energies',& ' after G:'/) endif if(trace) then call get_phase_record(iph,nend) ! write(33,44)iph,phlista(nend)%name 44 format('Endmembers (EM) and gridpoints (GP) for phase: ',i3,1x,a) endif else trace=.FALSE. endif ! write(*,*)'3Y Getting phase data',mode call get_phase_data(iph,1,nsl,nkl,knr,ydum,sites,qq,ceq) if(gx%bmperr.ne.0) goto 1000 ! calculate the number of endmembers and index of first constituent in subl ll nend=1 inkl(0)=0 lokph=phases(iph) do ll=1,nsl if(btest(phlista(lokph)%status1,PHIONLIQ) .and. ll.eq.2) then ! multiply with charged anions and Va only, add neutrals do jj=1,nkl(2) ! knr(i) is species(i) location but I use constitlist as I have access to it isp=phlista(lokph)%constitlist(nkl(1)+jj) if(btest(splista(isp)%status,SPION) .or. & btest(splista(isp)%status,SPVA)) then anion=anion+1 cycle endif enddo nend=nend*anion+phlista(lokph)%nooffr(2)-anion else ! this is the "normal" number of endmembers nend=nend*nkl(ll) endif inkl(ll)=inkl(ll-1)+nkl(ll) enddo ! if(btest(phlista(lokph)%status1,PHIONLIQ)) then ! write(*,*)'3Y ionic liq: ',anion,nend ! endif ny=inkl(nsl) ncon=inkl(nsl) negmode: if(mode.lt.0) then !--------------------------------------------------------- ! just determine the number of gridpoints for this phase for global minimimum ! ideal gases should just have the endmembers .... ! Hm, gases with ions?? ngdim=ngg ngg=nend lokph=phases(iph) ! write(*,*)'3Y nend 1: ',mode,ngg if(nend.eq.1 .or. nend.gt.100 .or. & btest(phlista(lokph)%status1,PHID)) then ! >100 or 1 endmember or ideal phase: only endmembers ngg=nend else ngg=nend ! The limits for various combinations will be adjusted when testing ... ! Max about 20000 gridpoints per phase ! if(nend.ge.50) then ! if(nend.ge.100) then ngg=ngg+nend*(nend-1) ! write(*,*)'3Y dense -1A: ',iph,nend,ngg,breaks(5) ! ATTENTION ! The calculation below is not correct, it overestimates a bit the number of ! gridpoints actually generated but it should not matter so much ... I hope ! When matching a gridpoint in the solution the code to generate the ! gridpoint is used, the code below is just an estimate for allocation ! if(nend.le.50) then ! Try 60 to handle 53 endmembers in liquid noc2500.TDB from TAF-ID ! if(nend.le.60) then if(nend.le.breaks6) then if(nend.gt.breaks(5)) then ngg=ngg+nend*(nend-1)+nend*nend*(nend-1) ! write(*,*)'3Y dense -1B: ',iph,nend,ngg,breaks(4) elseif(nend.gt.breaks(5)) then ngg=ngg+nend*(nend-1)+2*nend*nend*(nend-1) elseif(nend.gt.breaks(4)) then ngg=ngg+nend*(nend-1)+3*nend*nend*(nend-1) elseif(nend.gt.breaks(3)) then ngg=ngg+nend*(nend-1)+4*nend*nend*(nend-1) elseif(nend.gt.breaks(2)) then ngg=ngg+nend*(nend-1)+5*nend*nend*(nend-1) ! elseif(nend.gt.breaks(1)) then else ngg=ngg+nend*(nend-1)+6*nend*nend*(nend-1) endif endif ! write(*,*)'3Y dense -1X: ',iph,nend,ngg endif ! write(*,*)'3Y endmembers and gridpoints: ',nend,ngg ! read(*,11)ch1 11 format(a) ny=nend goto 1001 endif negmode !------------------------------------------------------------ ! for mode=0: ! set gridpoint sitefractions and calculate G ! for mode>0: ! return sitefractions (for mode=gridpoint number (part of the solution)) ! BUT: The only way to find the site fraction of a gripoint is to generate ! all gridpoints up the one specified by the value of mode (no G calculation) ! write(*,*)'3Y ggy: ',mode,iph,nsl,nend,inkl(nsl) ! ! write(*,*)'3Y allocating yfra mm',inkl(nsl),nsl,nend allocate(yfra(inkl(nsl)),stat=errall) ! endm(i,j) has constituent indices in i=1..nsl for endmember j ! endm(1,1) is constituent in sublattice 1 of first endmember ! endm(2,1) is constituent in sublattice 2 of first endmember ! endm(nsl,2) is constituent in sublattice nsl of second endmember ! endm(1..nsl,nend) are constituents in all sublattices of last endmember allocate(endm(nsl,nend),stat=errall) ! inkl(nsl) is the number of fraction variables in the phase ! allocate(yfra(inkl(nsl))) allocate(xbrr(noofel),stat=errall) if(errall.ne.0) then write(*,*)'3Y allocation error 6: ',errall gx%bmperr=4370; goto 1000 endif ! nofy=inkl(nsl) ! generate endmembers, endm(ll,ie) is set to consituent index in sublattice ll je=1 do ll=1,nsl endm(ll,je)=inkl(ll-1)+1 enddo 100 continue je=je+1 ! if je>nend we are finished ... if(je.gt.nend) goto 120 do ls=1,nsl endm(ls,je)=endm(ls,je-1) enddo ll=0 110 ll=ll+1 if(endm(ll,je).lt.inkl(ll)) then endm(ll,je)=endm(ll,je)+1 elseif(ll.lt.nsl) then endm(ll,je)=inkl(ll-1)+1 goto 110 else gx%bmperr=4148; goto 1000 endif goto 100 !--------------------------------------- ! We have now generated endm(1..nsl,j) 120 continue ! write(*,202)'3Y special 1: ',nsl,nend,inkl(nsl),endm(1,2),endm(2,2),& ! endm(1,nend),endm(1,3),endm(2,3),endm(1,4),endm(2,4) ! now generate all unary, binary and ternary combinations of endmember fractions ! Note the sum of constituent fractions in all sublattices must be unity ! By combining endmember fractions weighted according to ybas, ybin and yter ! we can ensure that ngg=0 l0=0 l1=0 lokph=phases(iph) endmem1: do iend=1,nend ! we start with a new endmember iend, ybas(1) is 1.00 l0=ngg yfra=yzero do ls=1,nsl yfra(endm(ls,iend))=ybas(-1) enddo ngg=ngg+1 if(mode.eq.0) then ! this is for a single endmember ! write(*,201)'3Y end: ',ngg,(yfra(is),is=1,inkl(nsl)) if(ngg.gt.0 .and. mod(ngg,30000).eq.0) & write(*,*)'3Y Gridmin calculated ',ngg,' gridpoints 4',& trim(phlista(lokph)%name) call calc_gridpoint(iph,yfra,nrel,xarr(1,ngg),garr(ngg),ceq) if(gx%bmperr.ne.0) goto 1000 if(garr(ngg).gt.gmax) gmax=garr(ngg) 201 format(a,i5,20(F5.2)) elseif(ngg.eq.mode) then goto 500 endif ! binary combinations 0.99*y1 + 0.01*y2 endmem2a: do jend=1,nend if(jend.eq.iend) cycle endmem2a yfra=zero ! write(*,202)'3Y special 3: ',endm(1,2) do ls=1,nsl ! to generate better start values for fcc-protototype ordering ! write(*,202)'3Y ls iend endm: ',ls,iend,jend,endm(ls,iend) 202 format(a,10i6) yfra(endm(ls,iend))=ybas(0) yfra(endm(ls,jend))=yfra(endm(ls,jend))+yter(1) enddo ngg=ngg+1 if(mode.eq.0) then ! this is for 0.99*y1 + 0.01*y2 ! STRANGE error that destroyed endm after the call to calc_gridpoint!! ! the error was due to wrong size allocated to xarr which is strange as it ! is done elsewhere but the error disapperared when I allocated a larger ! xarr although the allocated one did not seem too small. if(ngg.gt.0 .and. mod(ngg,30000).eq.0) & write(*,*)'3Y Calculate grid point ',ngg,' for ',& trim(phlista(lokph)%name) call calc_gridpoint(iph,yfra,nrel,xarr(1,ngg),garr(ngg),ceq) if(gx%bmperr.ne.0) goto 1000 if(garr(ngg).gt.gmax) gmax=garr(ngg) ! write(*,201)'3Y bin: ',ngg,(yfra(is),is=1,inkl(nsl)) elseif(ngg.eq.mode) then goto 500 endif enddo endmem2a ! ternary combinations ! ibas -1 0 1 2 3 4 5 6 ! ybas 1.00D0,0.99D0,0.96D0,0.91D0,0.68D0,0.80D0,0.54D0,0.42D0 ! ybin 0.03D0,0.07D0,0.25D0,0.15D0,0.36D0,0.35D0 ! yter 0.01D0,0.02D0,0.07D0,0.05D0,0.10D0,0.23D0 ! if(nend.gt.50) cycle endmem1 ! if(nend.gt.60) cycle endmem1 if(nend.gt.breaks6) cycle endmem1 ibasloop: do ibas=1,6 if(nend.ge.breaks(5) .and. ibas.eq.2) cycle endmem1 if(nend.ge.breaks(4) .and. ibas.eq.3) cycle endmem1 if(nend.ge.breaks(3) .and. ibas.eq.4) cycle endmem1 if(nend.ge.breaks(2) .and. ibas.eq.5) cycle endmem1 if(nend.ge.breaks(1) .and. ibas.eq.6) cycle endmem1 endmem2b: do jend=1,nend if(jend.eq.iend) cycle endmem2b endmem3: do kend=1,nend yfra=zero do ls=1,nsl yfra(endm(ls,iend))=ybas(ibas) yfra(endm(ls,jend))=yfra(endm(ls,jend))+ybin(ibas) yfra(endm(ls,kend))=yfra(endm(ls,kend))+yter(ibas) enddo ysum=zero do ls=1,inkl(nsl) ysum=ysum+yfra(ls) enddo ngg=ngg+1 if(mode.eq.0) then ! this is for 0.96*y1 + 0.03*y2+0.01*y3 if(ngg.gt.0 .and. mod(ngg,30000).eq.0) & write(*,*)'3Y to calculate grid point ',ngg,' for ',& trim(phlista(lokph)%name) call calc_gridpoint(iph,yfra,nrel,xarr(1,ngg),garr(ngg),ceq) if(gx%bmperr.ne.0) goto 1000 if(garr(ngg).gt.gmax) gmax=garr(ngg) ! write(*,201)'3Y ter: ',ngg,(yfra(is),is=1,inkl(nsl)),ysum elseif(ngg.eq.mode) then goto 500 endif enddo endmem3 enddo endmem2b l1=ngg enddo ibasloop enddo endmem1 ! write(*,*)'3Y Calculated points: ',ngg goto 1000 !---------------------------------------- ! here we return the constitution for gridpoint "mode" in the solution ! We must also return the mole fractions ... NO?? 500 continue ! write(*,505)'3Y ggg: ',mode,iph,nsl,inkl(nsl),ny 505 format(a,i7,i4,2x,i2,i5,i10) ! write(*,510)'3Y ggy: ',mode,ngdim,ny,(yfra(i),i=1,ny) 510 format(a,2i5,i3,10(F6.3)) do i=1,ny yarr(i)=yfra(i) enddo ! write(*,520)'3Y ggx: ',(xarr(is,ngg+ngdim),is=1,nrel) 520 format(a,10(f8.5)) 1000 continue ! these will be deallocated by default when exit this subroutine ... if(allocated(endm)) then deallocate(endm) deallocate(yfra) endif 1001 continue ! restore original constituent fractions ! call get_phase_data(iph,1,nsl,nkl,knr,ydum,sites,qq,ceq) errsave=gx%bmperr gx%bmperr=0 ! write(*,1010)'3Y Restore ',iph,(ydum(i),i=1,ny) 1010 format(a,'const for ',i3,10(f6.3)) call set_constitution(iph,1,ydum,qq,ceq) if(gx%bmperr.ne.0) then write(*,*)'3Y Error restoring constitution for phase: ',iph,gx%bmperr endif gx%bmperr=errsave if(gx%bmperr.ne.0) write(*,*)'3Y gengrid error: ',gx%bmperr return end subroutine generate_dense_grid !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine generate_ionliq_grid !\begin{verbatim} %- subroutine generate_ionliq_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq) ! generates gridpoints for ionic liquid (also dense) ! Different action depending of the value of mode, ! for mode<0: ! return the number of gridpoints that will be generated for phase iph in ngg ! for mode=0: ! return garr(i) gibbs energy and xarr(1,i) the compositions of gridpoint i ! for mode>0: ! return site fractions of gridpoint mode in yarr, number of fractions in ny ! iph is phase number, ngg is number of gridpoints, nrel number of elements, ! if mode=0: ! return xarr mole fractions of gridpoints, garr Gibbs energy of gridpoints, ! ngg is dimension of garr ! if mode>0: ! "mode" is a gridpoint of this phase in solution, return number of ! constituent fractions in ny and fractions in yarr for this gridpoint ! The current constitution is restored at the end of the subroutine implicit none TYPE(gtp_equilibrium_data), pointer :: ceq integer mode,iph,ngg,nrel,ny real xarr(nrel,*),garr(*) double precision yarr(*),gmax !\end{verbatim} %+ ! integer lokph,errsave double precision, parameter :: yzero=1.0D-12 integer je,iend,jend,kend,lend,ll,nend double precision ydum(maxconst) integer ngdim,nsl integer nkl(2),knr(maxconst),inkl(0:2) double precision, dimension(:), allocatable :: yfra double precision, dimension(:,:), allocatable :: yendm double precision sites(2),qq(5) ! endm(i,j) has constituent indices in i=1..nsl for endmember j integer, dimension(:,:), allocatable :: endm ! try to have denser cation grid when Va as cation integer anionva,constva,hasva integer, allocatable, dimension(:) :: endwithva !-------------------------------- ! grid is generated by combining end endmembers ! Number of endmemers is N ! First level generate for 4 endmembers including same N**4 pemutations ! 4 1+4 1+3 1+3+4 1+2 1+2+4 1+2+3 1+2+3+4 ! 0.52 0.54 0.63 0.65 0.87 0.81 0.98 1.00 ! 0.35 0.34 0.34 0.34 0.19 0.19 0.02 - ! 0.11 0.19 0.02 - 0.02 - - - ! 0.02 - - - - - - - ! for 2: 1.00 0.98 0.87 0.81 0.65 0.63 0.54 0.52 ... =16 ! for 3: 1.00 0.98/2 0.98/3 ... =81 ! for N=4..7: N*N*N*N =256-2401 ! 1 when 8..15: skip 0.02 except first and last (not dense) ! 2 when 16-25: 0.02 and 0.11 same except first and last (not dense) N*N*N+.. ! 3 when 26-60: 0.02, 0.11 and 0.35 same except first and last N*N+.. ! 4 >60 only endmembers !---------- ! IDE: ! 1) binary liquid of all endmembers N*N (53*53=2809) (incl pure endmembers) ! 2) ternary liquid of all cations with sanme anion or Va (4*11*10*9=2880) ! 3) neutrals? integer, parameter, dimension(4) :: breaks=[8,15,25,60] double precision, dimension(1:4), parameter:: yf=& [0.52D0,0.35D0,0.11D0,0.02D0] ! These are fractions of mixed cations for same anion, not all variants ! Used only when there are many endmembers >15 double precision, dimension(1:3), parameter:: yfc=& [0.42D0,0.33D0,0.25D0] ! Used when mixing cations with same anion double precision, dimension(1:3), parameter:: yfx=& [0.42D0,0.14D0,0.08D0] ! for output of gridpoints integer l1,ncon,jj,cation,anion,isp,iva,catloop,neutral1,errall integer looplim1,looplim2 logical trace,dense character ch1*1,dummy*128 ! if(mode.eq.0) then trace=.FALSE. ! trace=.TRUE. ! write(*,*)'3Y Calculating the number of gridpoints for ionic liquid' ! trace TRUE means generate outpt for each gridpoint if(trace) then ! unit 33 is opened before calling this routine write(33,43) 43 format('The constituent fractions, y, enclosed within parentheses',& 'for each sublattice'/'Mole fractions after x:, Gibbs energies',& ' after G:'/) endif if(trace) then call get_phase_record(iph,lokph) ! write(33,44)iph,phlista(lokph)%name 44 format('Endmembers (EM) and gridpoints (GP) for phase: ',i3,1x,a) endif else trace=.FALSE. endif if(btest(globaldata%status,GSXGRID) .or. & test_phase_status_bit(iph,PHXGRID)) then ! write(*,*)'Dense grid set' dense=.TRUE. else dense=.FALSE. endif ! write(*,*)'3Y Getting phase data',mode call get_phase_data(iph,1,nsl,nkl,knr,ydum,sites,qq,ceq) if(gx%bmperr.ne.0) goto 1000 ! calculate the number of endmembers and index of first constituent in subl ll nend=1 inkl(0)=0 inkl(1)=nkl(1) cation=nkl(1) ! Why is inkl(2) set like this? I have changed ncon below inkl(2)=nkl(1)+nkl(2) lokph=phases(iph) if(.not.btest(phlista(lokph)%status1,PHIONLIQ)) then write(*,*)'3Y internal error, this phase has not ionic liquid model!' gx%bmperr=4399; goto 1000 endif ! multiply with charged anions and Va only, add neutrals, nsl=2 anion=0 anionva=0 do jj=1,nkl(2) ! knr(i) is species(i) location but I use constitlist as I have access to it isp=phlista(lokph)%constitlist(nkl(1)+jj) if(btest(splista(isp)%status,SPVA)) anionva=jj if(btest(splista(isp)%status,SPION) .or. & btest(splista(isp)%status,SPVA)) then anion=anion+1 cycle endif enddo ! If no Va in anion sublattice anionva=0 if(anionva.gt.0) then ! if anaionva>0 allocate array for endmembers with Va allocate(endwithva(nkl(1))) ! save constituent index for Va constva=nkl(1)+anionva hasva=1 ! write(*,*)'3Y anionva: ',mode,anionva,nkl(1),constva endif ! error when compiling with -O2 ! nend=inkl(1)*anion+phlista(lokph)%nooffr(2)-anion nend=nkl(1)*anion+nkl(2)-anion ny=inkl(nsl) ! ncon=inkl(nsl) ! BoS corrected 2019/04/13: (U+4,Zr+4)(O-2,Va,O) has 5 constituents not 6 ncon=inkl(1)+nkl(2) ! write(*,45)'3Y liquid endmembers: ',mode,nkl(1),nkl(2),anion,nend 45 format(a,5i5) negmode: if(mode.lt.0) then !--------------------------------------------------------- ! this is never executed as mode<0 no longer used ! just estimate the number of gridpoints for the ionic liquid phase ! pairs of cation+anion, cation+Va, neutrals ngdim=ngg ngg=nend lokph=phases(iph) write(*,*)'3Y nend 1: ',mode,ngg,breaks if(nend.eq.1 .or. nend.gt.breaks(4)) then ! ! NOTE mode<0 is NO LONGER USED, this code not used <<<<<<<<<<<60 endmembers: only endmembers ! if more dense cation grid do not divide cation loop by 2 ngg=nend+(cation-2)*cation*(cation+1)*anion/2 elseif(.not.dense .and. nend.gt.breaks(3)) then ! 26..60: between 676-3600 ! if more dense cation grid do not divide cation loop by 2 ngg=nend*nend+(cation-2)*cation*(cation+1)*anion/2 ! write(*,*)'3Y catloop 17: ',ngg,nend,cation,anion,& ! (cation-2)*cation*(cation+1)*anion/2 elseif(.not.dense .and. nend.gt.breaks(2)) then ! 16..25: ?? ngg=nend*nend*2+(cation-2)*cation*(cation+1)*anion/2 ! write(*,*)'3Y catoop 18: ',ngg,nend,cation,anion elseif(nend.gt.breaks(1)) then ! 8..15: ?? ngg=nend*nend*nend else ! 2..7, all combinations ngg=nend*nend*nend*nend endif ! read(*,11)ch1 11 format(a) ny=nend goto 1001 endif negmode ! the negmode if statement above no longer used ^^^^^^^^^^^^^^^^^^^^ !------------------------------------------------------------ ! for mode=0: ! set gridpoint sitefractions and calculate G ! for mode>0: ! return sitefractions (for mode=gridpoint number (part of the solution)) ! BUT: The only way to find the site fraction of a gripoint is to generate ! all gridpoints up the one specified by the value of mode (no G calculation) ! write(*,*)'3Y ggy: ',mode,iph,nsl,nend,inkl(nsl) ! ! endm(i,j) has constituent indices in i=1..nsl for endmember j ! endm(1,1) is constituent in sublattice 1 of first endmember ! endm(2,1) is constituent in sublattice 2 of first endmember ! endm(nsl,2) is constituent in sublattice nsl of second endmember ! endm(1..nsl,nend) are constituents in all sublattices of last endmember ! if(mode.gt.0) write(*,*)'3Y allocate endm: ',nsl,nend ! write(*,*)'3Y allocating endmembers 5:',nsl,nend,inkl(nsl) allocate(endm(nsl,nend),stat=errall) if(errall.ne.0) then write(*,*)'3Y allocation error 7: ',errall gx%bmperr=4370; goto 1000 endif ! inkl(nsl) is the number of fraction variables in the phase ! allocate(yfra(inkl(nsl))) ! nofy=inkl(nsl) ! generate endmembers, endm(ll,ie) is set to consituent index in sublattice ll ! For neutrals in sublattice 2, sublattice 1 has -99 as constituent je=1 do ll=1,nsl endm(ll,je)=inkl(ll-1)+1 enddo ! we may not have any anions, just Va! isp=endm(2,je) if(btest(splista(knr(isp))%status,SPVA)) then ! save index for endmembers with va as anion ! write(*,*)'3Y ionic liquid endmember with Va 1: ',je,hasva,nkl(1) endwithva(hasva)=je hasva=hasva+1 endif ! we can have an ionic liquid without any cation if(knr(1).eq.-99) endm(1,1)=-99 genend: do while(je.lt.nend) je=je+1 ! next endmember is first equal to previous do ll=1,nsl endm(ll,je)=endm(ll,je-1) enddo ! increment the constituent in the first sublattice if(endm(1,je).lt.inkl(1)) then endm(1,je)=endm(1,je)+1 if(hasva.gt.1) then ! write(*,*)'3Y ionic liquid endmember with Va 3: ',je,hasva,nkl(1) endwithva(hasva)=je hasva=hasva+1 endif else endm(1,je)=1 isp=endm(2,je)+1 if(btest(splista(knr(isp))%status,SPVA)) then ! save index for endmembers with va as anion ! write(*,*)'3Y ionic liquid endmember with Va 2: ',je,hasva,nkl(1) endwithva(hasva)=je hasva=hasva+1 endif if(splista(knr(isp))%charge.eq.zero .and. & .not.btest(splista(knr(isp))%status,SPVA)) then ! The next constituent in second sublattice is not Va or a neutral exit genend else ! the next constituent is an anion or Va endm(2,je)=endm(2,je)+1 endif endif ! write(*,171)'3Y endmember 1: ',je,endm(1,je),endm(2,je) enddo genend 171 format(a,i3,' (',i2,':',i2,')') ! we must generate endmembers for neutrals, wildcard -99 in first sublattice do iend=je,nend endm(1,iend)=-99 endm(2,iend)=isp isp=isp+1 ! write(*,171)'3Y endmember 2: ',je,endm(1,je),endm(2,je) enddo ! debug check if(mode.eq.0) then ! write(*,*)'3Y NEW: mode, endmembers, gridpoints: ',mode,nend,ngg ! write(*,111)(endm(1,je),endm(2,je),je=1,nend) 111 format('3Y list: ',10(i4,i3)/11(i4,i3)) endif ! gx%bmperr=4399; goto 1000 !--------------------------------------- ! We have now generated endm(1..nsl,j) !120 continue ! write(*,202)'3Y special 1: ',nsl,nend,inkl(nsl),endm(1,2),endm(2,2),& ! endm(1,nend),endm(1,3),endm(2,3),endm(1,4),endm(2,4) ! we must allocate and set endmember fractions both for mode 0 and >0 ! if(mode.gt.0) write(*,*)'3Y allocate yendm: ',inkl(2),nend ! write(*,*)'3Y allocating endmembers 6:',inkl(2),nend allocate(yendm(inkl(2),nend),stat=errall) if(errall.ne.0) then write(*,*)'3Y allocation error 8: ',errall gx%bmperr=4370; goto 1000 endif yendm=zero ! SOMETIMES IT CRASHED IF THIS LINE IS REMOVED write(dummy,*)'3Y endmember fractions:',mode,je do je=1,nend if(endm(1,je).lt.0) then ! for neutrals set all fractions in first sublatice to unity/number of constit ! The G value calculated for the endmember is same as if all were zero ! but when mixing endmembers with cation fractions it may differ .... do l1=1,inkl(1) yendm(l1,je)=one/inkl(1) enddo else yendm(endm(1,je),je)=one endif yendm(endm(2,je),je)=one ! write(*,213)je,(yendm(l1,je),l1=1,inkl(2)) 213 format('3Y#',i2,14F5.2/(15F5.2)) enddo ! if(mode.gt.0) write(*,*)'3Y allocate yfra: ',nsl,inkl(nsl) ! allocate(yfra(inkl(nsl))) ! this is a small allocation, max 1000 double allocate(yfra(ncon)) !--------------------------------------------- ! now generate combinations of endmember fractions ! Note the sum of constituent fractions in all sublattices should be unity ngg=0 looplim1=breaks(4) looplim2=breaks(3) if(dense) then ! write(*,*)'3Y dense ionic liquid grid',nend looplim1=nend+1 looplim2=breaks(4) endif lokph=phases(iph) endmem1: do iend=1,nend endmem2: do jend=1,nend if(nend.gt.looplim1 .and. jend.ne.iend) cycle endmem2 endmem3: do kend=1,nend if(nend.gt.looplim2 .and. kend.ne.jend) cycle endmem3 endmem4: do lend=1,nend if(nend.gt.breaks(2) .and. lend.ne.kend) cycle endmem4 do jj=1,ncon yfra(jj)=yf(1)*yendm(jj,iend)+yf(2)*yendm(jj,jend)+& yf(3)*yendm(jj,kend)+yf(4)*yendm(jj,lend) enddo ngg=ngg+1 if(mode.eq.0) then if(ngg.gt.0 .and. mod(ngg,30000).eq.0) & write(*,*)'3Y calculate ',ngg,' grid points for ',& trim(phlista(lokph)%name) call calc_gridpoint(iph,yfra,nrel,xarr(1,ngg),garr(ngg),ceq) if(gx%bmperr.ne.0) goto 1000 if(lutbug.gt.0) then ! debug output for NEW version of ionic liquid, the grid was quite strange write(lutbug,710)'A: ',ngg,nrel,ncon,garr(ngg),& (xarr(jj,ngg),jj=1,nrel),(yfra(jj),jj=1,ncon) 710 format(a,i5,2i3,1pe10.2,10(0pF6.3)) endif if(garr(ngg).gt.gmax) gmax=garr(ngg) ! if(mod(ngg,10000).eq.0) write(*,*)'Calculated ',ngg,& ! ' gridpoints, more to go' ! write(*,211)'3Y ny:',ngg,garr(ngg),(xarr(jj,ngg),jj=1,nrel) ! write(*,212)'3Yy: ',(yfra(jj),jj=1,ncon) 211 format(a,i7,1pe12.4,0pf7.4,6f7.4,(3x,10f7.4)) 212 format(a,15F5.2,(16F5.2)) elseif(ngg.eq.mode) then ! when mode>0 we are searching for the constitution of a grid point ! and we must know the yfra here!! goto 500 endif enddo endmem4 enddo endmem3 enddo endmem2 enddo endmem1 ! write(*,*)'3Y Calculated points 1: ',ngg,nend,breaks(2),dense ! goto 1000 ! write(*,*)'3Y special cation loop: ' ! if(nend.le.breaks(2)) goto 1000 ! if(.not.dense .and. nend.le.breaks(2)) goto 1000 if(.not.dense .and. cation.gt.breaks(3)) goto 1000 ! combinations 3 different cations with same anion anion2: do lend=0,anion-1 catloop=lend*cation+1 ! REMEMBER: endmembers with same cation are ordered sequentially!!! ! write(*,*)'3Y catloop: ',lend+1,cation,catloop,ngg ! calculating "c g" followed by "c n" gives better result than "c e", why?? ! The reason was that I had forgotten to scale phase amounts with total moles endmem1b: do iend=catloop,catloop+cation-3 endmem2b: do jend=iend+1,catloop+cation-2 endmem3b: do kend=jend+1,catloop+cation-1 ! these loops generate a more dense grid but give same results in my test ! endmem1b: do iend=catloop,catloop+cation-1 ! endmem2b: do jend=catloop,catloop+cation-1 ! if(jend.eq.iend) cycle endmem2b ! endmem3b: do kend=catloop,catloop+cation-1 ! if(kend.eq.jend .or. kend.eq.iend) cycle endmem3b if(.not.dense .and. cation.gt.breaks(3)) then ! write(*,*)'3Y skipping ternary cationloop' cycle endmem3b endif ! mixing of 3 cations with the same anion do jj=1,ncon yfra(jj)=yfx(1)*yendm(jj,iend)+yfx(2)*yendm(jj,jend)+& yfx(3)*yendm(jj,kend) enddo ngg=ngg+1 if(mode.eq.0) then if(ngg.gt.0 .and. mod(ngg,30000).eq.0) & write(*,*)'3Y calculate ',ngg,' gridpoints for ',& trim(phlista(lokph)%name) call calc_gridpoint(iph,yfra,nrel,xarr(1,ngg),garr(ngg),ceq) if(lutbug.gt.0) then ! debug output for NEW version of ionic liquid, the grid was quite strange write(lutbug,710)'B: ',ngg,nrel,ncon,garr(ngg),& (xarr(jj,ngg),jj=1,nrel),(yfra(jj),jj=1,ncon) endif if(gx%bmperr.ne.0) goto 1000 if(garr(ngg).gt.gmax) gmax=garr(ngg) ! if(mod(ngg,10000).eq.0) write(*,*)'Calculated ',ngg,& ! ' gridpoints, more to go' ! write(*,211)'3Y ny:',ngg,garr(ngg),(xarr(jj,ngg),jj=1,nrel) ! write(*,212)'3Yy: ',(yfra(jj),jj=1,ncon) elseif(ngg.eq.mode) then ! when mode>0 we are searching for the constitution of a grid point ! and we must know the yfra here!! goto 500 endif enddo endmem3b enddo endmem2b enddo endmem1b enddo anion2 !-------- ! write(*,*)'3Y Calculated points 2: ',ngg,nend,breaks(2) ! skip next loop for the moment ....... still goto 1000 ! combination of 2 different cations with same anion and a neutral ! there are cation*anion endmembers (incl Va as anion), neutrals follow neutral1=cation*anion+1 iva=ngg write(*,*)'3Y ionliqgrid3: ',neutral1,ngg recip: do lend=0,anion-1 catloop=lend*cation+1 ! write(*,*)'3Y catloop: ',lend+1,cation,catloop,ngg ! calculating "c g" followed by "c n" gives better result than "c e", why?? ! The reason was that I had forgotten to scale phase amounts with total moles endmem1c: do iend=catloop,catloop+cation-2 endmem2c: do jend=iend,catloop+cation-1 ! now a neutral, endmem3c: do kend=neutral1,nend if(.not.dense .and. cation.gt.breaks(3)) then write(*,*)'skipping ternary cationloop' cycle endmem3c elseif(mode.eq.0) then write(*,480)'3Y cations: ',lend+1,iend,jend,kend,ngg 480 format(a,10i5) endif ! mixing of cations with the same anion and a neutral do jj=1,ncon yfra(jj)=yfc(1)*yendm(jj,iend)+yfc(2)*yendm(jj,jend)+& yfc(3)*yendm(jj,kend) enddo ngg=ngg+1 if(mode.eq.0) then if(ngg.gt.0 .and. mod(ngg,30000).eq.0) & write(*,*)'3Y Gridmin calculated ',ngg,& ' gridpoints for ',trim(phlista(lokph)%name) call calc_gridpoint(iph,yfra,nrel,xarr(1,ngg),garr(ngg),ceq) if(gx%bmperr.ne.0) goto 1000 if(garr(ngg).gt.gmax) gmax=garr(ngg) ! if(mod(ngg,10000).eq.0) write(*,*)'Calculated ',ngg,& ! ' gridpoints, more to go' ! write(*,211)'3Y ny:',ngg,garr(ngg),(xarr(jj,ngg),jj=1,nrel) ! write(*,212)'3Yy: ',(yfra(jj),jj=1,ncon) elseif(ngg.eq.mode) then ! when mode>0 we are searching for the constitution of a grid point ! and we must know the yfra here!! goto 500 endif enddo endmem3c enddo endmem2c enddo endmem1c enddo recip write(*,*)'3Y ionliqgrid7: ',neutral1,ngg,iva ! ! write(*,*)'3Y Calculated points 2: ',ngg ! generate combinations of ternary anions if not done above goto 1000 !---------------------------------------- ! jump here to return the constitution for gridpoint "mode" in the solution 500 continue if(ny.ne.ncon) write(*,*)'3Y ny and ncon: ',ny,ncon ! do jj=1,ny do jj=1,ncon yarr(jj)=yfra(jj) enddo 1000 continue ! these should be deallocated by default when exit this subroutine ... if(allocated(endm)) then deallocate(endm) deallocate(yfra) deallocate(yendm) endif 1001 continue ! restore original constituent fractions, also if error in this routine ! call get_phase_data(iph,1,nsl,nkl,knr,ydum,sites,qq,ceq) errsave=gx%bmperr gx%bmperr=0 call set_constitution(iph,1,ydum,qq,ceq) if(gx%bmperr.ne.0) then write(*,*)'3Y Error restoring constitution for phase: ',iph,gx%bmperr endif gx%bmperr=errsave if(gx%bmperr.ne.0) write(*,*)'3Y ionliq_grid error: ',gx%bmperr return end subroutine generate_ionliq_grid !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine generate_fccord_grid !\begin{verbatim} %- subroutine generate_fccord_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq) ! This generates grid for a phase with 4 sublattice fcc/bcc/hcp ordering ! NO LONGER USED: mode<0 just number of gridpoints in ngg, for allocations ! mode=0 calculate mole fraction and G for all gridpoints ! mode>0 return constitution for gridpoint mode in yarr implicit none integer mode,iph,ngg,nrel,ny real xarr(nrel,*),garr(*) double precision yarr(*),gmax type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ logical, save :: once=.TRUE. integer nsl,maxng,mend,nend,kend,ncon,i1,i2,i3,i4,i5,ij,ik,iz,ls,gridlimit integer nkl(1000),knr(1000),incl(0:9),loksp,lokph,jj integer, allocatable, dimension(:,:) :: endm double precision, allocatable, dimension(:,:) :: yendm double precision, allocatable, dimension(:) :: yfra double precision, allocatable, dimension(:) :: ysave double precision ydum(1000),ysame(1000),sites(9),qq(5) ! this generates >3000 gridpoints for a binary (A,B)(A,B)(A,B)(A,B) ! integer, parameter, dimension(3,4) :: & ! limits=reshape([150,50,20, 100,30,15, 20,10,7, 12,7,4],shape(limits)) integer, parameter, dimension(3,4) :: & limits=reshape([150,50,20, 100,30,15, 20,10,7, 12,7,4],shape(limits)) ! from generic_grid_generator ! logical dense,gles,defgrid double precision, dimension(5), parameter :: & yf=[0.07D0,0.28D0,0.16D0,0.45D0,0.04D0] integer ii,ijs,iks,il,ils,im,ims,is,nendj,nendk,nendl,nendm,ng,errall character phname*32 ! NOTHING IMPLEMENTED YET oh yes it is ... ! write(*,*)'3Y in generate_fccord_grid ',ngg if(mode.lt.0) then write(*,*)'3Y mode <0 not allowed' gx%bmperr=4399; goto 1000 endif ! check that F or B bit set if(.not.(test_phase_status_bit(iph,PHFORD) .or. & test_phase_status_bit(iph,PHBORD))) then write(*,*)'3Y calling ordered grid without F or B bit' gx%bmperr=4399; goto 1000 endif ! ! get phase model call get_phase_data(iph,1,nsl,nkl,knr,ydum,sites,qq,ceq) if(gx%bmperr.ne.0) goto 1010 ! max number of gridpoints allowed, ngg returned as number of gridpoints ??? ! maxng is zero ... maxng=ngg ngg=0 ! incl(ii) set to number of constituents up to including sublattice ii incl(0)=0 nend=1 do ij=1,nsl nend=nend*nkl(ij) incl(ij)=incl(ij-1)+nkl(ij) enddo ncon=incl(nsl) ! if nend<15 there is a single constituent on the ordered sublattices if(nend.lt.16) then gx%bmperr=-1 goto 1010 endif ! nend is number of endmembers, endm(1..nsl,ii) are constituent index of ii ! yendm(1..nsl,ii) has the constituent fractions for endmember ii ! yfra is used to generate a constitutuon from a combination of endmembers ! write(*,*)'3Y allocating endmembers 8:',nsl,nend,ncon if(nsl*nend.gt.100000) then call get_phase_name(iph,1,phname) write(*,*)'3Y Limiting gridpoints in ',trim(phname),nend,30000 ! I am not sure if nend is checked in the loops below, may cause segmentation ! fault nend=30000 endif allocate(endm(nsl,nend),stat=errall) allocate(yendm(ncon,nend),stat=errall) allocate(yfra(ncon),stat=errall) allocate(ysave(ncon),stat=errall) if(errall.ne.0) then write(*,*)'3Y allocation error 9: ',errall gx%bmperr=4370; goto 1000 endif yendm=1.0D-12 do ij=1,ncon ysave(ij)=ydum(ij) enddo ! set endm(1..nsl,1) to first constituent in each sublattice do ij=1,nsl endm(ij,1)=incl(ij) ! endm(ij,1)=incl(ij-1)+1 ! yendm(endm(ij,1),1)=one enddo ! loop to increment the constituents to generate all endmembers ! We should avoid all permutations according to BCC ! A:A:A:A ! A:A:A:B ingnore all permutations of B in sublattices ! A:A:A:C - A:A:A:X ! A:A:B:B - A:A:B:X ! A:A:C:C - A:A:X:X ! A:B:A:B - A:B:A:X <<<<<<< special for BCC ! A:C:A:C - A:X:A:X ! A:B:B:C - A:B:B:X ! A:B:C:C - A:B:X:X ! A:C:C:C - A:X:X:X ! B:B:B:B ! B:B:B:C - B:B:B:X ! etc ! X:X:X:X ! endm(1..nsl,1) set to first in all sublattices ! ordering always on the first 4 sublattices ! endm(1..nsl,jj) contains constituent indices in sublattice 1..nsl ! skip vacancies in the ordered sublattices ... kend=1 sl1: do i1=1,nkl(1) endm(1,kend)=incl(0)+i1 if(btest(splista(knr(endm(1,kend)))%status,SPVA)) then ! write(*,*)'Skipping vacancies in ordered sublattices: ',& ! trim(splista(knr(endm(1,kend)))%symbol),kend,knr(endm(1,kend)) cycle sl1 endif sl2: do i2=i1,nkl(2) endm(2,kend)=incl(1)+i2 if(btest(splista(knr(endm(2,kend)))%status,SPVA)) cycle sl2 sl3: do i3=i2,nkl(3) endm(3,kend)=incl(2)+i3 if(btest(splista(knr(endm(3,kend)))%status,SPVA)) cycle sl3 sl4: do i4=i3,nkl(4) endm(4,kend)=incl(3)+i4 if(btest(splista(knr(endm(4,kend)))%status,SPVA)) cycle sl4 extra: if(nsl.gt.4) then ! write(*,16)'3Y endm 1: ',0,kend,(endm(ik,kend),ik=1,nsl) rest: do ls=5,nsl ! Hm, problems to loop over constituents in sublattices nsl>4 sl5: do i5=1,nkl(ls) ! write(*,16)'3Y endm 2: ',i5,ls,kend,& ! (endm(ik,kend),ik=1,nsl),incl(ls) if(endm(ls,kend).ge.incl(ls)) then ! reset the constiuent in sublattice ls to the first in this sublattice endm(ls,kend)=incl(ls-1)+1 else endm(ls,kend)=endm(ls,1)+1 endif do ik=1,nsl yendm(endm(ik,kend),kend)=one enddo ! write(*,16)'3Y endm 3: ',i5,ls,kend,& ! (endm(ik,kend),ik=1,nsl),0 16 format(a,3i5,4i4,2i7) kend=kend+1 ! this can be ver very many so maybe nend set to lower value above if(kend.eq.nend) then write(*,*)'3Y limiting grid in ',trim(phname),kend goto 1000 endif do iz=1,nsl endm(iz,kend)=endm(iz,kend-1) enddo enddo sl5 enddo rest else ! write(*,16)'3Y yendm 3: ',kend,(endm(ik,kend),ik=1,nsl) do ik=1,nsl yendm(endm(ik,kend),kend)=one enddo ! write(*,16)'3Y endm 4: ',0,ls,kend,& ! (endm(ik,kend),ik=1,nsl),0 kend=kend+1 ! this can be ver very many so maybe nend set to lower value above if(kend.eq.nend) then write(*,*)'3Y limiting grid in ',trim(phname),kend goto 1000 endif do iz=1,nsl endm(iz,kend)=endm(iz,kend-1) enddo endif extra enddo sl4 enddo sl3 enddo sl2 enddo sl1 if(mode.eq.0 .and. test_phase_status_bit(iph,PHBORD)) then ! for BCC ordered phase add endmember with same constituents in first and third ! sublattices and loop in the others like A:B-X:A:B-X and B:C-X:B:C-X ! write(*,*)'3Y Grid minimizer has no gridpoints for B32 ordering',kend-1 ! stop 'too many gridpoints' endif ! kend has been incremented one too much nend=kend-1 ! write(*,*)'3Y ordered endmemb: ',nend ! if(mode.eq.0) then ! output adapted to 5 sublattices (interstitial) ! if(nsl.eq.5) then ! write(*,17)'3Y orded:',nend,((endm(ls,mend),ls=1,nsl),mend=1,nend) 17 format(a,i3,4(i4,4i3)/,(12x,i4,4i3,i4,4i3,i4,4i3,i4,4i3)) ! do i2=1,nend ! write(*,18)i2,(endm(ls,i2),ls=1,nsl),(yendm(i1,i2),i1=1,nsl) 18 format('3Y yendm: ',i5,2x,4i3,2x,4F6.3) ! enddo ! elseif(nsl.eq.4) then ! output adapted to 4 sublattices ! write(*,19)'3Y ordend: ',((endm(ls,mend),ls=1,nsl),mend=1,nend) 19 format(a,4(i4,3i3)/,(11x,i4,3i3,i4,3i3,i4,3i3,i4,3i3)) ! endif ! endif ! ! copied from generic_grid_generator ! ! now generate an grid depending on nend mixing up to 5 different endmembers. ! up to for 4 endmembers 4*4*4*4*4=1024 ! 5 to 7 endmembers 7*7*7*7 =2401 ! 7 to 13 endmembers 13*13*13=2197 ! max 50 endmembers 50*50 = 2500 ! for N>50 endmembers = N ! FOR DENSE about 10 times more ! up to 7 endmembers 7*7*7*7*7 = 16807 ! 8 to 12 endmembers 12*12*12*12 = 20736 ! 13 to 15 endmembers 15*15*15 =33750 ! max 150 endmembers 150*150 = 22500 ! for N>150 = N !-------------------------------------- ! dense=.FALSE. ! gles=.FALSE. ! defgrid=.TRUE. if(btest(globaldata%status,GSOGRID)) then gridlimit=3 elseif(btest(globaldata%status,GSXGRID) .or. & test_phase_status_bit(iph,PHXGRID)) then gridlimit=1 else gridlimit=2 endif ! write(*,*)'3Y in generate_ordered_grid ',iph,nend,gridlimit,& ! btest(globaldata%status,GSOGRID) ng=0 !----------------------- iiloop: do ii=1,nend ijs=1 nendj=nend if(nend.ge.limits(gridlimit,1)) then ! if(nend.eq.150 .or. (gles .and. nend.gt.40)) then nendj=ii ijs=ii endif ! write(*,*)'3Y ii:',ii,ijs,nendj ijloop: do ij=ijs,nendj iks=1 nendk=nend if(nend.ge.limits(gridlimit,2)) then ! if(nend.gt.15 .or. (gles .and. nend.gt.13)) then nendk=ij iks=ij endif ikloop: do ik=iks,nendk ils=1 nendl=nend if(nend.ge.limits(gridlimit,3)) then ! if((nend.gt.12 .or. (gles .and. nend.gt.7)) then nendl=ik ils=ik endif illoop: do il=ils,nendl ! illoop: do il=1,nendl ims=1 nendm=nend if(nend.ge.limits(gridlimit,4)) then ! if(nend.gt.7 .or. (gles .and. nend.gt.4)) then ! with 4 endmembers 1024 gridpoints nendm=il ims=il endif imloop: do im=ims,nendm ! sum up the weighted fractions from the different endmembers do is=1,ncon yfra(is)=yf(1)*yendm(is,ii)+yf(2)*yendm(is,ij)+& yf(3)*yendm(is,ik)+yf(4)*yendm(is,il)+& yf(5)*yendm(is,im) enddo ng=ng+1 if(mode.eq.0) then ! write(*,322)'3Y imloop: ',ng,ii,ij,ik,il,im 322 format(a,i8,5i4) ! write(*,323)'3Y imloop1: ',ng,ii,ij,ik,il,im,0.0D0,yfra 323 format(a,i5,5i3,': ',1pe12.4,0p20F5.2) ! strange bug in map3, maxng was zero sometimes ... if(ng.gt.maxng) then if(maxng.lt.100) then write(*,*)'3Y max gripoints wrong 6: ',maxng,iph,mode else write(*,*)'3Y Too many gridpoints 6',ng,maxng,iph gx%bmperr=4399; goto 1000 endif endif if(ng.gt.0 .and. mod(ng,30000).eq.0) then lokph=phases(iph) write(*,*)'3Y Gridmin calculated ',ng,& ' gridpoints for ',trim(phlista(lokph)%name) endif call calc_gridpoint(iph,yfra,nrel,xarr(1,ng),garr(ng),ceq) if(lutbug.gt.0) then write(lutbug,710)'F: ',ngg,nrel,ncon,garr(ngg),& (xarr(jj,ngg),jj=1,nrel),(yfra(jj),jj=1,ncon) 710 format(a,i5,2i3,1pe10.2,10(0pF6.3)) endif if(gx%bmperr.ne.0) then write(*,*)'3Y error calculating gridpoint: ',& iph,gx%bmperr goto 1000 endif ! write(*,323)'3Y imloop2: ',ng,ii,ij,ik,il,im,garr(ng),yfra elseif(mode.eq.ng) then ! when mode>0 we just want to know the constituent fractions goto 900 endif enddo imloop enddo illoop enddo ikloop enddo ijloop enddo iiloop ! do ii=1,ng ! write(*,700)ii,garr(ii),(xarr(ij,ii),ij=1,nrel) 700 format('3Y gp: ',i5,1pe12.4,9(0pF6.3)) ! enddo 800 continue if(mode.gt.0) then write(*,*)'3Y could not find gridpoint ',mode,' in phase ',iph,ng gx%bmperr=4399 else ngg=ng endif goto 1000 !-------------------------------------------- ! we found the gridpoint we were looking for 900 continue ny=ncon do ii=1,ny yarr(ii)=yfra(ii) enddo ! ! 1000 continue if(mode.eq.0) then ! restore the composition call set_constitution(iph,1,ysave,qq,ceq) endif ! nothing done, just exit 1010 continue return ! dense gles end subroutine generate_fccord_grid !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine generate_charged_grid !\begin{verbatim} %- subroutine generate_charged_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq) ! This generates grid for a phase with charged constituents ! mode<0 just number of gridpoints in ngg, needed for allocations ! mode=0 calculate mole fraction and G for all gridpoints ! mode>0 return constitution for gridpoint mode in yarr implicit none integer mode,iph,ngg,nrel,ny real xarr(nrel,*),garr(*) double precision yarr(*),gmax type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer nkl(maxsubl),knr(maxconst),inkl(0:maxsubl) ! double precision, dimension(:), allocatable :: yfra double precision sites(maxsubl),ydum(maxconst),qq(5) integer nend,ll,nsl,i1,i2,i3,loksp,mm,lokph,lokcs,np,nm,nn,ncc,iz,loopf,jj integer, dimension(:,:), allocatable :: neutral integer, dimension(10) :: gtype ! integer, dimension(:), allocatable :: savengg ! integer ielno(10) ! double precision stoi(10),smass,qsp double precision charge,ratio1,ratio2 double precision, dimension(:), allocatable :: y1,y2,y3,y4,y5 real xdum(nrel),gdum integer, parameter :: ncf5=5,ncf3=3,alloneut=300000 integer ncf,maxngg,ncon,maxgp1,errall integer, parameter :: maxgp2=10000,maxgp3=20000 ! These are used to combine endmembers double precision, dimension(7), parameter :: nfact=& [0.01D0,0.1D0,0.33D0,0.51D0,0.67D0,0.9D0,0.99D0] double precision, dimension(ncf5), parameter :: cfact5=& [0.05D0,0.3D0,0.5D0,0.7D0,0.95D0] double precision, dimension(ncf3), parameter :: cfact3=& [0.1D0,0.5D0,0.9D0] logical single,endout,dense,skipped ! all endmembers will have a record of this type type gtp_charged_endmem ! one species number for each sublattice integer, dimension(:), allocatable :: constit double precision charge end type gtp_charged_endmem type(gtp_charged_endmem), dimension(:), allocatable :: endmem ! this should be saved or passed as argument ! save savengg ! we will select 5 or 3 gripoints below ! endout=.true. endout=.FALSE. ! skipped=.TRUE. skipped=.FALSE. if(endout) write(*,*)'3Y charged grid phase:',iph ! ncf=ncf5 ! if(.not.allocated(savengg)) then ! allocate(savengg(noofph)) ! savengg=0 ! endif maxngg=ngg ngg=0 gtype=0 ! get the phase data call get_phase_data(iph,1,nsl,nkl,knr,ydum,sites,qq,ceq) if(gx%bmperr.ne.0) goto 1000 ! Clement Introini bugfix lokph=phases(iph) ! ! I will handle this by first generate all endmembers with their charge ! and then try to combine them to get neutral gridpoints. nend=1 inkl(0)=0 do ll=1,nsl nend=nend*nkl(ll) ! inkl(ll) is the number of constituents up to and including sublattice ll inkl(ll)=inkl(ll-1)+nkl(ll) enddo ! ncon is the total number of constituents ncon=inkl(nsl) ! write(*,*)'3Y Charged grid for phase ',iph,mode,nend,ncon if(nend.eq.1) then ! a single endmember, just check it is neutral ngg=1 charge=zero do ll=1,nsl loksp=knr(ll) charge=charge+sites(ll)*splista(loksp)%charge enddo if(charge.eq.zero) then np=ngg if(ngg.gt.maxngg) then write(*,*)'3Y too many gripoints 2',ngg,maxngg,iph gx%bmperr=4399; goto 1000 endif if(mode.eq.0) then ! if mode=0 calculate G for this endmember ! write(*,*)'3Y a single neutral endmember for ',iph,mode if(ngg.gt.0 .and. mod(ngg,30000).eq.0) & write(*,*)'3Y Gridmin calculated ',ngg,' gridpoints for ',& trim(phlista(lokph)%name) call calc_gridpoint(iph,ydum,nrel,xarr(1,ngg),garr(ngg),ceq) if(gx%bmperr.ne.0) goto 1000 if(garr(ngg).gt.gmax) gmax=garr(ngg) endif ! finally remove the request for external charge balance !!! ! write(*,*)'3Y No external charge balance for phase:',iph,lokcs,mode call get_phase_compset(iph,1,lokph,lokcs) phlista(lokph)%status1=ibclr(phlista(lokph)%status1,PHEXCB) goto 1000 endif call get_phase_compset(iph,1,lokph,lokcs) ! write(*,*)'3Y Phase suspended as net charge: ',phlista(lokph)%name ! suspend all composition sets do mm=1,phlista(lokph)%noofcs lokcs=phlista(lokph)%linktocs(mm) ceq%phase_varres(lokcs)%phstate=PHSUS enddo goto 1000 endif ! np=0 nm=0 nn=0 ! Problem with CU2ZN1SN1S4 maybe because of sublattce with just VA ?? ! write(*,10)'3Y nend: ',iph,nend,0.0D0,(nkl(ll),ll=1,nsl) 10 format(a,2i4,5x,1pe12.4,10i3) ! allocate a record for each endmembers allocate(endmem(nend),stat=errall) allocate(endmem(1)%constit(nsl),stat=errall) if(errall.ne.0) then write(*,*)'3Y allocation error 10: ',errall gx%bmperr=4370; goto 1000 endif charge=zero do ll=1,nsl endmem(1)%constit(ll)=inkl(ll-1)+1 loksp=knr(endmem(1)%constit(ll)) ! write(*,*)'3Y species location: ',loksp ! call get_species_data(loksp,mm,ielno,stoi,smass,qsp) ! if(gx%bmperr.ne.0) goto 1000 charge=charge+sites(ll)*splista(loksp)%charge enddo endmem(1)%charge=charge ! write(*,15)'3Y end1: ',mode,iph,nsl,charge,1,endmem(1)%constit 15 format(a,3i3,1pe12.4,i4,2x,8i3) if(charge.gt.zero) then np=np+1 elseif(charge.lt.zero) then nm=nm+1 else nn=nn+1 endif ! write(*,10)'3Y endmem: ',1,0,charge,endmem(1)%constit emloop: do i2=2,nend ! a small allocation allocate(endmem(i2)%constit(nsl)) endmem(i2)%constit=endmem(i2-1)%constit sloop: do ll=1,nsl if(endmem(i2)%constit(ll).lt.inkl(ll)) then exit sloop elseif(ll.lt.nsl) then endmem(i2)%constit(ll)=endmem(1)%constit(ll) else exit emloop endif enddo sloop endmem(i2)%constit(ll)=endmem(i2)%constit(ll)+1 charge=zero do mm=1,nsl loksp=knr(endmem(i2)%constit(mm)) charge=charge+sites(mm)*splista(loksp)%charge enddo endmem(i2)%charge=charge ! write(*,15)'3Y endx: ',mode,iph,nsl,charge,i2,endmem(i2)%constit if(charge.gt.zero) then np=np+1 elseif(charge.lt.zero) then nm=nm+1 else nn=nn+1 endif enddo emloop mm=nn*nn+np*nm*(nn+np+nm) ! not using phase grid bit: test_phase_status_bit(iph,PHXGRID) ! default grid density with this big system if(mm.gt.30000) then ! very many components, minimum number of loops (no low density option) ncf=1; maxgp1=maxgp2 if(btest(globaldata%status,GSXGRID) .or. & test_phase_status_bit(iph,PHXGRID)) then ! higher density requested ncf=ncf3; maxgp1=maxgp3 elseif(btest(globaldata%status,GSYGRID)) then ! maximum density requested (may cause grid overflow ...) ncf=ncf5; maxgp1=maxgp3 endif elseif(mm.gt.10000) then ! default grid density with a medium size system ncf=ncf3; maxgp1=maxgp2 if(btest(globaldata%status,GSOGRID)) then ! lower density requested ncf=1 elseif(btest(globaldata%status,GSXGRID) .or. & test_phase_status_bit(iph,PHXGRID)) then ! higher density requested ncf=ncf5 elseif(btest(globaldata%status,GSYGRID))then ! maximum density requested ncf=ncf5; maxgp1=maxgp3 endif else ! default grid for a small system ncf=ncf5; maxgp1=maxgp2 if(btest(globaldata%status,GSOGRID)) then ! lower density requested ncf=ncf3 elseif(btest(globaldata%status,GSXGRID) .or. & btest(globaldata%status,GSYGRID) .or. & test_phase_status_bit(iph,PHXGRID)) then ! higher density requested, this is maximum ncf=ncf5; maxgp1=maxgp3 endif endif ! the statements below replaced by if statements above ! if(.not.dense .and. mm.gt.5000) then ! maxgp1 used to skip some combinations ! ncf=1; maxgp1=maxgp2 ! elseif(dense) then ! testing ... ! ncf=ncf5; maxgp1=maxgp4 ! elseif(dense .or. mm.gt.2000) then ! ncf=ncf3; maxgp1=maxgp3 ! else ! maximum dense grid ! ncf=ncf5; maxgp1=maxgp3 ! endif ! debug output ! if(mode.eq.0) then ! write(*,'(a,10i7)')'3Y Generating charged grid: ',mode,iph,& ! nend,mm,ncf,maxgp1 ! noc2500 with just C1_MO2 ((12 * 2 * 2)=48 endmem) and GAS gives ! level C1_MO2 nend mm ncf maxgpl total gridpoints ! low density 0 22 48 21012 1 10000 11998 ! default 1 3 10000 33284 ! high 2 5 10000 42651 ! maximum 3 5 20000 57446 ! ! endif ! now calculate the number of gridpoints, consider single endmembers, ! binary and ternary combinations in a triple loop np=0 nn=0 ! if(mode.ge.0) then ! we have saved the number of gridpoints from the mode=-1 call here ! np=savengg(iph) ! write(*,*)'3Y allocate neutral: ',mode,alloneut ! guess a safe value ... allocate(neutral(alloneut,0:3),stat=errall) if(errall.ne.0) then write(*,*)'3Y allocation error 11: ',errall gx%bmperr=4370; goto 1000 endif neutral=0 np=0 if(endout) write(*,*)'3Y starting generating grid in ionic solid phase',nend loop1: do i1=1,nend charge1A: if(endmem(i1)%charge.eq.zero) then ! first endmember neutral, one gridpoint np=np+1 if(mode.ge.0) then ! for generating Y and G we save which endmembers to combine in neutral(*,0) neutral(np,0)=0 neutral(np,1)=i1 endif if(endout) write(*,298)'3Y generated 1 gp: ',np,mode,1,0,i1,0,0 298 format(a,2i7,2i2,2x,3i4) endif charge1A gtype(1)=gtype(1)+1 loop2: do i2=i1+1,nend charge1: if(endmem(i1)%charge.eq.zero) then ! first endmember neutral, that gridpoint already created charge2A: if(endmem(i2)%charge.eq.zero) then !----------------------------------------------------------------------- ! second endmember neutral, generate 7 points between them, (the point at pure ! i2 that will be generated later): 0.01; 0.1; 0.34; 0.51; 0.67; 0.9; 0.99 if(mode.ge.0) then do ll=1,7 neutral(np+ll,0)=1 neutral(np+ll,1)=i1 neutral(np+ll,2)=i2 enddo endif np=np+7 if(endout) write(*,298)'3Y generated 7 gps: ',np,mode,3,1,i1,i2,0 gtype(2)=gtype(2)+7 else !----------------------------------------------------------------------- ! second endmember has charge, a third endmember needed with opposite charge loop3A: do i3=i2+1,nend if(endmem(i2)%charge*endmem(i3)%charge.lt.zero) then ! second and third endmembers have opposite charge, we have ncf gridpoints ! I1_n(I2_(1/c2)I3_(1/c3)_(1-n) where c2 is charge of i2 and c3 charge of i3 if(gtype(3).gt.maxgp1) then if(skipped) & write(*,*)'Skipping gridpoints type 3',gtype(3) exit charge2A endif if(mode.ge.0) then do ll=1,ncf neutral(np+ll,0)=2 neutral(np+ll,1)=i1 neutral(np+ll,2)=i2 neutral(np+ll,3)=i3 enddo endif np=np+ncf if(endout) write(*,298)'3Y generated 3A gps: ',& np,mode,3,2,i1,i2,i3 gtype(3)=gtype(3)+ncf endif enddo loop3A endif charge2A !======================================================================= ! first endmember has a charge elseif(endmem(i2)%charge.eq.zero) then ! second endmember is neutral, we need a third with opposite charge to first loop3B: do i3=i2+1,nend if(endmem(i1)%charge*endmem(i3)%charge.lt.zero) then ! first and third endmembers have opposite charge, we have ncf gridpoints ! (I1_(1/c1)I3_(1/c3))_n(I2)_(1-n) where c1 is charge of i1 and c3 charge of i3 ! where n is 0.1; 0.5; 0.9 if(gtype(4).gt.maxgp1) then if(endout) write(*,*)'Skipping gridpoints type 4',gtype(4) exit loop3B endif if(mode.ge.0) then do ll=1,ncf neutral(np+ll,0)=3 neutral(np+ll,1)=i1 neutral(np+ll,2)=i2 neutral(np+ll,3)=i3 enddo endif np=np+ncf if(endout) write(*,298)'3Y generated 3B gps: ',& np,mode,3,3,i1,i2,i3 gtype(4)=gtype(4)+ncf endif enddo loop3B !----------------------------------------------------------------------- ! first and second endmembers have charge with opposite sign elseif(endmem(i1)%charge*endmem(i2)%charge.lt.zero) then ! we have one gridpoint I1_(1/c1)I2_(1/c2) np=np+1 if(mode.ge.0) then neutral(np,0)=4 neutral(np,1)=i1 neutral(np,2)=i2 endif if(endout) write(*,298)'3Y generated 1 gp: ',np,mode,1,4,i1,i2,0 gtype(5)=gtype(5)+1 !----------------------------------------------------------------------- loop3C: do i3=i2+1,nend charge3A: if(endmem(i3)%charge.eq.zero) then ! third is neutral, we have ncf more gripoints ! at (I1_(1/c1)I2_(1/c2))_n(I3)_(1-n) if(gtype(6).gt.maxgp1) then if(skipped) write(*,*)'Skipping gridpoints type 6',gtype(6) exit charge3A endif if(mode.ge.0) then do ll=1,ncf neutral(np+ll,0)=5 neutral(np+ll,1)=i1 neutral(np+ll,2)=i2 neutral(np+ll,3)=i3 enddo endif np=np+ncf if(endout) write(*,298)'3Y generated 3C gps: ',& np,mode,3,5,i1,i2,i3 gtype(6)=gtype(6)+ncf elseif(endmem(i1)%charge*endmem(i3)%charge.lt.zero) then !------------------------------------------------------------- ! all 3 endmembers are charged, those of i2 and i3 have same sign, ncf gridp ! (I1_(1/c1)I2_(1/c2))_n(I1_(1/c1)I3_(1/c3))_(1-n) if(gtype(7).gt.maxgp1) then if(skipped) write(*,*)'Skipping gridpoints type 7',gtype(7) exit charge3A endif if(mode.ge.0) then do ll=1,ncf neutral(np+ll,0)=6 neutral(np+ll,1)=i1 neutral(np+ll,2)=i2 neutral(np+ll,3)=i3 enddo endif np=np+ncf if(endout) write(*,298)'3Y generated 3D gps: ',& np,mode,3,6,i1,i2,i3 gtype(7)=gtype(7)+ncf elseif(gtype(8).lt.maxgp1) then !------------------------------------------------------------- ! all 3 endmembers are charged, those of i1 and i3 have same sign, ncf gridp ! (I1_(1/c1)I2_(1/c2))_n(I2_(1/c2)I3_(1/c3))_(1-n) if(mode.ge.0) then do ll=1,ncf neutral(np+ll,0)=7 neutral(np+ll,1)=i1 neutral(np+ll,2)=i2 neutral(np+ll,3)=i3 enddo endif np=np+ncf if(endout) write(*,298)'3Y generated 3E gps: ',& np,mode,3,7,i1,i2,i3 gtype(8)=gtype(8)+ncf else if(skipped) write(*,*)'Skipping gridpoints type 8,',gtype(8) endif charge3A enddo loop3C !----------------------------------------------------------------------- ! first and second endmembers have charge with same sign elseif(gtype(9).lt.maxgp1) then ! we need a third endmember with opposite charge unless too many endmembers loop3D: do i3=i2+1,nend if(endmem(i1)%charge*endmem(i3)%charge.lt.zero) then ! all 3 endmembers are charged, those of i1 and i2 have same sign, ncf gridp ! (I1_(1/c1)I3_(1/c2))_n(I2_(1/c1)I3_(1/c3))_(1-n) if(mode.ge.0) then do ll=1,ncf neutral(np+ll,0)=8 neutral(np+ll,1)=i1 neutral(np+ll,2)=i2 neutral(np+ll,3)=i3 enddo endif np=np+ncf if(endout) write(*,298)'3Y generated 3F gps: ',& np,mode,3,8,i1,i2,i3 gtype(9)=gtype(9)+ncf endif enddo loop3D if(endout) write(*,777)'3Y loop3',gtype else if(skipped) write(*,*)'3Y skipping gridpoints type 9',gtype(9) endif charge1 if(endout) write(*,777)'3Y loop2 ',gtype enddo loop2 if(endout) write(*,777)'3Y loop1 ',gtype 777 format(a,10i6) enddo loop1 !======================================================================= if(endout) write(*,*)'3Y finished all loops for ionic phase: ',ngg ! if(mode.eq.0) then ! write(*,*)'3Y ionic crystal: ',iph,np ! endif ! if(mode.lt.0) then ! we have just calculated the number of gridpoints, save and exit ! write(*,*)'3Y neutral gridpoints: ',np ! ngg=np ! savengg(iph)=ngg ! else ! Generate the composition of the gridpoints from 1-3 endmembers and ! if mode=0 calculate the composition and Gibbs energy for the gridpoints ! if mode>0 return the constitution of gridpoint mode. ! How do I know mode is mode gridpoint in this phase?? ! write(*,29)'3Y we are here?',iph,mode,np,nsl,inkl(nsl) !29 format(a,10i5) ncc=inkl(nsl) allocate(y1(ncc),stat=errall) allocate(y2(ncc),stat=errall) allocate(y3(ncc),stat=errall) allocate(y4(ncc),stat=errall) if(errall.ne.0) then write(*,*)'3Y allocation error 12: ',errall gx%bmperr=4370; goto 1000 endif ! write(*,*)'3Y Charged grid: ',mode,nend,ncon,ncc ! write(*,*)'3Y allocated neutral: ',mode,alloneut,np ! loopf keeps track if several gridpoints belong together ! if(.not.(allocated(neutral))) then ! write(*,*)'3Y ionic liquid has not allocated neutral array' ! allocate(neutral(alloneut,0:3)) ! neutral=0 ! endif loopf=0 ygen: do nm=1,np ! neutral(nm,0) is endmember combination (0 to 8), ,1..3) is endmember index nn=neutral(nm,0) i1=neutral(nm,1) i2=neutral(nm,2) i3=neutral(nm,3) if(loopf.eq.0) then ! when loopf=0 we have a new set of endmembers, zero yi y1=zero y2=zero y3=zero endif ! we must generate all gridpoints to have corrrect loopf ! if(mode.gt.0) then ! if(mode.ne.nm) exit ! cycle ! endif ! now we must generate correct constituent fractions and calculate G (mode=0) ! write(*,*)'3Y select case',iph,nn select case(nn) case default write(*,*)'3Y case error in generate_charged_grid!!' !----------------------- first endmember is neutral, 1 gridpoint ! single neutral endmember case(0) do ll=1,nsl y1(endmem(i1)%constit(ll))=one enddo y4=y1 ! write(*,300)'3Y gp0 ',nm,nn,loopf,i1,i2,i3,zero,y4 300 format(a,i5,2i2,3i3,1pe10.2,7(0pf6.3),13(f6.3)) !----------------------- first and second endmembers are neutral, 7 gridpoints ! combine with factors: 0.01; 0.10; 0.33; 0.51; 0.67; 0.9; 0.01 case(1) if(loopf.eq.0) then do ll=1,nsl y1(endmem(i1)%constit(ll))=one y2(endmem(i2)%constit(ll))=one enddo endif loopf=loopf+1 do iz=1,ncc y4(iz)=nfact(loopf)*y1(iz)+nfact(8-loopf)*y2(iz) enddo if(loopf.ge.7) loopf=0 ! write(*,300)'3Y gp1 ',nm,nn,loopf,i1,i2,i3,zero,y4 !----------------------- first endmember is neutral, 2 and 3 charged, 3 gridp ! ratio 2/3 depend on charge, ratio 1/(2+3) case(2) if(loopf.eq.0) then do ll=1,nsl y1(endmem(i1)%constit(ll))=one y2(endmem(i2)%constit(ll))=one y3(endmem(i3)%constit(ll))=one enddo ratio1=abs(endmem(i3)%charge)/& (abs(endmem(i2)%charge)+abs(endmem(i3)%charge)) ratio2=abs(endmem(i2)%charge)/& (abs(endmem(i2)%charge)+abs(endmem(i3)%charge)) do iz=1,ncc y2(iz)=ratio1*y2(iz)+ratio2*y3(iz) enddo charge=ratio1*endmem(i2)%charge+ratio2*endmem(i3)%charge endif loopf=loopf+1 do iz=1,ncc y4(iz)=cfact5(loopf)*y1(iz)+cfact5(ncf+1-loopf)*y2(iz) enddo if(loopf.ge.ncf) loopf=0 ! write(*,300)'3Y gp2 ',nm,nn,loopf,i1,i2,i3,charge,y4 !----------------------- first charged, second neutral, third charged, 3 gridp ! ratio 1/3 depend on charge, ratio 2/(1+3): 0.1; 0.5; 0.9 case(3) if(loopf.eq.0) then do ll=1,nsl y1(endmem(i1)%constit(ll))=one y2(endmem(i2)%constit(ll))=one y3(endmem(i3)%constit(ll))=one enddo ! neutral combination of 1 and 3 ratio1=abs(endmem(i3)%charge)/& (abs(endmem(i3)%charge)+abs(endmem(i1)%charge)) ratio2=abs(endmem(i1)%charge)/& (abs(endmem(i3)%charge)+abs(endmem(i1)%charge)) do iz=1,ncc y1(iz)=ratio1*y1(iz)+ratio2*y3(iz) enddo charge=ratio1*endmem(i1)%charge+ratio2*endmem(i3)%charge endif loopf=loopf+1 do iz=1,ncc y4(iz)=cfact5(loopf)*y1(iz)+cfact5(ncf+1-loopf)*y2(iz) enddo if(loopf.ge.ncf) loopf=0 ! write(*,300)'3Y gp3 ',nm,nn,loopf,i1,i2,i3,charge,y4 !----------------------- first charged, second opposite, 1 gridp ! ratio 1/2 depend on charge case(4) do ll=1,nsl y1(endmem(i1)%constit(ll))=one y2(endmem(i2)%constit(ll))=one enddo ! neutral combination of 1 and 2 ratio1=abs(endmem(i2)%charge)/& (abs(endmem(i1)%charge)+abs(endmem(i2)%charge)) ratio2=abs(endmem(i1)%charge)/& (abs(endmem(i1)%charge)+abs(endmem(i2)%charge)) do iz=1,ncc y4(iz)=ratio1*y1(iz)+ratio2*y2(iz) enddo charge=ratio1*endmem(i1)%charge+ratio2*endmem(i2)%charge ! write(*,300)'3Y gp4 ',nm,nn,loopf,i1,i2,i3,charge,y4 !----------------------- first charged, second opposite, third neutral, 3 gridp ! ratio 1/2 depend on charge, ratio 3(1+2): 0.1; 0.5; 0.9 case(5) if(loopf.eq.0) then do ll=1,nsl y1(endmem(i1)%constit(ll))=one y2(endmem(i2)%constit(ll))=one y3(endmem(i3)%constit(ll))=one enddo ! neutral combination of 1 and 2 ratio1=abs(endmem(i2)%charge)/& (abs(endmem(i1)%charge)+abs(endmem(i2)%charge)) ratio2=abs(endmem(i1)%charge)/& (abs(endmem(i1)%charge)+abs(endmem(i2)%charge)) do iz=1,ncc y1(iz)=ratio1*y1(iz)+ratio2*y2(iz) enddo charge=ratio1*endmem(i1)%charge+ratio2*endmem(i2)%charge endif loopf=loopf+1 do iz=1,ncc y4(iz)=cfact5(loopf)*y1(iz)+cfact5(ncf+1-loopf)*y3(iz) enddo if(loopf.ge.ncf) loopf=0 ! write(*,300)'3Y gp5 ',nm,nn,loopf,i1,i2,i3,charge,y4 !----------------------- all charged, 2 and 3 same sign, 3 gridp ! ratio depend on charge case(6) if(loopf.eq.0) then do ll=1,nsl y1(endmem(i1)%constit(ll))=one y2(endmem(i2)%constit(ll))=one y3(endmem(i3)%constit(ll))=one enddo ! neutral combination of 1 and 3 ratio1=abs(endmem(i3)%charge)/& (abs(endmem(i3)%charge)+abs(endmem(i1)%charge)) ratio2=abs(endmem(i1)%charge)/& (abs(endmem(i3)%charge)+abs(endmem(i1)%charge)) do iz=1,ncc y3(iz)=ratio1*y1(iz)+ratio2*y3(iz) enddo charge=ratio1*endmem(i1)%charge+ratio2*endmem(i3)%charge ! write(*,410)'3Y gp charge 1+3: ',nm,i1,i2,i3,& ! endmem(i1)%charge,endmem(i2)%charge,endmem(i3)%charge,& ! ratio1,ratio2,charge ! neutral combination of 1 and 2 ratio1=abs(endmem(i2)%charge)/& (abs(endmem(i1)%charge)+abs(endmem(i2)%charge)) ratio2=abs(endmem(i1)%charge)/& (abs(endmem(i1)%charge)+abs(endmem(i2)%charge)) do iz=1,ncc y1(iz)=ratio1*y1(iz)+ratio2*y2(iz) enddo charge=ratio1*endmem(i1)%charge+ratio2*endmem(i2)%charge endif loopf=loopf+1 do iz=1,ncc y4(iz)=cfact5(loopf)*y1(iz)+cfact5(ncf+1-loopf)*y3(iz) enddo if(loopf.ge.ncf) loopf=0 ! write(*,300)'3Y gp6 ',nm,nn,loopf,i1,i2,i3,charge,y4 !----------------------- all charged, 1 and 3 same sign, 3 gridp ! ratio depend on charge case(7) if(loopf.eq.0) then do ll=1,nsl y1(endmem(i1)%constit(ll))=one y2(endmem(i2)%constit(ll))=one y3(endmem(i3)%constit(ll))=one enddo ! neutral combination of 1 and 2 ratio1=abs(endmem(i2)%charge)/& (abs(endmem(i2)%charge)+abs(endmem(i1)%charge)) ratio2=abs(endmem(i1)%charge)/& (abs(endmem(i2)%charge)+abs(endmem(i1)%charge)) do iz=1,ncc y1(iz)=ratio1*y1(iz)+ratio2*y2(iz) enddo charge=ratio1*endmem(i1)%charge+ratio2*endmem(i2)%charge ! write(*,410)'3Y gp charge 1+2: ',nm,i1,i2,i3,& ! endmem(i1)%charge,endmem(i2)%charge,endmem(i3)%charge,& ! ratio1,ratio2,charge ! neutral combination of 2 and 3 ratio1=abs(endmem(i3)%charge)/& (abs(endmem(i3)%charge)+abs(endmem(i2)%charge)) ratio2=abs(endmem(i2)%charge)/& (abs(endmem(i3)%charge)+abs(endmem(i2)%charge)) do iz=1,ncc y2(iz)=ratio1*y2(iz)+ratio2*y3(iz) enddo charge=ratio1*endmem(i2)%charge+ratio2*endmem(i3)%charge endif loopf=loopf+1 do iz=1,ncc y4(iz)=cfact5(loopf)*y1(iz)+cfact5(ncf+1-loopf)*y2(iz) enddo if(loopf.ge.ncf) loopf=0 ! write(*,300)'3Y gp7 ',nm,nn,loopf,i1,i2,i3,charge,y4 !----------------------- all charged, 1 and 2 same sign, 3 gridp ! ratio depend on charge case(8) if(loopf.eq.0) then do ll=1,nsl y1(endmem(i1)%constit(ll))=one y2(endmem(i2)%constit(ll))=one y3(endmem(i3)%constit(ll))=one enddo ! neutral combination of 1 and 3 ratio1=abs(endmem(i3)%charge)/& (abs(endmem(i3)%charge)+abs(endmem(i1)%charge)) ratio2=abs(endmem(i1)%charge)/& (abs(endmem(i3)%charge)+abs(endmem(i1)%charge)) do iz=1,ncc y1(iz)=ratio1*y1(iz)+ratio2*y3(iz) enddo charge=ratio1*endmem(i1)%charge+ratio2*endmem(i3)%charge ! write(*,410)'3Y gp charge 1+3: ',nm,i1,i2,i3,& ! endmem(i1)%charge,endmem(i2)%charge,endmem(i3)%charge,& ! ratio1,ratio2,charge 410 format(a,i4,3i3,6(1pe10.2)) ! neutral combination of 2 and 3 ratio1=abs(endmem(i3)%charge)/& (abs(endmem(i3)%charge)+abs(endmem(i2)%charge)) ratio2=abs(endmem(i2)%charge)/& (abs(endmem(i3)%charge)+abs(endmem(i2)%charge)) do iz=1,ncc y2(iz)=ratio1*y2(iz)+ratio2*y3(iz) enddo charge=ratio1*endmem(i2)%charge+ratio2*endmem(i3)%charge endif loopf=loopf+1 do iz=1,ncc y4(iz)=cfact5(loopf)*y1(iz)+cfact5(ncf+1-loopf)*y2(iz) enddo if(loopf.ge.ncf) loopf=0 ! write(*,300)'3Y gp8 ',nm,nn,loopf,i1,i2,i3,charge,y4 !----------------------- end select ! if(iph.ge.72) write(*,*)'3Y end select',iph,mode !=============================================================== ! Here we have the neutral constituent fraction in y4 ! if mode>0 we have found the requested constitution ! if(mode.lt.0) then ! write(*,*)'3Y We should never be here ...' ! goto 1000 if(mode.gt.0) then if(mode.eq.nm) then ! ncc and ncon should be identical, ny is returned as number of constituents ny=ncc do ll=1,ny yarr(ll)=y4(ll) enddo ! write(*,507)'3Y Solution gp: ',mode,ny,y4 507 format(a,2i5,10F7.4) goto 1000 endif ! continue searching for correct gridpoint of the solution else ngg=ngg+1 if(ngg.gt.maxngg) then write(*,*)'3Y too many gripoints 3',ngg,maxngg,iph gx%bmperr=4399; goto 1000 endif if(ngg.gt.0 .and. mod(ngg,30000).eq.0) & write(*,*)'3Y Gridmin calculated ',ngg,' gridpoints for ',& trim(phlista(lokph)%name) call calc_gridpoint(iph,y4,nrel,xarr(1,ngg),garr(ngg),ceq) if(lutbug.gt.0) then ! ny, ncon, ncc ?? write(lutbug,710)'I: ',ngg,nrel,ncon,garr(ngg),& (xarr(jj,ngg),jj=1,nrel),(y4(jj),jj=1,ncon) 710 format(a,i5,2i3,1pe10.2,20(0pF6.3)) endif if(gx%bmperr.ne.0) goto 1000 ! created a bug here, used ngg instead of nm .... suck ! if(garr(ngg).gt.gmax) gmax=garr(ngg) if(garr(ngg).gt.gmax) gmax=garr(ngg) ! write(*,512)nm,qq(2),gdum,(xarr(ll,nm),ll=1,nrel) 512 format('3Y gridpoint: ',i5,2(1pe12.4),7(0pF5.2),14(F5.2)) ! if(iph.ge.72) then ! write(*,*)'3Y calling done' ! write(*,515)(xarr(ll,nm),ll=1,nrel) !515 format('3Y yx: ',10F6.3) ! endif endif enddo ygen ! 1000 continue ! deallocate creates problems ... ! if(allocated(savengg)) then ! deallocate(savengg) ! deallocate(endmem) ! endif ! if(allocated(neutral)) then ! deallocate(neutral) ! deallocate(y1) ! deallocate(y2) ! deallocate(y3) ! deallocate(y4) ! endif ! restore original constitution ! write(*,*)'3Y Gridpoints for: ',iph,mode,np call set_constitution(iph,1,ydum,qq,ceq) if(gx%bmperr.ne.0) then write(*,*)'Error restoring constitution for: ',iph,gx%bmperr endif return end subroutine generate_charged_grid !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine calc_gridpoint !\begin{verbatim} subroutine calc_gridpoint(iph,yfra,nrel,xarr,gval,ceq) ! called by global minimization routine ! Not adopted to charged crystalline phases as gridpoints have net charge ! but charged gripoints have high energy, better to look for neutral ones ... implicit none real xarr(*),gval integer iph,nrel double precision yfra(*) TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} ! ny just needed for debugging ... integer i,lokres,lokph double precision qq(5),xmol(nrel),ytemp(maxconst),gg,ss TYPE(gtp_phase_varres), pointer :: varres ! set constitution and calculate G per mole atoms and composition ! ! BEWARE must be tested for parallel processing ! ! write(*,'(a,F8.2)')'3Y in calc_gridpoint',globaldata%sysreal(1) call set_constitution(iph,1,yfra,qq,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'3Y constitution set',qq(1) call calcg(iph,1,0,lokres,ceq) ! write(*,*)'3Y calculated G error:',gx%bmperr if(gx%bmperr.ne.0) goto 1000 call calc_phase_mol(iph,xmol,ceq) ! write(*,*)'3Y calculated x, error:',gx%bmperr if(gx%bmperr.ne.0) goto 1000 !------------------------------------------------- ! globaldata%sysreal(1) is positive if EEC activated if(globaldata%sysreal(1).gt.one) then ! if eec check if this is the liquid and if so select the maximum S ?? varres=>ceq%phase_varres(lokres) lokph=varres%phlink ! value per mole component gres(2,1) is the -entropy NOTE ss is postive!! ss=-varres%gval(2,1)/qq(1) gg=varres%gval(1,1) ! I do not understand why iph and lokph is not the same!! ! write(*,*)'3Y liqtest: ',iph,lokph eecheck: if(btest(phlista(lokph)%status1,PHLIQ)) then ! write(*,*)'In calc_gridpoint liquid: ',sliqmax ! if(sliqmax.gt.zero) exit eecheck ! neecgrid=neecgrid+1 ! note varres%gval(2,1) is -S !! Should we test max or min of liquid S ?? ! write(*,*)'Determining sliqmax: ',ss,sliqmax if(ss.gt.sliqmax) then ! write(*,'(a,i3,5(1pe10.2))')'Liquid gridpoint: ',iph,& ! ss,sliqmin,gliqeec,varres%gval(1,1)/qq(1) sliqmax=ss; gliqeec=varres%gval(1,1)/qq(1) endif ! note sliqmax is - dg/dt and always positive. It is the max entropy ! for the liquid at any gridpoint. If the solid has higher entropy ! it should not be allowed to be stable. elseif(sliqmax.gt.zero) then ! this is a solid and we have a value for sliqmax for EEC to work better ! write(*,*)'In calc_gridpoint solid: ',varres%gval(2,1)/qq(1),sliqmax if(ss.gt.sliqmax) then ! the solid s=-dG/dt is larger than sliqmax make the G more positive ! Note values are divided by RT. Multiply with the number of atoms? varres%gval(1,1)=(gg+1.5D1) ! varres%gval(1,1)=(gliqeec+one) ! write(*,'(a,2i3,5(1pe10.2))')'3Y Solid corr: ',iph,lokres,& ! ss,sliqmax,gg,varres%gval(1,1),qq(1) endif else write(*,*)'3Y Gridminimizer has no Sliqmax for solid',iph endif eecheck ! list EEC values ! write(*,11)'3Y EEC set: ',iph,xmol(1),ss,sliqmax,gg,varres%gval(1,1) 11 format(a,i3,F8.4,5(1pe12.4)) endif !-------------------------------------- do i=1,nrel xarr(i)=real(xmol(i)) enddo ! write(*,111)'3Y X:',qq(1),(xarr(i),i=1,nrel) 111 format(a,1pe12.4,20(F8.4)) ! handle special problems if(qq(1).lt.5.0D-1) then ! number of real atoms less than 50%, a gridpoint with mainly vacancies .... ! write(*,12)'3Y real atoms less than 0.5',lokres,qq(1),& ! ceq%phase_varres(lokres)%gval(1,1)/qq(1) 12 format(a,i5,3(1pe12.4)) gval=1.0E3 ! gval=max(1.0E2,real(ceq%phase_varres(lokres)%gval(1,1)/qq(1))) elseif(abs(qq(2)).gt.1.0D-14) then !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> ! the gridpoint has net charge, qq(2), make gval more positive. ! Note gval(1,1) is divided by RT so around -5<0 ! There is special grid generator combining charged gripoints!!!! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> ! gval=real(ceq%phase_varres(lokres)%gval(1,1)/qq(1)+20*qq(2)**2) ! gval=real(ceq%phase_varres(lokres)%gval(1,1)/qq(1)+5*qq(2)**2) write(*,*)'3Y Problem with net charge ',iph,qq(2) gval=real(ceq%phase_varres(lokres)%gval(1,1)/qq(1)+qq(2)**2) if(ocv()) write(*,66)'3Y charged gp: ',& ceq%phase_varres(lokres)%gval(1,1)/qq(1),qq(1),abs(qq(2)) 66 format(a,6(1pe12.4)) else gval=real(ceq%phase_varres(lokres)%gval(1,1)/qq(1)) endif ! write(*,'(a,1pe10.2,10(0pF6.3))')'3Y gp: ',gval,(xarr(i),i=1,nrel) ! write(*,12)'All gridpoints: ',lokres,qq(1),gval ! read(*,20)ch1 20 format(a) 1000 continue return end subroutine calc_gridpoint !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine calcg_endmember !\begin{verbatim} subroutine calcg_endmember(iphx,endmember,gval,ceq) ! calculates G for one mole of real atoms for a single end member ! used for reference states. Restores current composition (but not G or deriv) ! endmember contains indices in the constituent array, not species index ! one for each sublattice ! HERE G is divided by the number of atoms in the endmember implicit none integer iphx double precision gval integer endmember(maxsubl) TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer iph,ierr,kk0,ll,lokres,nsl,lokph integer nkl(maxsubl),knr(maxconst) double precision savey(maxconst),sites(maxsubl),yfra(maxconst) double precision qq(5),saveg(6) ! when called by matsmin negative iph should be interpreted as index to ! phlista, convert to phase index ... suck if(iphx.lt.0) then iph=phlista(-iphx)%alphaindex else iph=iphx endif ! write(*,*)'3Y calcg_endmember: ',iphx,' ',trim(phlista(abs(iphx))%name),& ! iph,' ',trim(phlista(iph)%name) ! call get_phase_data(iph,1,nsl,nkl,knr,savey,sites,qq,ceq) if(gx%bmperr.ne.0) goto 1100 ! set constitution to be just the endmember ! It is difficult to make this simpler as one can have magnetic contributions ! to G, thus it is not sufficient just to calculate the G function, one must ! calculate TC etc. yfra=zero kk0=0 do ll=1,nsl if(endmember(ll).gt.kk0 .and. endmember(ll).le.kk0+nkl(ll)) then yfra(endmember(ll))=one else write(*,16)'3Y endmember outside range 1: ',iph,ll,endmember(ll),& kk0,kk0+nkl(ll) 16 format(a,10i5) gx%bmperr=4160; goto 1100 endif kk0=kk0+nkl(ll) enddo ! write(*,17)'3Y set: ',kk0,(yfra(ll),ll=1,kk0) 17 format(a,i3,5(1pe12.4)) call set_constitution(iph,1,yfra,qq,ceq) if(gx%bmperr.ne.0) goto 1000 ! this was necessary using this routine when reference states are ! defined for components ! The calcg below returns lokres but we need it to save G values first!!! call get_phase_compset(iph,1,lokph,lokres) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'3Y saving gval: ',lokres,iph do ll=1,6 saveg(ll)=ceq%phase_varres(lokres)%gval(ll,1) enddo ! just calculate Gm no derivatives! call calcg(iph,1,0,lokres,ceq) if(gx%bmperr.ne.0) goto 1000 if(qq(1).ge.1.0D-2) then ! avoid calculating endmembers with too many vacancies. gval is divided by RT gval=ceq%phase_varres(lokres)%gval(1,1)/qq(1) ! write(*,*)'3Y gval: ',gval,qq(1) else ! write(*,*)'3Y End member has no atoms' gx%bmperr=4161; goto 1000 endif 1000 continue ! restore constitution and gval even if there has been an error flag!! ierr=gx%bmperr if(gx%bmperr.ne.0) gx%bmperr=0 ! write(*,17)'3Y res: ',kk0,(savey(i),i=1,kk0) do ll=1,6 ceq%phase_varres(lokres)%gval(ll,1)=saveg(ll) enddo call set_constitution(iph,1,savey,qq,ceq) if(gx%bmperr.ne.0) then write(*,*)'3Y Error resetting constitution: ',ierr,gx%bmperr endif ! return first error if any if(ierr.ne.0) gx%bmperr=ierr 1100 continue return end subroutine calcg_endmember !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine calcg_endmemberx !\begin{verbatim} subroutine calcg_endmemberx(iphx,endmember,gval,ceq) ! calculates G for single end member with current number of atoms ! used for reference states. Restores current composition (but not G or deriv) ! endmember contains indices in the constituent array, not species index ! one for each sublattice ! THIS ONE does not divide with the number of atoms implicit none integer iphx double precision gval integer endmember(maxsubl) TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer iph,ierr,kk0,ll,lokres,nsl,lokph integer nkl(maxsubl),knr(maxconst) double precision savey(maxconst),sites(maxsubl),yfra(maxconst) double precision qq(5),saveg(6) ! when called by matsmin negative iph should be interpreted as index to ! phlista, convert to phase index ... suck if(iphx.lt.0) then iph=phlista(-iphx)%alphaindex else iph=iphx endif ! write(*,*)'3Y calcg_endmember: ',iphx,' ',trim(phlista(abs(iphx))%name),& ! iph,' ',trim(phlista(iph)%name) ! call get_phase_data(iph,1,nsl,nkl,knr,savey,sites,qq,ceq) if(gx%bmperr.ne.0) goto 1100 ! set constitution to be just the endmember ! It is difficult to make this simpler as one can have magnetic contributions ! to G, thus it is not sufficient just to calculate the G function, one must ! calculate TC etc. yfra=zero kk0=0 do ll=1,nsl if(endmember(ll).gt.kk0 .and. endmember(ll).le.kk0+nkl(ll)) then yfra(endmember(ll))=one else write(*,16)'3Y endmember outside range 1: ',iph,ll,endmember(ll),& kk0,kk0+nkl(ll) 16 format(a,10i5) gx%bmperr=4160; goto 1100 endif kk0=kk0+nkl(ll) enddo ! write(*,17)'3Y set: ',kk0,(yfra(ll),ll=1,kk0) 17 format(a,i3,5(1pe12.4)) call set_constitution(iph,1,yfra,qq,ceq) if(gx%bmperr.ne.0) goto 1000 ! this was necessary using this routine when reference states are ! defined for components ! The calcg below returns lokres but we need it to save G values first!!! call get_phase_compset(iph,1,lokph,lokres) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'3Y saving gval: ',lokres,iph do ll=1,6 saveg(ll)=ceq%phase_varres(lokres)%gval(ll,1) enddo ! just calculate Gm no derivatives! call calcg(iph,1,0,lokres,ceq) if(gx%bmperr.ne.0) goto 1000 ! DO NOT DIVIDE WITH QQ gval=ceq%phase_varres(lokres)%gval(1,1) 1000 continue ! restore constitution and gval even if there has been an error flag!! ierr=gx%bmperr if(gx%bmperr.ne.0) gx%bmperr=0 ! write(*,17)'3Y res: ',kk0,(savey(i),i=1,kk0) do ll=1,6 ceq%phase_varres(lokres)%gval(ll,1)=saveg(ll) enddo call set_constitution(iph,1,savey,qq,ceq) if(gx%bmperr.ne.0) then write(*,*)'3Y Error resetting constitution: ',ierr,gx%bmperr endif ! return first error if any if(ierr.ne.0) gx%bmperr=ierr 1100 continue return end subroutine calcg_endmemberx !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine calcg_endmember6 !\begin{verbatim} %- subroutine calcg_endmember6(iph,endmember,gval,ceq) ! calculates G AND ALL DERIVATEVS wrt T and P for one mole of real atoms ! for a single end member, used for reference states. ! Restores current composition and G (but not deriv) ! endmember contains indices in the constituent array, not species index ! one for each sublattice ! THIS ONE returns 6 values: G, dG/dT; dG/dP; d2G/dT2; d2G/dTdP; d2G/dP2 implicit none integer iph double precision gval(6) integer endmember(maxsubl) TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer ierr,kk0,ll,lokres,lokph,nsl integer nkl(maxsubl),knr(maxconst),ics double precision savey(maxconst),sites(maxsubl),qq(5),yfra(maxconst) double precision saveg(6),savedabnorm(3) ! call get_phase_data(iph,1,nsl,nkl,knr,savey,sites,qq,ceq) if(gx%bmperr.ne.0) goto 1100 ! set constitution to be just the endmember ! It is difficult to make this simpler as one can have magnetic contributions ! to G, this it is not sufficient just to calculate the G function, one must ! calculate TC etc. yfra=zero kk0=0 ! NOTE abnorm(1) not restored by setting constitution, why? ics=1 call get_phase_compset(iph,ics,lokph,lokres) if(gx%bmperr.ne.0) goto 1000 savedabnorm=ceq%phase_varres(lokres)%abnorm ! write(*,432)'3Y em6a: ',ceq%phase_varres(lokres)%gval(3,1),& ! ceq%phase_varres(lokres)%abnorm(1),ceq%phase_varres(lokres)%amfu 432 format(a,6(1pe12.4)) ! write(*,11)'3Y refstate: ',iph,nsl,nkl(1),endmember(1) 11 format(a,10i5) do ll=1,nsl if(endmember(ll).gt.kk0 .and. endmember(ll).le.kk0+nkl(ll)) then yfra(endmember(ll))=one else write(*,16)'3Y endmember outside range 2',ll,endmember(ll),& kk0,nkl(ll) 16 format(a,10i5) gx%bmperr=4160; goto 1100 endif kk0=kk0+nkl(ll) enddo ! write(*,17)'set: ',kk0,(yfra(i),i=1,kk0) 17 format(a,i3,5(1pe12.4)) call set_constitution(iph,1,yfra,qq,ceq) if(gx%bmperr.ne.0) goto 1000 ! we do not know lokres here !! YES we do now ! ics=1 ! call get_phase_compset(iph,ics,lokph,lokres) ! if(gx%bmperr.ne.0) goto 1000 do ll=1,6 ! Why dividing with qq(1)??? ! saveg(ll)=ceq%phase_varres(lokres)%gval(ll,1)/qq(1) saveg(ll)=ceq%phase_varres(lokres)%gval(ll,1) enddo ! third argument to calcg is 2 to calculate all derivatives call calcg(iph,1,2,lokres,ceq) if(gx%bmperr.ne.0) goto 1000 if(qq(1).ge.1.0D-2) then ! avoid calculating endmembers with too many vacancies. gval is divided by RT ! gval(1..6,1) are G, G.T, G.P, G.T.T, G.T.P and G.P.P do ll=1,6 gval(ll)=ceq%phase_varres(lokres)%gval(ll,1)/qq(1) enddo else ! write(*,*)'End member has no atoms' gx%bmperr=4161; goto 1000 endif ! we do not restore values of other properties like TC BMAGN etc do ll=1,6 ceq%phase_varres(lokres)%gval(ll,1)=saveg(ll) enddo 1000 continue ierr=gx%bmperr if(gx%bmperr.ne.0) gx%bmperr=0 ! restore constitution ! write(*,17)'res: ',kk0,(savey(i),i=1,kk0) call set_constitution(iph,1,savey,qq,ceq) ! this is probably redundant ... ceq%phase_varres(lokres)%abnorm=savedabnorm ! write(*,432)'3Y em6b: ',ceq%phase_varres(lokres)%gval(3,1),& ! ceq%phase_varres(lokres)%abnorm(1),ceq%phase_varres(lokres)%amfu if(gx%bmperr.ne.0) then if(ierr.ne.0) then write(*,*)'Double errors in calcg_endmember: ',ierr,gx%bmperr endif endif ! return first error if any if(ierr.ne.0) gx%bmperr=ierr 1100 continue return end subroutine calcg_endmember6 !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine find_gridmin !\begin{verbatim} subroutine find_gridmin(kp,nrel,xarr,garr,xknown,jgrid,phfrac,cmu,trace) ! there are kp gridpoints, nrel is number of components ! composition of each gridpoint in xarr, G in garr ! xknown is the known overall composition ! return the gridpoints of the solution in jgrid, the phase fraction in phfrac ! cmu are the final chemical potentials implicit none integer, parameter :: jerr=50 integer kp,nrel integer, dimension(*) :: jgrid real xarr(nrel,*),garr(*) double precision xknown(*),phfrac(*),cmu(nrel) logical trace !\end{verbatim} !------------------------------------------------------------------------ ! How to include conditions on chemical potentials (activities) ?? ! Assume mix of conditions N(A)=value and MU(B)=value ! 1. find gridpoints with phase alpha for pure A with highest MU(A), ! set NP(alpha)=N(A) ! 2. Tangent plane is \sum_A MU(A)+\sum_B MU(B) ! 2. seach gridpoint with composition N(C) most below tangent plane ! 3. setup matrix with rows \sum_alpha N(alpha,A)*NP(alpha) = N(A) ! replacing the gridpoints one by onw with the new ! to find a set of gridpoints with positive NP(alpha) ! 4. replace the gridpoint that gives positive NP(alpha) with the new ! 5. repeat from 3 intil no gridpoint lower ! The set of gridpoints should now fullfill the massbalance for A and MU(B) !--------------------------------------------------------------------------- ! inverting just a C1_MO2 phase I got phfmain around 1.0e-13 as smallest double precision, parameter :: phfmin=1.0D-15 real xmat(nrel,nrel),xmatsave(nrel,nrel),xmaxx(nrel) ! used to solve the linear system of equations double precision qmat(nrel,nrel+1),qmatsave(nrel,nrel+1) double precision zmat(nrel,nrel+1),cmusave(nrel) integer notuse(kp),i,ie,iel,ierr,iesave,inerr,inuse,ip,je,jj,jp,jsave,nj integer nrel1,nyp,griter,nopure(nrel),gpfail,evigloop double precision phfsave(nrel) integer, dimension(jerr) :: removed real gmin(nrel),dg,dgmin,gplan,gy,gvvp ! gridpoints that has less difference with the plane than this limit is ignored real, parameter :: dgminlim=1.0E-6 logical checkremoved,linglderr,grindingon,failadd character ch1*1 ! if trace then open file to write grid linglderr=.FALSE. grindingon=.TRUE. failadd=.TRUE. if(trace) then write(*,*)'3Y Opening ocgrid.dat to write grid solution' open(31,file='ocgrid.dat ',access='sequential') write(31,700)nrel,kp,(xknown(inuse),inuse=1,nrel) 700 format('Output from OC gridmin'/' Elements: ',i2,', gridpoints: ',i5,& ', composition: '/6(F7.4)) write(31,*)' Gridpoints in use: ' do inuse=1,kp write(31,710)inuse,(xarr(inerr,inuse),inerr=1,nrel),garr(inuse) 710 format(i6,6(1pe12.4)) enddo endif ! initiallize local arrays inuse=kp inerr=0 removed=0 notuse=0 cmu=zero xmat=zero qmat=zero do je=1,nrel xmat(je,je)=9.9D-1 jgrid(je)=0 enddo nrel1=nrel+1 checkremoved=.false. ! write(*,11)'3Y fm8: ',(xknown(i),i=1,nrel) !11 format(a,7(F8.4)) ! Find the lowest Gibbs energy as close as possible to each pure element ! or with max content nopure=0 ! skip code below until label 88 goto 88 !---------------------------------------------------------------------- do ip=1,kp ! write(*,118)'3Y pure: ',ip,(xarr(je,ip),je=1,nrel) 118 format(a,i5,10F6.3) do je=1,nrel if(xarr(je,ip).ge.xmat(je,je)) then if(jgrid(je).gt.0) then if(garr(ip).gt.gmin(je)) goto 120 ! if(gmin(je).lt.garr(ip) .and. & ! xarr(je,ip).eq.xmat(je,je)) then ! goto 120 ! endif endif xmat(je,je)=xarr(je,ip) jgrid(je)=ip gmin(je)=garr(ip) ! write(*,*)'3Y pure: ',je,ip,gmin(je) ! elseif(jgrid(je).eq.0 .and. xarr(je,ip).gt.xmaxx(je)) then ! failed attempt to handle cases with no gridpoint for a pure element ! xmaxx(je)=xarr(je,ip) ! nopure(je)=ip ! gmin=garr(ip) ! write(*,*)'3Y nopure: ',je,ip,xarr(je,ip) endif 120 continue enddo enddo ! check that we have nrel gridpoints for the pure elements do je=1,nrel if(jgrid(je).eq.0) then ! no gridpoint assigned to this element!! error (note C in pure fcc has no gp) ! gx%bmperr=4149; goto 1000 write(*,122)'3Y Warning, no gridpoint for pure element ',je ! nopure(je),xmaxx(je) 122 format(a,2i5,2F7.4) if(nopure(je).eq.0) then ! write(*,122)'3Y No solubility in any phase for element ',je gx%bmperr=4149; goto 1000 elseif(xarr(je,nopure(je)).gt.xknown(je)) then ! accept gripoint with highest content of element je outside known composition do ie=1,nrel xmat(ie,je)=xarr(ie,nopure(je)) enddo gmin(je)=garr(ip) phfrac(je)=xknown(je) else write(*,122)'3Y Composition outside phase compositions for element',& je,nopure(je),xmaxx(je),xknown(je) gx%bmperr=4149; goto 1000 endif else ip=jgrid(je) do ie=1,nrel xmat(ie,je)=xarr(ie,ip) enddo gmin(je)=garr(ip) phfrac(je)=xknown(je) endif enddo ! skip code above----------------------------------------- 88 continue ! set start matrix with chemical potential equal to cmu(1) (max G all gridpoint) ! for all components do iel=1,nrel phfrac(iel)=xknown(iel) xmat(iel,iel)=one cmu(iel)=1.0D8 ! jgrid value here is dummy ... jgrid(iel)=kp+iel ! we must also set gridpoint enegies!!! maybe 1.0D20 better .... gmin(iel)=1.0D8 enddo ! check inial chemical potentials and gripoint energies... ! write(*,63)'3Ymu: ',(cmu(ie),ie=1,nrel) !63 format(a,8(1pe10.2)) ! write(*,63)'3Ygm: ',(gmin(ie),ie=1,nrel) ! Add nrel "gridpoints" for the pure elements ! kp=kp+nrel ! output of start matrix ! do ip=1,nrel ! write(*,121)ip,phfrac(ip),cmu(ip),(xmat(je,ip),je=1,nrel) ! enddo ! write(*,119)'3Y start: ',0,0,kp,zero,(jgrid(ip),ip=1,nrel) 119 format(a,3i6,1pe12.4/(12i6)) 121 format('3Y: ',i2,2(1pe10.2),12(0pf5.2)) 123 format('3Y: ',i2,1pe12.4,10(0pf6.3)) ! looking for tbase calculation error ! if(trace) write(*,770)(jgrid(je),je=1,nrel) !770 format('Initial set of gridpoints: ',(/15i5)) do je=1,nrel if(one-xmat(je,je).lt.1.0d-12) then cmu(je)=dble(gmin(je)) else ! we should have a composition for an almost pure element gx%bmperr=4150; goto 1000 endif enddo ! copy this into qmat (double precision) do ie=1,nrel do je=1,nrel qmat(je,ie)=dble(xmat(je,ie)) enddo enddo qmatsave=qmat ! debug output ! do je=1,nrel ! write(*,177)'3Y fm4: ',jgrid(je),phfrac(je),(xmat(ie,je),ie=1,nrel) ! enddo 177 format(a,i5,1pe11.3,2x,5(1pe11.3)) gvvp=zero do ie=1,nrel gvvp=gvvp+xknown(ie)*cmu(ie) enddo if(trace) then write(31,715)nrel 715 format(/'3Y Initial matrix:',i3) do je=1,nrel write(31,720)'3Y1:',xknown(je),xknown(je),(xmat(ie,je),ie=1,nrel) enddo 720 format(a,2F7.4,1x,8f7.3) write(31,730)gvvp,(cmu(je),je=1,nrel) 730 format('3Y Gibbs energy: ',1pe14.6/'Chemical potentials: '/6(1pe12.4)) endif griter=0 gpfail=0 ! write(*,175)'3Y ini: ',gvvp,(cmu(ie),ie=1,nrel) 175 format(a,(1e12.4),2x,6(1pe12.4)) ! write(*,*)'3Y gvvp: ',gvvp ! check we have the correct global composition ! call chocx('fgm1 ',nrel,jgrid,phfrac,xmat) ! if(gx%bmperr.ne.0) goto 1000 ! write(*,173)gvvp,(jgrid(i),i=1,nrel) 173 format('3Y fms: ',1pe12.4,10i5) ! read(*,174)ch1 !174 format(a) !---------------------------------------------------------- ! All setup for starting the search ! search the gridpoint most below the current hyperplane, cmu are ! the chemical potentials of each pure element for the current lowest plane. ! set notuse nonzero for all points above so they can be skipped next time ! TBASE problem, notuse suspended as a point may fall below later ... ??? evigloop=0 200 continue griter=griter+1 dgmin=zero nyp=0 ! write(*,*)'3Y Gridpoints in use: ',inuse ! ovall=zero ! do i=1,nrel ! ovall=ovall+xknown(i)*cmu(i) ! enddo ! write(*,203)'3Y ff:',inuse,ovall,(cmu(je),je=1,nrel) 203 format(a,i4,1pe12.4,6(1pe11.3)) pointloop: do jp=1,kp included: if(notuse(jp).eq.0) then gplan=zero ! first index in xarr is component, second is gridpoint do iel=1,nrel gplan=gplan+xarr(iel,jp)*cmu(iel) enddo dg=garr(jp)-gplan ! write(*,209)'3Y fmz: ',dg,garr(jp),gplan 209 format(a,3(1pe12.4)) if(dg.gt.zero) then ! inuse=inuse-1 ! we cannot be sure that a point that has a positive value now will always be ! above the surface of the chemical potentials!!! ! notuse(jp)=1 else ! if this is the most negative dg we should include it in the solution if(dg.lt.dgmin) then dgmin=dg; nyp=jp ! write(*,*)'3Y Lower G: ',griter,nyp,kp,dgmin endif ! debugging LC_CsI (61) and SC_CsI (94) ! if(jp.eq.61 .or. jp.eq.94) & ! write(*,44)'3Y extra: ',jp,dg,dgmin,garr(jp),gplan 44 format(a,i5,5(1pe12.4)) endif ! else ! write(*,*)'3X Excluded: ',griter,jp endif included enddo pointloop !----------------------------------------------------------- ! OUTPUT AFTER EACH SEARCH ! if lower gridpoint nyp>0 ! write(*,43)griter,nyp,kp,dgmin,(jgrid(ie),ie=1,nrel) 43 format('3Y Finished loop ',i6,' for all gridpoints: ',2i6,1pe12.4/12i6) ! TBASE bug------------------------ ! jp=94 ! do iel=1,nrel ! gplan=gplan+xarr(iel,jp)*cmu(iel) ! enddo ! dg=garr(jp)-gplan ! write(*,7677)jp,gplan,garr(jp),dg,(xarr(iel,jp),iel=1,nrel) !7677 format('3Y Gridpoint: ',i5,3(1pe12.4)/(10f7.4)) ! TBASE bug------------------------end ! if nyp=0 we have found the lowest tangent plane including the composition if(nyp.eq.0 .or. abs(dgmin).lt.dgminlim) then if(trace) write(31,*)'Found the solution after iterations: ',griter,dgmin ! write(31,*)'Found the solution after iterations: ',griter,dgmin goto 900 else if(trace) write(*,*)'3Y new gridpoint: ',griter,nyp,dgmin endif ! inuse=inuse-1 notuse(nyp)=1 ! write(*,211)'3Y ny:',nyp,dgmin,(xarr(ie,nyp),ie=1,nrel) ! if(trace) write(*,212)'3Y Found gridpoint ',nyp,inuse,dgmin,garr(nyp) ! evigloop happends when two gridpoints are exchanged ! uncomment the line below indicated gridmin can be improved ... ! write(*,212)'3Y Found gridpoint ',nyp,inuse,dgmin,garr(nyp) 211 format(a,i7,1pe12.4,0pf7.4,6f7.4,(3x,10f7.4)) 212 format(a,2i8,6(1pe11.3)) !------------------------------------------------------------------------- ! A case found when this seach never enden evigloop=evigloop+1 if(evigloop.gt.500) then write(*,*)'3Y Gridmin gives up finding minimal set of gridpoints',evigloop goto 900 endif qmat=qmatsave do i=1,nrel phfsave(i)=phfrac(i) enddo ie=0 ! loop to try to replace an old gridpoint by nyp. Try to replace all. 300 continue ie=ie+1 if(ie.gt.nrel) then ! tried to change all columns but no solution, error ! write(*,301)'3Y Failed gp: ',nyp,gpfail,(xarr(i,nyp),i=1,nrel) 301 format(a,i7,i3,1pe10.2,2x,8(0pF5.2)) gpfail=gpfail+1 if(griter.gt.10*nrel .and. gpfail.gt.8*nrel) then ! this must be wrong!! Maybe someone can understand it ... if(grindingon) then write(*,*)'3Y Grid minimizer problem but grinding on ' grindingon=.false. endif ! gx%bmperr=4346; goto 1000 endif ! listing restored solution ...... ! xtx=zero ! do jjq=1,nrel ! write(*,177)'3Y flp: ',jgrid(jjq),phfrac(jjq),(xmat(ie,jjq),ie=1,nrel) ! do jjz=1,nrel ! xtx(jjz)=xtx(jjz)+phfrac(jjq)*xmat(jjz,jjq) ! enddo ! enddo ! gvv=zero ! do jjq=1,nrel ! gvv=gvv+xtx(jjq)*cmu(jjq) ! enddo ! write(*,175)'3Y cur: ',gvv,(cmu(ie),ie=1,nrel) ! ! >>>> problem with gas phase test case cho1 with x(c)=.2 x(o)=x(H)=.4 ! The gridpoints returned not good, probably due to too many gridpoints ... ! if(trace) write(*,*)'3Y Failed when trying to add gridpoint ',nyp if(failadd) then write(*,*)'3Y Failed trying to use some gridpoints ' failadd=.false. endif if(checkremoved) goto 950 ! just ignore this gridpoint and continue, it has been added to notuse ! and will be checked again later as "removed" inerr=inerr+1 if(inerr.gt.jerr) then inerr=1 endif removed(inerr)=nyp goto 200 endif ! replace one column in qmat by new composition do je=1,nrel qmat(je,ie)=dble(xarr(je,nyp)) enddo ! right hand side are the known composition do je=1,nrel qmat(je,nrel1)=xknown(je) enddo ! solver, note qmat is destroyed inside lingld, nrel is dimension ! qmat matrix with left hand side as additional column i.e. QMAT(1..ND1,ND2) ! phfrac(ND1) is result array, nz number of unknown, ierr nonzero=error ! do ik=1,nrel1 ! write(*,317)'3Y fm6A: ',(qmat(je,ik),je=1,nrel) ! enddo ! do je=1,nrel ! write(*,55)(qmat(je,iel),iel=1,nrel+1) ! enddo !55 format('3Yq:',7(1pe11.3)) call lingld(nrel,nrel1,qmat,phfrac,nrel,ierr) if(ierr.ne.0) then ! error may occur and is not fatal, just try to replace next column ! write(*,*)'3Y failed replace: ',dgmin if(.not.linglderr) then if(ocv()) write(*,*)'3Y gridmin warning(s) using lingld: ',ierr,nyp linglderr=.TRUE. endif qmat=qmatsave do i=1,nrel phfrac(i)=phfsave(i) enddo goto 300 endif ! write(*,299)'3Y q: ',ierr,(phfrac(iel),iel=1,nrel) !299 format(a,i5,7(1pe10.2)) ! read(*,302)ch1 302 format(a) ! write(*,*)'3Y fm6B: ',ie,ierr ! write(*,317)'3Y fm6C: ',(phfrac(i),i=1,nrel) 317 format(a,6(1pe12.4)) !----------------------- ! if solution has only positive values accept this, ierr nonzero if singular do je=1,nrel if(phfrac(je).le.phfmin .or. phfrac(je).gt.one) then ! maybe problems if known composition have almost zero of some components? ! restore qmat ! write(*,*)'3Y fm6D: ',je qmat=qmatsave do i=1,nrel phfrac(i)=phfsave(i) enddo goto 300 endif enddo ! write(*,*)'3Y Replaced column: ',ie,nyp ! we have found that column ie should be replaced !-------------------------------------------------- ! update xmat, qmatsave and gmin ! as we may fail to find the solution for the chemical potentials later ! keep a copy that can be restored iesave=ie jsave=jgrid(iesave) ! mark that the replaced gridpoint should be checked again .... ! write(*,*)'3Y Putting gridpoint back: ',jgrid(ie) ! DO NOT SAVE THE PURE ELEMENT POINTS ... >k ! write(*,*)'3Y for notuse: ',ie,jgrid(ie),size(notuse) if(jgrid(ie).le.size(notuse)) then notuse(jgrid(ie))=0 endif jgrid(ie)=nyp xmatsave=xmat do je=1,nrel xmat(je,ie)=xarr(je,nyp) qmatsave(je,ie)=dble(xarr(je,nyp)) enddo gmin(ie)=garr(nyp) ! do ik=1,nrel ! write(*,317)'3Y fm6F: ',(xmat(je,ik),je=1,nrel) ! enddo ! write(*,317)'3Y fm6G: ',(gmin(je),je=1,nrel) ! to solve for the chemical potentials we have ro replace the rows by ! columns, there is a TRANSPOSE command for symmetrical matrices do ie=1,nrel do je=1,nrel zmat(ie,je)=qmatsave(je,ie) enddo enddo ! we have changed the solution, calculate new chemical potentials do je=1,nrel zmat(je,nrel1)=gmin(je) enddo ! do ik=1,nrel1 ! write(*,317)'3Y fm8A: ',(zmat(je,ik),je=1,nrel) ! enddo cmusave=cmu call lingld(nrel,nrel1,zmat,cmu,nrel,ierr) if(ierr.ne.0) then ! this should also be handelled by ignoring the new gridpoint but ! here we must restore the xmat, qmatsave and cmu. write(*,*)'3Y Failed to calculate chemical potentials',ierr ! if(trace) write(*,*)'3Y Error from LINGLD for chem.pot.: ',ierr,nyp if(checkremoved) goto 950 inerr=inerr+1 if(inerr.gt.jerr) then inerr=1 endif removed(inerr)=nyp jgrid(iesave)=jsave cmu=cmusave xmat=xmatsave do ie=1,nrel do je=1,nrel qmatsave(ie,je)=dble(xmat(ie,je)) enddo enddo ! we may have successfully added a removed gridpoint if(checkremoved) then goto 950 endif goto 200 endif ! check new chemical potentials ... ! write(*,63)'3Yny: ',(cmu(ie),ie=1,nrel) ! calculate total G ! gvv=zero ! do ie=1,nrel ! do je=1,nrel ! first index is component, second is species ! gvv=gvv+xmat(je,ie)*cmu(je) ! enddo ! enddo ! if(trace) write(*,*)'3Y New total G: ',gvv,gvvp ! check if gvv is lower than previous ! if(gvv.gt.gvvp) then ! write(*,*)'3Y *** Gibbs energy increased, restore!' ! endif ! gvvp=gvv !---------------------------------------------------------- ! debug output as we have changed one gridpoint ! xtx=zero ! do jjq=1,nrel ! write(*,177)'3Y gpf: ',jgrid(jjq),phfrac(jjq),(xmat(ie,jjq),ie=1,nrel) ! do jjz=1,nrel ! xtx(jjz)=xtx(jjz)+phfrac(jjq)*xmat(jjz,jjq) ! enddo ! enddo ! gvv=zero ! do jjq=1,nrel ! gvv=gvv+xtx(jjq)*cmu(jjq) ! enddo ! write(*,175)'3Y ny4: ',gvv,(cmu(ie),ie=1,nrel) ! write(*,317)'3Y new cmu: ',(cmu(je),je=1,nrel) ! read(*,321)ch1 !321 format(a) gy=zero do ie=1,nrel gy=gy+xknown(ie)*cmu(ie) enddo ! write(*,199)griter,gvvp,gy 199 format('3Y Gibbs energy changed: ',i5,2(1pe15.6)) gvvp=gy ! if(trace) then write(31,740)griter,nyp 740 format(/'Iteration ',i6,' found gridpoint: ',i6,', new matrix:') do je=1,nrel write(*,720)'3Yz:',phfrac(je),xknown(je),(xmat(je,ie),ie=1,nrel) enddo write(31,730)gvvp,(cmu(je),je=1,nrel) endif if(checkremoved) then write(*,198)nyp 198 format('3Y Added previously removed gridpoint ',i6) goto 950 endif !---------------------------------------------- ! here we go back to loop through all gridpoints again ! write(*,*)'3Y New search: ',griter goto 200 !============================================== 900 continue if(gpfail.gt.0) then ! NOTE is a H-O gas with N(H)=2 N(O)=1 it fails to find H2O because then ! there is just one gridpoint stable! write(*,906)gpfail 906 format('3Y Gridmin could not make use of ',i7,' gridpoint(s)') endif ! write(*,*)'3Y Gridmin has found a solution' ! write(*,316)'3Y fm9A: ',(jgrid(i),i=1,nrel) ! do ik=1,nrel ! write(*,317)'3Y fm9B: ',(xmat(je,ik),je=1,nrel) ! enddo ! write(*,317)'3Y fm9C: ',(garr(je),je=1,nrel) ! write(*,317)'3Y fm9D: ',(cmu(je),je=1,nrel) ! write(*,317)'3Y fm9E: ',(phfrac(je),je=1,nrel) 316 format(a,10i5) nj=0 ! do j=1,jerr ! if(removed(j).gt.0) then ! write(*,*)'3Y Failed testing gridpoint ',removed(j) ! nj=nj+1 ! endif ! enddo 950 continue nj=0 checkremoved=.true. ! write(*,*)'3Y Checking removed gridpoints',inerr ! xtx=zero ! do jjq=1,nrel ! write(*,177)'3Y flp: ',jgrid(jjq),phfrac(jjq),(xmat(ie,jjq),ie=1,nrel) ! do jjz=1,nrel ! xtx(jjz)=xtx(jjz)+phfrac(jjq)*xmat(jjz,jjq) ! enddo ! enddo ! gvv=zero ! do jjq=1,nrel ! gvv=gvv+xtx(jjq)*cmu(jjq) ! enddo ! write(*,175)'3Y cur: ',gvv,(cmu(ie),ie=1,nrel) !---------------- testloop: do jj=1,inerr jp=removed(jj) ! write(*,*)'3Y Checking removed gridpoint: ',jj,jp if(jp.gt.0) then gplan=zero do iel=1,nrel gplan=gplan+xarr(iel,jp)*cmu(iel) enddo dg=garr(jp)-gplan if(dg.lt.zero) then ! if(trace) write(*,985)jp,dg,garr(jp),gplan ! write(*,982)jp,dg,garr(jp),gplan 982 format('3Y Removed gridpoint ',i5,' is below surface ',3(1pe12.4)) ! try to include it .... ie=0 removed(jj)=-jp nyp=jp goto 300 else ! write(*,983)jp,dg 983 format('3Y Removed gridpoint ',i5,' above surface ',1pe12.4) removed(jj)=-jp endif endif enddo testloop if(inerr.gt.0 .and. nj.eq.0) then ! if(trace) write(*,986)inerr 986 format('3Y None of the ',i3,' removed gridpoints below final surface') endif if(trace) write(*,771)(jgrid(je),je=1,nrel) 771 format('3Y Final set of gridpoints: ',(/15i5)) ! xtx=0 ! do iii=1,nrel ! write(*,987)jgrid(iii),phfrac(iii),(xarr(i,jgrid(iii)),i=1,nrel) !987 format('3Y GP: ',i5,F7.4,2x,6F9.6) ! do j=1,nrel ! xtx(j)=xtx(j)+phfrac(iii)*xarr(j,jgrid(iii)) ! enddo ! enddo ! write(*,988)(xtx(i),i=1,nrel) !988 format('3Y MF: ',6F9.6) ! ! call chocx('fgme ',nrel,jgrid,phfrac,xmat) 1000 continue ! write(*,*)'3Y exit find_gridmin' return end subroutine find_gridmin !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine merge_gridpoints !\begin{verbatim} subroutine merge_gridpoints(nv,iphl,aphl,nyphl,yphl,trace,nrel,xsol,cmu,ceq) ! ! BEWARE not adopted for parallel processing ! ! if the same phase has several gridpoints check if they are really separate ! (miscibility gaps) or if they can be murged. Compare them two by two ! nv is the number of phases, iphl(i) is the index of phase i, aphl(i) is the ! amount of phase i, nyphl is the number of site fractions for phase i, ! and yphl is the site fractions packed together ! implicit none TYPE(gtp_equilibrium_data), pointer :: ceq integer nv,nrel integer, dimension(*) :: iphl,nyphl double precision, dimension(*) :: aphl,yphl,cmu logical trace real xsol(maxel,*) !\end{verbatim} integer i,ip,iph,jp,jump,kk,klast,kp,lokres,nm,jj,mj,lokph,j,npm integer notuse(nv),incy(nv) double precision ycheck(maxconst),qq(5),xerr(maxel),xfromy(maxel) double precision summu,sumam logical igen real xmix(maxel) double precision a1,a2,gdf,gval1,gval2,gval3,gval4,gval5,gmindif character phname*24 ! ! gmindif is the value to accept to merge two gridpoints ! It should be a variable that can be set by the user for finetuning ! write(*,*)'3Y Now we try to merge gridpoints in the same phase' ! write(*,7)'3Y Merge_gridpoints is dissabled for the moment',nv !7 format(a,i3) ! NOTE, always merge gripoints in ideal phases like gas ! UNFINISHED gmindif=ceq%gmindif ! used for testing 190603/BoS ! gmindif=-1.0D-2 ! write(*,'(a,i3,1pe12.4)')'3Y Entering merge_gridpoints',nv,ceq%gmindif ! goto 1100 !--------------------- notuse=0 nm=0 npm=0 ! write(*,67)'3Y yl: ',(aphl(i),nyphl(i),i=1,nv) 67 format(a,20(F7.3,i4)) incy(1)=1 do i=2,nv incy(i)=incy(i-1)+nyphl(i-1) enddo ! start points of fractions for all gridpoints ! write(*,68)'3Y ys: ',(incy(i),i=1,nv) 68 format(a,20i5) summu=zero xerr=zero ! constitution of solution gridpoints ! do jp=1,nv ! write(*,69)'3Y y:',(yphl(incy(jp)+i-1),i=1,nyphl(jp)) ! enddo 69 format(a,(12F6.2)) ! this calculate the overall composition from gridpoints do jp=1,nv summu=summu+aphl(jp) do i=1,nrel xerr(i)=xerr(i)+aphl(jp)*xsol(i,jp) enddo enddo ! write(*,73)'3Y in1: ',summu,(xerr(i),i=1,nrel) 73 format(a,F5.2,2x,9(f7.4)) !---------------------------------------------- 100 continue igen=.false. firstgp: do jp=1,nv-1 ! write(*,*)'3Y notuse 1: ',jp,notuse(jp) if(notuse(jp).ne.0) cycle firstgp secondgp: do kp=jp+1,nv ! write(*,*)'3Y notuse 2: ',kp,notuse(kp) if(notuse(kp).ne.0) cycle secondgp sameph: if(iphl(jp).eq.iphl(kp)) then gdf=zero iph=iphl(jp) lokph=phases(iph) if(btest(phlista(lokph)%status1,PHID)) then ! always merge gridpoints in ideal phases for example gas goto 200 endif ! do not merge gridpoints in other phases if(btest(globaldata%status,GSNOMERGE)) cycle secondgp ! calculate G at 0 and 1 and 0.25, 0.5, 0.75 mix of gridpoints ! if any of these abouve the line between any two others do not merge ! as merged gridpoints are below the initial common tahnegt plane we cannot ! use that as reference call set_constitution(iph,1,yphl(incy(jp)),qq,ceq) if(gx%bmperr.ne.0) goto 1000 call calcg(iph,1,0,lokres,ceq) if(gx%bmperr.ne.0) goto 1000 gval1=ceq%phase_varres(lokres)%gval(1,1)/qq(1) ! second point call set_constitution(iph,1,yphl(incy(kp)),qq,ceq) if(gx%bmperr.ne.0) goto 1000 call calcg(iph,1,0,lokres,ceq) if(gx%bmperr.ne.0) goto 1000 gval5=ceq%phase_varres(lokres)%gval(1,1)/qq(1) ! take middle point a1=5.0D-01 a2=5.0D-01 do i=0,nyphl(jp)-1 ycheck(i+1)=a1*yphl(incy(jp)+i)+a2*yphl(incy(kp)+i) enddo call set_constitution(iph,1,ycheck,qq,ceq) if(gx%bmperr.ne.0) goto 1000 call calcg(iph,1,0,lokres,ceq) if(gx%bmperr.ne.0) goto 1000 gval3=ceq%phase_varres(lokres)%gval(1,1)/qq(1) ! Check if this is above the mean of gval1 and gval5, if so quit merge gdf=gval3-a1*gval1-a2*gval5 ! merge require that difference is less than gmindif or phase ideal if(gdf.gt.gmindif) then ! middle is higher, no merge 1-3-5 ! write(*,830)'3Y not merged 9: ',jp,kp,gdf,iphl(jp),gmindif cycle secondgp endif ! calculate G at 0.25 a1=7.5D-01 a2=2.5D-01 do i=0,nyphl(jp)-1 ycheck(i+1)=a1*yphl(incy(jp)+i)+a2*yphl(incy(kp)+i) enddo call set_constitution(iph,1,ycheck,qq,ceq) if(gx%bmperr.ne.0) goto 1000 call calcg(iph,1,0,lokres,ceq) if(gx%bmperr.ne.0) goto 1000 gval2=ceq%phase_varres(lokres)%gval(1,1)/qq(1) ! Check if this is above the mean of gval1 and gval5, if so quit merge gdf=gval2-a1*gval1-a2*gval5 if(gdf.gt.gmindif) then ! middle is higher, no merge 1-2-5 ! write(*,830)'3Y not merged 1: ',jp,kp,gdf,iphl(jp),gmindif cycle secondgp else ! also compare between gval1 and gval3 gdf=gval2-a1*gval1-a2*gval3 if(gdf.gt.gmindif) then ! gval2 is s higher, no merge 1-2-3 ! write(*,830)'3Y not merged 2: ',jp,kp,gdf,iphl(jp),gmindif cycle secondgp endif endif ! finally calculate at 0.75 ! calculate G at 0.25 a1=2.5D-01 a2=7.5D-01 do i=0,nyphl(jp)-1 ycheck(i+1)=a1*yphl(incy(jp)+i)+a2*yphl(incy(kp)+i) enddo call set_constitution(iph,1,ycheck,qq,ceq) if(gx%bmperr.ne.0) goto 1000 call calcg(iph,1,0,lokres,ceq) if(gx%bmperr.ne.0) goto 1000 gval4=ceq%phase_varres(lokres)%gval(1,1)/qq(1) ! Check if this is above the mean of gval1 and gval5, if so quit merge gdf=gval4-a1*gval1-a2*gval5 if(gdf.gt.gmindif) then ! gval4 is higer mo merge 1-4-5 ! write(*,830)'3Y not merged 3',jp,kp,gdf,iphl(jp),gmindif cycle secondgp else gdf=gval4-a1*gval1-a2*gval5 if(gdf.gt.gmindif) then ! gval4 is higer mo merge 1-4-5 ! write(*,830)'3Y not merged 4',jp,kp,gdf,iphl(jp),gmindif cycle secondgp endif gdf=gval4-a1*gval1-a2*gval5 if(gdf.gt.gmindif) then ! gval4 is higer mo merge 1-4-5 ! write(*,830)'3Y not merged 5',jp,kp,gdf,iphl(jp),gmindif cycle secondgp endif endif ! compared 1-3-5, 1-2-5, 1-2-3, 1-4-5, 3-4-5, 2-3-5 ! in no case the middle point was above, that means merge !--------------------------------------------- here we merge !! 200 continue ! gridpoint in ideal phase or point in between has lower G, merge call get_phase_name(iphl(jp),1,phname) if(gx%bmperr.ne.0) then phname='UNKNOWN'; gx%bmperr=0 endif ! write(*,830)'3Y merging:',jp,kp,gdf,aphl(jp),aphl(kp),trim(phname) 830 format(a,2i4,3(1pe12.4),' in ',a) ! If merging use correct phase amounts npm=npm+1 a1=aphl(jp)/(aphl(jp)+aphl(kp)) a2=aphl(kp)/(aphl(jp)+aphl(kp)) ! write(*,162)'3Y p1:',a2,(yphl(incy(jp)+j),j=0,nyphl(jp)-1) ! write(*,162)'3Y p2:',a2,(yphl(incy(kp)+j),j=0,nyphl(kp)-1) 162 format(a,1pe12.4,12(0pF5.2)) ! The gridpoint jp has new amount, composition and constitution ! SURPRISE: adding together constituent fractions does not reproduce ! the correct molefractions if the constituents are molecules .... ???? aphl(jp)=aphl(jp)+aphl(kp) do i=0,nyphl(jp)-1 yphl(incy(jp)+i)=a1*yphl(incy(jp)+i)+a2*yphl(incy(kp)+i) enddo call set_constitution(iph,1,yphl(incy(jp)),qq,ceq) if(gx%bmperr.ne.0) goto 1000 ! extract correct mole fractions call calc_phase_mol(iph,xfromy,ceq) ! write(*,162)'3Y ym:',0.0D0,(yphl(incy(jp)+i),i=0,nyphl(jp)-1) ! write(*,162)'3Y xy:',0.0D0,(xfromy(i),i=1,nrel) ! calculate mole fractions from xsol to compare!! do i=1,nrel xerr(i)=a1*xsol(jp,i)+a2*xsol(kp,i) enddo ! write(*,162)'3Y xj+xk:',0.0D0,(xerr(i),i=1,nrel) do i=1,nrel xsol(i,jp)=xerr(i) enddo igen=.true. nm=nm+1 ! Mark the gripoint that has disappeared iphl(kp)=-iphl(kp) notuse(kp)=1 ! check overall composition of solution ... summu=zero xerr=zero do i=1,nrel if(iphl(i).lt.0) cycle summu=summu+aphl(i) ! write(*,*)'3Y point: ',i,aphl(i) do jj=1,nrel xerr(jj)=xerr(jj)+aphl(i)*xsol(jj,i) enddo enddo ! write(*,73)'3Y nu: ',summu,(xerr(jj),jj=1,nrel) ! the chemical potentials has changed but how? Approximate the change by ! making gmindif more negative for each merge (does not affect ideal phases) ! I do not understand this but I keep it for the moment ! gmindif=2.0D0*gmindif gmindif=1.2D0*gmindif ! after merging always restart loop goto 100 endif sameph enddo secondgp enddo firstgp ! if two gridpoints merged compare all grispoints again if(igen) goto 100 !---------------------------------------- ! shift fractions for the removed phases 450 continue ! write(*,*)'3Y at label 450: ',nm klast=0 do jp=1,nv klast=klast+nyphl(jp) enddo ! ! uncomment listing here if error moving fractions ! write(*,502)nv,(iphl(i),i=1,nv) ! write(*,502)0,(incy(i),i=1,nv) ! write(*,502)klast,(nyphl(i),i=1,nv) 502 format('3Y check1: ',i3,2x,20i4) ! kk=0 ! do j=1,nv ! write(*,510)j,(yphl(i),i=kk+1,kk+nyphl(j)) ! kk=kk+nyphl(j) ! enddo ! kk=0 jp=1 do while(jp.lt.nv) if(iphl(jp).lt.0) then ! shift all fractions down. klast should be updated each shift but ... jump=nyphl(jp) ! write(*,503)jp,kk,klast,jump 503 format('3Y check3: ',5i5) ! write(*,555)'3Y nyy1: ',(yphl(ip),ip=kk+1,kk+jump) 555 format(a,6(1pe12.4)) do ip=kk+1,klast-jump yphl(ip)=yphl(ip+jump) enddo ! write(*,555)'3Y nyy2: ',(yphl(ip),ip=kk+1,kk+jump) do kp=jp,nv-1 iphl(kp)=iphl(kp+1) aphl(kp)=aphl(kp+1) nyphl(kp)=nyphl(kp+1) enddo nv=nv-1 else kk=kk+nyphl(jp) jp=jp+1 endif 500 continue enddo if(iphl(nv).lt.0) nv=nv-1 ! write(*,*)'3Y final number of gridpoints: ',nv ! list overall composition with merged gridpoints summu=zero xerr=zero ! this calculate the overall composition from gridpoints ! write(*,87)'3Y aphl: ',nv,(aphl(jp),jp=1,nv) 87 format(a,i2,7(1pe10.2)) do jp=1,nv summu=summu+aphl(jp) do i=1,nrel xerr(i)=xerr(i)+aphl(jp)*xsol(i,jp) enddo enddo ! write(*,73)'3Y in2: ',summu,(xerr(i),i=1,nrel) ! uncomment here if problems shifting fractions ! write(*,502)nv,(iphl(i),i=1,nv) ! write(*,502)0,(incy(i),i=1,nv) ! write(*,502)klast,(nyphl(i),i=1,nv) ! kk=0 ! do j=1,nv ! write(*,510)j,(yphl(i),i=kk+1,kk+nyphl(j)) ! kk=kk+nyphl(j) ! enddo ! if there are two or more gripoints in the same phase we have a ! miscibility gap and may have to create miscibility gaps. ! ! >>>> unfinished ! 510 format(i3,':',6(1pe12.4)) 1000 continue if(npm.gt.0) write(*,'(a,i2,a)')'3Y Removed ',npm,' gridpoints by merging' if(ocv()) write(*,*)'3Y At return from merge_gridpoints: ',nv return !------------------------------------------ ! temporary fix to avoid creating several composition sets in ideal gas 1100 continue ! write(*,1102)'3Y merge ideal: ',nv,(iphl(jp),jp=1,nv) 1102 format(a,i2,20i3) nm=0 notuse=0 incy(1)=1 do i=2,nv incy(i)=incy(i-1)+nyphl(i-1) enddo 1110 continue igen=.FALSE. do jp=1,nv-1 do kp=jp+1,nv if(notuse(kp).ne.0) cycle if(iphl(jp).eq.iphl(kp)) then iph=iphl(jp) lokph=phases(iph) if(btest(phlista(lokph)%status1,PHID)) then ! add together gridpoints in ideal phases (gas) ! write(*,*)'3Y merging gridpoints in ideal phase' sumam=aphl(jp)+aphl(kp) a1=aphl(jp)/sumam a2=aphl(kp)/sumam aphl(jp)=aphl(jp)+aphl(kp) ! sum the constituent fractions do i=0,nyphl(jp)-1 yphl(incy(jp)+i)=a1*yphl(incy(jp)+i)+a2*yphl(incy(kp)+i) enddo ! sum also mole fractions!! do i=1,nrel xsol(i,jp)=a1*xsol(i,jp)+a2*xsol(i,kp) enddo notuse(kp)=1 igen=.TRUE. nm=nm+1 iphl(kp)=-iphl(kp) endif endif enddo enddo if(igen) goto 1110 if(nm.eq.0) goto 1000 goto 450 ! end subroutine merge_gridpoints !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine set_metastable_constitutions2 !\begin{verbatim} subroutine set_metastable_constitutions2(pph,nrel,nphl,iphx,xarr,garr,& nr,iphl,cmu,ceq) ! this subroutine goes through all the metastable phases ! after a global minimization and sets the constituion to the most ! favourable one. Later care should be taken that exiting higher composition ! sets are not set equal to the stable ! pph number of phases for which a grid has been calculated ! nrel number of components ! nphl(p) is last gridpoint for phase(p), nphl(0)=0, p=1,pph ! iphx(p) phase number of phase(p) (skipping dormant and suspended phases) ! xarr(1..nrel,i) composition of gridpoint i ! garr(i) Gibbs energy/RT for gridpoint i ! nr is the number of stable phases in the solution ! iphl(s) the phase number of the stable phases s (not ordered) ! cmu are the chemical potentials/RT of the solution ! ceq equilibrium record ! called by global_gridmin implicit none integer pph,nrel,nr integer, dimension(0:*) :: nphl integer, dimension(*) :: iphl,iphx double precision, dimension(*) :: cmu real garr(*),xarr(nrel,*) type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer ig1,ign,ip,iph,ics,jph,lokcs,lokph,mode,ny,ie,ig,kp,i,zph double precision yarr(maxconst),qq(5),xxx,dgmin,gmax real dg,gplan ! write(*,*)'3Y In set_metastable constitution' ! goto 1000 ! The phases that have gridpoints calculated are in iphx(1..pph) phloop: do zph=1,pph iph=iphx(zph) do jph=1,nr if(iph.eq.iphl(jph)) then ! this phase is stable, skip cycle phloop endif enddo ! this phase is metastable, find its gridpoint closesed to the tangent plane ! the grid points belonging to phase iph is between nphl(zph-1) and nphl(zph) ! NOTE nphl(0)=0 ig1=nphl(zph-1)+1 ign=nphl(zph) ! if ign=ig1 there is a single gridpoint, otherwise seach for minimim dgmin=-1.0d12 ip=0 ! search for gripoint closeset to stable plane defined by cmu igloop: do ig=ig1,ign if(garr(ig).ge.999.0) then ! gridpoints in phases with more than 50% vacancies have their garr(ig)=1.0D3 ! write(*,*)'Skipping gridpoint with too few atoms' cycle igloop endif gplan=zero do ie=1,nrel gplan=gplan+xarr(ie,ig)*cmu(ie) enddo dg=gplan-garr(ig) if(abs(dg).lt.abs(dgmin)) then ip=ig dgmin=dg endif enddo igloop ! write(*,79)'3Y metastable: ',trim(phlista(iph)%name),iph,zph,& ! ig1,ip,ign,dgmin 79 format(a,a,2i4,3i6,1pe12.4) ! write(*,81)'3Y x: ',ip-nphl(zph),(xarr(ie,ip),ie=1,nrel) ! write(*,81)'3Y x: ',ip-ig1,(xarr(ie,ip),ie=1,nrel) 81 format(a,i4,(10F6.3)) if(ign.gt.ig1) then ! if ign=ig1 the phase has fixed constitution ! otherwise retrieve constitution for this gridpoint and insert it in phase ! we must provide mode and iph. The subroutine returns ny and yarr ! mode is the gridpoint in the phase ! mode=ip-nphl(zph) mode=ip-ig1+1 ! find the constitution of this gridpoint ! call generate_grid(mode,iph,ign,nrel,xarr,garr,ny,yarr,gmax,ceq) ! write(*,*)'3Y Get constitution of metastable phase ',iph,mode if(mode.gt.0) then ! this call returnes the constitution of gridpoint "mode" ! if mode=0 it generates the grid ... infinite loop call generic_grid_generator(mode,iph,ign,nrel,xarr,garr,& ny,yarr,gmax,ceq) if(gx%bmperr.ne.0) then write(*,120)trim(phlista(iph)%name) 120 format('3Y Failed to set metastable constitution of ',a) gx%bmperr=0; cycle phloop endif ! write(*,81)'3Y y: ',mode,(yarr(ie),ie=1,ny) call set_constitution(iph,1,yarr,qq,ceq) if(gx%bmperr.ne.0) goto 1000 endif endif ! set driving force also for phases with fix composition call set_driving_force(iph,1,dgmin,ceq) 500 continue enddo phloop 1000 continue return end subroutine set_metastable_constitutions2 !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable logical function global_equil_check1 !\begin{verbatim} logical function global_equil_check1(mode,addtuple,yfr,ceq) ! subroutine global_equil_check(ceq,newceq) ! ! This subroutine checks there are any gridpoints below the calculated solution ! if not it is taken as a correct global equilibrium ! This avoids creating any new composition sets but may fail in some cases ! to detect that the equilibrium is not global. ! mode=1 means try to recalculate equilibrium if not global (not implemented) ! if a gridpoint below is found addtuple and yfr returned with this implicit none integer mode,addtuple double precision, allocatable, dimension(:) :: yfr TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} TYPE(gtp_equilibrium_data), target :: cceq TYPE(gtp_equilibrium_data), pointer :: pceq logical global,newcs,notglobwarning1,notglobwarning2,wrongfrac,addgridpoint real, allocatable :: xarr(:,:),garr(:) real sumx double precision, dimension(maxconst) :: yarr double precision totmol,totmass,amount,gmax,dgmax,dgtest integer, allocatable :: kphl(:),iphx(:) integer gmode,iph,ngg,nrel,ny,ifri,firstpoint,sumng,nrph,ii,jj,nz,lokcs integer ics,pph,nyfas,gpz,iphz,nggz,errall,haha integer, parameter :: maxgrid=400000 ! ! write(*,*)'3Y In global_equil_check1',mode global=.TRUE. if(btest(globaldata%status,GSNOGLOB)) then write(*,*)'3Y Ignoring call to global_equil_check as global turned off!' goto 2000 endif notglobwarning1=.TRUE. notglobwarning2=.TRUE. addgridpoint=.TRUE. if(mode.ne.1) addgridpoint=.FALSE. dgmax=zero addtuple=0 ! Problem with invariant when mapping but not here ! if(inveq(haha,ceq)) then ! write(*,*)'3Y equilibrium is invariant when entering',haha ! else ! write(*,*)'3Y equilibrium is not invariant when entering',haha ! endif ! COPY the whole equilibrium record to avoid destroying anything!! ! otherwise I had strange problems with amounts of phases ?? cceq=ceq pceq=>cceq nrph=noofph allocate(kphl(0:nrph+1),stat=errall) allocate(iphx(nrph+1),stat=errall) if(errall.ne.0) then write(*,*)'3Y allocation error 13: ',errall gx%bmperr=4370; goto 1000 endif ! sumng=0 ifri=0 firstpoint=1 iphx=0 kphl=0 ifri=0 pph=0 wrongfrac=.true. ggloop: do iph=1,nrph ! include all phases with any composition set entered (but only once!) if(test_phase_status_bit(iph,PHMQMQA)) then write(*,7) 7 format('3Y MQMQA phase excluded from global test') cycle ggloop endif do ics=1,noofcs(iph) ! new: -3 suspended, -2 dormant, -1,0,1 entered, 2 fixed ! ignore phases whith no composition set entered ! If a phase+compset FIX one should never be here as conditions wrong if(test_phase_status(iph,ics,amount,pceq).gt.PHDORM) then pph=pph+1 iphx(pph)=iph cycle ggloop endif enddo enddo ggloop ! nrel=noofel ! write(*,11)'3Y gpa:',pph,(iphx(iph),iph=1,pph) ! allocate arrays, added 1 to avoid a segmenentation fault .... allocate(xarr(nrel,maxgrid),stat=errall) allocate(garr(maxgrid),stat=errall) if(errall.ne.0) then write(*,*)'3Y allocation error 14: ',errall gx%bmperr=4370; goto 1000 endif ! calculate the composition and G for the gridpoints ii=1 loop2: do ifri=1,pph ngg=maxgrid-ii ! write(*,10)'3Y calling generic_grid 2: ',ifri,iphx(ifri),ngg,pph 10 format(a,2i5,2i10,5i5) !>>>>>>> important: changes here must be made also in global_gridmin if(btest(globaldata%status,GSOGRID)) then ! The possibility to use the old grid tested call generate_grid(0,iphx(ifri),ngg,nrel,xarr(1,ii),& garr(ii),ny,yarr,gmax,pceq) else call generic_grid_generator(0,iphx(ifri),ngg,nrel,xarr(1,ii),& garr(ii),ny,yarr,gmax,pceq) endif !>>>>>>>> impportant end! ! write(*,*)'3Y Back from grid generator: ',ifri,iphx(ifri),ngg if(gx%bmperr.ne.0) goto 1000 kphl(ifri)=kphl(ifri-1)+ngg ii=kphl(ifri)+1 enddo loop2 sumng=kphl(pph) ! write(*,11)'3Y gpc:',(kphl(iph),iph=1,nrph) 11 format(a,10i7/(7x,10i7)) ! write(*,*)'3Y Calculated ',sumng,' gridpoints for check.',kphl(0) ! We have calculated sumng gripoints in pph phases ! check if any gridpoint is below the G surface defined by cmuval iph=0 nyfas=0 iphz=0 loop4: do ifri=1,sumng ! keep track of the phase the gridpoint belongs to if(ifri.gt.nyfas) then ! iph is the phase index in phasetuple (and phases) iph=iph+1 ! ny=ny+kphl(iph) nyfas=kphl(iph) endif gmax=zero sumx=0.0E0 do ngg=1,nrel gmax=gmax+dble(xarr(ngg,ifri))*pceq%cmuval(ngg) sumx=sumx+xarr(ngg,ifri) enddo ! if(ifri.eq.sumng) write(*,*)'3Y OK ',ifri,iph if(abs(sumx-1.0E0).gt.1.0E-4) then cycle loop4 endif ! write(*,75)'3Y check: ',ifri,iphx(iph),garr(ifri),gmax,garr(ifri)-gmax 75 format(a,i6,i4,5(1pe12.4)) dgtest=gmax-dble(garr(ifri)) stableornot: if(dgtest.gt.1.0D-4*abs(gmax)) then ! stableornot: if(dgtest.gt.1.0D-7*abs(gmax)) then ! if(dgtest.gt.dgmax) then !------------------------------------------------------------------ ! write(*,76)'3Y gridpoint below G surface: ',ifri,iph,iphx(iph),& ! dgtest,1.0D-4*dgmax 76 format(a,i7,2i4,2(1pe12.4)) ! if the phase is stoichiometric and stable this is a rounding off problem ! find the phase record using the phase tuple lokcs=phasetuple(iph)%lokvares nz=size(pceq%phase_varres(lokcs)%sites)-& size(pceq%phase_varres(lokcs)%yfr) if(nz.eq.0) then if(pceq%phase_varres(lokcs)%phstate.ge.PHENTSTAB) cycle loop4 ! if number of constituent fractions equal to sublattice the composition is fix ! If this is a test at a node point we may have an allotropic phase whicj is ! stable, then the driving force should be small ... check if dgm is very small write(*,'(a,i5,F10.2,2(1pe12.4))')'3Y allotrop DGM: ',& lokcs,pceq%tpval(1),pceq%phase_varres(lokcs)%dgm if(pceq%phase_varres(lokcs)%dgm.lt.2.0D-1) cycle loop4 endif ! This phase should be stable, maybe there are others? if(dgtest.lt.dgmax) cycle loop4 dgmax=dgtest ! This gridpoint is the currently lowest below the current G plane ! write(kou,77)ifri,iph,iphx(iph),trim(phlista(phases(iphx(iph)))%name) 77 format('3Y found a stable gridpoint: ',3i5,' in ',a) global=.FALSE. gpz=ifri ! iphz=iph iphz=iphx(iph) nggz=kphl(iph-1) ! write(*,*)'3Y saving most stable gp: ',gpz,iphz endif stableornot ! if(ifri.eq.sumng) write(*,*)'OK ',ifri enddo loop4 ! no gridpoint below current G surface ! write(*,*)'3Y finished loop4',iphz,global goto 1000 ! Found gridpoint below gmax, if mode=/=1 just return error message 500 continue write(*,*)'3Y Sorry I have not yet implemented automatic recalculation!' if(mode.eq.1) then ! Here we try to recalculate the equilibrium with a new phase stable continue else write(*,*)'3Y Please include this phase and recalculate equilibrium' endif ! 1000 continue !1010 continue ! write(*,*)'3Y global_equil_check label 1000',global,gx%bmperr ! set the error code here so we can finish this routine if(.not.global) then ! write(*,1011)'3Y most stable gridpoint: ',gpz,nggz,iphz,dgmax 1011 format(a,2i7,i3,1pe12.4) addornot: if(addgridpoint) then ! Add this gripoint as entered and recalculate ! extract constitution, ny=-100 to get some output .. ! write(*,*)'3Y Trying to extract constitution, ngg:' ! ny=-100 if(btest(globaldata%status,GSOGRID)) then ! we do not have ifri and iphx here call generate_grid(gpz-nggz,iphz,nggz,nrel,xarr,& garr,ny,yarr,gmax,pceq) else call generic_grid_generator(gpz-nggz,iphz,nggz,nrel,& xarr,garr,ny,yarr,gmax,pceq) endif if(ny.gt.0) then ! write(*,83)'3Y gpy: ',ny,(yarr(ngg),ngg=1,ny) 83 format(a,i7,9F7.4,(8x,14F5.2)) ! a small allocate allocate(yfr(ny)) do ngg=1,ny yfr(ngg)=yarr(ngg) enddo else write(*,*)'3Y Failed extract constitution',ny endif else ! This gridpoint is for a phase that is not stable but has a stable grid point ! but we will not try to recalculate if(notglobwarning1) then ! write this once only write(kou,87)trim(phlista(phases(iphz))%name),pceq%tpval(1),& (xarr(ngg,gpz),ngg=1,nrel) 87 format(/' *** Gridtest found equilibrium not global, ',a,& ' is stable at T=',F8.2/5x,'with mole fractions:'/(1x,13F6.3)) notglobwarning1=.FALSE. endif endif addornot addtuple=iphz gx%bmperr=4352 endif ! write(*,*)'3Y Deallocating, check due to segmentation fault ...' if(allocated(xarr)) then deallocate(xarr) deallocate(garr) deallocate(kphl) deallocate(iphx) endif 2000 continue ! if(inveq(haha,ceq)) then ! write(*,*)'3Y equilibrium is invariant when at exit',haha ! else ! write(*,*)'3Y equilibrium is not invariant when at exit',haha ! endif global_equil_check1=global return end function global_equil_check1 !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine check_all_phases !\begin{verbatim} subroutine check_all_phases(mode,ceq) ! ! This function check for all phases if there are any gridpoints ! closer (or below) to the current calculated solution ! if so it changes the composition of the phase ! If a gridpoint is BELOW the current plane an error code is returned ! phase should be stable with another composition an error code is returned ! It does not creating any new composition sets ! It can be usd during STEP/MAP to update compositions of metastable ! phases which have become stuck in a local minimium ! if error 4365 or 4364 is set mode will return index in meqrec%phr ! of the phase that should be stable implicit none integer mode TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} TYPE(gtp_equilibrium_data), target :: cceq TYPE(gtp_equilibrium_data), pointer :: pceq integer iph,phstat,saverr ! ! write(*,*)'3Y In check_all_phases' ! COPY the whole equilibrium record to avoid destroying anything!! ! otherwise I had strange problems with amounts of phases ?? saverr=0 cceq=ceq pceq=>cceq ! mode will be updated inside check_phase_grid to correspond to meqrec%phr index mode=0 ggloop: do iph=1,noofph ! include all phases with any composition set entered (but only once!) ! loop for composition sets inside check_phase as they all have the same grid call check_phase_grid(iph,mode,pceq,ceq) if(gx%bmperr.ne.0) then ! if a stable phase need a new composition terminate and return error if(gx%bmperr.eq.4366) then ! grid minimizer needed to create new composition set is needed write(*,*)'3Y New composition set needed: ',gx%bmperr,mode,mode goto 1000 elseif(gx%bmperr.eq.4365) then ! new stable phase composition inserted in unstable composition set ! go back and take halfstep in step/map write(*,*)'3Y found stable phase: ',gx%bmperr,mode,mode goto 1000 saverr=gx%bmperr endif gx%bmperr=0 endif enddo ggloop if(saverr.ne.0) gx%bmperr=saverr ! 1000 continue return end subroutine check_all_phases !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine check_phase_grid !\begin{verbatim} subroutine check_phase_grid(iph,jcs,pceq,ceq) ! ! This function check for A SINGLE PHASE if there are any gridpoints ! closer (or below) to the current calculated solution if so it ! changes the composition of the phase If a gridpoint is below the ! phase should be stable with another composition an error code is ! returned It does not creating any new composition sets but may fail ! It can be usd during STEP/MAP to update compositions of metastable ! phases which have become stuck in a local minimium ! NOTE pceq is a pointer to a copy of the real equilibrium record ! ceq is a pointer to the real equilibrium record ! jcs is returned as the composition set that should be stable (if any) implicit none integer iph,jcs TYPE(gtp_equilibrium_data), pointer :: ceq,pceq !\end{verbatim} real, allocatable :: xarr(:,:),garr(:) double precision, dimension(maxel) :: x1mol,wmass double precision, dimension(maxconst) :: yarr double precision totmol,totmass,amount,gmax,dgmax,dgtest double precision, parameter :: mindg=1.0D-6 ! max 9 composition sets double precision gorig,gbest,gdiff,gset(9),gplan,am,qq(5) ! for debugg double precision yold(100) integer, allocatable :: kphl(:),iphx(:) integer ii,jj,kk,nrel,lokcs,moded,ny,ics,ics2,ncs,stcs(4),nstcs,ie,ngg integer phstat,lokph,lokres,errall logical skip integer, parameter :: maxgrid=100000 ! ! write(*,*)'3Y In check_phase_grid: ',iph nrel=noofel moded=0 ! allocate arrays allocate(xarr(nrel,maxgrid),stat=errall) allocate(garr(maxgrid),stat=errall) if(errall.ne.0) then write(*,*)'3Y allocation error 15: ',errall gx%bmperr=4370; goto 1000 endif gset=-one skip=.TRUE. ! loop for all composition sets ncs=noofcs(iph) stcs=0 nstcs=0 gloop: do ics=1,ncs ! calculate G for current composition, ignore dormant and suspended sets phstat=test_phase_status(iph,ics,amount,pceq) if(phstat.lt.PHDORM) cycle gloop skip=.FALSE. call calcg(iph,ics,moded,lokcs,ceq) if(gx%bmperr.ne.0) goto 1000 call calc_phase_molmass(iph,ics,x1mol,wmass,totmol,totmass,am,ceq) if(gx%bmperr.ne.0) goto 1000 ! abnorm(1) is number of atoms per formula unit gorig=pceq%phase_varres(lokcs)%gval(1,1)/& pceq%phase_varres(lokcs)%abnorm(1) ! calculate the difference with the current stable tangent plane ! It can be zero if the composition set is stable gplan=zero do ii=1,nrel gplan=gplan+x1mol(ii)*pceq%cmuval(ii) enddo ! this is the original drivining force for each composition set gset(ics)=gorig-gplan ! there can be more than one stable composition set ... fix another time ... if(phstat.ge.PHENTSTAB) then if(nstcs.ge.4) then ! write(*,*)'More than 4 stable composition sets of phase',iph gx%bmperr=4399; goto 1000 endif ! write(*,*)'Stable phase and set: ',iph,ics,gset(ics) nstcs=nstcs+1; stcs(nstcs)=ics endif enddo gloop ! all composition sets suspended or dormant in this phase if(skip) goto 1000 ! write(*,20)'3Y phase grid: ',nstcs,ncs,(gset(ii),ii=1,ncs) !20 format(a,2i2,6(1pe12.4)) ! ! now calculate the gridpoints, composition and G ngg=maxgrid ! write(*,*)'Calculate grid for phase ',iph,nrel,ngg call generic_grid_generator(0,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,pceq) ! write(*,*)'3Y error & grid: ',gx%bmperr,ngg if(gx%bmperr.ne.0) goto 1000 ! loop through all gridpoints to find one closesed to the stable tangent plane ! ngg set to number of real gridpoints ! note mixed single and double precision but that is OK gbest=-1.0D3 do ii=1,ngg gplan=zero do jj=1,nrel gplan=gplan+xarr(jj,ii)*pceq%cmuval(jj) enddo ! note gdiff should be negative if metetstable gdiff=gplan-garr(ii) ! write(*,22)'3Y GRID: ',ii,gdiff,gbest,garr(ii),gplan 22 format(a,i4,4(1pe12.4)) if(gdiff.gt.gbest) then kk=ii; gbest=gdiff endif enddo ! ! write(*,30)'3Y Gridpoint ',kk,gbest,(xarr(ii,kk),ii=1,nrel) 30 format(a,i4,e12.4,10(F8.5)) ! now we compare the best gridpoint with the composition sets loop1: do ics=1,ncs ! jcs will be the correct phase index inside meqrec%phr array ?? jcs=jcs+1 phstat=test_phase_status(iph,ics,amount,pceq) if(phstat.lt.PHDORM) cycle loop1 ! extract constitution for the best gridpoint kk call generic_grid_generator(kk,iph,ngg,nrel,xarr,garr,& ny,yarr,gmax,pceq) if(gbest.ge.mindg) then ! there is a gridpoint below the tangent plane ! If there is a metastable composition set copy the gripoint constitution ! to that and recalculate. If no free composition set test if the grid ! point can be merged with a stable composition set. If not recalculate ! with grid minimizer if(nstcs.gt.0) then ! There is one or more stable composition set, if there is an unstable one ! then set the gridpoint constitution in that if(nstcs.eq.ncs) then ! All composition sets already stable! ! we have to compare if the G curve between the gridpoint and all the ! composition sets is convex or concave. NOT IMPLEMENTED ! loop2: do ics2=1,nstcs ! if(stcs(ics2).lt.0) cycle loop2 ! call calc_phase_molmass(iph,stcs(ics2),x1mol,wmass,totmol,& ! totmass,am,pceq) ! if(gx%bmperr.ne.0) goto 1000 ! we should check here if there is a maximum G between the gridpoint and the ! stable composition set. To be done ... ! write(*,*)'3Y New composition set needed' ! gx%bmperr=4365; goto 1000 ! enddo loop2 ! we arrive here if we could not merge gridpoint with a stable composition set ! the error code demand a global grid minimization. write(*,*)'3Y New composition set needed for:',iph,ncs,nstcs ! write(*,90)1,iph,ics,ceq%tpval(1),gbest,gset(ics) call set_constitution(iph,ics,yarr,qq,ceq) if(gx%bmperr.ne.0) goto 1000 gx%bmperr=4365; goto 1000 elseif(gset(ics).lt.zero) then ! there is at least one unstable composition set, check if gset(ics)<0 ! and insert the GRIDPOINT constitution if gset(ics) negative ! This composition set is not stable, insert stable gridpoint constitution write(*,90)2,iph,ics,ceq%tpval(1),gbest,gset(ics),4365 90 format('3Y stable gridpoint ',i1,2x,2i4,F10.2,2(1pe12.4),i5) ! Check old constitution ! call get_phase_compset(iph,ics,lokph,lokres) ! write(*,95)'3Y oldy: ',ceq%phase_varres(lokres)%yfr ! write(*,95)'3Y newy: ',(yarr(ii),ii=1,ny) call set_constitution(iph,ics,yarr,qq,ceq) if(gx%bmperr.ne.0) goto 1000 ! this error code demand recalculation without grid minimizer gx%bmperr=4365; goto 1000 endif else ! There are no stable composition sets, we can set the stable gridpoint ! constitution in this composition set and request a new equilibrium calculation ! NOTE we use ceq pointer to set yarr in original record write(*,90)3,iph,ics,ceq%tpval(1),gbest,gset(ics),4365 ! Check old constitution ! call get_phase_compset(iph,ics,lokph,lokres) ! write(*,95)'3Y oldy: ',ceq%phase_varres(lokres)%yfr ! write(*,95)'3Y newy: ',(yarr(ii),ii=1,ny) 95 format(a,10(F7.4)) call set_constitution(iph,ics,yarr,qq,ceq) if(gx%bmperr.ne.0) goto 1000 gx%bmperr=4365; goto 1000 endif elseif(gbest.gt.gset(ics)) then ! SKIP THIS FOR THE MOMENT ! The best gridpoint is not stable but it is closer to tangent plane than this ! composition set WHICH THUS MUST BE UNSTABLE!. ! This change can avoid a phase is stuck in a local minimum ! BUT if another composition set is stable do not change because it the ! gridpoint is probably close to the stable composition. if(nstcs.eq.0) then write(*,92)iph,ics,ceq%tpval(1),gbest,gset(ics) 92 format('3Y better gridpoint in ',i4,i2,F10.2,2(1pe12.4)) call set_constitution(iph,ics,yarr,qq,ceq) if(gx%bmperr.ne.0) goto 1000 endif ! This do not require a new calculation ! else ! Nothing to do as the best gridpoint is further away from tangent plane ! than this metastable composition set endif enddo loop1 ! The allocated arrays should deallocate by themselves 1000 continue return end subroutine check_phase_grid !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine separate_constitutions !\begin{verbatim} subroutine separate_constitutions(ceq) ! This is called during step/map ! Go through all entered phases and if there are two composition sets ! that have similar constitutions then separate them ! Used during mapping of for example Fe-Cr to detect the miscibility gap implicit none TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer phtup,nextset,lokcs1,lokcs2,ic,ll,lokph,ss,ts ! max 9 sublattices integer iymin(9),iymax(9),qq double precision ymax(9),ymin(9),ysame double precision, allocatable :: yarr(:) ! write(*,*)'3Y Check if two composition sets are same: ',ceq%tpval(1) allph: do phtup=1,nooftup() nextset=phasetuple(phtup)%nextcs if(nextset.le.0) cycle allph lokph=phasetuple(phtup)%lokph lokcs1=phasetuple(phtup)%lokvares lokcs2=phasetuple(nextset)%lokvares ymin=one ymax=zero iymin=0 iymax=0 ! ts=ceq%phase_varres(lokcs1)%tnoofr ts=phlista(lokph)%tnooffr ll=1 qq=phlista(lokph)%nooffr(1) do ic=1,ts ysame=ceq%phase_varres(lokcs1)%yfr(ic) if(abs(ysame-ceq%phase_varres(lokcs2)%yfr(ic)).gt.1.0D-2) then ! write(*,66)'3Y two compsets not same:',lokcs1,lokcs2,ceq%tpval(1) ! write(*,77)'3Y d1:',lokcs1,(ceq%phase_varres(lokcs1)%yfr(ss),ss=1,ts) ! write(*,77)'3Y d2:',lokcs2,(ceq%phase_varres(lokcs2)%yfr(ss),ss=1,ts) cycle allph else ! map8 gave segmentation fault here, fixed ?? ! write(*,10)'3Y qq: ',phtup,nextset,ic,qq,ll,ts,& ! phlista(lokph)%nooffr(ll),size(phlista(lokph)%nooffr),& ! size(ceq%phase_varres(lokcs2)%yfr) !10 format(a,10i5) if(ic.gt.qq) then ll=ll+1 qq=qq+phlista(lokph)%nooffr(ll) endif if(ysame.lt.ymin(ll)) then iymin(ll)=ic; ymin(ll)=ysame endif if(ysame.gt.ymax(ll)) then iymax(ll)=ic; ymax(ll)=ysame endif endif enddo ! These two composition sets have identical compositions, skip if both stable ! write(*,66)'3Y two compsets same:',lokcs1,lokcs2,ceq%tpval(1),& ! (ymin(ic),ymax(ic),ic=1,ll) 66 format(a,2i3,f8.2,2x,(8F6.3)) if(ceq%phase_varres(lokcs1)%phstate.ge.PHENTSTAB) then if(ceq%phase_varres(lokcs2)%phstate.ge.PHENTSTAB) then ! write(*,*)'Wow, two identical phases stable!',lokcs1,lokcs2 cycle allph endif ! write(*,77)'3Y s1:',lokcs1,(ceq%phase_varres(lokcs1)%yfr(ss),ss=1,ts) ! set the constitution of lokcs2 to one-the stable ! or maybe to its default?? lokph=phasetuple(phtup)%lokph ic=0 phsubl1: do ll=1,phlista(lokph)%noofsubl if(phlista(lokph)%nooffr(ll).eq.1) then ic=ic+1; cycle phsubl1 endif ysame=0.1/real(phlista(lokph)%nooffr(ll)) do ss=1,phlista(lokph)%nooffr(ll) ic=ic+1 if(ic.eq.iymin(ll)) then ceq%phase_varres(lokcs2)%yfr(ic)=0.9 else ceq%phase_varres(lokcs2)%yfr(ic)=ysame endif enddo enddo phsubl1 ! write(*,77)'3Y s1:',lokcs1,(ceq%phase_varres(lokcs1)%yfr(ss),ss=1,ts) ! write(*,77)'3Y s2:',lokcs2,(ceq%phase_varres(lokcs2)%yfr(ss),ss=1,ts) 77 format(a,i3,8F6.3) else ! lokcs1 is not stable, change its constitution away from lokcs2 ! elseif(ceq%phase_varres(lokcs2)%phstate.ge.PHENTSTAB) then ! set the constitution of lokcs1 to one-the lokcs2 ! or maybe to its default?? lokph=phasetuple(phtup)%lokph ic=0 phsubl2: do ll=1,phlista(lokph)%noofsubl if(phlista(lokph)%nooffr(ll).eq.1) then ic=ic+1; cycle phsubl2 endif ! very strange, if I divide with real(phlista(lokph)%nooffr(ll)-1) ! the metastable exrapolation is still there !! ysame=0.1/real(phlista(lokph)%nooffr(ll)) do ss=1,phlista(lokph)%nooffr(ll) ic=ic+1 if(ic.eq.iymin(ll)) then ceq%phase_varres(lokcs1)%yfr(ic)=0.9 else ceq%phase_varres(lokcs1)%yfr(ic)=ysame endif enddo enddo phsubl2 ! write(*,77)'3Y z1:',lokcs1,(ceq%phase_varres(lokcs1)%yfr(ss),ss=1,ts) ! write(*,77)'3Y z2:',lokcs2,(ceq%phase_varres(lokcs2)%yfr(ss),ss=1,ts) ! else ! write(*,*)'Both compsets unstable' endif enddo allph 1000 continue end subroutine separate_constitutions !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable logical function allotropes !\begin{verbatim} logical function allotropes(irem,iadd,iter,ceq) ! This function return TRUE if the phases indicated by IREM and IADD both have ! fixed and identical composition, i.e. they are componds and allotropes ! Such a transition can cause problems during a STEP command. implicit none TYPE(gtp_equilibrium_data), pointer :: ceq integer iadd,irem,iter !\end{verbatim} %+ integer lokph1,lokph2,nofr,jj double precision x1mol(maxel),x2mol(maxel),wmass(maxel),totmol,totmass,am logical allo allo=.false. goto 1000 ! write(*,*)'3A checking allotropes',irem,iadd write(*,10)iter,trim(phlista(phases(irem))%name),& trim(phlista(phases(iadd))%name) 10 format('3A checking allotropes',i5,2x,a,2x,a) lokph1=phases(irem) lokph2=phases(iadd) ! spurious segmentation faults here ... if(lokph1.le.0 .or. lokph2.le.0) then ! composition ses created during mapping are not included in phases array ?? write(*,*)'3A error checking allotropes: ',lokph1,lokph2 goto 1000 endif ! check if both have fixed composition if(phlista(lokph1)%noofsubl-phlista(lokph1)%tnooffr.eq.0 .and. & phlista(lokph2)%noofsubl-phlista(lokph2)%tnooffr.eq.0) then ! they have fixed composition but can be modelled differently ! we have to calculate their mole fractions ... call calc_phase_molmass(irem,1,x1mol,wmass,totmol,totmass,am,ceq) call calc_phase_molmass(irem,1,x2mol,wmass,totmol,totmass,am,ceq) if(gx%bmperr.ne.0) goto 1000 do jj=1,noofel if(abs(x1mol(jj)-x2mol(jj)).gt.1.0D-6) exit enddo ! Fortran standard says jj>noofel if loop finish without exit if(jj.gt.noofel) then allo=.true. ! write(*,*)'The phases are allotropes!',ceq%tpval(1) endif endif 1000 continue allotropes=allo return end function allotropes !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable logical function same_stoik !\begin{verbatim} logical function same_stoik(iph,jph) ! MAYBE IDENTICAL TO ALLOTROPES ? ! return TRUE if phase iph and jph are both stoichiometric and have the ! same composition Used to check when adding a phase during equilibrium ! calculation as it normally fails to have two such phases stable ! iph and jph are phase tuple indices implicit none integer iph,jph !\end{verbatim} %+ integer loki,lokj,ll,kk logical same ! same=.false. ! iph and jph can be second or later composition sets ! write(*,*)'3F same_stoik 1: ',iph,jph,& ! phasetuple(iph)%lokph,phasetuple(jph)%lokph ! loki=phases(iph); lokj=phases(jph) if(iph.le.0 .or. iph.gt.nooftup() .or. jph.le.0 .or.jph.gt.nooftup()) then write(*,*)'Calling same_stoik with illegal arguments ',iph,jph gx%bmperr=4399; goto 1000 endif loki=phasetuple(iph)%lokph; lokj=phasetuple(jph)%lokph if(.not.btest(phlista(loki)%status1,PHNOCV)) goto 1000 if(.not.btest(phlista(lokj)%status1,PHNOCV)) goto 1000 if(phlista(loki)%noofsubl.ne.phlista(lokj)%noofsubl) goto 1000 kk=0 do ll=1,phlista(loki)%noofsubl if(firsteq%phase_varres(phlista(loki)%linktocs(1))%sites(ll).ne.& firsteq%phase_varres(phlista(lokj)%linktocs(1))%sites(ll)) goto 1000 kk=kk+1 if(phlista(loki)%constitlist(kk).ne.& phlista(lokj)%constitlist(kk)) goto 1000 enddo same=.true. 1000 continue same_stoik=same return end function same_stoik !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable logical function fixedcomposition !\begin{verbatim} logical function fixedcomposition(iph) ! returns TRUE if phase cannot vary its composition integer iph !\end{verbatim} integer lokph lokph=phases(iph) ! Wow a bug! using iph instead of lokph!! if(phlista(lokph)%tnooffr-phlista(lokph)%noofsubl.eq.0) then ! write(*,*)'3G fixedcomposition: ',iph,lokph,& ! phlista(lokph)%tnooffr,phlista(lokph)%noofsubl fixedcomposition=.true. else fixedcomposition=.false. endif 1000 continue return end function fixedcomposition !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !> 17. Section: miscellaneous !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable integer function phvarlok !\begin{verbatim} integer function phvarlok(lokph) ! return index of the first phase_varres record for phase with location lokph ! needed for external routines as phlista is private implicit none integer lokph !\end{verbatim} phvarlok=phlista(lokph)%linktocs(1) return end function phvarlok !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine palmtree !\begin{verbatim} subroutine palmtree(lokph) ! Initiates a numbering of all interaction trees of an endmember of a phase ! Called from calcg_internal for each phase unless PHPALM set implicit none integer lokph !\end{verbatim} integer seq,level type(gtp_endmember), pointer :: endm type(gtp_interaction), pointer :: intrec type stack type(gtp_interaction), pointer :: p1 end type stack type(stack), dimension(5) :: int_stack logical both both=.false. endm=>phlista(lokph)%ordered 70 continue emloop:do while(associated(endm)) intrec=>endm%intpointer seq=0 level=0 100 continue do while(associated(intrec)) level=level+1 if(level.gt.5) then write(*,*)'3Y Interaction more than 5 levels deep!' gx%bmperr=4347; goto 1000 endif int_stack(level)%p1=>intrec seq=seq+1 intrec%order=seq intrec=>intrec%highlink enddo if(level.gt.0) then intrec=>int_stack(level)%p1 level=level-1 intrec=>intrec%nextlink goto 100 endif endm=>endm%nextem enddo emloop if(.not.both .and. associated(phlista(lokph)%disordered)) then endm=>phlista(lokph)%disordered both=.true. goto 70 endif 1000 continue return end subroutine palmtree !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine sortinphtup !\begin{verbatim} subroutine sortinphtup(n,m,xx) ! subroutine to sort the values in xx which are in phase and compset order ! in phase tuple order. This is needed by the TQ interface ! The number of values belonging to the phase is m (for example composition) ! argument ceq added as new composition sets can be created ... integer n,m ! double precision xx(n*m) double precision xx(*) ! type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} ! integer iz,jz,kz,lz,lokph,aha,errall double precision, dimension(:), allocatable :: dum ! I assume the values are NP(*), maybe there are other cases ... ! Karl had overflow error in dum ... no problem to make it a little larger ! but then I cannot set xx=dum below ... allocate(dum(n*m+10),stat=errall) if(errall.ne.0) then write(*,*)'3Y allocation error 16: ',errall gx%bmperr=4370; goto 1000 endif ! write(*,*)'3F corrected sortinphtup',n,m ! write(*,10)'3F in: ',(xx(iz),iz=1,n*m) 10 format(a,10(f7.4)) kz=0 do iz=1,noofph lokph=phases(iz) do jz=1,phlista(lokph)%noofcs ! if(jz.gt.1) then ! in xx the values are sequentially for all composition sets for this phase ! But they should be stored in tuple order and compset 2 etc comes at the end ! the index to the tuple is in %phtups ! phlista(lokph)%linktocs(jz) is index of phase_varres record for compset ! firsteq%phase_varres(..)%phtupx is index of phase tuple for compset ! There can be m values (for example compositions) for each phase ! BUG FIXED: Sigli example gives hard error here ! index '0' of array 'firsteq' below lower boundary of 1 aha=(firsteq%phase_varres(phlista(lokph)%linktocs(jz))%phtupx-1)*m ! if(aha.ne.kz) then ! write(*,*)'3F shifting from, to, values: ',kz,aha,m ! endif do lz=1,m dum(aha+lz)=xx(kz+lz) enddo kz=kz+m enddo enddo ! xx=dum do iz=1,n*m xx(iz)=dum(iz) enddo deallocate(dum) ! write(*,10)'3F ut: ',(xx(iz),iz=1,n*m) 1000 continue return end subroutine sortinphtup !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable integer function get_mpi_index !\begin{verbatim} integer function get_mpi_index(mpi) ! Return the index of a model parameter identifier character mpi*(*) !\end{verbatim} %+ ! propid(jj)%symbol is *4 character text*4 integer jj text=mpi do jj=1,ndefprop if(propid(jj)%symbol.eq.text) exit enddo ! if(jj.gt.ndefprop) then write(*,*)'3A no such model parameter identifier: ',trim(mpi) gx%bmperr=4399; jj=-1 endif ! write(*,*)'3A get_mpi_index: ',text,ndefprop,jj get_mpi_index=jj return end function get_mpi_index !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ ! !\addtotable integer function getmqindex !\begin{verbatim} ! integer function getmqindex() ! This is necessary because mqindex is private, replaced by getmpiindex ... !\end{verbatim} ! getmqindex=mqindex ! return ! end function getmqindex ! !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable logical function allowenter !\begin{verbatim} logical function allowenter(mode) ! Check if certain commands are allowed ! mode=1 means entering an element or species ! this routine is no longer used when entering species ! mode=2 means entering a phase ! mode=3 means entering an equilibrium ! returns TRUE if command can be executed implicit none integer mode !\end{verbatim} ! write(*,*)'3Y In allowenter: ',mode logical yesorno yesorno=.FALSE. if(mode.le.0 .or. mode.gt.3) goto 1000 if(mode.eq.1) then ! enter element or species not allowed after entering first phase if(noofph.gt.0) goto 1000 yesorno=.TRUE. elseif(mode.eq.2) then ! enter phases of a disordred fraction set not allowed ! if there are no elements or after entering a second equilibrium ! write(*,*)'3Y allowenter ',mode,noofel,eqfree,noofph if(noofel.eq.0) goto 1000 if(eqfree.gt.2) goto 1000 yesorno=.TRUE. elseif(mode.eq.3) then ! there must be at least one phase before entering a second equilibrium ! Note this is tested also for entering the default equilibrium ! write(*,*)'3Y mode 3: ',eqfree,noofph if(eqfree.ge.2 .and. noofph.eq.0) goto 1000 yesorno=.TRUE. endif 1000 continue allowenter=yesorno ! write(*,*)'3Y: allowenter:',yesorno,mode return end function allowenter !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable logical function proper_symbol_name !\begin{verbatim} logical function proper_symbol_name(name,typ) ! checks that name is a proper name for a symbol ! A proper name must start with a letter A-Z ! for typ=0 it must contain only letters, digits and underscore ! for typ=1 it may contain also +, - maybe ? ! It must not be equal to a state variable implicit none integer typ character name*(*) !\end{verbatim} character name2*64,ch1*1,chx*1 integer jl logical korrekt ! write(*,*)'3Y entering proper_symbol_name: ',name,typ korrekt=.FALSE. if(typ.lt.0 .or. typ.gt.0) then gx%bmperr=4139; goto 1000 endif name2=name call capson(name2) if(.not.ucletter(name2(1:1))) then ! the first character of a symbol must always be a letter A-Z ! write(*,*)'3Y Wrong first letter of symbol: ',name2(1:1),':',name2(1:5) gx%bmperr=4137; goto 1000 endif jl=1 ! write(*,*)'3Y check name: ',name2 100 continue jl=jl+1 ch1=name2(jl:jl) ! always finish when fining a space if(ch1.eq.' ') then ! any symbol with at least 3 characters OK if(jl.le.2) then ! A single letter must be a state variable if(name2(1:1).eq.'A' .or. name2(1:1).eq.'B' .or. & name2(1:1).eq.'G' .or. name2(1:1).eq.'H' .or. & name2(1:1).eq.'M' .or. name2(1:1).eq.'N' .or.& name2(1:1).eq.'P' .or. name2(1:1).eq.'Q' .or. & name2(1:1).eq.'S' .or. & name2(1:1).eq.'T' .or. name2(1:1).eq.'U' .or.& name2(1:1).eq.'V' .or. name2(1:1).eq.'W' .or. & name2(1:1).eq.'X' .or. name2(1:1).eq.'Y') then if(jl.eq.2) then gx%bmperr=4137; goto 1000 elseif(name2(2:2).eq.'F' .or. name2(2:2).eq.'M' .or. & name2(2:2).eq.'P' .or. name2(2:2).eq.'U' .or. & name2(2:2).eq.'V' .or. name2(2:2).eq.'W') then ! A two letter name must not have certain second letter gx%bmperr=4137; goto 1000 endif endif endif korrekt=.TRUE. name(jl:)=' ' goto 1000 endif if(typ.eq.0) then if(ch1.ge.'0' .and. ch1.le.'9') goto 100 if(ch1.ge.'A' .and. ch1.le.'Z') goto 100 if(ch1.eq.'_') goto 100 gx%bmperr=4138 ! else ! unknown type of symbol ! gx%bmperr=4139 endif ! 1000 continue ! if(.not.korrekt) write(*,*)'3Y Illegal name: ',name2,jl proper_symbol_name=korrekt return end function proper_symbol_name !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine compmassbug !\begin{verbatim} subroutine compmassbug(ceq) ! debug subroutine type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer cp,sp,ep ! elements(1..n) is ordered alphabetcally ! complist(1..n) is initially also ordered alphabetcally but with errors ... ! do cp=1,noofel sp=ceq%complist(cp)%splink ep=splista(sp)%ellinks(1) write(*,100)cp,sp,ep,trim(ellista(ep)%name),trim(splista(sp)%symbol),& ellista(ep)%alphaindex,ellista(ep)%splink,& ceq%complist(cp)%mass,mass_of(cp,ceq),& ellista(ep)%mass,splista(sp)%mass 100 format(3i3,2x,a2,2x,a2,2i3,3x,4(1pe12.4)) enddo write(*,*) return end subroutine compmassbug !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine list_free_lists !\begin{verbatim} subroutine list_free_lists(lut) ! for debugging the free lists and routines using them implicit none integer lut !\end{verbatim} integer lok,last write(lut,1007)noofel,noofsp,noofph,noofem,noofint,noofprop,& notpf(),highcs,eqfree-1,nsvfun,reffree-1,addrecs 1007 format('Records for elements, species, phases: ',3i5/& 'end members, interactions, properties: ',3i5/& 'TP-funs, composition sets, equilibria: ',3i5/& 'state variable functions, references, additions: ',3i5) !---------------------------- ! first free is csfree, free list is only in equilibrium firsteq 600 continue write(lut,610)csfree,highcs 610 format('Phase_varres first free/highcs: ',2i5) ! NOTE csfree can be higher than highcs ... after deletion pointers can go back ! UNFINISHED?? ! lok=csfree ! list free list for composition sets ! write(*,*)'3Y csfree and highcs: ',csfree,highcs !611 continue ! last=lok ! lok=firsteq%phase_varres(last)%nextfree ! write(*,*)'3Y lok: ',last,lok ! if(lok.gt.0) goto 611 ! lok=csfree 620 continue if(lok+5.lt.highcs) then last=lok lok=firsteq%phase_varres(last)%nextfree write(*,*)'3Y free varres record at: ',lok,last if(lok.le.0) then write(lut,*)'Error in phase_varres free list',last,lok goto 1000 else goto 620 endif endif ! no more 630 continue 1000 continue return end subroutine list_free_lists !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine set_phase_amounts !\begin{verbatim} subroutine set_phase_amounts(jph,ics,val,ceq) ! set the amount formula units of a phase. Called from user i/f ! iph can be -1 meaning all phases, all composition sets implicit none integer jph,ics double precision val TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer iph,lokph,lokcs double precision amount if(jph.lt.0) then iph=1; ics=1 else iph=jph endif call get_phase_compset(iph,ics,lokph,lokcs) if(gx%bmperr.ne.0) goto 1000 100 continue if(test_phase_status(iph,ics,amount,ceq).gt.3) goto 700 ! ceq%phase_varres(lokcs)%amount(1)=val ceq%phase_varres(lokcs)%amfu=val 700 continue if(jph.lt.0) then ics=ics+1 710 continue call get_phase_compset(iph,ics,lokph,lokcs) if(gx%bmperr.ne.0) then gx%bmperr=0; iph=iph+1 if(iph.gt.noofph) goto 1000 ics=1; goto 710 endif goto 100 endif 1000 continue return end subroutine set_phase_amounts !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine set_default_constitution !\begin{verbatim} subroutine set_default_constitution(iph,ics,ceq) ! the current constitution of (iph#ics) is set to its default constitution ! (if any), otherwise a random value. The amount of the phase not changed implicit none integer iph,ics TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer lokph,lokcs,ll,jj,kk,kk0 type(gtp_phase_varres), pointer :: cset double precision, allocatable :: yarr(:) double precision sum, qq(5),var ! call get_phase_compset(iph,ics,lokph,lokcs) if(gx%bmperr.ne.0) goto 1000 cset=>ceq%phase_varres(lokcs) ! we must use set_constitution at the end to update various internal variables allocate(yarr(phlista(lokph)%tnooffr)) ! if(btest(cset%status2,CSDEFCON)) then if(allocated(cset%mmyfr)) then ! there is an allocated default constitution ! write(*,12)'3Y mmfy: ',(cset%mmyfr(kk),kk=1,phlista(lokph)%tnooffr) kk=0 subl1: do ll=1,phlista(lokph)%noofsubl kk0=kk sum=zero if(phlista(lokph)%nooffr(ll).gt.1) then do jj=1,phlista(lokph)%nooffr(ll) ! negative mmy(kk) means < , a maximum, set a small value kk=kk+1 if(cset%mmyfr(kk).lt.0.0E0) then yarr(kk)=0.01D0 else yarr(kk)=one endif sum=sum+yarr(kk) enddo kk=kk0 ! the sum of fractions should be unity, hm done in set_constitution also ... do jj=1,phlista(lokph)%nooffr(ll) kk=kk+1 yarr(kk)=yarr(kk)/sum enddo else ! a single constituent, just increment kk and leave fraction as unity kk=kk+1 yarr(kk)=one endif enddo subl1 ! write(*,12)'3Y defy: ',(yarr(kk),kk=1,phlista(lokph)%tnooffr) 12 format(a,10F6.3) else ! there is no default constitution, set equal amount of all fractions ! with some randomness ! write(*,*)'3Y No default constituition for: ',iph,ics ! if(btest(cset%status2,CSDEFCON)) then ! write(*,*)'3Y default constitution set not allocated' ! endif kk=0 subl2: do ll=1,phlista(lokph)%noofsubl if(phlista(lokph)%nooffr(ll).gt.1) then ! set equal amount of all fractions with some variation sum=one/real(phlista(lokph)%nooffr(ll)) var=0.1D0*sum do jj=1,phlista(lokph)%nooffr(ll) kk=kk+1 yarr(kk)=sum+var var=-0.9D0*var enddo else ! a single constituent, just increment kk and ensure the fraction is unity kk=kk+1 yarr(kk)=one endif enddo subl2 endif ! write(*,411)yarr 411 format('3Y set_def_const: ',8F7.4,(10f7.4)) ! in this routine the fractions in each sublattice is normallized to be unity call set_constitution(iph,ics,yarr,qq,ceq) deallocate(yarr) 1000 continue return end subroutine set_default_constitution !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine todo_before !\begin{verbatim} subroutine todo_before(mode,ceq) ! this could be called before an equilibrium calculation ! It should remove any phase amounts and clears CSSTABLE ! DUMMY ! implicit none TYPE(gtp_equilibrium_data), pointer :: ceq integer mode !\end{verbatim} integer iph,ics,lokph,lokcs ! ! write(*,*)'3Y Todo_before ... not implemented' goto 1000 ! phloop: do iph=1,noph() lokph=phases(iph) ! skip hidden phases if(btest(phlista(lokph)%status1,PHHID)) cycle 300 csloop: do ics=1,phlista(lokph)%noofcs lokcs=phlista(lokph)%linktocs(ics) ! ceq%phase_varres(lokcs)%amount(1)=zero ceq%phase_varres(lokcs)%amfu=zero ! ceq%phase_varres(lokcs)%status2=& ! ibclr(ceq%phase_varres(lokcs)%status2,CSSTABLE) enddo csloop enddo phloop ! 1000 continue return end subroutine todo_before !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine todo_after_found_equilibrium !\begin{verbatim} subroutine todo_after_found_equilibrium(mode,addtuple,ceq) ! this is called after an equilibrium calculation by calceq2 and calceq3 ! It marks stable phase (set CSSTABLE and remove any CSAUTO) ! It removes redundant unstable composition sets created automatically ! (CSAUTO set). It will also shift stable composition sets to loweest ! possible (it will take into account if there are default constituent ! fractions, CSDEFCON set). ! mode determine some of the actions, at present only >0 or <0 matters ! ! >>>>>>>>>>> THIS IS DANGEROUS IN PARALLEL PROCESSING ! It should work in step and map as a composition set that once been stable ! will never be removed except if one does global minimization during the ! step and map. The function global_equil_check works on a copy of the ! ceq record and creates only a grid, it does not create any composition sets. ! NOTE that automatically entered metallic-FCC and MC-carbides may shift ! composition sets. Such shifts can be avoided by manual entering composition ! sets with default constitutions, but that does not always work as comparing ! a stable constitution with several defaults is not trivial ... ! implicit none TYPE(gtp_equilibrium_data), pointer :: ceq integer mode,addtuple !\end{verbatim} integer iph,ics,lokph,lokics,jcs,lokjcs,lastset,lokkcs,kzz,jtup,qq integer jstat2,fit,phs,haha1,haha2,disfravares,addph,icsno double precision val,xj1,xj2,extra(5) logical notok,noremove,globalok,once character jpre*4,jsuf*4 real, dimension(:), allocatable :: tmmyfr double precision, dimension(:), allocatable :: yfr ! THIS ROUTINE MUST BE CLEANED UP ! ! write(*,*)'3Y in todo_after',mode !---------------------------------------------------------------- addtuple=0 if(btest(globaldata%status,GSNOAFTEREQ)) goto 1000 nostart: if(mode.lt.0 .or. btest(globaldata%status,GSTGRID)) then ! if mode<0 the conditions did not allow gridmin before use it after if(btest(globaldata%status,GSNOGLOB)) goto 200 ! Problems with this calculation so global_equil_check is disabled inside ... write(*,3) 3 format('3Y Testing if any gridpoint is below the calculated equilibrium') if(btest(globaldata%status,GSNOTELCOMP)) then write(*,*)'3Y Cannot test global equilibrium when these components' goto 1000 endif qq=1 ! this generates a grid for test globalok=global_equil_check1(qq,addph,yfr,ceq) ! write(*,*)'3Y Back from global_equil_check1',gx%bmperr,lokph if(globalok) then ! if TRUE equilibrium OK or it could not be tested if(gx%bmperr.ne.0) then write(*,*)'3Y Testing equilibrium with global minimizer failed' goto 1000 endif ! write(*,*)'3Y Grid minimizer test of equilibrium OK' else ! if FALSE the test showed this is not a global equilibrium, handle this! gx%bmperr=0 lokph=phases(addph) write(*,*)'3Y Equilibrium wrong, gridtest found ',phlista(lokph)%name if(btest(globaldata%status,GSNORECALC)) goto 1000 ! write(*,*)'3Y add as stable: ',phlista(lokph)%name ! we should add addph to the stable set of phases and recalculate ! we have to check the state of all composition sets do ics=1,9 lokics=phlista(lokph)%linktocs(ics) ! write(*,*)'3Y Checking: ',addph,ics,lokph,lokics if(lokics.eq.0) then ! If we are not allowed to create composition sets quit if(btest(globaldata%status,GSNOACS)) goto 1000 ! we have to create a new composition set and set that stable ! return with error code to initiate new calculation, icsno returned ! write(*,*)'3Y Creating a new composition set',addph call enter_composition_set(addph,' ','CHKD',icsno) if(gx%bmperr.ne.0) then write(*,*)'Error creating composition set',gx%bmperr goto 1000 endif call get_phase_compset(addph,icsno,lokph,lokics) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'3Y ceated comp.set: ',ceq%phase_varres(lokics)%phtupx ceq%phase_varres(lokics)%status2=& ibset(ceq%phase_varres(lokics)%status2,CSAUTO) ! we must set the constitution also!! call set_constitution(addph,icsno,yfr,extra,ceq) if(gx%bmperr.ne.0) then write(*,*)'3Y error setting y of new comp.set' goto 1000 endif ! set some positive amount ceq%phase_varres(lokics)%amfu=1.0D-3 ! I do not think the tuple has been created ... just set the phase index addtuple=ceq%phase_varres(lokics)%phtupx write(*,*)'3Y recalculate with: ',addtuple,icsno,lokics gx%bmperr=4358 goto 1000 elseif(ceq%phase_varres(lokics)%phstate.lt.PHENTUNST) then ! this set is dormant, ignore this stable ste and give no error write(*,*)'3Y Skip dormant phase no',& ceq%phase_varres(lokics)%phtupx ! if there is a dormant composition set do not enter a new goto 200 elseif(ceq%phase_varres(lokics)%phstate.eq.PHENTERED) then ! This composition set is entered but not stable, set it as stable and ! jump back with error code and calculate again ceq%phase_varres(lokics)%phstate=PHENTSTAB ceq%phase_varres(lokics)%amfu=1.0D-3 addtuple=ceq%phase_varres(lokics)%phtupx ! write(*,*)'3Y recalculate with gridpoint stable',addtuple,ics ! we must set the constitution also!! call set_constitution(addph,ics,yfr,extra,ceq) gx%bmperr=4358 goto 1000 else ! phase is stable or even fix, there is a miscibility gap, check if there are ! any more composition sets? ! write(*,*)'3Y phase has a stable comp.set: ',addph,ics endif enddo ! no cleanup goto 1000 endif endif nostart !-------------------------------------------------------------------- ! Shift all stable composition down to lower comp.sets 200 continue ! write(*,*)'3Y Shifting composition sets' phloop1: do iph=1,noph() lokph=phases(iph) if(btest(phlista(lokph)%status1,PHHID)) cycle csloop1: do ics=2,phlista(lokph)%noofcs lokics=phlista(lokph)%linktocs(ics) ! write(*,*)'3Y shift down: ',ics,lokics,& ! ceq%phase_varres(lokics)%phstate,& ! btest(ceq%phase_varres(lokics)%status2,CSAUTO),& ! btest(ceq%phase_varres(lokics)%status2,CSTEMPAR) if(ceq%phase_varres(lokics)%phstate.eq.PHENTSTAB .and. & btest(ceq%phase_varres(lokics)%status2,CSTEMPAR)) then ! btest(ceq%phase_varres(lokics)%status2,CSAUTO)) then fit=100 ! This comp.set is stable, check if a lower compset is unstable csloop2: do jcs=1,ics-1 lokjcs=phlista(lokph)%linktocs(jcs) if(ceq%phase_varres(lokjcs)%phstate.le.PHENTERED) then ! do not bother if composition of lokics fits defaults in lokjcs ! if(.not.checkdefcon(lokics,lokjcs,fit,ceq)) cycle csloop2 ! write(*,*)'3Y Moving stable comp.set ',ics,' down to ',jcs goto 500 elseif(jcs.eq.ics-1) then if(fit.gt.2) then ! No lower unstable comp.set, or no one which almost fit default const, ! lokics must remain stable, remove CSAUTO bit ! Do not remove the suffix _AUTO ! write(*,*)'3Y Keeping AUTO comp.set ',ics,lokics ceq%phase_varres(lokics)%status2=& ibclr(ceq%phase_varres(lokics)%status2,CSAUTO) exit csloop2 endif else cycle csloop2 endif ! Accept a default consitution which almost fits the default ! write(*,*)'3Y Accept fit to default: ',fit,lokics,lokjcs 500 continue ! write(*,*)'3Y Move stable to lower unstable compsets' ! move STABLE lokics to UNSTABLE lokjcs ! save some jcs values of amount, dgm, status, pre&suffix and tuple index xj1=ceq%phase_varres(lokjcs)%amfu xj2=ceq%phase_varres(lokjcs)%dgm jtup=ceq%phase_varres(lokjcs)%phtupx jstat2=ceq%phase_varres(lokjcs)%status2 jpre=ceq%phase_varres(lokjcs)%prefix jsuf=ceq%phase_varres(lokjcs)%suffix phs=ceq%phase_varres(lokjcs)%phstate ! write(*,489)lokics,lokjcs if(ocv()) write(*,489)ceq%phase_varres(lokics)%phtupx,jtup 489 format('3Y move results from tuplet ',i4,' to ',i4) ! write(*,501)lokics,ceq%phase_varres(lokics)%mmyfr ! write(*,501)lokjcs,ceq%phase_varres(lokjcs)%mmyfr 501 format('3Y 501: ',i5,10F5.1) ! copy main content of the phase_varres(lokics) record to phase_varres(lokjcs) ! BEWARE mmyfr must be kept! ! BEWARE disordered fraction set!!!! disfravares=ceq%phase_varres(lokjcs)%disfra%varreslink if(allocated(ceq%phase_varres(lokjcs)%mmyfr)) then allocate(tmmyfr(size(ceq%phase_varres(lokjcs)%mmyfr))) tmmyfr=ceq%phase_varres(lokjcs)%mmyfr ceq%phase_varres(lokjcs)=ceq%phase_varres(lokics) ceq%phase_varres(lokics)%mmyfr=tmmyfr deallocate(tmmyfr) endif ceq%phase_varres(lokjcs)=ceq%phase_varres(lokics) ! Some content in jcs must be set or restorted separately ceq%phase_varres(lokjcs)%phtupx=jtup ceq%phase_varres(lokjcs)%status2=jstat2 ceq%phase_varres(lokjcs)%prefix=jpre ceq%phase_varres(lokjcs)%suffix=jsuf ceq%phase_varres(lokjcs)%phstate=PHENTSTAB ! ceq%phase_varres(lokjcs)%status2=& ! ibset(ceq%phase_varres(lokjcs)%status2,CSSTABLE) ! write(*,501)lokics,ceq%phase_varres(lokics)%mmyfr ! write(*,501)lokjcs,ceq%phase_varres(lokjcs)%mmyfr ! maybe CSAUTO bit set, always remove it! ! write(*,*)'3Y Ensure CSAUTO cleared in ',jcs ceq%phase_varres(lokjcs)%status2=& ibclr(ceq%phase_varres(lokjcs)%status2,CSAUTO) ! Some content in ics must be set separately from saved values of jcs ceq%phase_varres(lokics)%amfu=xj1 ceq%phase_varres(lokics)%dgm=xj2 ceq%phase_varres(lokics)%phstate=phs ! clear the stable bit and set AUTO of ics ?? ! ceq%phase_varres(lokics)%status2=& ! ibclr(ceq%phase_varres(lokics)%status2,CSSTABLE) ! if(btest(ceq%phase_varres(lokics)%status2,CSAUTO)) & ! write(*,*)'3Y AUTO bit already set in ',ics ceq%phase_varres(lokics)%status2=& ibset(ceq%phase_varres(lokics)%status2,CSAUTO) ! move the link to the disordered fraction set ceq%phase_varres(lokjcs)%disfra%varreslink=& ceq%phase_varres(lokics)%disfra%varreslink ceq%phase_varres(lokics)%disfra%varreslink=disfravares exit csloop2 enddo csloop2 endif enddo csloop1 enddo phloop1 ! haha2=phlista(lokph)%linktocs(1) ! write(*,*)'3Y mitt 1:',lokph,haha2,ceq%phase_varres(haha2)%disfra%varreslink ! haha2=phlista(lokph)%linktocs(2) ! if(haha2.gt.0) & ! write(*,*)'3Y mitt 2:',lokph,haha2,ceq%phase_varres(haha2)%disfra%varreslink ! Here we may try to ensure that the stable comp.sets fits the ! default constitutions of their current set ! write(*,*)'3Y Try to shift stable comp.sets. to match default const.' ! SEGNENTATION FAULT efter this write statement when reading unformatted file call shiftcompsets(ceq) ! ! upto now is safe ... now remove CSAUTO comp.sets if allowed ! check if allowed to remove if(btest(globaldata%status,GSNOREMCS)) goto 1000 ! ! Now try to remove unstable composition sets with CSTEMPAR bit set ! write(*,*)'3Y loop to remove comp sets and auto bits' once=.TRUE. phloop: do iph=1,noph() noremove=.FALSE. lokph=phases(iph) if(btest(phlista(lokph)%status1,PHHID)) cycle ! loop backwards for compsets to remove unstable with CSAUTO set lastset=phlista(lokph)%noofcs csloopdown: do ics=lastset,2,-1 lokics=phlista(lokph)%linktocs(ics) ! write(*,*)'3Y Checking comp.set ',ics ! auto: if(btest(ceq%phase_varres(lokics)%status2,CSAUTO)) then auto: if(btest(ceq%phase_varres(lokics)%status2,CSTEMPAR)) then if(ceq%phase_varres(lokics)%phstate.le.PHENTERED) then ! comp.set was created automatically but is not stable, it can be removed if(noeq().eq.1) then ! we have just one equilibrium, OK to remove even in parallel ... if(once) then if(ocv()) write(*,801)lokics 801 format('3Y Removing unstable phase tuple(s)',i5) once=.FALSE. endif ! write(*,802)'3Y removing unstable phase tuple/compset ',& ! ceq%phase_varres(lokics)%phtupx,lokics 802 format(a,3i5) ! remove the higherst composition set call remove_composition_set(iph,.FALSE.) if(gx%bmperr.ne.0) then write(*,*)'3Y failed to remove tuplet:',& ceq%phase_varres(lokics)%phtupx ! reset the error code but exit the attempt to clean up gx%bmperr=0; goto 1000 endif ! write(*,*)'3Y Phase tuple removed for phase: ',iph !$ elseif(omp_get_num_threads().gt.1) then ! we are running with several threads, just suspend the compset for the ! equilibrium in this thread !$ call suspend_composition_set(iph,.TRUE.,ceq) else ! when more than one equilibria in sequential eexecution suspend the compset ! in all equilibria where it is not stable call suspend_composition_set(iph,.FALSE.,ceq) endif else ! the comp.set is stable, clear the CSAUTO and CSTEMPAR bits ! write(*,*)'3Y this comp.set. should never be removed' ceq%phase_varres(lokics)%status2=& ibclr(ceq%phase_varres(lokics)%status2,CSAUTO) ceq%phase_varres(lokics)%status2=& ibclr(ceq%phase_varres(lokics)%status2,CSTEMPAR) endif endif auto enddo csloopdown enddo phloop ! 1000 continue ! write(*,*)'3Y Leaving todo_after!' ! lokph=1 ! jcs=phlista(lokph)%linktocs(1) ! write(*,*)'3Y after 1: ',lokph,jcs,ceq%phase_varres(jcs)%disfra%varreslink ! jcs=phlista(lokph)%linktocs(2) ! write(*,*)'3Y Leaving todo_after' ! if(jcs.gt.0) & ! write(*,*)'after 2: ',lokph,jcs,ceq%phase_varres(jcs)%disfra%varreslink return end subroutine todo_after_found_equilibrium !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine checkdefcon !\begin{verbatim} subroutine checkdefcon(lokics,lokjcs,fit,ceq) ! check if composition of lokics fits default constitution in lokjcs ! return TRUE if lokics fits default in lokjcs ! NOTE lokics and lokjcs can be the same!! integer lokics,lokjcs,fit type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer kk real xdef ! write(*,*)'3Y in checkdefcon: ',lokics,lokjcs if(btest(ceq%phase_varres(lokjcs)%status2,CSDEFCON)) then if(.not.allocated(ceq%phase_varres(lokjcs)%mmyfr)) then ! write(*,'(a,i3,a)')'3Y *** Warning: phasetuple ',& ! ceq%phase_varres(lokjcs)%phtupx,' has no default constitution' fit=0; goto 1000 endif ! write(*,9)(ceq%phase_varres(lokjcs)%mmyfr(fit),& ! fit=1,size(ceq%phase_varres(lokjcs)%yfr)) 9 format('3Y default: ',10F6.2) fit=1 do kk=1,size(ceq%phase_varres(lokjcs)%mmyfr) ! do kk=1,size(ceq%phase_varres(lokjcs)%yfr) xdef=ceq%phase_varres(lokjcs)%mmyfr(kk) if(xdef.eq.0) then ! no default for this constitution fit=fit+1 elseif(xdef.lt.0.0) then ! A fraction with a maximum set (mmyfr<0) must be below mmyfr(kk) if(ceq%phase_varres(lokics)%yfr(kk).lt.abs(xdef)) fit=fit+1 ! write(*,11)ceq%phase_varres(lokics)%yfr(kk),' < ',xdef,kk,fit 11 format('3Y If ',F10.6,a,F10.6,' increment ',2i3) else ! A fraction with a minimum set (mmyfr>0) should be above mmyfr(kk) if(ceq%phase_varres(lokics)%yfr(kk).gt.xdef) fit=fit+1 ! write(*,11)ceq%phase_varres(lokics)%yfr(kk),' > ',xdef,kk,fit endif enddo ! write(*,*)'3Y checkdefcon fit: ',fit,kk else ! no default constitution, perfect fit!! fit=size(ceq%phase_varres(lokjcs)%yfr) endif 1000 continue return end subroutine checkdefcon !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine shiftcompsets !\begin{verbatim} %- subroutine shiftcompsets(ceq) ! check phase with several composition sets if they should be shifted ! to fit the default constitution better ! IGNORE UNSTABLE COMP.SETS type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer lokph,iph,ics,lokics,jcs,lokjcs,bestfit(9,9),jj,kk,kki,kkj integer moveto(9) character ch1*1 ! write(*,*)'3Y in shiftcompsets' phloop: do iph=1,noofph lokph=phases(iph) manycs: if(phlista(lokph)%noofcs.gt.1) then ! seach all compset which default constitution that fits best a stable one bestfit=0 csloop1: do ics=1,phlista(lokph)%noofcs lokics=phlista(lokph)%linktocs(ics) ! ignore UNSTABLE compsets with CSAUTO set ?? if(ceq%phase_varres(lokics)%phstate.le.PHENTERED) cycle csloop1 call checkdefcon(lokics,lokics,kk,ceq) ! write(*,*)'3Y fit 1: ',kk,phlista(lokph)%tnooffr bestfit(ics,ics)=kk if(kk.eq.phlista(lokph)%tnooffr) cycle csloop1 ! if no default or not perfect fit compare with other compsets ! write(*,*)'3Y compare with next compset' csloop2: do jcs=1,phlista(lokph)%noofcs if(jcs.eq.ics) cycle csloop2 lokjcs=phlista(lokph)%linktocs(jcs) if(ceq%phase_varres(lokjcs)%phstate.le.PHENTERED) cycle csloop2 call checkdefcon(lokics,lokjcs,kk,ceq) ! write(*,*)'3Y fit 2: ',kk,phlista(lokph)%tnooffr bestfit(jcs,ics)=kk enddo csloop2 enddo csloop1 ! do ics=1,phlista(lokph)%noofcs ! write(*,17)(bestfit(jcs,ics),jcs=1,phlista(lokph)%noofcs) ! enddo 17 format('3Y bestfit: ',9i5) ! when we are here whe can use bestfit to shift constitutions moveto=0 shiftfrom: do ics=1,phlista(lokph)%noofcs kk=bestfit(ics,ics) if(kk.eq.phlista(lokph)%tnooffr) cycle shiftfrom shiftto: do jcs=2,phlista(lokph)%noofcs if(bestfit(jcs,ics).gt.kk) then kk=bestfit(jcs,ics) write(*,*)'3Y shifting: ',ics,jcs call switch_compsets2(lokph,ics,jcs,ceq) endif enddo shiftto enddo shiftfrom ! just check do nothing for the moment .... ! if moveto(ics) is zero do not move. otherwise moveto moveto(ics) ! but if moveto(moveto(ics)) is zero look for a moveto() that is negative ... endif manycs enddo phloop ! 1000 continue return end subroutine shiftcompsets !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine switch_compsets2 !\begin{verbatim} %- subroutine switch_compsets2(lokph,ics1,ics2,ceq) ! copy constitution and results from ic2 to ic1 and vice versa integer lokph,ics1,ics2 type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer iph,lokcs1,lokcs2,ncon,idum,ncc double precision, dimension(:), allocatable :: val double precision, dimension(:,:), allocatable :: gval,d2gval double precision, dimension(:,:,:), allocatable :: dgval double precision qq(5),xdum ! ! write(*,*)'3Y In switch_compsets ',lokph,ics1,ics2 lokcs1=phlista(lokph)%linktocs(ics1) lokcs2=phlista(lokph)%linktocs(ics2) ! save current constitution of lokcs1 in val ncon=size(ceq%phase_varres(lokcs1)%yfr) allocate(val(ncon)) val=ceq%phase_varres(lokcs1)%yfr ! set the constitution in lokcs1 equal to that in lokcs2. This call ! also updates a number of other variables in the record iph=phlista(lokph)%alphaindex call set_constitution(iph,ics1,ceq%phase_varres(lokcs2)%yfr,qq,ceq) if(gx%bmperr.ne.0) goto 1000 call set_constitution(iph,ics2,val,qq,ceq) if(gx%bmperr.ne.0) goto 1000 ! copy some variables: phstate, amfu and dgm idum=ceq%phase_varres(lokcs1)%phstate ceq%phase_varres(lokcs1)%phstate=ceq%phase_varres(lokcs2)%phstate ceq%phase_varres(lokcs2)%phstate=idum xdum=ceq%phase_varres(lokcs1)%amfu ceq%phase_varres(lokcs1)%amfu=ceq%phase_varres(lokcs2)%amfu ceq%phase_varres(lokcs2)%amfu=xdum xdum=ceq%phase_varres(lokcs1)%dgm ceq%phase_varres(lokcs1)%dgm=ceq%phase_varres(lokcs2)%dgm ceq%phase_varres(lokcs2)%dgm=xdum ! listprop will be the same ! Now copy result arrays ncon=ceq%phase_varres(lokcs1)%nprop allocate(gval(6,ncon)) gval=ceq%phase_varres(lokcs1)%gval ceq%phase_varres(lokcs1)%gval=ceq%phase_varres(lokcs2)%gval ceq%phase_varres(lokcs2)%gval=gval ! ceq%phase_varres(lokph1)%ncc is not the dimension of dgval, why?? ncc=size(ceq%phase_varres(lokcs1)%yfr) allocate(dgval(3,ncc,ncon)) ! write(*,77)'3Y copycomp: ',ncc,ncon,& ! size(dgval),size(ceq%phase_varres(lokcs1)%dgval),& ! ceq%phase_varres(lokcs2)%ncc, !77 format(a,10i5) dgval=ceq%phase_varres(lokcs1)%dgval ceq%phase_varres(lokcs1)%dgval=ceq%phase_varres(lokcs2)%dgval ceq%phase_varres(lokcs2)%dgval=dgval allocate(d2gval(ncc*(ncc+1)/2,ncon)) d2gval=ceq%phase_varres(lokcs1)%d2gval ceq%phase_varres(lokcs1)%d2gval=ceq%phase_varres(lokcs2)%d2gval ceq%phase_varres(lokcs2)%d2gval=d2gval ! addg!! ! if(btest(ceq%phase_varres(lokcs1)%status2 if(allocated(ceq%phase_varres(lokcs1)%addg)) then val(1)=ceq%phase_varres(lokcs1)%addg(1) ceq%phase_varres(lokcs1)%addg(1)=ceq%phase_varres(lokcs2)%addg(1) ceq%phase_varres(lokcs2)%addg(1)=val(1) endif ! curlat, cinvy, cxmol, cdxmol? 1000 continue ! deallocate deallocate(val) deallocate(gval) deallocate(dgval) deallocate(d2gval) return end subroutine switch_compsets2 !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine select_composition_set !\begin{verbatim} subroutine select_composition_set(iph,ics,yarr,ceq) ! PROBABLY NOT USED but should be implemenented ! if phase iph wants to become stable and there are several user defined ! composition sets with default composition limits this subroutine tries to ! select the one that fits these limits best. ! For example if an FCC phase that could be an austenite (low carbon content) ! or a cubic carbo-nitride (high carbon or nitrogen content, low vacancy) ! Less easy to handle ordered phases like B2 or L1_2 as ordering can be ! in any sublatittice ... but with option B and F that is possible implicit none TYPE(gtp_equilibrium_data), pointer :: ceq double precision, dimension(*) :: yarr integer iph,ics !\end{verbatim} double precision, parameter :: yl=0.1D0,yh=0.5D0 integer best,lokph,maxnh,ncc,jcs,lokcs,nh,jl lokph=phases(iph) best=1 maxnh=0 ncc=phlista(lokph)%tnooffr do jcs=1,phlista(lokph)%noofcs ! loop through all composition sets lokcs=phlista(lokph)%linktocs(jcs) ! compare yarr with ceq%phase_varres(lokcs)%mmyfr nh=0 do jl=1,ncc if(ceq%phase_varres(lokcs)%mmyfr(jl).lt.zero) then if(yarr(jl).lt.yl) nh=nh+1 elseif(ceq%phase_varres(lokcs)%mmyfr(jl).gt.zero) then if(yarr(jl).gt.yh) nh=nh+1 endif enddo if(nh.gt.maxnh) then maxnh=nh best=jcs endif enddo ! if only one compset return this! ics=best ! 1000 continue return end subroutine select_composition_set !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine verify_phase_varres_array !\begin{verbatim} subroutine verify_phase_varres_array(ieq,verbose) ! This subroutine checks that the phase varres array is consistent ! in equilibrium ieq. For ieq=1 it also checks the free list ! UNFINISHED and not yet used BUT IMPORTANT implicit none integer ieq,verbose !\end{verbatim} integer free,lokcs,lokph type(gtp_phase_varres), pointer :: vares type(gtp_equilibrium_data), pointer :: ceq ceq=>eqlista(ieq) if(ieq.eq.1) then ! check free list inside phase_varres records if(csfree.lt.1 .or. csfree.gt.size(ceq%phase_varres)) then write(*,*)'3Y ERROR: csfree value outside limits: ',csfree goto 1000 endif lokcs=csfree 50 continue if(lokcs.lt.1 .or. lokcs.gt.size(ceq%phase_varres)) then write(*,*)'3Y ERROR: varres free list index outside limits: ',lokcs goto 1000 endif lokcs=ceq%phase_varres(lokcs)%nextfree if(lokcs.lt.size(ceq%phase_varres)) goto 50 !------- write(*,*)'3Y varres free list seems OK.' endif !------- ! check each used varres record that it has a correct phase pointer etc. ! UNFINISHED 1000 continue return end subroutine verify_phase_varres_array !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine set_emergency_startpoint !\begin{verbatim} subroutine set_emergency_startpoint(mode,phl,amfu,ceq) ! this is called if no previous equilibrium and if grid minimizer ! cannot be used. Select for each element a phase with as much of that ! element as possible to set as stable. Set the remaining phases to a default ! composition. It will never create any compositon sets ! implicit none integer mode,phl(*) double precision amfu(*) TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer iph,lokph,lokcs,iel,errall integer, allocatable, dimension(:) :: selected double precision, allocatable, dimension(:,:) :: maxel double precision, allocatable, dimension(:) :: wmass double precision totmol,totmass,am ! write(*,*)'In emergency startpoint: ',mode,noofel,noofph allocate(selected(noofel),stat=errall) allocate(maxel(noofel,noofph),stat=errall) allocate(wmass(noofel),stat=errall) if(errall.ne.0) then write(*,*)'3Y allocation error 17: ',errall gx%bmperr=4370; goto 1000 endif ! phl=0 ! amfu=zero maxel=zero phloop1: do iph=1,noofph lokph=phases(iph) lokcs=phlista(iph)%linktocs(1) if(ceq%phase_varres(lokcs)%phstate.le.PHDORM) cycle phloop1 if(phlista(iph)%tnooffr-phlista(iph)%noofsubl.eq.0) then call calc_phase_molmass(iph,1,maxel(1,iph),wmass,totmol,totmass,am,ceq) if(gx%bmperr.ne.0) goto 1000 else write(*,*)'3Y TODO: Phases with variable composition not included yet' endif ! loop through all fractions to find limits enddo phloop1 ! do iph=1,noofph ! write(*,100)iph,(maxel(iel,iph),iel=1,noofel) ! enddo 100 format('3Y maxel: ',i3,6(F8.5)) selected=0 wmass=zero phloop2: do iph=1,noofph lokph=phases(iph) lokcs=phlista(iph)%linktocs(1) if(ceq%phase_varres(lokcs)%phstate.le.PHDORM) cycle phloop2 elloop1: do iel=1,noofel if(maxel(iel,iph).gt.wmass(iel)) then wmass(iel)=maxel(iel,iph) selected(iel)=iph ! we can only have one element selected per phase ... cycle phloop2 endif enddo elloop1 enddo phloop2 ! write(*,*)'3Y Emergency startpoint testing',mode ! write(*,200)'3Y selected: ',(selected(iel),iel=1,noofel) 200 format(a,10i4) ! Now set default constitution of all non-selected and non-suspended phases phloop3: do iph=1,noofph lokph=phases(iph) lokcs=phlista(iph)%linktocs(1) if(ceq%phase_varres(lokcs)%phstate.le.PHDORM) cycle phloop3 do iel=1,noofel if(iph.eq.selected(iel)) cycle phloop3 enddo ! write(*,*)'3Y TODO set default constitutions: ',iph call set_default_constitution(iph,1,ceq) if(gx%bmperr.ne.0) goto 1000 enddo phloop3 mode=noofel do iph=1,mode phl(iph)=selected(iph) enddo ! 1000 continue return end subroutine set_emergency_startpoint !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable logical function ocv !\begin{verbatim} logical function ocv() ! returns TRUE if GSVERBOSE bit is set !\end{verbatim} %+ ! typical use: if(ocv()) write(*,*).... ocv=btest(globaldata%status,GSVERBOSE) return end function ocv !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable integer function ceqsize !\begin{verbatim} integer function ceqsize(ceq) ! calculates the size in words (4 bytes) of an equilibrium record implicit none type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer sum,vsum,ivs,vss ! write(*,*)'In ceqsize 1' ! ! integer status,multiuse,eqno,next ! character eqname*24 ! double precision tpval(2),rtn ! svfunres: the values of state variable functions valid for this equilibrium ! double precision, dimension(:), allocatable :: svfunres sum=18+2*size(ceq%svfunres) write(*,*)'total + svfunres: ',sum,size(ceq%svfunres) ! the experiments are used in assessments and stored like conditions ! lastcondition: link to condition list ! lastexperiment: link to experiment list ! TYPE(gtp_condition), pointer :: lastcondition,lastexperiment ! assuming a pointer is 4 bytes (2 words) sum=sum+4 ! components and conversion matrix from components to elements ! complist: array with components ! compstoi: stoichiometric matrix of compoents relative to elements ! invcompstoi: inverted stoichiometric matrix ! TYPE(gtp_components), dimension(:), allocatable :: complist ! double precision, dimension(:,:), allocatable :: compstoi ! double precision, dimension(:,:), allocatable :: invcompstoi ! a gtp_component record is about 20 words, invcompstoi same as compsoti if(allocated(ceq%complist)) sum=sum+20*size(ceq%complist)+& 4*size(ceq%compstoi) write(*,*)'total + complist:',sum,20*size(ceq%complist),4*size(ceq%compstoi) ! one record for each phase+composition set that can be calculated ! phase_varres: here all calculated data for the phase is stored ! TYPE(gtp_phase_varres), dimension(:), allocatable :: phase_varres ! each phase_varres record is different for each phase vsum=0 ! highcs is highest used free phase_varres record do ivs=1,highcs vss=vssize(ceq%phase_varres(ivs)) write(*,*)'Phase varres: ',ivs,vss vsum=vsum+vss enddo sum=sum+vsum write(*,*)'total + varres',sum,vsum ! index to the tpfun_parres array is the same as in the global array tpres ! eq_tpres: here local calculated values of TP functions are stored ! TYPE(tpfun_parres), dimension(:), pointer :: eq_tpres ! each tpfun_parres record is 8 double sum=sum+16*size(ceq%eq_tpres) ! current values of chemical potentials stored in component record but ! duplicated here for easy acces by application software ! double precision, dimension(:), allocatable :: cmuval if(allocated(ceq%cmuval)) sum=sum+2*size(ceq%cmuval) write(*,*)'total + cmuval: ',sum,2*size(ceq%cmuval) ! xconc: convergence criteria for constituent fractions and other things ! double precision xconv ! delta-G value for merging gridpoints in grid minimizer ! smaller value creates problem for test step3.BMM, MC and austenite merged ! double precision :: gmindif=-5.0D-2 ! maxiter: maximum number of iterations allowed ! integer maxiter sum=sum+5 ! this is to save a copy of the last calculated system matrix, needed ! to calculate dot derivatives, initiate to zero ! integer :: sysmatdim=0,nfixmu=0,nfixph=0 ! integer, allocatable :: fixmu(:) ! integer, allocatable :: fixph(:,:) ! double precision, allocatable :: savesysmat(:,:) sum=sum+3+size(ceq%fixmu)+size(ceq%fixph)+size(ceq%savesysmat) write(*,*)'total + savesysmat:',sum,size(ceq%fixmu),size(ceq%fixph),& size(ceq%savesysmat) ceqsize=sum 1000 continue return end function ceqsize !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable integer function vssize !\begin{verbatim} integer function vssize(varres) ! calculates the size in words (4 bytes) of a phase_varres record implicit none type(gtp_phase_varres) :: varres !\end{verbatim} integer sum ! write(*,*)'In vssize 1' ! integer nextfree,phlink,status2,phstate ! double precision, dimension(2) :: abnorm ! character*4 prefix,suffix sum=10 ! changed to allocatable ! integer, dimension(:), allocatable :: constat ! double precision, dimension(:), allocatable :: yfr ! real, dimension(:), allocatable :: mmyfr ! double precision, dimension(:), allocatable :: sites if(allocated(varres%constat)) sum=sum+size(varres%constat) write(*,*)'varressum+yfr: ',sum,size(varres%constat),3*size(varres%yfr) if(allocated(varres%yfr)) sum=sum+3*size(varres%yfr) ! write(*,*)'In vssize 2',sum ! for ionic liquid derivatives of sites wrt fractions (it is the charge), ! 2nd derivates only when one constituent is vacancy ! 1st sublattice P=\sum_j (-v_j)*y_j + Qy_Va ! 2nd sublattice Q=\sum_i v_i*y_i ! double precision, dimension(:), allocatable :: dpqdy ! double precision, dimension(:), allocatable :: d2pqdvay if(allocated(varres%dpqdy)) sum=sum+size(varres%dpqdy) if(allocated(varres%d2pqdvay)) sum=sum+size(varres%d2pqdvay) write(*,*)'varressum+ionliq',sum,size(varres%dpqdy),size(varres%d2pqdvay) ! for extra fraction sets, better to go via phase record index above ! this TYPE(gtp_fraction_set) variable is a bit messy. Declaring it in this ! way means the record is stored inside this record. ! type(gtp_fraction_set) :: disfra ! size of disfra record?? sum=sum+10 if(allocated(varres%disfra%dsites)) sum=sum+size(varres%disfra%dsites) if(allocated(varres%disfra%nooffr)) sum=sum+size(varres%disfra%nooffr) if(allocated(varres%disfra%splink)) sum=sum+size(varres%disfra%splink) if(allocated(varres%disfra%y2x)) sum=sum+size(varres%disfra%y2x) if(allocated(varres%disfra%dxidyj)) sum=sum+size(varres%disfra%dxidyj) write(*,*)'varresum incl disfra and pointer: ',sum,varres%disfra%varreslink ! It seems difficult to get the phdapointer in disfra record to work ! --- ! arrays for storing calculated results for each phase (composition set) ! amfu: is amount formula units of the composition set (calculated result) ! netcharge: is net charge of phase ! dgm: driving force (calculated result) ! amcom: not used ! damount: set to last change of phase amount in equilibrium calculations ! qqsave: values of qq calculated in set_constitution ! double precision amount(2),dgm,amcom,damount,qqsave(3) ! double precision amfu,netcharge,dgm,amcom,damount,qqsave(3) ! double precision amfu,netcharge,dgm,amcom,damount sum=sum+10 ! Other properties may be that: gval(*,2) is TC, (*,3) is BMAG, see listprop ! nprop: the number of different properties (set in allocate) ! ncc: total number of site fractions (redundant but used in some subroutines) ! BEWHARE: ncc seems to be wrong using TQ test program fenitq.F90 ??? ! listprop(1): is number of calculated properties ! listprop(2:listprop(1)): identifies the property stored in gval(1,ipy) etc ! 2=TC, 3=BMAG. Properties defined in the gtp_propid record ! integer nprop,ncc ! integer, dimension(:), allocatable :: listprop if(allocated(varres%listprop)) sum=sum+2+size(varres%listprop) write(*,*)'varresum + listprop: ',sum,size(varres%listprop) ! gval etc are for all composition dependent properties, gval(*,1) for G ! gval(*,1): is G, G.T, G.P, G.T.T, G.T.P and G.P.P ! dgval(1,j,1): is first derivatives of G wrt fractions j ! dgval(2,j,1): is second derivatives of G wrt fractions j and T ! dgval(3,j,1): is second derivatives of G wrt fractions j and P ! d2gval(ixsym(i,j),1): is second derivatives of G wrt fractions i and j ! double precision, dimension(:,:), allocatable :: gval ! double precision, dimension(:,:,:), allocatable :: dgval ! double precision, dimension(:,:), allocatable :: d2gval if(allocated(varres%gval)) sum=sum+2*size(varres%gval) if(allocated(varres%dgval)) sum=sum+2*size(varres%dgval) if(allocated(varres%d2gval)) sum=sum+2*size(varres%d2gval) write(*,*)'varresum + gvals: ',sum,2*size(varres%gval),& 2*size(varres%dgval),2*size(varres%d2gval) ! added for strain/stress, current values of lattice parameters ! double precision, dimension(3,3) :: curlat ! saved values from last equilibrium calculation ! double precision, dimension(:,:), allocatable :: cinvy ! double precision, dimension(:), allocatable :: cxmol ! double precision, dimension(:,:), allocatable :: cdxmol if(allocated(varres%cinvy)) sum=sum+18+2*size(varres%cinvy) if(allocated(varres%cxmol)) sum=sum+18+2*size(varres%cxmol) if(allocated(varres%cdxmol)) sum=sum+18+2*size(varres%cdxmol) write(*,*)'varresum + saved: ',sum ! 1000 continue vssize=sum return end function vssize !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable logical function inveq !\begin{verbatim} logical function inveq(phases,ceq) ! Only called for mapping tie-lines not in plane. If tie-lines in plane ! then all nodes are invariants. integer phases type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer nrel,ii,nostph,tpvar,degf,www type(gtp_condition), pointer :: pcond,lastcond type(gtp_state_variable), pointer :: stvr ! How to know if the ceq is invariant? Gibbs phase rule, Degrees of freedom ! f = n + z - w - p ! where n is number of components, z=2 if T and P variable, ! z=1 if T or P variable, z=0 if both T and P fixed, ! w is number of other potential conditions (MU, AC) ! p is number of stable phases. ! write(*,*)'3Y in inveq' nrel=noel() ! sum up nubler of stable phases and check if T and P are fixed nostph=0 ! ntups=nooftup() ! do ii=1,noofphasetuples() do ii=1,nooftup() if(ceq%phase_varres(phasetuple(ii)%lokvares)%phstate.gt.0) & nostph=nostph+1 enddo ! loop all conditions lastcond=>ceq%lastcondition pcond=>lastcond tpvar=2 www=0 100 continue if(pcond%active.eq.0) then ! condtion is active stvr=>pcond%statvar(1) ! statevarid 1 is T and 2 is P if(stvr%statevarid.eq.1 .or. stvr%statevarid.eq.2) then ! Hm, ceq is not the equilibrium record for the node point ... tpvar=tpvar-1 elseif(stvr%statevarid.lt.10) then ! potential/activity condition for a component www=www+1 endif endif pcond=>pcond%next if(.not.associated(pcond,lastcond)) goto 100 ! ! Hm again, ignore tpvar? ! degf=nrel+tpvar-www-nostph degf=nrel-www-nostph ! write(*,'(a,8i4)')'3Y in inveq 2',nrel,tpvar,www,nostph,degf if(degf.lt.0) then ! We have an invariant equilibrium, return the number of stable phases phases=nostph inveq=.true. ! write(*,200)'3Y An invariant equilibrium!',nrel,tpvar,nostph,phases !200 format(a,5i7) else ! write(*,210)degef,nrel,tpvar,phases !210 format('3Y not invariant eq, elements, stable phases: ',4i4) ! if not invariant isoplet node there are 3 exits (2 lines crossing) phases=nostph inveq=.false. endif 1000 continue return end function inveq !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ ================================================ FILE: src/models/gtp3Z.F90 ================================================ ! ! gtp3Z included in gtp3.F90 ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !> 18. Section: TP functions !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ ! !*************************************************************** ! library with TP functions used by general thermodynamic package ! ! the declarations below are all moved to gtp3Z.F90 ! ! MODULE TPFUNLIB ! ! Copyright 2009-2015, Bo Sundman, France ! ! This program is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 2 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this program; if not, write to the Free Software ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! !------------------------------------------------------------------------- ! ! !\addtotable subroutine tpfun_init !\begin{verbatim} subroutine tpfun_init(nf,tpres) ! allocate tpfuns and create a free list inside the tpfuns implicit none integer nf ! use tpres declared externally for parallel processing TYPE(tpfun_parres), dimension(:), allocatable :: tpres !\end{verbatim} integer ifri allocate(tpfuns(nf)) ! write(*,*)'3Z allocated tpfuns: ',nf ! tpres allocated when creating equilibria ! allocate(tpres(nf)) ! create free list for named functions records freetpfun=1 do ifri=1,nf-1 tpfuns(ifri)%nextorsymbol=ifri+1 tpfuns(ifri)%noofranges=0 tpfuns(ifri)%status=0 tpfuns(ifri)%forcenewcalc=0 ! should also be initiallized ?? ! tpres(ifri)%forcenewcalc=0 enddo ! The last TP function has no next link tpfuns(nf)%nextorsymbol=-1 return END SUBROUTINE tpfun_init !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable integer function notpf !\begin{verbatim} integer function notpf() ! number of tpfunctions because freetpfun is private implicit none !\end{verbatim} notpf=freetpfun-1 end function notpf !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine find_tpfun_by_name !\begin{verbatim} subroutine find_tpfun_by_name(name,lrot) ! returns the location of a TP function ! if lrot>0 then start after lrot, this is to allow finding with wildcard * implicit none integer lrot character name*(*) !\end{verbatim} %+ character name1*16 integer i,j name1=name call capson(name1) if(lrot.le.0 .or. lrot.ge.freetpfun) then j=1 else ! if 1 < lrot < freetpfun start looking from lrot+1 j=lrot+1 endif do i=j,freetpfun-1 if(compare_abbrev(name,tpfuns(i)%symbol)) then lrot=i; goto 1000 endif enddo gx%bmperr=4060 1000 continue return end SUBROUTINE find_tpfun_by_name !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine find_tpfun_by_name_exact !\begin{verbatim} %- subroutine find_tpfun_by_name_exact(name,lrot,notent) ! returns the location of a TP function, notent TRUE if not entered implicit none integer lrot logical notent character name*(*) !\end{verbatim} character name1*16 integer i notent=.FALSE. name1=name call capson(name1) do i=1,freetpfun-1 if(name.eq.tpfuns(i)%symbol) then lrot=i if(btest(tpfuns(i)%status,TPNOTENT)) then notent=.TRUE. endif goto 1000 endif enddo gx%bmperr=4060 1000 continue return end SUBROUTINE find_tpfun_by_name_exact !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine eval_tpfun !\begin{verbatim} subroutine eval_tpfun(lrot,tpval,result,tpres) ! subroutine eval_tpfun(lrot,tpval,symval,result) ! evaluate a TP function with several T ranges implicit none integer lrot double precision tpval(2),result(6),xxx ! changes to avoid memory leak in valgrind TYPE(tpfun_parres), dimension(*) :: tpres !\end{verbatim} integer nr,ns TYPE(tpfun_expression), pointer :: exprot ! mini is the maximum relative difference between calculated and current values ! of T and P for using the stored values of a function double precision, parameter :: mini=1.0D-8 ! use lowest range for all T values lower than first upper limit ! and highest range for all T values higher than the next highest limit ! one should signal if T is lower than lowest limit or higher than highest ! used saved reults if same T and P ! if(lrot.le.0) then result=zero goto 1000 elseif(btest(tpfuns(lrot)%status,TPCONST)) then ! TP symbol is a constant, value stored in tpfuns(lrot)%limits(1) ! This takes care of updating assessment parameters!! result=zero result(1)=tpfuns(lrot)%limits(1) ! wow, we must not forget to store the constant in tpres(lrot)%results! ! write(*,*)'3Z const: ',tpres(lrot)%forcenewcalc,tpfuns(lrot)%forcenewcalc ! write(*,*)'3Z store: ',lrot,result(1),tpres(lrot)%results(1) goto 990 else ! check if previous values can be used ! tpfuns(lrot)%forcenewcalc is located with the function expression ! tpres(lrot)%forcenewcalc is different for each ceq, there can be several ! IT IS MEANINGLESS TO COMPARE THEM ... if(tpres(lrot)%forcenewcalc.eq.tpfuns(lrot)%forcenewcalc) then if(abs(tpres(lrot)%tpused(1)-tpval(1)).le.& mini*tpres(lrot)%tpused(1) .and. & (abs(tpres(lrot)%tpused(2)-tpval(2)).le.& mini*tpres(lrot)%tpused(2))) then result=tpres(lrot)%results ! write(*,12)'3Z oldval: ',lrot,tpres(lrot)%forcenewcalc,& ! tpfuns(lrot)%forcenewcalc,tpres(lrot)%results(1),tpval(1) !12 format(a,i5,2i4,4(1pe12.4)) goto 1000 endif ! else ! write(*,*)'3Z forced recalc: ',lrot,tpres(lrot)%forcenewcalc,& ! tpfuns(lrot)%forcenewcalc endif ! new values must be calculated ! write(*,23)'3Z new T,P: ',lrot,tpres(lrot)%tpused,tpval !23 format(a,i4,4(1pe12.4)) ! result=zero endif ! we must calculate the function ! write(*,35)'3Z new TPval:',lrot,tpfuns(lrot)%forcenewcalc,& ! tpres(lrot)%forcenewcalc,& ! abs(tpres(lrot)%tpused(1)-tpval(1)),abs(tpres(lrot)%tpused(2)-tpval(2)) !35 format(a,3i5,2(1pe12.4)) nr=tpfuns(lrot)%noofranges if(nr.eq.1) then exprot=>tpfuns(lrot)%funlinks(1) call ct1efn(exprot,tpval,result,tpres) else ns=1 do while(ns.lt.nr) if(tpval(1).lt.tpfuns(lrot)%limits(ns+1)) then exprot=>tpfuns(lrot)%funlinks(ns) call ct1efn(exprot,tpval,result,tpres) ! for debug output below nr=ns goto 900 endif ns=ns+1 enddo exprot=>tpfuns(lrot)%funlinks(nr) call ct1efn(exprot,tpval,result,tpres) endif ! save the calculated results 900 continue if(gx%bmperr.ne.0) then write(*,901)gx%bmperr,tpfuns(lrot)%symbol 901 format('Error ',i5,' evaluating tp function: ',a) goto 1000 endif 990 continue ! new: do i=1,6 ! tpres(lrot)%results(i)=result(i) ! enddo new ! xxx=tpres(lrot)%results(1) tpres(lrot)%results=result tpres(lrot)%forcenewcalc=tpfuns(lrot)%forcenewcalc tpres(lrot)%tpused(1)=tpval(1) tpres(lrot)%tpused(2)=tpval(2) ! Searching for strange bug when entering parameter ... ! write(*,991)'3Z new value: ',lrot,tpres(lrot)%forcenewcalc,& ! tpres(lrot)%results(1),tpval(1),xxx !991 format(a,2i5,6(1pe12.4)) !22 format(A,i3,4(1PE11.2)) 1000 continue return end subroutine eval_tpfun !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_tpfun !\begin{verbatim} subroutine list_tpfun(lrot,nosym,str) ! lists a TP symbols with several ranges into string str ! lrot is index of function, if nosym=0 the function name is copied to str implicit none character str*(*) integer nosym,lrot !\end{verbatim} %+ integer ip,nr character line*2048,tps(2)*1 TYPE(tpfun_expression), pointer :: exprot ! Handle variables if(lrot.le.0) then ! constant equal to zero ?? str=' =0; N ' goto 1000 elseif(btest(tpfuns(lrot)%status,TPCONST)) then ! UNFINISHED temporarily list all optimizing variables if(btest(tpfuns(lrot)%status,TPOPTCON)) then if(tpfuns(lrot)%limits(1).eq.zero) then ! this is a clumsy way to suppress listing optimizing coeff that are zero str='_A00 '; goto 1000 endif endif line=tpfuns(lrot)%symbol ip=len_trim(line) line(ip+1:ip+3)=' = ' ip=ip+4 call wrinum(line,ip,12,0,tpfuns(lrot)%limits(1)) goto 900 endif ! these are the symbols used to represent T and P tps(1)='T' tps(2)='P' if(nosym.eq.0) then line=tpfuns(lrot)%symbol ip=len_trim(line) line(ip+1:ip+3)=' = ' ip=ip+4 else line='= ' ip=3 endif if(lrot.le.0) then line(ip:)=' 298.15 0; 6000 N' goto 900 endif ! nr=1 do nr=1,tpfuns(lrot)%noofranges ! write(line(ip:ip+10),10)tpfuns(lrot)%limits(nr) !10 format(F8.2,' Y ') ! ip=ip+9 ! write(*,*)'tpfun4: ',lrot,tpfuns(lrot)%noofranges,nr if(tpfuns(lrot)%limits(nr).gt.1.0D3) then call wrinum(line,ip,8,0,tpfuns(lrot)%limits(nr)) else ! problem as 298.15 is written as 298.14999 and ! problem that 1 is written as 1.00001 ! call wrinum(line,ip,6,0,tpfuns(lrot)%limits(nr)+1.0D-5) call wrinum(line,ip,6,0,tpfuns(lrot)%limits(nr)) endif line(ip:ip+2)=' Y ' ip=ip+1 if(nr.gt.1) ip=ip+2 exprot=>tpfuns(lrot)%funlinks(nr) call ct1wfn(exprot,tps,line,ip) line(ip:ip+1)='; ' ip=ip+2 enddo ! write(line(ip:ip+10),11)tpfuns(lrot)%hightlimit !11 format(F8.2,' N ') ! ip=ip+11 call wrinum(line,ip,8,0,tpfuns(lrot)%hightlimit) line(ip:ip+2)=' N ' 900 continue ! write(*,*)'list_tpfun: ',len(str),len_trim(line) if(len_trim(line).gt.len(str)) then write(kou,910)'3Z *** WARNING: Character for listing funtion too short',& len_trim(line),len(str) 910 format(a,2i5) endif str=line !20 format(a) 1000 continue return end subroutine list_tpfun !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_all_funs !\begin{verbatim} %- subroutine list_all_funs(lut) ! list all functions except those starting with _ (parameters) implicit none integer lut !\end{verbatim} ! implicit double precision (a-h,o-z) integer nosym,ifun character str*2048,number*4 logical once ! nosym=0 means the local symbol name is included in the listing once=.TRUE. nosym=0 write(lut,10) 10 format(/'List of all symbols used in phase parameters (TP-functions):'/ & ! ' Predefined symbols:'/& ! ' BELOW(TB) = something;'/& ! ' ABOVE(TB) = 1-BELOW(TB);'/& ' Nr Name = T-low expression; T-high Y/N') 20 format(I4,1x,A) ! write(*,*)'First free index: ',freetpfun do ifun=1,freetpfun-1 write(str,20)ifun call list_tpfun(ifun,nosym,str(6:)) if(str(6:9).eq.'_A00 ') then if(once) then write(lut,30) 30 format(' *** Optimizing coefficents that are zero are not listed') once=.FALSE. endif else if(str(6:6).ne.'_') call wrice2(lut,0,12,78,1,str) endif enddo return end subroutine list_all_funs !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_unentered_funs !\begin{verbatim} subroutine list_unentered_funs(lut,nr) ! counts and list functions with TPNOTENT bit set if lut>0 implicit none integer lut,nr !\end{verbatim} ! implicit double precision (a-h,o-z) integer nosym,ifun nr=0 do ifun=1,freetpfun-1 if(btest(tpfuns(ifun)%status,TPNOTENT)) then if(lut.gt.0) write(lut,30)tpfuns(ifun)%symbol 30 format('Missing function: ',a) nr=nr+1 endif enddo !1000 continue return end subroutine list_unentered_funs !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine ct1xfn !\begin{verbatim} subroutine ct1xfn(string,ip,nc,coeff,koder,fromtdb) !...compiles an expression in string from position ip ! it can refer to T and P or symbols in fnsym ! compiled expression returned in coeff and koder ! ! >>> this is very messy ! !...algorithm for function extraction ! 10*T**2 -5*T*LOG(T) +4*EXP(-5*T**(-1)) ! ! AT LABEL 100 start of expression or after ( ! sign=1 ! -, sign=-1 goto 200 ! +, skip ! ! AT LABEL 200 after sign ! if A-Z goto 300 ! if 0-9, extract number goto 400 ! ( goto 100 ! ; END or ERROR ! empty END or ERROR ! anything else ERROR ! ! AT LABEL 300 symbol ! if T or P, extract power if any incl () goto 400 ! unary fkn? extract ( goto 100 ! symbol goto 400 ! ! AT LABEL 400 after factor ! -, sign=-1 goto 200 ! sign=1 ! +, skip goto 200 ! ) goto 400 ! ** or ^ extract and store power incl () goto 400 ! * goto 200 ! empty goto 900 ! ! for TDB compatibility skip # ! ! check consistency implicit none integer ip,nc,koder(5,*) character string*(*) double precision coeff(*) logical fromtdb !\end{verbatim} %+ ! implicit double precision (a-h,o-z) ! integer, parameter :: nunary=5 integer, parameter :: nunary=6 integer, parameter :: lenfnsym=16 double precision, parameter :: zero=0.0D0,one=1.0D0 integer i,j,jss,levelp,mterm,ipower,nterm double precision sign,val,another character ch1*1 logical zeroc character symbol*(lenfnsym),unary(nunary)*6 character*2, parameter :: tsym='T ',psym='P ' ! NEIN is the Einstein function ! MAX1 is 1.0 if argument is larger than 1.0, error if argument negative ! LOG is LOG10 and LN is the natural logarithm!!! DATA unary/'LOG ','LN ','EXP ','ERF ','GEIN','MAX1 '/ ! DATA unary/'LOG ','LN ','EXP ','ERF ','INTEIN','MAX1 '/ ! DATA unary/'LOG ','LN ','EXP ','ERF ','XNEIN ','MAX1 '/ ! DATA unary/'LOG ','LN ','EXP ','ERF ','XNEIN '/ ! DATA unary/'LOG ','LN ','EXP ','ERF ','ABOVE ','BELOW '/ ! ! coeff(nterm) double with coefficient ! koder(1,nterm) power of T ! koder(2,nterm) power of P ! koder(3,nterm) power of linked symbol (see koder(5,nterm) ! koder(4,nterm) level of parenthesis ! koder(5,nterm) symbol link or -(unary function index) mterm=nc levelp=0 nterm=1 coeff(1)=zero do i=1,5 koder(i,1)=0 enddo ! write(*,*)'3Z ct1xfn: ',trim(string(ip:)) ! !...start of expression or after( 100 if(eolch(string,ip)) goto 800 zeroc=.FALSE. ch1=biglet(string(ip:ip)) sign=one if(ch1.eq.'-') then sign=-one ip=ip+1 if(coeff(nterm).ne.zero) nterm=nterm+1 if(nterm.gt.mterm) then gx%bmperr=4000 goto 1000 endif coeff(nterm)=zero do i=1,5 koder(i,nterm)=0 enddo endif if(ch1.eq.'+') then ip=ip+1 if(coeff(nterm).ne.zero) nterm=nterm+1 if(nterm.gt.mterm) then gx%bmperr=4000 goto 1000 endif coeff(nterm)=zero do i=1,5 koder(i,nterm)=0 enddo endif ! !...allowed: unsigned number or symbol (any previous sign in "sign") 200 continue if(eolch(string,ip)) goto 800 ch1=biglet(string(ip:ip)) if(ch1.eq.'(') then levelp=levelp+1 if(nterm.eq.0) then nterm=1 coeff(nterm)=zero do i=1,5 koder(i,nterm)=0 enddo endif koder(4,nterm)=levelp ip=ip+1 goto 100 elseif(ch1.eq.';') then goto 900 endif if(ch1.ge.'A' .and. ch1.le.'Z') goto 300 !...this check because getrel accepts + and - and no sign is allowed if(.not.(ch1.ge.'0' .and. ch1.le.'9') .and. ch1.ne.'.') then write(*,*)'ct1xfn 66:',ip,ch1,' >',trim(string),'<' gx%bmperr=4001 goto 1000 endif ! write(*,202)ip,string(1:ip+5) !202 format('Expected real at position: ',i5,' in >',a,'< ') call getrel(string,ip,val) if(buperr.ne.0) then gx%bmperr=buperr goto 1000 endif ! looking for 0*fun bug if(val.eq.zero) zeroc=.TRUE. ! write(*,*)'ct1xfn 1: ',nterm,ip,val !...if nterm>0 and coeff(nterm)=0 then store this coefficent there if(nterm.gt.0 .and. coeff(nterm).eq.zero) then coeff(nterm)=sign*val ! write(*,*)'ct1xfn 2: ',nterm,val,coeff(nterm) else nterm=nterm+1 if(nterm.gt.mterm) then gx%bmperr=4000; goto 1000 endif coeff(nterm)=sign*val sign=one ! write(*,*)'ct1xfn 3: ',nterm,val,coeff(nterm) do i=1,5 koder(i,nterm)=0 enddo endif goto 400 ! !...unsigned symbol, first character at ip 300 continue symbol=' ' call ct1getsym(string,ip,symbol) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'ct1xfn 5: ',nterm,ip,coeff(nterm) !...one can have a symbol as first part, then create a term ! otherwise symbols are usually part of a term already created if(nterm.eq.0) then nterm=1 coeff(nterm)=one do i=1,5 koder(i,nterm)=0 enddo elseif(coeff(nterm).eq.zero) then ! this can happen if one has no coefficient in front of a function!!! ! write(*,*)'ct1xfn 5A: ',nterm,ip,coeff(nterm) if(.not.zeroc) coeff(nterm)=sign*one ! write(*,*)'ct1xfn 5B: ',nterm,ip,coeff(nterm) endif !...check if T or P if(symbol(1:2).eq.tsym) then if(string(ip:ip).eq.'^' .or. string(ip:ip+1).eq.'**') then ip=ip+1 if(string(ip:ip).eq.'*') ip=ip+1 call ct1power(string,ip,ipower) if(gx%bmperr.ne.0) goto 1000 else ipower=1 endif koder(1,nterm)=koder(1,nterm)+ipower goto 400 elseif(symbol(1:2).eq.psym) then ! allow powers as ^ or ** if(string(ip:ip).eq.'^' .or. string(ip:ip+1).eq.'**') then ip=ip+1 if(string(ip:ip).eq.'*') ip=ip+1 call ct1power(string,ip,ipower) if(gx%bmperr.ne.0) goto 1000 else ipower=1 endif koder(2,nterm)=koder(2,nterm)+ipower goto 400 endif !...check if unary operator do j=1,nunary if(symbol(1:6).eq.unary(j)) goto 380 enddo ! here search tpfuns for symbols, there are freetpfun-1 of them do jss=1,freetpfun-1 if(symbol.eq.tpfuns(jss)%symbol) goto 350 enddo !...unknown new symbol if(fromtdb) then ! if we are reading a TDB file allow references to unknown functions ! We will scan for un-entered TPfuns later ! write(*,*)'Unknown symbol to be entered later: ',symbol call store_tpfun_dummy(symbol) else ! otherwise give error message write(*,*)'TPFUN contain unknown symbol: ',symbol,freetpfun-1 gx%bmperr=4002; goto 1000 endif ! we have found the symbol 350 continue if(koder(5,nterm).ne.0) then ! two symbols multipled with each other if(koder(3,nterm).ne.0) then write(*,*)'too many symbols in one term: ',koder(3,nterm) gx%bmperr=4022; goto 1000 else ! set new function in koder(3,nterm), otherwise written in oposite order koder(3,nterm)=1000+jss endif else koder(5,nterm)=jss endif goto 400 !...unary function must be follwed by ( 380 continue ch1=string(ip:ip) if(ch1.ne.'(') then gx%bmperr=4003 goto 1000 else ip=ip+1 levelp=levelp+1 koder(4,nterm)=levelp if(koder(5,nterm).ne.0) then ! this is like R*T*LN(1E-5*P), save link to R in koder(3,nterm) if(koder(3,nterm).ne.0) then write(*,*)'too many symbols in one term: ',koder(3,nterm) gx%bmperr=4022; goto 1000 elseif(koder(5,nterm).lt.0) then write(*,*)'two unary functions in one term: ',koder(3,nterm) gx%bmperr=4023; goto 1000 else koder(3,nterm)=1000+koder(5,nterm) endif endif koder(5,nterm)=-j !...new term for argument of unary function, set coefficint to zero ! to mark that none has been found. nterm=nterm+1 if(nterm.gt.mterm) then write(*,*)'ct1xfn 8: ',nterm,mterm,ip gx%bmperr=4000 goto 1000 endif coeff(nterm)=zero do i=1,5 koder(i,nterm)=0 enddo goto 100 endif ! !...after a factor of a term: ),operator *, ^, +, - (division / not allowed) 400 continue if(eolch(string,ip)) goto 800 ch1=string(ip:ip) !...+ or - means new term if(ch1.eq.'-' .or. ch1.eq.'+') goto 100 sign=one after: if(ch1.eq.')') then koder(4,nterm)=levelp if(levelp.eq.0) then gx%bmperr=4004 goto 1000 endif levelp=levelp-1 ip=ip+1 goto 400 elseif(ch1.eq.'^') then ip=ip+1 call ct1power(string,ip,ipower) if(koder(3,nterm).ne.0) then ! several symbols or unary and power, too complicated gx%bmperr=4024; goto 1000 endif koder(3,nterm)=ipower goto 400 elseif(ch1.eq.'*') then ! write(*,*)'3Z we found a multiplication: ',trim(string),ip ip=ip+1 ch1=string(ip:ip) if(ch1.eq.'*') then ip=ip+1 call ct1power(string,ip,ipower) if(koder(3,nterm).ne.0) then ! several symbols or unariy and power, too complicated gx%bmperr=4024; goto 1000 endif koder(3,nterm)=ipower goto 400 elseif(ch1.ge.'0' .and. ch1.le.'9') then ! multiplying value in coeff(nterm) with another number ! write(*,*)'3Z string and position: "',trim(string),'"',ip ! write(*,*)'3Z multplication followed by digit: ',ch1,nterm ! write(*,*)'3Z data: ',buperr,coeff(nterm),trim(string(ip:)) ! Does getrel increment ip?? NO call getrel(string,ip,another) if(buperr.ne.0) then ! write(*,*)'2Z error from getrel',buperr gx%bmperr=buperr; goto 1000 endif ! write(*,'(a,i2,2(1pe12.4))')'3Z multiplying two numbers: ',nterm,& ! coeff(nterm),another coeff(nterm)=coeff(nterm)*another ! now we expect an operator or ) or ; goto 400 ! else ! multiply symbol with something .... ! write(*,*)'ct1xfn 4: ',nterm,ip,coeff(nterm) !654 format(a,i5,'"',a,'"',i5) endif ! new we expect a symbol or end of expression goto 200 elseif(ch1.eq.';') then goto 900 endif after write(*,777)ch1,ip,trim(string) 777 format('3Z Illegal character "',a,'" at pos ',i3,' in expression "',a,'"') gx%bmperr=4005 goto 1000 ! no more characters, check!! 800 continue ! !...; or no more characters, expression finished, check!! 900 continue if(levelp.gt.0) then gx%bmperr=4006 goto 1000 endif nc=nterm !990 format('ct1xfn 99> ',1PE15.6,5I7) 1000 continue return end subroutine ct1xfn !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine ct1getsym !\begin{verbatim} %- subroutine ct1getsym(string,ip,symbol) !...extracts an symbol ! implicit double precision (a-h,o-z) implicit none integer ip character string*(*),symbol*(*) !\end{verbatim} %+ integer, parameter :: lenfnsym=16 integer jp character ch1*1,chs*1,localsym*(lenfnsym) ! these 2 functions are declared in METLIB and no type decration needed here jp=0 localsym=' ' symbol=' ' 100 continue ch1=biglet(string(ip:ip)) ! write(6,*)'ct1getsym 2 >',ch1,'<',ip if((ch1.ge.'A' .and. ch1.le.'Z') .or. & (jp.gt.0 .and. ch1.eq.'_') .or. & (jp.gt.0 .and. (ch1.ge.'0' .and. ch1.le.'9'))) then jp=jp+1 ! ignore characters after length of localsym if(jp.le.len(localsym)) then localsym(jp:jp)=ch1 endif ip=ip+1 goto 100 endif symbol=localsym !1000 return end subroutine ct1getsym !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine ct1power !\begin{verbatim} %- subroutine ct1power(string,ip,ipower) !...extracts an integer power possibly surrounded by ( ) implicit none integer ip,ipower character string*(*) !\end{verbatim} %+ integer ich,isig,lp,jp character ch1*1,chs*1 ! write(*,*)'3Z ct1power: ',trim(string(ip:)) lp=0 isig=1 ipower=0 100 continue ch1=string(ip:ip) ! write(*,*)'3Z ct1power ch1: "',ch1,'" ',lp,isig if(ch1.eq.'(') then if(lp.gt.0) then gx%bmperr=4007 goto 1000 elseif(ipower.ne.0) then gx%bmperr=4008 goto 1000 endif jp=ip+1 if(eolch(string,jp)) then gx%bmperr=4009 goto 1000 endif chs=string(jp:jp) ! if(chs.eq.'-') then ! to allow (+2) etc after a ( if(chs.eq.'-' .or. chs.eq.'+') then !...mark ( and save sign, update ip (incremented below) lp=1 ! isig=-1 if(chs.eq.'-') isig=-1 ip=jp endif elseif(ch1.eq.')') then if(ipower.ne.0) then !...the ) can belong to other parts of the expression ??? if(lp.eq.1) then ip=ip+1 lp=0 endif goto 900 endif gx%bmperr=4010 goto 1000 elseif(ch1.ge.'0' .and. ch1.le.'9') then ich=ichar(ch1)-ichar('0') ipower=10*ipower+ich else ! no ) if ipower=0 then error if(ipower.eq.0) lp=99 ! write(*,*)'3Z ct1power: no ( or digit or ) or some other error',lp,ipower goto 900 endif ip=ip+1 if(ipower.gt.100) then gx%bmperr=4011 goto 1000 endif goto 100 ! error return unless lp=0, then it coulld be just T**3, T**(+3) should be OK 900 if(lp.gt.0) then if(gx%bmperr.eq.0) gx%bmperr=4012 goto 1000 endif ipower=isig*ipower ! write(*,*)'3Z exit ct1power: ',trim(string(ip:)),ipower,gx%bmperr 1000 return end subroutine ct1power !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine ct1mfn !\begin{verbatim} %- subroutine ct1mfn(symbol,nranges,tlimits,lokexpr,lrot) !...creates a root record with name symbol and temperature ranges ! highest T limit is in tlimits(nranges+1) ! implicit double precision (a-h,o-z) implicit none integer nranges,lrot character*(*) symbol TYPE(tpfun_expression), dimension(*) :: lokexpr real tlimits(*) !\end{verbatim} %+ ! special for unformatted files, lrot < 0 and this index MUST be used ! ignore freetpfun!! integer ir character name*16 if(lrot.lt.0) then ! store funtion at this specific place!! lrot=-lrot ! if(lrot.gt.freetpfun) then write(*,*)'Storing at position above freetpfun',lrot ! gx%bmperr=4399; goto 1000 ! endif else lrot=freetpfun ! write(*,*)'ct1mfn: ',freetpfun ! write(*,*)'ct1mfn: ',lrot,tpfuns(lrot)%nextorsymbol if(lrot.gt.0) then freetpfun=tpfuns(lrot)%nextorsymbol tpfuns(lrot)%nextorsymbol=0 else ! no more tpfun records write(*,*)'No more space for TP functions: ',size(tpfuns) gx%bmperr=4014; goto 1000 endif endif allocate(tpfuns(lrot)%limits(nranges)) allocate(tpfuns(lrot)%funlinks(nranges)) do ir=1,nranges tpfuns(lrot)%limits(ir)=tlimits(ir) ! should this be an assignment or setting a link? tpfuns(lrot)%funlinks(ir)=lokexpr(ir) enddo tpfuns(lrot)%hightlimit=tlimits(nranges+1) tpfuns(lrot)%noofranges=nranges ! save name as upper case name=symbol call capson(name) tpfuns(lrot)%symbol=name 1000 continue return end subroutine ct1mfn !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine ct2mfn !\begin{verbatim} %- subroutine ct2mfn(symbol,nranges,tlimits,lokexpr,lrot) !...stores a TPfun in an existing lrot record with name symbol ! and temperature ranges, highest T limit is in tlimits(nranges+1) implicit none integer nranges,lrot character*(*) symbol TYPE(tpfun_expression), dimension(*) :: lokexpr real tlimits(*) !\end{verbatim} %+ integer ir character name*16 if(lrot.gt.0 .and. lrot.lt.freetpfun .and. & btest(tpfuns(lrot)%status,TPNOTENT)) then if(tpfuns(lrot)%noofranges.gt.0) then write(*,*)'This TPfun has already been entered ...',symbol gx%bmperr=4348; goto 1000 endif else ! illegal value of lrot gx%bmperr=4349; goto 1000 endif allocate(tpfuns(lrot)%limits(nranges)) allocate(tpfuns(lrot)%funlinks(nranges)) do ir=1,nranges tpfuns(lrot)%limits(ir)=tlimits(ir) ! should this be an assignment or setting a link? tpfuns(lrot)%funlinks(ir)=lokexpr(ir) enddo tpfuns(lrot)%hightlimit=tlimits(nranges+1) tpfuns(lrot)%noofranges=nranges ! clear the bit that this TPFUN is not entered tpfuns(lrot)%status=ibclr(tpfuns(lrot)%status,TPNOTENT) ! write(*,*)'Clearing noentered bit: ',lrot,tpfuns(lrot)%symbol ! name already stored ! name=symbol ! call capson(name) ! tpfuns(lrot)%symbol=name 1000 continue return end subroutine ct2mfn !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine ct1mexpr !\begin{verbatim} %- subroutine ct1mexpr(nc,coeff,koder,lrot) !...makes a datastructure of an expression. root is returned in lrot ! implicit double precision (a-h,o-z) implicit none integer nc,koder(5,*) ! TYPE(tpfun_expression), pointer :: lrot TYPE(tpfun_expression) :: lrot ! TYPE(tpfun_expression), pointer :: noexpr double precision coeff(*) !\end{verbatim} %+ integer i ! write(*,*)'3Z in ct1mexpr',nc lrot%noofcoeffs=nc if(nc.le.0) then ! nullify(lrot) goto 1000 endif ! allocate an expression record and then allocate all arrays ! allocate(lrot) lrot%noofcoeffs=nc allocate(lrot%coeffs(nc)) allocate(lrot%tpow(nc)) allocate(lrot%ppow(nc)) allocate(lrot%wpow(nc)) allocate(lrot%plevel(nc)) allocate(lrot%link(nc)) ! store data save2: do i=1,nc lrot%coeffs(i)=coeff(i) lrot%tpow(i)=koder(1,i) lrot%ppow(i)=koder(2,i) lrot%wpow(i)=koder(3,i) lrot%plevel(i)=koder(4,i) lrot%link(i)=koder(5,i) enddo save2 1000 continue ! write(*,*)'3Z leaving ct1mexpr' return end subroutine ct1mexpr !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine ct1efn !\begin{verbatim} %- subroutine ct1efn(inrot,tpval,val,tpres) !...evaluates a datastructure of an expression. Value returned in val ! inrot is root expression tpfunction record ! tpval is valuse of T and P, ! val is array of values calculated here ! tpres is array of all calculated functions ! first and second derivatives of T and P also calculated and returned ! in order F, F.T, F.P, F.T.T, F.T.P, F.P.P ! ! if function already calculated one should never enter this subroutine ! ! It can call "itself" by reference to another TP function and for ! that case one must store results in levels. implicit none double precision val(6),tpval(*) TYPE(tpfun_expression), pointer :: inrot TYPE(tpfun_parres), dimension(*) :: tpres !\end{verbatim} integer mlev,level,jpow,link2 double precision mini parameter (mlev=10,mini=1.0D-8) TYPE tpfun_nest TYPE(tpfun_nest), pointer :: previous TYPE(tpfun_expression), pointer :: exprot integer savenc,saveic,savelink4,level,savetp double precision saveval(6) end TYPE tpfun_nest TYPE(tpfun_nest), pointer :: temp,topsave TYPE(tpfun_expression), pointer :: exprot,nyrot double precision symval(6),sym,dsymdp,dsymdt double precision sym1,sym2,dsym1dt,dsym2dt,dsym1dp,dsym2dp double precision ff,dfdt,dfdp,d2fdt2,d2fdtdp,d2fdp2,cc double precision gg,dgdt,dgdp,d2gdt2,d2gdtdp,d2gdp2,cc1 integer i,ic,mc,lrot,ipow,link,nc,unfun,itpow,tprot,link3,link4 double precision t0,breakfun(6) integer becareful ! val=zero level=0 link4=0 exprot=>inrot nullify(topsave) becareful=0 ! write(*,*)'ct1efn 0: ',tpval(1) !----------------------------------------------- ! return here for a linked function 100 continue if(.not.associated(exprot)) then ! this is not an error, just return zero or the value of a constant !!! goto 900 endif !------------------------------------------ ic=0 nc=exprot%noofcoeffs !------------------------------------------------ ! return here for each new term and after evaluating linked symbols 200 continue eval: do while (ic.lt.nc) ic=ic+1 cc=exprot%coeffs(ic) if(cc.eq.zero) cycle eval ipow=exprot%tpow(ic) if(ipow.ne.0) then ff=cc*tpval(1)**ipow dfdt=cc*ipow*tpval(1)**(ipow-1) dfdp=zero d2fdt2=cc*ipow*(ipow-1)*tpval(1)**(ipow-2) d2fdtdp=zero d2fdp2=zero else ff=cc dfdt=zero dfdp=zero d2fdt2=zero d2fdtdp=zero d2fdp2=zero endif ipow=exprot%ppow(ic) if(ipow.ne.0) then ! calculate backwards not to destroy value of ff d2fdp2=ff*ipow*(ipow-1)*tpval(2)**(ipow-2) d2fdtdp=dfdt*ipow*tpval(2)**(ipow-1) d2fdt2=d2fdt2*tpval(2)**ipow dfdp=ff*ipow*tpval(2)**(ipow-1) dfdt=dfdt*tpval(2)**ipow ff=ff*tpval(2)**ipow endif !...power of symbols is handeled below ! ipow=exprot%wpow(ic) ipow=exprot%plevel(ic) !...igore this at present, should never be set ... ! if(ipow.ne.0) then ! gx%bmperr=4017 ! goto 1000 ! endif !>>>>>>>>>>>>> very uncertain code from here <<<<<<<<<<<<<<<<<<<<<< link=exprot%link(ic) link3=exprot%wpow(ic) ! nonzero link4 inserted in the wrong term in step3.OCM ... link4=0 ! if(link.ne.0) write(*,201)'funev: ',lrot,ic,link,link3 !201 format(a,10i5) ! write(*,'(a,5i4,1pe12.4)')'3Z intein2: ',ic,ipow,link,link3,link4,ff if(link.lt.0 .and. link3.gt.1000) then ! if link is negative (unary funktion) and link3 is >1000 (link) ! we must evaluate link3 first link4=link3-1000 if(abs(tpres(link4)%tpused(1)-tpval(1)).lt.& mini*tpres(link4)%tpused(1) .and. & abs(tpres(link4)%tpused(2)-tpval(2)).lt.& mini*tpres(link4)%tpused(2)) then ! The test for forcenewcalc is not reasonable: ! tpres%forcenewcalc is local for each equilibrium ! tpfun(link4)%forcenewcalc is global for whole system. If we calculate in ! parallel there is no reason they should be the same ! It creates problem in testcond1.OCM after adding a mobility parameter ! although I do not understand why that should create the problem ! I added it to be sure that updated assessment parameters should be used ! but there seems no problem with that ... ! Better to speed a few months to rerwrite the whole TPFUN package ... ! mini*tpres(link4)%tpused(2) .and. & ! added test of forcenewcalc ... removed ?? ! tpres(link4)%forcenewcalc.eq.tpfuns(link4)%forcenewcalc) then ! function in link3-1000 is evaluated, multiply it with ff sym1=tpres(link4)%results(1) dsym1dt=tpres(link4)%results(2) dsym1dp=tpres(link4)%results(3) d2fdp2=sym1*d2fdp2+2.0D0*dsym1dp*dfdp+& tpres(link4)%results(6)*ff d2fdtdp=sym1*d2fdtdp+dsym1dp*dfdt+dsym1dt*dfdp+& tpres(link4)%results(5)*ff d2fdt2=sym1*d2fdt2+2.0D0*dsym1dt*dfdt+& tpres(link4)%results(4)*ff dfdp=sym1*dfdp+dsym1dp*ff dfdt=sym1*dfdt+dsym1dt*ff ff=sym1*ff ! write(*,202)'mulnk 0: ',lrot,ic,link,link4,0,sym1,ff else ! we must first evaluate link3, after that is done we come here again ! and take the else path below tpres(link4)%forcenewcalc=tpfuns(link4)%forcenewcalc ! DANGER changing wpow ! write(*,22)'3Z wpow 1: ',level,nc,ic,exprot%wpow(ic),link-1000 exprot%wpow(ic)=-1000+link link=link3-1000 link4=link3 endif elseif(link3.lt.-1000) then ! now we have evaluated the symbol, we must multiply that ! with ff and then evaluate the unary function d2fdp2=d2fdp2*symval(1)+2.0D0*dfdp*symval(3) & +ff*symval(6) d2fdtdp=d2fdtdp*symval(1)+dfdp*symval(2) & +dfdt*symval(3)+ff*symval(5) d2fdt2=d2fdt2*symval(1)+2.0D0*dfdt*symval(2) & +ff*symval(4) dfdp=dfdp*symval(1)+ff*symval(3) dfdt=dfdt*symval(1)+ff*symval(2) ff=ff*symval(1) ! DANGER, restoring wpow, note also wpow pop below! ! write(*,22)'3Z wpow 2: ',level,nc,ic,exprot%wpow(ic),link4 !22 format(a,7i7) exprot%wpow(ic)=link4 endif !------------------------------------------------------------- ! write(*,'(a,5i4,1pe12.4)')'3Z intein3: ',ic,ipow,link,link3,link4,ff evlink: if(link.gt.0) then ! link to another symbol, extract its value and use chain rule ! extract the results from the symbol if already calculated ! if not calculated then do that and then recalculate this term linkif: if(abs(tpres(link)%tpused(1)-tpval(1)).lt.& mini*tpres(link)%tpused(1) .and. & abs(tpres(link)%tpused(2)-tpval(2)).lt.& ! mini*tpres(link)%tpused(2)) then mini*tpres(link)%tpused(2) .and. & ! added this check as it seems new assessment coefficients are nor used!! tpres(link)%forcenewcalc.eq.tpfuns(link)%forcenewcalc) then ! Valgrid complained about uninitial variable in if above, I do not know which jpow=exprot%wpow(ic) !--------------------------------------------- jpowif: if(jpow.gt.1000) then ! suck, two functions have to be multiplied .... link2=jpow-1000 jpowev: if(abs(tpres(link2)%tpused(1)-tpval(1)).lt.& mini*tpres(link2)%tpused(1) .and. & abs(tpres(link2)%tpused(2)-tpval(2)).lt.& ! mini*tpres(link2)%tpused(2)) then mini*tpres(link2)%tpused(2) .and. & ! added this check as it seems new assessment coefficients are nor used!! tpres(link2)%forcenewcalc.eq.tpfuns(link2)%forcenewcalc) then ! both functions are evaluated, multiply the two functions here ! one function is in tpres(link)%results, the other in tpres(link2)%results sym1=tpres(link)%results(1) dsym1dt=tpres(link)%results(2) dsym1dp=tpres(link)%results(3) sym2=tpres(link2)%results(1) dsym2dt=tpres(link2)%results(2) dsym2dp=tpres(link2)%results(3) symval(6)=sym1*tpres(link2)%results(6)+& 2.0D0*dsym1dp*dsym2dp+& tpres(link)%results(6)*sym2 symval(5)=sym1*tpres(link2)%results(5)+& dsym1dp*dsym2dt+dsym1dt*dsym2dp+& tpres(link)%results(5)*sym2 symval(4)=sym1*tpres(link2)%results(4)+& 2.0D0*dsym1dt*dsym2dt+& tpres(link)%results(4)*sym2 symval(3)=sym1*dsym2dp+dsym1dp*sym2 symval(2)=sym1*dsym2dt+dsym1dt*sym2 symval(1)=sym1*sym2 else ! function link2 must be evaluated, push and calculate tpres(link2)%forcenewcalc=tpfuns(link2)%forcenewcalc if(btest(tpfuns(link2)%status,TPCONST)) then ! write(*,*)'3Z Link to a constant 1',& ! link2,tpfuns(link2)%limits(1) becareful=link2 nullify(nyrot) else call nested_tpfun(link2,tpval,nyrot) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'ct1efn nest 2: ',link2,nyrot endif ! here we must push current values and start evaluating a new function nyrot ! when that has been done one must return here ... how?? ! Well probably simplest by a new evaluation the same term again and when ! finding the link one takes the newly evaluated numbers !!! ! That means this function must save values in the tpfunction !!! level=level+1 allocate(temp) temp%previous=>topsave topsave=>temp ! MEMORY LEAK nullify(temp) topsave%exprot=>exprot topsave%level=level topsave%saveic=ic-1; topsave%savenc=nc ! write(*,22)'3Z wpow push 1: ',level,nc,ic,0,link4 topsave%savetp=link2; topsave%savelink4=link4 topsave%saveval=val link4=0 val=zero if(becareful.gt.0) then ! save the constant value in val(1), then jump to 900 val(1)=tpfuns(becareful)%limits(1) becareful=0 goto 900 else exprot=>nyrot goto 100 endif endif jpowev elseif(jpow.eq.0 .or. jpow.lt.-1000) then ! jpow can be <-1000 if a symbol is multiplied with a unary function ! Here we just extract the values of the function do i=1,6 symval(i)=tpres(link)%results(i) enddo elseif(jpow.ne.0) then ! this symbol is raised to a power, use chain rule for derivatives backward sym=tpres(link)%results(1) dsymdt=tpres(link)%results(2) dsymdp=tpres(link)%results(3) symval(6)=jpow*(jpow-1)*sym**(jpow-2)*dsymdp**2+& jpow*sym**(jpow-1)*tpres(link)%results(6) symval(5)=jpow*(jpow-1)*sym**(jpow-2)*dsymdp*dsymdt+& jpow*sym**(jpow-1)*tpres(link)%results(5) symval(4)=jpow*(jpow-1)*sym**(jpow-2)*dsymdt**2+& jpow*sym**(jpow-1)*tpres(link)%results(4) symval(3)=jpow*sym**(jpow-1)*dsymdp symval(2)=jpow*sym**(jpow-1)*dsymdt symval(1)=sym**jpow endif jpowif else ! one must evaluaste the function in link, it is recursive through eval_tpfun ! which will call ct1efn again but this is handelled automatically????? ! One should add some check that two TP functions does not call each other ! to infinite depth. Same as done above tpres(link)%forcenewcalc=tpfuns(link)%forcenewcalc if(btest(tpfuns(link)%status,TPCONST)) then ! the function is a constant!! ! write(*,*)'3Z Link to a constant 2',link,tpfuns(link)%limits(1) becareful=link else call nested_tpfun(link,tpval,nyrot) if(gx%bmperr.ne.0) goto 1000 endif ! here we must push current values and start evaluating a new function nyrot ! when that has been done one must return here ... how?? ! Well probably simplest: new evaluation of the same term again and when ! finding the link one takes the evaluated numbers !!! ! That means this function must save values in the tpfunction !!! level=level+1 allocate(temp) temp%previous=>topsave topsave=>temp ! MEMORY LEAK nullify(temp) topsave%exprot=>exprot topsave%level=level topsave%saveic=ic-1; topsave%savenc=nc ! write(*,22)'3Z wpow push 2: ',level,nc,ic,0,link4 topsave%savetp=link; topsave%savelink4=link4 topsave%saveval=val link4=0 val=zero if(becareful.gt.0) then ! save the constant value in val(1), then jump to 900 val(1)=tpfuns(becareful)%limits(1) becareful=0 goto 900 else exprot=>nyrot goto 100 endif endif linkif ! The symbol (or multiplied symbols) value in symval, apply chain rule d2fdp2=d2fdp2*symval(1)+2.0D0*dfdp*symval(3) & +ff*symval(6) d2fdtdp=d2fdtdp*symval(1)+dfdp*symval(2) & +dfdt*symval(3)+ff*symval(5) d2fdt2=d2fdt2*symval(1)+2.0D0*dfdt*symval(2) & +ff*symval(4) dfdp=dfdp*symval(1)+ff*symval(3) dfdt=dfdt*symval(1)+ff*symval(2) ff=ff*symval(1) elseif(link.lt.0) then !------------------------------------------------------ ! unary function, next term is argument, not very elegant .... ! write(*,'(a,5i4,1pe12.4)')'3Z intein4: ',ic,ipow,link,link3,link4,ff unfun=link cc=exprot%coeffs(ic+1) ! cc should never be zero here, if so bug in the parser if(cc.eq.zero) then gx%bmperr=4018; goto 1000 endif ipow=exprot%tpow(ic+1) if(ipow.ne.0) then gg=cc*tpval(1)**ipow dgdt=cc*ipow*tpval(1)**(ipow-1) dgdp=zero d2gdt2=cc*ipow*(ipow-1)*tpval(1)**(ipow-2) d2gdtdp=zero d2gdp2=zero else gg=cc dgdt=zero dgdp=zero d2gdt2=zero d2gdtdp=zero d2gdp2=zero endif ipow=exprot%ppow(ic+1) if(ipow.ne.0) then d2gdp2=gg*ipow*(ipow-1)*tpval(2)**(ipow-2) d2gdtdp=dgdt*ipow*tpval(2)**(ipow-1) d2gdt2=d2gdt2*tpval(2)**ipow dgdp=gg*ipow*tpval(2)**(ipow-1) dgdt=dgdt*tpval(2)**ipow gg=gg*tpval(2)**ipow endif !...ignore these at present ipow=exprot%wpow(ic+1) if(ipow.ne.0) then write(*,*)'TP ipow error: ',ipow gx%bmperr=4019 goto 1000 endif link2=exprot%link(ic+1) if(link2.gt.0) then ! link2, another symbol inside unary term, extract its value and use chain rule ! extract the results from the symbol if already calculated if(abs(tpres(link2)%tpused(1)-tpval(1)).lt.& mini*tpres(link2)%tpused(1) .and. & abs(tpres(link2)%tpused(2)-tpval(2)).lt.& mini*tpres(link2)%tpused(2) .and. & ! added this check as it seems new assessment coefficients are nor used!! tpres(link2)%forcenewcalc.eq.tpfuns(link2)%forcenewcalc) then symval=tpres(link2)%results else ! one must evaluaste another function, it is recursive through eval_tpfun ! which will call ct1efn again but this is handelled automatically????? ! One should add some check that two TP functions does not call each other ! to infinite depth tpres(link2)%forcenewcalc=tpfuns(link2)%forcenewcalc if(btest(tpfuns(link2)%status,TPCONST)) then ! the function is a constant!! ! write(*,*)'3Z link to a constant 3',link2,& ! tpfuns(link2)%limits(1) becareful=link2 else call nested_tpfun(link2,tpval,nyrot) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'ct1efn nest 1: ',link2 endif ! here we must push current values and start evaluating a new function nyrot ! when that has been done one must return here ... how?? ! Well probably simplest ny evaluation the same term again and when ! finding the link one takes the evaluated numbers !!! ! That means this function must save values in the tpfunction !!! level=level+1 allocate(temp) temp%previous=>topsave topsave=>temp ! MEMORY LEAK nullify(temp) topsave%exprot=>exprot topsave%level=level topsave%saveic=ic-1; topsave%savenc=nc ! this searching for strange bug at midsummer 2018 ... ! write(*,22)'3Z wpow push 3: ',level,nc,ic,0,link4 topsave%savetp=link2; topsave%savelink4=link4 topsave%saveval=val link4=0 val=zero if(becareful.gt.0) then ! save the constant value in val(1), then jump to 900 val(1)=tpfuns(becareful)%limits(1) becareful=0 goto 900 else exprot=>nyrot goto 100 endif endif if(exprot%wpow(ic+1).ne.0) then ! it is illegal to have two symbols inside unary or power of symbol gx%bmperr=4016; goto 1000 endif ! the value of the another symbol in symval. use the chain rule d2gdp2=d2gdp2*symval(1)+2.0D0*dgdp*symval(3) & +gg*symval(6) d2gdtdp=d2gdtdp*symval(1)+dgdp*symval(2) & +dgdt*symval(3)+gg*symval(5) d2gdt2=d2gdt2*symval(1)+2.0D0*dgdt*symval(2) & +gg*symval(4) dgdp=dgdp*symval(1)+gg*symval(3) dgdt=dgdt*symval(1)+gg*symval(2) gg=gg*symval(1) endif ! now combine term1 and term2 using chain rule. link values are ! -1: LOG, -2: LN, -3: EXP, -4: ERF, only LN and EXP implemented below ! -5: GEIN, is the Einstein function, integrated as a Gibbs energy ! the argument is the Einstein theta, NO LONGER ln(theta) ! -6: MAX1, if argument <0 ERROR, if >1 replace by 1 ! write(*,'(a,5i4,1pe12.4)')'3Z intein5: ',ic,ipow,link,link3,link4,ff evunfun: if(unfun.eq.-1) then ! LOG base 10 ! ff=ff*Log10(gg) added by Sheng Yen Li if(gg.le.zero) then gx%bmperr=4020 goto 1000 endif d2fdp2=d2fdp2*log10(gg)+2.0d0*dfdp*dgdp/(gg*log(10d0)) & -(ff*(dgdp/gg)**2)/log(10d0)+ff*d2gdp2/(gg*log(10d0)) d2fdtdp=d2fdtdp*log10(gg)+dfdt*dgdp/(gg*log(10d0)) & +dfdp*dgdt/(gg*log(10d0))-ff*dgdt*dgdp/((gg**2)*log(10d0)) & +ff*d2gdtdp/(gg*log(10d0)) d2fdt2=d2fdt2*log10(gg)+2.0d0*dfdt*dgdt/(gg*log(10d0)) & -(ff*(dgdt/gg)**2)/log(10d0)+ff*d2gdt2/(gg*log(10d0)) dfdp=dfdp*log10(gg)+ff*dgdp/(gg*log(10d0)) dfdt=dfdt*log10(gg)+ff*dgdt/(gg*log(10d0)) ff=ff*log10(gg) elseif(unfun.eq.-2) then ! LN NATURAL LOGARITHM ! ff=ff*LN(gg) if(gg.le.zero) then gx%bmperr=4020 goto 1000 endif d2fdp2=d2fdp2*log(gg)+2.0d0*dfdp*dgdp/gg & -ff*(dgdp/gg)**2+ff/gg*d2gdp2 d2fdtdp=d2fdtdp*log(gg)+dfdt*dgdp/gg+dfdp*dgdt/gg & -ff*dgdt*dgdp/gg**2+ff*d2gdtdp/gg d2fdt2=d2fdt2*log(gg)+2.0d0*dfdt*dgdt/gg & -ff*(dgdt/gg)**2+ff/gg*d2gdt2 dfdp=dfdp*log(gg)+ff*dgdp/gg dfdt=dfdt*log(gg)+ff*dgdt/gg ff=ff*log(gg) elseif(unfun.eq.-3) then ! EXPonential ! ff=ff*exp(gg) d2fdp2=exp(gg)*(d2fdp2+2.0D0*dfdp*dgdp+ff*d2gdp2+ff*(dgdp)**2) d2fdtdp=exp(gg)*(d2fdtdp+dfdt*dgdp+dfdp*dgdt+ff*d2gdtdp & +ff*dgdt*dgdp) d2fdt2=exp(gg)*(d2fdt2+2.0D0*dfdt*dgdt+ff*d2gdt2+ff*(dgdt)**2) dfdp=exp(gg)*(dfdp+ff*dgdp) dfdt=exp(gg)*(dfdt+ff*dgdt) ff=ff*exp(gg) elseif(unfun.eq.-4) then ! ERROR FUNCTION or ABOVE not implemented write(*,*)'Error function not implemented' stop 71 elseif(unfun.eq.-5) then ! INTEGRATED EINSTEIN: GEIN = 1.5*R*THETA + 3*R*T*LN(EXP(THETA/T)+1), THETA=gg if(dfdt.ne.zero) then write(*,*)'3Z GEIN must not be multiplied with T!' gx%bmperr=4399; goto 1000 endif ! write(*,'(a,5i5,1pe12.4)')'3Z intein6: ',ic,ipow,link,link3,link4,ff ! ff is the constant factor in front of the Einstein function ! It is overwritten by the Einstein function (multiplied by original ff) call tpfun_geinstein(tpval,gg,ff,dfdt,dfdp,d2fdt2,d2fdtdp,d2fdp2) ! write(*,'(a,i3,6(1pe12.4))')'3Z call Einstein:',link,& ! gg,ff,dfdt,d2fdt2 ! ff is the coefficient for the Einstein Functions, should be a constant ...? ! write(*,*)'Einstein function not implemented' ! stop 72 if(gx%bmperr.ne.0) goto 1000 elseif(unfun.eq.-6) then ! MAX1 function, used for SRO .... function and derivatives in gg, dgdt etc. ! write(*,*)'MAX1 function',gg if(gg.le.zero) then write(*,*)'MAX1 called with negative argument',gg stop 73 endif if(gg.le.one) then ! just copy values from g to f d2fdp2=d2gdp2; d2gdtdp=d2fdtdp; d2fdt2=d2gdt2 dfdp=dgdp; dfdt=dgdt; ff=gg else ! function value is 1 and all derivatives zero d2fdp2=zero; d2fdtdp=zero; d2fdt2=zero dfdp=zero; dfdt=zero; ff=one endif else ! undefined function gx%bmperr=4021 goto 1000 endif evunfun ic=ic+1 !----------------------------- end two-term unary function !>>>>>>>>>>>>> very uncertain code above here <<<<<<<<<<<<<<<<<<<<<< else ! link=0, just continue continue endif evlink ! adding terms together val(1)=val(1)+ff val(2)=val(2)+dfdt val(3)=val(3)+dfdp val(4)=val(4)+d2fdt2 val(5)=val(5)+d2fdtdp val(6)=val(6)+d2fdp2 enddo eval 900 continue ! If level>1 save the values of the TP function. The link to the ! address of TP function is in savetp(level) if(level.gt.0) then ! save calculated TP function values tprot=topsave%savetp do i=1,6 tpres(tprot)%results(i)=val(i) enddo tpres(tprot)%tpused(1)=tpval(1) tpres(tprot)%tpused(2)=tpval(2) ! then unpack saved values of val and derivatives symval=val val=topsave%saveval ! POP the coefficients and the rest ic=topsave%saveic; nc=topsave%savenc link2=topsave%savetp; link4=topsave%savelink4 ! For some unknown reason topsave%saveic is ic-1 !!! correct below ! write(*,22)'3Z wpow pop 1: ',level,nc,ic,0,link4 exprot=>topsave%exprot ! MEMORY LEAK avoided by deallocate topsave ?? ! write(*,*)'Trying to remove memory leak' temp=>topsave%previous deallocate(topsave) ! write(*,*)'Deallocated topsave' ! topsave=>topsave%previous topsave=>temp level=level-1 ! restart from coefficient ic, note the value saved is ic-1 !! if(ic.ge.0 .and. ic.lt.nc) then ! restore value in %wpow !!! ! without this an expression like VCRBCC*EXP(ZCRBCC) became ! just EXP(ZRBCC) as the link to VCRBCC had been removed ... ! BUT for macro step3 the link4 was inserted in the wrong term !!! ! if(link4.gt.1000 .and. exprot%wpow(ic).lt.1000) then if(link4.gt.1000 .and. exprot%wpow(ic+1).lt.1000) then ! write(*,22)'3Z wpow save: ',level+1,nc,ic,exprot%wpow(ic),link4 ! topsave%saveic is ic-1, I do not know why but this correction is added now! exprot%wpow(ic+1)=link4 endif endif goto 200 endif ! 1000 continue return end subroutine ct1efn !level %wpow link4 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine tpfun_geinstein !\begin{verbatim} subroutine tpfun_geinstein(tpval,gg,ff,dfdt,dfdp,d2fdt2,d2fdtdp,d2fdp2) ! evaluates the integrated Einstein function (including 1.5*R) INTEIN/GEIN ! gg is the value of the Einstein THETA ! ff is a constant factor which should be multiplied with all terms ! ff is overwritten with the Einstein function (multiplied with ff in) ! the other parameters are derivatives of the integrated Einstein function implicit none double precision tpval(*) double precision gg,ff,dfdt,dfdp,d2fdt2,d2fdtdp,d2fdp2 !\end{verbatim} double precision kvot,kvotexpkvotm1,expmkvot,lnexpkvot,ww,rgas,egg ! return ff = 1.5*R*gg + 3*R*T*LN(1 - EXP(-gg/T)) and derivatives ! NOTE gg is THETA, not LN(THETA) below ! gg must be a constant >0 rgas=globaldata%rgas ! write(*,*)'3Z in Einstein function',gg,tpval(1) ! in the call ff is a constant factor multiplied with the Einstein function ! NOTE gg is the logarithm of the Einstein THETA, take the exponential!! ww=ff ! if(gg.gt.8.0D1) then ! write(*,'(a,F8.2)')'Einstein T in GEIN too large, use the logarithm!',gg ! gx%bmperr=5399; goto 1000 ! endif ! MODIFIED 2023.10.26/BoS the value of gg is THETA, not LN(THETA) if(gg.lt.1.0D1) then write(*,*)' *** Warning, Einstein THETA in GEIN less than 10,',& ' use THETA not LN(THETA)!' endif ! egg=exp(gg) egg=gg kvot=egg/tpval(1) !write(*,'(a,5(1pE12.4))')'GEIN: ',gg,egg,kvot,tpval(1) ! no risk for extreme values of eqq !- if(kvot.gt.2.0d2) then ! handle extreme values of kvot, we divide by kvotexpkvotm1**2 by expmkvot bolw !- expmkvot=one !- kvotexpkvotm1=zero !- lnexpkvot=zero ! write(*,'(a,5(1pe12.4))')'3Z Einetsin 1: ',kvot,expmkvot,& ! kvotexpkvotm1,lnexpkvot !- else expmkvot=exp(-kvot) kvotexpkvotm1=kvot/(exp(kvot)-one) lnexpkvot=log(one-expmkvot) ! write(*,'(a,5(1pe12.4))')'3Z Einetsin 2: ',kvot,expmkvot,& ! kvotexpkvotm1,lnexpkvot !- endif ! this is the integral G contribution from an Einstein solid ff=1.5d0*rgas*egg*ww + 3.0D0*rgas*tpval(1)*lnexpkvot*ww dfdt=3.0d0*rgas*(lnexpkvot-kvotexpkvotm1)*ww ! write(*,10)rgas,kvot,lnexpkvot,kvotexpkvotm1,dfdt !10 format('3Z bug: ',6(1pe12.4)) dfdp=zero ! this is the second derivative of G wrt T; i.e. the Einstein solid Cp equation d2fdt2=-3.0d0*rgas*kvotexpkvotm1**2/(expmkvot*tpval(1))*ww d2fdtdp=zero d2fdp2=zero 1000 continue return end subroutine tpfun_geinstein !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine tpfun_geinstein_ln !\begin{verbatim} subroutine tpfun_geinstein_ln(tpval,gg,ff,dfdt,dfdp,d2fdt2,d2fdtdp,d2fdp2) ! evaluates the integrated Einstein function (including 1.5*R) INTEIN/GEIN ! gg is the value of the Einstein THETA, here provided as ln(THETA) ! ff is a constant factor which should be multiplied with all terms ! ff is overwritten with the Einstein function (multiplied with ff in) ! the other parameters are derivatives of the integrated Einstein function implicit none double precision tpval(*) double precision gg,ff,dfdt,dfdp,d2fdt2,d2fdtdp,d2fdp2 !\end{verbatim} double precision kvot,kvotexpkvotm1,expmkvot,lnexpkvot,ww,rgas,egg ! return ff = 1.5*R*gg + 3*R*T*LN(1 - EXP(-gg/T)) and derivatives ! gg must be a constant >0 rgas=globaldata%rgas ! write(*,*)'3Z in Einstein function',gg,tpval(1) ! in the call ff is a constant factor multiplied with the Einstein function ! NOTE gg is the logarithm of the Einstein THETA, take the exponential!! ww=ff if(gg.gt.8.0D1) then write(*,'(a,F8.2)')'Einstein T in GEIN too large, use the logarithm!',gg gx%bmperr=5399; goto 1000 endif ! MODIFIED 2023.10.26/BoS the value of gg is THETA, not LN(THETA) egg=exp(gg) kvot=egg/tpval(1) !write(*,'(a,5(1pE12.4))')'GEIN: ',gg,egg,kvot,tpval(1) if(kvot.gt.2.0d2) then ! handle extreme values of kvot, we divide by kvotexpkvotm1**2 by expmkvot bolw expmkvot=one kvotexpkvotm1=zero lnexpkvot=zero ! write(*,'(a,5(1pe12.4))')'3Z Einetsin 1: ',kvot,expmkvot,& ! kvotexpkvotm1,lnexpkvot else expmkvot=exp(-kvot) kvotexpkvotm1=kvot/(exp(kvot)-one) lnexpkvot=log(one-expmkvot) ! write(*,'(a,5(1pe12.4))')'3Z Einetsin 2: ',kvot,expmkvot,& ! kvotexpkvotm1,lnexpkvot endif ! this is the integral G contribution from an Einstein solid ff=1.5d0*rgas*egg*ww + 3.0D0*rgas*tpval(1)*lnexpkvot*ww dfdt=3.0d0*rgas*(lnexpkvot-kvotexpkvotm1)*ww ! write(*,10)rgas,kvot,lnexpkvot,kvotexpkvotm1,dfdt !10 format('3Z bug: ',6(1pe12.4)) dfdp=zero ! this is the second derivative of G wrt T; i.e. the Einstein solid Cp equation d2fdt2=-3.0d0*rgas*kvotexpkvotm1**2/(expmkvot*tpval(1))*ww d2fdtdp=zero d2fdp2=zero 1000 continue return end subroutine tpfun_geinstein_ln !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine ct1wfn !\begin{verbatim} subroutine ct1wfn(exprot,tps,string,ip) !...writes an expression into string starting at ip ! lrot is an index to an tpexpr record ! implicit double precision (a-h,o-z) implicit none character tps(2)*(*) character string*(*) !\end{verbatim} %+ integer, parameter :: levl=5,nunary=6 integer, parameter :: lenfnsym=16 integer koder(5,levl),ip,jus,is,kk,kpow,level,lpar,mult,nc,nos,i,ic double precision coeff(levl) character ch1*1,cht*1,extsym*(lenfnsym),unary(nunary)*6 TYPE(tpfun_expression), pointer :: exprot ! these should be the same as in ct1xfn !!! ?? DATA unary/'LOG ','LN ','EXP ','ERF ','GEIN ','MAX1 '/ ! DATA unary/'LOG ','LN ','EXP ','ERF ','INTEIN','MAX1 '/ ! if(.not.associated(exprot)) then string(ip:ip+2)='0; ' ip=ip+2 goto 1000 endif nc=exprot%noofcoeffs ic=0 level=1 lpar=0 ! write(*,*)'in ct1wfn',nc 200 ic=ic+1 if(ic.gt.nc) goto 1000 coeff(level)=exprot%coeffs(ic) ! bug in the expression parser ... (fixed??) if(coeff(level).eq.zero .and. nc.eq.1) then ! error in parser that such a function can exist, lrot should be zero string(ip:ip+1)='0 ' ip=ip+1 goto 1000 elseif(coeff(level).eq.zero) then goto 200 endif koder(1,level)=exprot%tpow(ic) koder(2,level)=exprot%ppow(ic) koder(3,level)=exprot%wpow(ic) koder(4,level)=exprot%plevel(ic) koder(5,level)=exprot%link(ic) ! !71 format(A,I5,1PE15.6,5I5) is=koder(5,level) ! write(*,202)'ct1wfn: ',ic,ip,is,koder(1,level),string(1:ip) !202 format(a,4i4,a) symbol: if(is.ne.0) then !...reference to symbol or unary function, write coefficient only if not one if(abs(coeff(level)).ne.one) then call wrinum(string,ip,12,6,coeff(level)) string(ip:ip)='*' ip=ip+1 nos=0 if(coeff(level).eq.zero) write(*,*)'ct1wfn ',ip,string(1:ip) elseif(coeff(level).eq.one) then nos=1 else nos=-1 endif !230 continue unaryfun: if(is.lt.0) then !...write the T or P power before the unary function if(nos.eq.1) then string(ip:ip)='+' ip=ip+1 elseif(nos.eq.-1) then string(ip:ip)='-' ip=ip+1 endif ! there can be a symbol link in koder(3,level) if(koder(3,level).gt.1000) then jus=koder(3,level)-1000 kk=len_trim(tpfuns(jus)%symbol) string(ip:ip+kk-1)=tpfuns(jus)%symbol ip=ip+kk string(ip:ip)='*' ip=ip+1 endif call ct1wpow(string,ip,tps(1),1,koder(1,level)) call ct1wpow(string,ip,tps(2),1,koder(2,level)) kk=len_trim(unary(-is)) string(ip:)=unary(-is)(1:kk)//'(' ip=ip+kk+1 lpar=koder(4,level) ! write(*,*)'lpar: ',string(1:ip),' ',lpar else ! an external symbol, possibly a sign and power if(nos.eq.1) then string(ip:ip)='+' ip=ip+1 elseif(nos.eq.-1) then string(ip:ip)='-' ip=ip+1 endif kk=len_trim(tpfuns(is)%symbol) string(ip:ip+kk-1)=tpfuns(is)%symbol ip=ip+kk kpow=koder(3,level) if(kpow.gt.1000) then ! this is a link to another symbol, two symbols multiplied jus=kpow-1000 kk=len_trim(tpfuns(jus)%symbol) string(ip:ip+kk)='*'//tpfuns(jus)%symbol ip=ip+kk+1 elseif(kpow.lt.0) then kpow=-kpow if(kpow.gt.9) then ! power must be less than 99!!! ch1=char(ichar('0')+mod(kpow,10)) cht=char(ichar('0')+kpow/10) string(ip:ip+6)='**(-'//cht//ch1//')' ip=ip+7 else ch1=char(ichar('0')+kpow) string(ip:ip+5)='**(-'//ch1//')' ip=ip+6 endif elseif(kpow.gt.0) then ! power must be less than 99!!! if(kpow.gt.9) then ch1=char(ichar('0')+mod(kpow,10)) cht=char(ichar('0')+kpow/10) string(ip:ip+3)='**'//cht//ch1 ip=ip+4 else ch1=char(ichar('0')+kpow) string(ip:ip+2)='**'//ch1 ip=ip+3 endif endif !...write the T or P power after the symbol and possible power call ct1wpow(string,ip,tps(1),-1,koder(1,level)) call ct1wpow(string,ip,tps(2),-1,koder(2,level)) ! fixing missing ) after unary function of symbol like exp(s1) ! write(*,*)'problem here??:',string(1:ip),' ',lpar ! We got one extra ) as lpar not reset below if(lpar.gt.0) then string(ip:ip)=')' ip=ip+1 lpar=0 endif endif unaryfun goto 200 endif symbol ! no symbol or unary function, coefficient with possible powers if(coeff(level).ne.one) then ! if 4th argument >0 then write a sign call wrinum(string,ip,12,6,coeff(level)) mult=-1 else ! in the case of a single value exactly 1 without unary or T or P power ! the number was never written ! write(*,203)'ct1wfn2: ',(koder(i,level),i=1,4),coeff(level) !203 format(a,4i4,1pe12.4) do i=1,4 if(koder(i,level).ne.0) goto 219 enddo ! without this the Inden magnetic function will miss its initial 1.0 ! call wrinum(string,ip,2,0,coeff(level)) ! changed 20.03.17/BoS because EXP(T)+1 missed the + between ) and 1 ! Force wrinum to write positive signs by 4th parameter positive call wrinum(string,ip,2,1,coeff(level)) goto 220 219 continue ! missing coefficient discovered by Mauro, as the coefficient is unity ! it is not written. Check with -1 maybe sign problems? ! call wrinum(string,ip,2,1,coeff(level)) string(ip:ip)='+' ip=ip+1 220 continue mult=0 endif !...write the T or P power after the coefficient call ct1wpow(string,ip,tps(1),mult,koder(1,level)) call ct1wpow(string,ip,tps(2),mult,koder(2,level)) if(koder(4,level).eq.1) then string(ip:ip)=')' ip=ip+1 ! lpar was not reset here causing an extra ) later in expression ... lpar=0 ! write(*,*)'lpar not reset?:',string(1:ip) ! write(*,*)lpar,koder(4,level) endif goto 200 1000 return end subroutine ct1wfn !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine ct1wpow !\begin{verbatim} %- subroutine ct1wpow(string,ip,tps,mult,npow) !...writes "ips" with a power if needed and a * before or after ! implicit double precision (a-h,o-z) implicit none integer ip,mult,npow character string*(*),tps*(*) !\end{verbatim} integer lentps if(npow.eq.0) goto 1000 if(mult.lt.0) then string(ip:ip)='*' ip=ip+1 endif lentps=len_trim(tps) string(ip:ip+lentps-1)=tps ip=ip+lentps if(npow.gt.9) then write(string(ip:ip+3),110)npow ip=ip+4 elseif(npow.gt.1) then write(string(ip:ip+4),120)npow ip=ip+3 elseif(npow.lt.-9) then write(string(ip:ip+6),140)npow ip=ip+7 elseif(npow.lt.0) then write(string(ip:ip+5),150)npow ip=ip+6 endif if(mult.gt.0) then string(ip:ip)='*' ip=ip+1 endif 110 format('**',i2) 120 format('**',i1) 140 format('**(',i3,')') 150 format('**(',i2,')') 1000 return end subroutine ct1wpow !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine enter_tpfun_interactivly !\begin{verbatim} subroutine enter_tpfun_interactivly(cline,ip,longline,jp) ! interactive input of a TP expression, whole function returned in longline ! implicit double precision (a-h,o-z) implicit none integer ip,jp character cline*(*),longline*(*) !\end{verbatim} character line*80,ch1*1 integer nexpr,lsc,kkp double precision xx ! write(*,*)'Max ',len(longline),' characters' call gparrdx('Low temperature limit: ',cline,ip,xx,2.9815D2,'?Enter TPfun') if(buperr.ne.0) then ! set default low limit buperr=0; longline=' 298.15 ' jp=8 else longline=' ' jp=1 call wrinum(longline,jp,8,0,xx) if(buperr.ne.0) goto 1000 jp=jp+1 endif nexpr=1 lsc=1 !----------------------------------------------- ! return here for new expression in another range 115 continue call gparcx('Give expression, end with ";":',cline,ip,6,line,';',& '?Enter TPfun') if(buperr.ne.0) then buperr=0; line=';' endif 120 continue longline(jp:)=line jp=len_trim(longline)+1 ! write(*,*)'tpfun: ',longline(1:jp) ! lsc is position after the ";" in any previous range if(index(longline(lsc:),';').le.0) then call gparcx('&',cline,ip,6,line,';','?Enter TPfun') if(buperr.ne.0) then buperr=0; line=';' endif goto 120 endif !150 continue ! make sure there is a ; at the end of each expression kkp=index(longline(nexpr:),';') ! write(*,130)'3Z pos1: ',nexpr,kkp,lsc,jp,trim(longline) !130 format(a,4i4,': ',a/26x,'123456789.123456789.123456789.123456789.') ! write(*,*)'tpfun add ;' if(kkp.le.0) then kkp=len_trim(longline) longline(kkp+1:)='; ' jp=kkp+3 nexpr=jp write(*,*)'3Z adding ; at position: ',kkp+1,nexpr else ! nexpr=kkp+1 nexpr=len_trim(longline)+2 endif ! lsc is position of ; for previous range ! write(*,130)'3Z pos2: ',nexpr,kkp,lsc,jp,trim(longline) lsc=nexpr call gparrdx('Upper temperature limit ',cline,ip,xx,6.0D3,'?Enter TPfun') if(buperr.ne.0) then buperr=0; xx=6.0D3 endif ! enter a space after ; jp=jp+1 call wrinum(longline,jp,8,0,xx) if(buperr.ne.0) goto 1000 call gparcdx('Any more ranges',cline,ip,1,ch1,'N','?Enter TPfun') ! write(*,*)'3Z ch1: ',ch1 if(ch1.eq.'n' .or. ch1.eq.'N') then longline(jp:)=' N' jp=jp+3 else longline(jp:)=' Y' jp=jp+3 goto 115 endif ! remove any "#" (comes from TC functions) 900 continue kkp=index(longline,'#') if(kkp.gt.0) then longline(kkp:kkp)=' ' goto 900 endif ! write(*,910)'3Z tpf: ',jp,trim(longline) !910 format(a,i3,': ',a) ! 1000 continue return end subroutine enter_tpfun_interactivly !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine tpfun_deallocate !\begin{verbatim} subroutine tpfun_deallocate ! deallocates all arrays associated with a TP function !\end{verbatim} implicit none TYPE(tpfun_expression), pointer :: exprot integer j,nr,nexp,nc ! write(*,*)'3Z freetpfun: ',freetpfun do j=1,freetpfun-1 nr=tpfuns(j)%noofranges if(nr.gt.0) then ! modified 170517 due to memory leaks when read/write unformatted do nc=1,nr exprot=>tpfuns(j)%funlinks(nc) ! write(*,*)'3Z Deallocating TP function',j,nc deallocate(exprot%tpow) deallocate(exprot%ppow) deallocate(exprot%wpow) deallocate(exprot%plevel) deallocate(exprot%link) deallocate(exprot%coeffs) enddo ! deallocate(tpfuns(j)%funlinks) deallocate(tpfuns(j)%limits) endif enddo deallocate(tpfuns) !1000 continue return end subroutine tpfun_deallocate !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine store_tpfun_dummy !\begin{verbatim} subroutine store_tpfun_dummy(symbol) ! creates a dummy entry for a TP function called symbol, used when entering ! TPfuns from a TDB file where they are not in order implicit none character*(*) symbol !\end{verbatim} ! set the TPNOTENT bit of this symbol integer lrot character name*16 lrot=freetpfun if(lrot.gt.0) then freetpfun=tpfuns(lrot)%nextorsymbol tpfuns(lrot)%nextorsymbol=0 else write(*,*)'No space for TP functions: ',size(tpfuns) gx%bmperr=4014; goto 1000 endif tpfuns(lrot)%noofranges=0 name=symbol call capson(name) tpfuns(lrot)%symbol=name tpfuns(lrot)%status=ibset(tpfuns(lrot)%status,TPNOTENT) tpfuns(lrot)%rewind=0 1000 continue return end subroutine store_tpfun_dummy !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine store_tpfun !\begin{verbatim} subroutine store_tpfun(symbol,text,lrot,rewind) ! creates a data structure for a TP function called symbol with several ranges ! text is whole expression ! lrot is returned as index. If fromtdb is FALSE and lrot<0 it is a new ! expression for an old symbol ! if fromtdb is TRUE references to unknown functions are allowed ! default low temperature limit is 298.16; high 6000 implicit none integer lrot,rewind character*(*) text,symbol ! logical fromtdb !\end{verbatim} ! max number of ranges, max number of coefficents in each range ! integer, parameter :: mrange=20,mc=15 ! in a paper more than 15 terms were used for a TP function! integer, parameter :: mrange=20,mc=20 integer jss,nc,ip,nrange,cbug real tlim(mrange) double precision coeff(mc),val integer koder(5,mc) ! attempt to remove big memory leak ! TYPE(tpfun_expression) :: links(mrange) ! TYPE(tpfun_expression), target :: links(mrange) TYPE(tpfun_expression) :: links(mrange) ! TYPE(tpfun_expression), pointer :: ltpexpr character ch1*1,lsym*(lenfnsym) logical already,fromtdb ! check if function already entered, there are freetpfun-1 of them ! ignore functions that start with a "_" as they are parameters ! lrot=0 ! special when read unformatted or direct files, lrot<0 and this ?? ! must be the location for storing the function ... fromtdb=.TRUE. if(rewind.lt.0) fromtdb=.FALSE. already=.FALSE. if(symbol(1:1).ne.'_') then lsym=symbol call capson(lsym) ! write(*,*)'3Z store_tpfun: ',trim(lsym),lrot,rewind do jss=1,freetpfun-1 ! write(*,17)jss,lsym,tpfuns(jss)%symbol !17 format('enter_tpfun: ',i5,' >,',a,'=',a,'?') if(lsym.eq.tpfuns(jss)%symbol) then if(btest(tpfuns(jss)%status,TPNOTENT)) then ! function name already entered, now enter expression, this is from TDB files lrot=jss; already=.TRUE. ! mark the expression was entered at current rewind tpfuns(jss)%rewind=rewind; goto 18 else ! write(*,*)'amend tpfun? ',trim(lsym),fromtdb,lrot if(.NOT.fromtdb .and. lrot.lt.0) then ! this is an AMEND TPFUN, delete old expression to be able to store a new lrot=jss; already=.TRUE. nrange=tpfuns(lrot)%noofranges ! write(*,*)'Deallocating: ',lrot,nrange deallocate(tpfuns(lrot)%limits) deallocate(tpfuns(lrot)%funlinks) tpfuns(lrot)%noofranges=0 tpfuns(lrot)%status=ibset(tpfuns(lrot)%status,TPNOTENT) ! we should clear the stored values! But those are stored separatly in all ceq nrange=0; goto 18 else write(*,*)'3Z A never never error again! ',trim(symbol) gx%bmperr=4026; goto 1000 endif endif endif enddo endif ! lrot=0 18 continue ! low T limit ip=1 cbug=ip call getrel(text,ip,val) if(buperr.ne.0) then ! A , has been used to select default low temperature limit if(text(ip:ip).eq.',') then buperr=0; val=298.15D0 else write(*,*)'Illegal character for low temperature limit: ',text(ip:ip) val=298.15; buperr=0 ! write(*,19)ip,cbug,trim(text) !19 format('TPFUN: ',2i3,' >',a) endif ! increement ip! ip=ip+1 endif tlim(1)=val nrange=0 ch1='Y' ! parse and store expression for each temperature range ranges: do while(ch1.eq.'Y') nrange=nrange+1 if(nrange.gt.mrange) then gx%bmperr=4025; goto 1000 endif nc=mc call ct1xfn(text,ip,nc,coeff,koder,fromtdb) if(gx%bmperr.ne.0) then ! write(*,*)'3E error ocurred for: ',trim(symbol) goto 1000 endif ! big memory leak ... still there ... ! call ct1mexpr(nc,coeff,koder,ltpexpr) ! links(nrange)=ltpexpr ! ltpexpr=>links(nrange) ! call ct1mexpr(nc,coeff,koder,ltpexpr) ! write(*,*)'3Z calling ct1mexpr', nrange call ct1mexpr(nc,coeff,koder,links(nrange)) ! attempt to remove memory leak ! bypass final ; of expression ip=ip+1 call getrel(text,ip,val) if(buperr.ne.0) then ! acceppt a , for default ... if(text(ip:ip).eq.',') then val=6.0D3; buperr=0 else write(*,27)buperr,ip,text(1:ip+5) 27 format(' *** Error in enter_tpfun 2: ',i5,', position ',i5/& '>',a,'<') endif endif tlim(nrange+1)=val if(.not.eolch(text,ip)) then ch1=biglet(text(ip:ip)) ip=ip+1 endif enddo ranges if(already) then ! a function symbol already entered, lrot is location call ct2mfn(symbol,nrange,tlim,links,lrot) else ! a new function record will be allocated call ct1mfn(symbol,nrange,tlim,links,lrot) endif ! force functions to be recalculated ! write(*,*)'3Z calling force_recalculate from enter_tpfun' call force_recalculate_tpfuns 1000 continue return end subroutine store_tpfun !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine nested_tpfun !\begin{verbatim} subroutine nested_tpfun(lrot,tpval,nyrot) ! called from ct1efn when a it calls another TP function that must be ! evaluated. nyrot is the link to the ct1efn in the correct range ! implicit double precision (a-h,o-z) implicit none integer lrot double precision tpval(2) TYPE(tpfun_expression), pointer :: nyrot ! use lowest range for all T values lower than first upper limit ! and highest range for all T values higher than the next highest limit ! one should signal if T is lower than lowest limit or higher than highest ! used saved reults if same T and P !\end{verbatim} %+ integer nr,ns nullify(nyrot) if(lrot.le.0) goto 1000 nr=tpfuns(lrot)%noofranges if(nr.eq.0) then ! this is the case for constants! Does this work?? if(btest(tpfuns(lrot)%status,TPCONST)) then write(*,*)'nested constant: ',nr,lrot else write(*,*)'A never never error evaluation a TP function',lrot write(*,*)'Function name: ',tpfuns(lrot)%symbol gx%bmperr=4350; goto 1000 endif elseif(nr.eq.1) then nyrot=>tpfuns(lrot)%funlinks(1) else ns=1 do while(ns.lt.nr) if(tpval(1).lt.tpfuns(lrot)%limits(ns+1)) then nyrot=>tpfuns(lrot)%funlinks(ns) goto 900 endif ns=ns+1 enddo nyrot=>tpfuns(lrot)%funlinks(nr) endif 900 continue 1000 continue return end subroutine nested_tpfun !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine enter_optvars !\begin{verbatim} subroutine enter_optvars(firstindex) ! enter variables for optimization A00-A99 implicit none integer firstindex !\end{verbatim} %+ character symbol*(lenfnsym) integer jss,symix,lrot symbol='A00 ' ! check if any TP fun with name A00 already entered do jss=1,freetpfun-1 if(symbol.eq.tpfuns(jss)%symbol) then write(kou,*)'Optimizing symbols already entered' goto 1000 endif enddo firstindex=freetpfun do jss=1,100 ! create TPfun symbols with names A00 to A99 with value 0.0D0 lrot=freetpfun if(lrot.eq.0) then gx%bmperr=4104; goto 1000 else freetpfun=tpfuns(lrot)%nextorsymbol tpfuns(lrot)%nextorsymbol=0 endif allocate(tpfuns(lrot)%limits(1)) allocate(tpfuns(lrot)%funlinks(1)) tpfuns(lrot)%symbol=symbol tpfuns(lrot)%limits(1)=zero ! mark this is a single value and can be optimized tpfuns(lrot)%status=ibset(tpfuns(lrot)%status,TPCONST) tpfuns(lrot)%status=ibset(tpfuns(lrot)%status,TPOPTCON) ! increment symbol symix=ichar(symbol(3:3))-ichar('0') symix=symix+1 if(symix.eq.10) then symbol(3:3)='0' symbol(2:2)=char(ichar(symbol(2:2))+1) else symbol(3:3)=char(ichar(symbol(3:3))+1) endif ! write(*,*)'Next symbol created: ',symbol(1:4),lrot enddo 1000 continue return end subroutine enter_optvars !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine find_tpsymbol !\begin{verbatim} %- subroutine find_tpsymbol(name,type,value) ! enter variables implicit none ! type=0 if function, 1 if variable, 2 if optimizing variable integer type character name*(lenfnsym) double precision value !\end{verbatim} %+ integer jss,symix,lrot character symbol*(lenfnsym) symbol=name call capson(symbol) ! check if any TP fun with name symbol exists type=0 do jss=1,freetpfun-1 if(symbol.eq.tpfuns(jss)%symbol) then ! found symbol if(btest(tpfuns(jss)%status,TPCONST)) then value=tpfuns(jss)%limits(1) if(btest(tpfuns(jss)%status,TPOPTCON)) then type=2 else type=1 endif endif goto 200 endif enddo ! no such symbol gx%bmperr=4351 type=-1 200 continue !1000 continue return end subroutine find_tpsymbol !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine store_tpconstant !\begin{verbatim} %- subroutine store_tpconstant(symbol,value) ! enter variables implicit none character symbol*(lenfnsym) double precision value !\end{verbatim} %+ integer jss,symix,lrot ! check if any TP fun with name symbol already entered do jss=1,freetpfun-1 if(symbol.eq.tpfuns(jss)%symbol) then ! symbol already exist, just change value unless it is an optimizing coeff. if(btest(tpfuns(jss)%status,TPOPTCON)) then write(*,*)'Not allowed to change optimizing coefficents' goto 1000 else lrot=jss goto 200 endif endif enddo ! create TPfun symbols with name symbol and value value lrot=freetpfun if(lrot.eq.0) then gx%bmperr=4104; goto 1000 else freetpfun=tpfuns(lrot)%nextorsymbol tpfuns(lrot)%nextorsymbol=0 endif allocate(tpfuns(lrot)%limits(1)) allocate(tpfuns(lrot)%funlinks(1)) call capson(symbol) tpfuns(lrot)%symbol=symbol ! mark this is a single value tpfuns(lrot)%status=ibset(tpfuns(lrot)%status,TPCONST) 200 continue ! write(*,*)'3Z store tpconstant: ',lrot,value tpfuns(lrot)%limits(1)=value nullify(tpfuns(lrot)%funlinks) ! OBS! calculate all tpfun after this to make sure value is propagated!! ! This indicate for all TPFUN that they must be recalculated call force_recalculate_tpfuns 1000 continue return end subroutine store_tpconstant !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine change_optcoeff !\begin{verbatim} %- subroutine change_optcoeff(lrot,value) ! change value of optimizing coefficient. lrot is index ! -1 means just force recalculate implicit none integer lrot double precision value !\end{verbatim} %+ integer mrot if(lrot.gt.0 .and. lrot.lt.freetpfun-1) then if(.not.btest(tpfuns(lrot)%status,TPOPTCON)) then write(*,*)'Attempt to change non-existing coefficent',lrot gx%bmperr=7777; goto 1000 endif tpfuns(lrot)%limits(1)=value endif ! force recalculation of all functions. HOW? the force_... does not work ... call force_recalculate_tpfuns 1000 continue return end subroutine change_optcoeff !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine force_recalculate_tpfuns !\begin{verbatim} %- subroutine force_recalculate_tpfuns ! force recalculation of all tpfuns by incrementing an integer in tpfuns !\end{verbatim} %+ implicit none integer mrot ! it seems difficult to force recalculating all TP functions !!! ! write(*,*)'3Z GLAVESCUMG: ',tpfuns(125)%forcenewcalc do mrot=1,freetpfun-1 tpfuns(mrot)%forcenewcalc=tpfuns(mrot)%forcenewcalc+1 ! I have no access to tpres here so I cannot see any current value ... enddo ! write(*,*)'3Z Force recalculate tpfuns: ',freetpfun-1 ! write(*,*)'3Z GLAVESCUMG: ',tpfuns(125)%forcenewcalc return end subroutine force_recalculate_tpfuns !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_value_of_constant_name !\begin{verbatim} %- subroutine get_value_of_constant_name(symbol,lrot,value) ! get value (and index) of a TP constant. lrot is index implicit none integer lrot character symbol*(*) double precision value !\end{verbatim} %+ write(*,*)'get_value_of_constant_name not implemented yet' ! value=tpfuns(lrot)%limits(1) !1000 continue return end subroutine get_value_of_constant_name !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_value_of_constant_index !\begin{verbatim} %- subroutine get_value_of_constant_index(lrot,value) ! get value of a TP constant at known lrot implicit none integer lrot double precision value !\end{verbatim} %+ if(lrot.le.0 .or. lrot.gt.freetpfun-1) then write(kou,*)'Constant index outside limits',lrot else ! unifished: check if it is really a constant ... value=tpfuns(lrot)%limits(1) endif !1000 continue return end subroutine get_value_of_constant_index !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_all_opt_coeff !\begin{verbatim} %- subroutine get_all_opt_coeff(values) ! get values of all optimizing coefficients implicit none double precision values(*) !\end{verbatim} %+ write(*,*)'Not yet implemeneted' !1000 continue return end subroutine get_all_opt_coeff !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine delete_all_tpfuns !\begin{verbatim} %- subroutine delete_all_tpfuns ! delete all TPFUNs. No error if some are already deleted ... ! note: tpres is deallocated when deleting equilibrium record !\end{verbatim} implicit none integer lrot,nrex TYPE(tpfun_expression), pointer :: expr ! write(*,*)'In delete_all_tpfuns' deallocate(tpfuns) goto 1000 ! code below skipped as it created a lot of memory errors ... if(tpfun_expression_version.ne.1 .or. tpfun_root_version.ne.1 .or. & tpfun_parres_version.ne.1) then write(*,*)'Data structure error when deleting tpfuns',& tpfun_expression_version,tpfun_root_version,& tpfun_parres_version gx%bmperr=7777; goto 1000 endif funloop: do lrot=1,freetpfun-1 write(*,*)'TP Deleting TP function: ',lrot ! if(tpfuns(lrot)%noofranges.eq.0) cycle if(tpfuns(lrot)%noofranges.eq.0) goto 200 write(*,*)'TP deleting ranges 1-',tpfuns(lrot)%noofranges range: do nrex=1,tpfuns(lrot)%noofranges expr=>tpfuns(lrot)%funlinks(nrex) if(associated(expr)) then deallocate(expr%coeffs) deallocate(expr%tpow) deallocate(expr%ppow) deallocate(expr%wpow) deallocate(expr%plevel) deallocate(expr%link) deallocate(expr) else write(*,*)'TP delete; no expression? ',lrot,nrex endif enddo range 200 continue write(*,*)'TP deleting limits ',size(tpfuns(lrot)%limits) deallocate(tpfuns(lrot)%limits) write(*,*)'TP deleting funlinks ',size(tpfuns(lrot)%funlinks) deallocate(tpfuns(lrot)%funlinks) enddo funloop write(*,*)'TP finally deleting roots' deallocate(tpfuns) 1000 continue return end subroutine delete_all_tpfuns !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine save0tpfun !\begin{verbatim} subroutine save0tpfun(lfun,iws,jfun) ! save one tpfun (or parameter) with index jfun in workspace iws ! implicit double precision (a-h,o-z) implicit none integer lfun,iws(*),jfun !\end{verbatim} %+ integer nr,i,kx,nc,displace,lexpr,rsize,mmz TYPE(tpfun_expression), pointer :: exprot double precision dummy,xxx ! jfun can be zero meaning a parameter that is zero ! unformatted if(jfun.eq.0) then iws(lfun)=0 else nr=tpfuns(jfun)%noofranges rsize=4+nwch(16)+nr*(1+nwpr)+nwpr call wtake(lfun,rsize,iws) if(buperr.ne.0) then write(*,*)'Error reserving record for TPfun',buperr,rsize,nr gx%bmperr=4399; goto 1000 endif ! write(*,11)'3Z tpfun ',lfun,jfun,trim(tpfuns(jfun)%symbol),& ! tpfuns(jfun)%noofranges,tpfuns(jfun)%status !11 format(a,2i7,2x,a,2x,5i7) iws(lfun+1)=tpfuns(jfun)%noofranges iws(lfun+2)=tpfuns(jfun)%status ! what is nextfree?? iws(lfun+3)=tpfuns(jfun)%nextorsymbol call storc(lfun+4,iws,tpfuns(jfun)%symbol) displace=4+nwch(16) call storrn(nr,iws(lfun+displace),tpfuns(jfun)%limits) ! write(lut)(tpfuns(jfun)%limits(i),i=1,nr) call storr(lfun+displace+nr*nwpr,iws,tpfuns(jfun)%hightlimit) ! store location of expressions from displace displace=displace+nwpr*(nr+1) ! now the expressions, number of coefficients, nc, can be different ! link them from lfun do kx=1,nr exprot=>tpfuns(jfun)%funlinks(kx) nc=exprot%noofcoeffs rsize=1+nc*(5+nwpr) call wtake(lexpr,rsize,iws) if(buperr.ne.0) then write(*,*)'Error reserving record for TPfun' gx%bmperr=4399; goto 1000 endif iws(lfun+displace+kx-1)=lexpr iws(lexpr)=nc mmz=lexpr+1 ! The coefficients and the codes do i=1,nc iws(mmz)=exprot%link(i) iws(mmz+1)=exprot%tpow(i) iws(mmz+2)=exprot%ppow(i) iws(mmz+3)=exprot%wpow(i) iws(mmz+4)=exprot%plevel(i) call storr(mmz+5,iws,exprot%coeffs(i)) call loadr(mmz+5,iws,xxx) mmz=mmz+5+nwpr enddo enddo endif 1000 continue return end subroutine save0tpfun !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine read0tpfun !\begin{verbatim} %- subroutine read0tpfun(lfun,iws,jfun) ! read one TPfun from workspace implicit none integer lfun,jfun,iws(*) !\end{verbatim} integer i,i2,kx,nc,nr,displace,lexpr,loklexpr,mmz TYPE(tpfun_expression), pointer :: exprot character*16 symbol double precision dummy ! jfun can be sero meaning no link to a TPFUN ! read(lut)jfun,symbol,nr,i2 ! the TPfuns are stored in an array, no need to allocate ! if(iws(lfun).gt.0) then if(jfun.gt.0) then nr=iws(lfun+1) tpfuns(jfun)%noofranges=nr tpfuns(jfun)%status=iws(lfun+2) tpfuns(jfun)%nextorsymbol=iws(lfun+3) call loadc(lfun+4,iws,tpfuns(jfun)%symbol) else write(*,*)'not a function: ',lfun,jfun goto 1000 endif ! special for optimizing variables if(btest(tpfuns(jfun)%status,TPOPTCON)) then ! write(*,*)'3Z allocating zero limit for ',tpfuns(jfun)%symbol allocate(tpfuns(jfun)%limits(1)) tpfuns(jfun)%limits(1)=zero goto 1000 endif ! a TPfun can have different number of ranges, must be allocated displace=4+nwch(16) allocate(tpfuns(jfun)%limits(nr)) allocate(tpfuns(jfun)%funlinks(nr)) call loadrn(nr,iws(lfun+displace),tpfuns(jfun)%limits) call loadr(lfun+displace+nr*nwpr,iws,tpfuns(jfun)%hightlimit) ! write(*,*)'3Z high T',tpfuns(jfun)%hightlimit ! the expressions are linked from here, one per range displace=displace+(1+nr)*nwpr loklexpr=lfun+displace-1 ! extract the expressions do kx=1,nr lexpr=iws(loklexpr+kx) nc=iws(lexpr) ! write(*,*)'3Z coeffs 1',kx,lfun,lexpr,nr,nc exprot=>tpfuns(jfun)%funlinks(kx) exprot%noofcoeffs=nc ! if(nc.gt.20) stop allocate(exprot%tpow(nc)) allocate(exprot%ppow(nc)) allocate(exprot%wpow(nc)) allocate(exprot%plevel(nc)) allocate(exprot%link(nc)) allocate(exprot%coeffs(nc)) mmz=lexpr ! write(*,*)'3Z coeffs 2',nc,iws(nc),mmz do i=1,nc exprot%link(i)=iws(mmz+1) exprot%tpow(i)=iws(mmz+2) exprot%ppow(i)=iws(mmz+3) exprot%wpow(i)=iws(mmz+4) exprot%plevel(i)=iws(mmz+5) call loadr(mmz+6,iws,exprot%coeffs(i)) mmz=mmz+5+nwpr enddo enddo ! if(jfun.gt.0) then ! read(lut)tpfuns(jfun)%hightlimit ! else ! read(lut)dummy ! endif 1000 continue return end subroutine read0tpfun !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine makeoptvname !\begin{verbatim} subroutine makeoptvname(name,indx) implicit none character name*(*) integer indx !\end{verbatim} %+ if(indx.lt.99) then if(indx.le.9) then name(1:2)='A0' name(3:3)=char(indx+ichar('0')) else name(1:1)='A' name(2:2)=char(indx/10+ichar('0')) name(3:3)=char(mod(indx,10)+ichar('0')) endif else name='A99' endif !1000 continue return end subroutine makeoptvname !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine findtpused !\begin{verbatim} subroutine findtpused(lfun,string) ! this routine finds which other TPFUNS (including parameters) that ! use the TPFUN lfun. It is used when listing optimizing coefficients implicit none integer lfun character string*(*) !\end{verbatim} %+ integer jp,kfun,nr,nc,j1 type(tpfun_expression), pointer :: exprot string=' ' jp=1 loop1: do kfun=1,freetpfun-1 if(kfun.eq.lfun) cycle loop2: do nr=1,tpfuns(kfun)%noofranges exprot=>tpfuns(kfun)%funlinks(nr) if(.not.associated(exprot)) cycle loop2 nc=exprot%noofcoeffs loop3: do j1=1,nc if(exprot%link(j1).eq.lfun) then ! write(*,*)'3Z found: ',trim(tpfuns(kfun)%symbol),kfun string(jp:)=tpfuns(kfun)%symbol jp=len_trim(string)+2 cycle loop1 endif enddo loop3 enddo loop2 enddo loop1 ! write(*,*)'3Z where: ',trim(string) !1000 continue return end subroutine findtpused !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_tpfun_details !\begin{verbatim} subroutine list_tpfun_details(lfun) ! listing the internal datastructure of all tpfuns ! converts all TP functions to arrays of coefficients with powers of T implicit none integer lfun !\end{verbatim} integer j1,j2,j3,nc TYPE(tpfun_expression), pointer :: exprot if(lfun.lt.0) then ! list all ... continue elseif(lfun.ge.freetpfun) then write(*,*)'No such function' else exprot=>tpfuns(lfun)%funlinks(1) nc=exprot%noofcoeffs write(*,100)tpfuns(lfun)%symbol,tpfuns(lfun)%noofranges,nc,& firsteq%eq_tpres(lfun)%results(1) 100 format('Name: ',a,2i5,(1pe12.4)/& ' term coefficent tpow ppow wpow plevel link') do j1=1,nc write(*,110)j1,exprot%coeffs(j1),exprot%tpow(j1),exprot%ppow(j1),& exprot%wpow(j1),exprot%plevel(j1),exprot%link(j1) 110 format('Term: ',i2,1pe12.4,2x,5i6) enddo endif !1000 continue return end subroutine list_tpfun_details !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ ! ! Below are a couple of routines to generate SOLGASMIX DAT files ! %debug=1 set in gtp3E ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine tpfun2coef !\begin{verbatim} subroutine tpfun2coef(ctpf,ntpf,npows,text) ! called by saveadatformat in gtp3C to generate SOLGASMIX DAT files ! converts all TP functions to arrays of coefficients with powers of T implicit none integer ntpf,npows type(gtp_tpfun2dat) :: ctpf(*) character text*(*) !\end{verbatim} %+ ! powers are 0 1 100 2 3 -1 ; 7 -9 -2 -3 extra ! Tln(T) these on extra line integer, parameter :: maxnc=15 integer i1,i2,i3,usedpow(maxnc) character buffer*80 logical done ! write(*,*)'In tpfun2coef with ',ntpf,' ctpf records allocated' do i1=1,ntpf ctpf(i1)%nranges=-1 enddo ! this loop may have to be done several times as functions calling functions done=.false. do while(.not.done) done=.true. ! skip the first two functions ... R and RTLNP do i1=3,ntpf ! done is set false if the function ctpf(i1) is not converted if(ctpf(i1)%debug.ne.0) & write(*,*)'Converting: ',trim(tpfuns(i1)%symbol) ctpf(i1)%name=tpfuns(i1)%symbol call tpf2c(ctpf,i1,done) if(gx%bmperr.ne.0) goto 1000 enddo enddo ! here all TP functions are converted to coefficients ! i1=19 ! call tpwrite('ee',i1,ctpf(i1)%nranges,ctpf(i1)%cfun) ! extract the powers used npows=0 do i1=3,ntpf do i2=1,ctpf(i1)%nranges call sortcoeffs(maxnc,i1,ctpf(i1)%cfun%coefs(1,i2),& ctpf(i1)%cfun%tpows(1,i2)) call checkpowers(maxnc,i1,ctpf(i1)%cfun%tpows(1,i2),npows,usedpow) enddo enddo buffer=' ' ! write(*,12)npows,(usedpow(i1),i1=1,npows) ! write(buffer,11)npows,(usedpow(i1),i1=1,npows) !11 format(12i5) !12 format('3Z power2: ',i3,12i4) text=buffer ! do i1=3,ntpf ! call tpwrite('ee',i1,ctpf(i1)%nranges,ctpf(i1)%cfun) ! write(*,*)'Sorting function/range: ',i1,ctpf(i1)%nranges ! write(*,699)i1,ctpf(i1)%nranges ! do i2=1,ctpf(i1)%nranges ! write(*,700)ctpf(i1)%cfun%tbreaks(i2),& ! (ctpf(i1)%cfun%coefs(i3,i2),i3=1,npows) ! enddo ! enddo !800 format(a,2i3,3(1pe12.4,i5)) !699 format('Function/parameter and ranges: ',2i4) !700 format(F11.4,4x,4(1x,G14.8)/5(1x,G14.8)) 1000 continue return end subroutine tpfun2coef !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_tpascoef !\begin{verbatim} %- subroutine list_tpascoef(lut,text,paratyp,i1,npows,factor,ctpf) ! writes a parameter in DAT format ! text contains the stoichiometries written with the format 1x,F11.6 ! it can be very long if there are many coefficients. implicit none integer lut,i1,npows,paratyp character text*(*) ! this is a factor that may be multiplied with all coefficients for ! phases like sigma which has only a disordered part. Also ionic liquid double precision factor type(gtp_tpfun2dat) :: ctpf(*) !\end{verbatim} %+ integer i2,i3,ip,kk,mm ip=len_trim(text) ! this is the endmember stoichiometry, 12 characters per value, 6x12=72 ! write(*,*)'3Z len_trim(text): ',ip if(ip.gt.72) then write(lut,698)paratyp,ctpf(i1)%nranges,text(1:72) i2=73 do while(i2.lt.ip) write(lut,699)trim(text(i2:i2+71)) i2=i2+72 enddo else write(lut,698)paratyp,ctpf(i1)%nranges,trim(text) endif !698 format(i4,i3,a) ! According to Ted 698 format(i2,i3,1x,a) 699 format(a) do i2=1,ctpf(i1)%nranges if(ctpf(i1)%cfun%coefs(7,i2).eq.zero .and. & ctpf(i1)%cfun%coefs(8,i2).eq.zero .and. & ctpf(i1)%cfun%coefs(9,i2).eq.zero .and. & ctpf(i1)%cfun%coefs(10,i2).eq.zero .and. & ctpf(i1)%cfun%coefs(11,i2).eq.zero) then write(lut,700)ctpf(i1)%cfun%tbreaks(i2),& (factor*ctpf(i1)%cfun%coefs(i3,i2),i3=1,6) else ! There are some special powers, write only non-zero coefficients ! write(lut,705)ctpf(i1)%cfun%tbreaks(i2),& ! (ctpf(i1)%cfun%coefs(i3,i2),i3=1,6),& ! (ctpf(i1)%cfun%coefs(i3,i2),& ! ctpf(i1)%cfun%tpows(i3,i2),i3=7,npows) write(lut,710)ctpf(i1)%cfun%tbreaks(i2),& (factor*ctpf(i1)%cfun%coefs(i3,i2),i3=1,6) mm=0 ! The 6 first powers are the default 0 1 100 2 3 -1 ! Possible extra powers are 7 -9 -2 unknown1 unknown2 ! uknown can be -3, 4, 5, -8 (for sqrt(T), do kk=7,npows if(ctpf(i1)%cfun%coefs(kk,i2).ne.zero) mm=mm+1 enddo ! write(*,719)'3Z powers: ',npows,mm,& ! (ctpf(i1)%cfun%coefs(i3,i2),ctpf(i1)%cfun%tpows(i3,i2),i3=7,npows) ! UNFINISHED write(lut,730,advance='no')mm do kk=7,npows if(ctpf(i1)%cfun%coefs(kk,i2).ne.zero) then if(mm.eq.1) then if(ctpf(i1)%cfun%tpows(kk,i2).eq.-8) then ! this is the square root of T write(lut,733)factor*ctpf(i1)%cfun%coefs(kk,i2) else write(lut,731)factor*ctpf(i1)%cfun%coefs(kk,i2),& ctpf(i1)%cfun%tpows(kk,i2) endif mm=mm-1 elseif(mm.lt.0) then write(*,*)'3Z wrong number of coefficeints!!!' else if(ctpf(i1)%cfun%tpows(kk,i2).eq.-8) then ! this is the square root of T write(lut,733)factor*ctpf(i1)%cfun%coefs(kk,i2) else write(lut,731,advance='no')& factor*ctpf(i1)%cfun%coefs(kk,i2),& ctpf(i1)%cfun%tpows(kk,i2) endif mm=mm-1 endif endif enddo endif enddo ! according to Ted 700 format(1x,F11.4,6(1x,G15.8)/' 1 0.00000000 0.00') !705 format(1x,F11.4,6(1x,G15.8)/' 3 ',3(1x,G15.8,i3,'.00')) 710 format(1x,F11.4,6(1x,G15.8)) !719 format(a,2i3,4(1x,G10.2,1x,i3,'.00')) !721 format(1x,i3,4(1x,G15.8,1x,F5.2)) 730 format(i3) 731 format(1x,G15.8,1x,i3,'.00') 733 format(1x,G15.8,1x,' 0.50') !1000 continue return end subroutine list_tpascoef !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine tpf2c !\begin{verbatim} %- subroutine tpf2c(ctpf,lfun,done) ! convert TPfun lfun to an array of coefficients with powers of T ! if this TP function already converted just return ! if this TP function calls another TP function not converted return error ! implicit none integer lfun logical done type(gtp_tpfun2dat) :: ctpf(*) !\end{verbatim} %+ integer i1,i2,i3,nrange,nc,funref type(tpfun_root), pointer :: tpfroot type(tpfun_expression), pointer :: tpfexpr ! return if already converted ! write(*,*)'3Z in tpf2c ',lfun,tpfuns(lfun)%noofranges if(ctpf(lfun)%nranges.ge.0) goto 1000 ! This function not converted, check if it reference an unconverted TPfunction tpfroot=>tpfuns(lfun) if(btest(tpfuns(lfun)%status,TPCONST)) then write(*,*)'3Z this function is a constant, have to think about',lfun stop 18 endif nrange=tpfroot%noofranges do i1=1,nrange tpfexpr=>tpfroot%funlinks(i1) nc=tpfexpr%noofcoeffs ! skip the first two predefined functions, R and RTLNP do i2=1,nc funref=tpfexpr%link(i2) if(funref.eq.1) then ! this is a constant R, multiply the coefficient with 8.31451 and set link=0 ! write(*,*)'3Z Replacing R with its value in function ',lfun tpfexpr%coeffs(i2)=8.31451*tpfexpr%coeffs(i2) tpfexpr%link(i2)=0 elseif(funref.eq.2) then ! write(*,*)'3Z Deleting use of RTLNP for gas in function ',lfun tpfexpr%link(i2)=0 tpfexpr%coeffs(i2)=zero elseif(funref.gt.0) then if(ctpf(funref)%nranges.lt.0) then ! this function has a reference to an unconverted TPfunction ! write(*,*)'3Z TPfun ',lfun,' reference ',funref,& ! ctpf(funref)%nranges done=.false. ! write(*,*)'Skipping for the moment ',lfun,funref goto 1000 endif endif enddo enddo ! convert the TPfun "lfun" to coefficents and powers call tpf2cx(ctpf,lfun,nrange,ctpf(lfun)%cfun) ! write(*,*)'3Z tp2c: ',tpfuns(lfun)%symbol,nrange ! call tpwrite('z2',lfun,nrange,ctpf(lfun)%cfun) ! do i1=1,nrange ! write(*,200)(ctpf(lfun)%cfun%coefs(i2,i1),i2=1,6) ! enddo !200 format(10F12.3) 1000 continue return end subroutine tpf2c !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ ! each term has a coefficent and an array of integers ! tpow is power of T ! ppow is power of P ! wpow is power of linked symbol, the link is in link ! plevel is level of parenthesis ?? ! link is link to another function if >0 or a unary function if <0 ! accept only -2 which is taken as LN(T) !\addtotable subroutine tpf2cx !\begin{verbatim} %- subroutine tpf2cx(ctpf,lfun,nrange,cfun1) ! convert TPfun lfun to an array of coefficients with powers of T ! if this TP function already converted just return ! if this TP function calls another TP function not converted return error implicit none integer lfun,nrange type(gtp_tpfun_as_coeff) :: cfun1 type(gtp_tpfun2dat) :: ctpf(*) ! type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ ! max no of coefficent, max no of ranges ... integer, parameter :: maxnc=15,maxnr=20 integer i1a,i1b,i2,i3,i4,nc1,funref,iadd,nrangeb,ncc,caddnr(maxnr),nrr,jadd integer caddid(maxnr),krange,klink type(tpfun_root), pointer :: tpfroot type(tpfun_expression), pointer :: tpfexpr type(gtp_tpfun_as_coeff), dimension(:), allocatable :: cadd double precision ccc logical skipnext,isqrt integer noofcadd,fsqrt !---------- ! TYPE gtp_tpfun_as_coeff ! record for a TPFUN converted to coefficents without any references to other ! functions. Note ranges may change when adding functions!! ! double precision, dimension(:), allocatable :: tbreaks ! double precision, dimension(:,:), allocatable :: coefs ! integer, dimension(:,:), allocatable :: tpows ! end type gtp_tpfun_as_coeff !---------- ! Now convert !! ! allocate a record for all ranges and coefficients iadd=0 tpfroot=>tpfuns(lfun) if(nrange.gt.maxnr) then write(*,*)'3Z too many T ranges!',nrange stop 13 endif ! write(*,*)'3Z converting ',lfun ! allocate and zero cfun1 data allocate(cfun1%tbreaks(maxnr)) allocate(cfun1%coefs(maxnc,maxnr)) allocate(cfun1%tpows(maxnc,maxnr)) cfun1%tbreaks=zero cfun1%coefs=zero cfun1%tpows=-100 ! T ranges, low T limit ignored. NOTE the number of ranges may change! do i1a=2,nrange cfun1%tbreaks(i1a-1)=tpfroot%limits(i1a) enddo cfun1%tbreaks(nrange)=tpfroot%hightlimit nrangeb=nrange ! write(*,2)tpfuns(lfun)%symbol !2 format(/'Entering tpf2cx ---------------------------------: ',a) ! functions ! NOTE nrange may change below if referenced functions have a smaller range ! not so good to have a loop ... ! i1a is range index for original TPfun ! i1b is range index for TPfun converted to coefficients as referenced ! functions may have shorter range ! do i1b=1,nrange ! tpfexpr=>tpfroot%funlinks(i1b) ! nc1=tpfexpr%noofcoeffs ! do i1a=1,nc1 ! write(*,30)i1a,tpfexpr%coeffs(i1a),tpfexpr%tpow(i1a),& ! tpfexpr%ppow(i1a),tpfexpr%wpow(i1a),tpfexpr%plevel(i1a),& ! tpfexpr%link(i1a) ! enddo ! enddo !30 format('3Z term: ',i3,1pe12.4,5i7) i1a=0 i1b=0 jadd=0 noofcadd=0 krange=1 isqrt=.false. 100 continue i1a=i1a+1 i1b=i1b+1 if(i1a.gt.nrange) goto 700 jadd=jadd+i1a tpfexpr=>tpfroot%funlinks(i1a) nc1=tpfexpr%noofcoeffs if(ctpf(1)%debug.ne.0) & write(*,107)'TPfun ranges: ',tpfuns(lfun)%symbol,i1a,i1b,nrangeb,jadd 107 format(a,a,5i4) skipnext=.false. ! maybe needed? YES! iadd=0 trange: do i2=1,nc1 cfun1%coefs(i2,i1b)=tpfexpr%coeffs(i2) cfun1%tpows(i2,i1b)=tpfexpr%tpow(i2) ! assume link to unary LN function just means LN(T) funref=tpfexpr%link(i2) ! write(*,113)'3Z cc: ',i1a,i1b,i2,funref,& ! cfun1%coefs(i2,i1b),cfun1%tpows(i2,i1b) !113 format(a,4i4,E20.8,i5) if(skipnext) then ! skip this term as it should just contain the ln(T) if(tpfexpr%plevel(i2).ne.1 .or. tpfexpr%link(i2).ne.0 & .or. tpfexpr%tpow(i2).ne.1) then ! write(*,*)'3Z WARNING check if TPFUN error in: ',& ! trim(tpfroot%symbol),lfun ! gx%bmperr=4393; goto 1000 endif cfun1%coefs(i2,i1b)=zero cfun1%tpows(i2,i1b)=-100 skipnext=.false. if(isqrt) then ! fixing a bug for T**2 as EXP(0.5*LN(T)) isqrt=.false. cycle trange endif endif funrefif: if(funref.lt.0) then ! this is assumed to be a link to LN(T) or SQRT if(funref.eq.-3) then ! this is to handle sqrt(t) which in a TDB file is EXP(0.5LN(T)) ! check that link to function is SQRT fsqrt=tpfexpr%link(i2+1) ! write(*,114)'Found SQRTT?: ',lfun,tpfuns(lfun)%symbol,& ! fsqrt,tpfuns(fsqrt)%symbol !114 format(a,i5,2x,a,i5,2x,a) ! set T power to -8; this will be converted to 0.5 when writing !!! cfun1%tpows(i2,i1b)=-8 ! write(*,*)'3Z sqrt coeff: ',cfun1%coefs(i2,i1b) isqrt=.true. skipnext=.true. elseif(funref.ne.-2) then ! this is an unknown type of funref link (-2 means LN(T)) write(*,*)'3Z TPFUN with other unary function than LN(T): ',& trim(tpfroot%symbol),lfun,funref gx%bmperr=4393; goto 1000 elseif(tpfexpr%tpow(i2).eq.1) then ! NOTE not elseif(funref ... just extract the power of T, could be 0? ! Tln(T) will have tpows = 100, we skip the next term with the T cfun1%tpows(i2,i1b)=tpfexpr%tpow(i2)+99 skipnext=.true. ! else ! This could be a LN(T) term? ! write(*,'(a,a,5i5)')'3Z TPFUN with just LN(T)? ',& ! trim(tpfroot%symbol),lfun,i2,funref,tpfexpr%tpow(i2) ! gx%bmperr=4393; goto 1000 endif elseif(funref.gt.0) then funrefranges: if(ctpf(funref)%nranges.gt.0) then ! this range has a reference to a converted TPfunction, ! store this separately, possibly multiplied with coefficent and T powers ! and link all such functions to be added using cfun1%nextcrec ! examples: +22*GHSERCR, ff*exp(qq*irt) ... the latter will not work ... ccc=tpfexpr%coeffs(i2) ! write(*,32)'3Z link from: ',tpfuns(lfun)%symbol,& ! i2,funref,ccc,trim(tpfuns(funref)%symbol) !32 format(a,a,2i4,F6.2,' to ',a) ! write(*,333)'3Z term, link, factor: ',i2,funref,ccc,& ! IMPORTRANT funref is also index in tpfuns!!! ! trim(tpfroot%symbol),trim(tpfuns(funref)%symbol),& ! ctpf(funref)%nranges,& ! tpfuns(funref)%noofranges,size(tpfuns(funref)%limits) !333 format(a,2i4,1pe11.2,2x,a,2x,a,5i5) ! only allow a constant coefficent, no T or P powers, no unary function ... if(tpfexpr%tpow(i2).ne.0 .or. tpfexpr%ppow(i2).ne.0 .or. & tpfexpr%wpow(i2).ne.0 .and. & (tpfexpr%plevel(i2).ne.0 .or. tpfexpr%plevel(i2).ne.1)) then ! Above the function SQRT which has tpfexpr%plevel(i2)=1 is accepted ... if(tpfuns(funref)%noofranges.eq.1) then ! Now check if funref is just a constant, then multiply ccc with that! ! write(*,334)'3Z trying to handle MEV factor ... ',& ! trim(tpfuns(funref)%symbol),& ! tpfuns(funref)%funlinks(1)%noofcoeffs,& ! tpfuns(funref)%funlinks(1)%coeffs(1) !334 format(a,a,i2,1pe11.2) ! WOW wpow-1000 is link to another function! klink=tpfexpr%wpow(i2)-1000 if(tpfuns(funref)%funlinks(1)%noofcoeffs.eq.1 .and.& tpfuns(klink)%funlinks(1)%noofcoeffs.eq.1) then ccc=ccc*tpfuns(funref)%funlinks(1)%coeffs(1)*& tpfuns(klink)%funlinks(1)%coeffs(1) ! write(*,335)'3Z Wow! ',trim(tpfuns(funref)%symbol),& ! trim(tpfuns(lfun)%symbol),i2,nc1,ccc,& ! tpfuns(funref)%funlinks(1)%coeffs(1),& ! klink,trim(tpfuns(klink)%symbol),& ! tpfuns(klink)%funlinks(1)%coeffs(1) !335 format(a,2x,a,2x,a,2i3,2(1pe12.4),i3,2x,a,1pe12.4) ! cfun1%coefs(i2,i1b)=ccc cfun1%coefs(i2,i1b)=ccc exit funrefif endif endif ! else give up write(*,116)'3Z Too complicated function: ',& trim(tpfroot%symbol),tpfexpr%tpow(i2),& tpfexpr%ppow(i2),tpfexpr%wpow(i2),tpfexpr%plevel(i2),& funref,trim(tpfuns(funref)%symbol) 116 format(a,a,5i5,2x,a) gx%bmperr=4399; goto 1000 endif ! this term should be ignored as it replaced by the function cfun1%coefs(i2,i1b)=zero cfun1%tpows(i2,i1b)=-100 ! we must create a new coefficient array with the funref coefficents ! multiplied with the current coef within the current T-range ! It may be necessary to increase the number of T-ranges if(.not.allocated(cadd)) then ! we have more than 6 functions added in soma cases ... allocate(cadd(10)) noofcadd=noofcadd+1 ! write(*,*)'Allocating cadd ',i2,noofcadd ! ?? iadd=0 caddnr=0 endif ! call a new function to add the coefficents of funref iadd=iadd+1 if(iadd.gt.7) then write(*,*)'3Z many added functions in: ',& trim(tpfuns(lfun)%symbol),': ',iadd,funref endif cadd(iadd)=ctpf(funref)%cfun caddnr(iadd)=ctpf(funref)%nranges caddid(iadd)=funref ! write(*,800)'3Z aa: ',funref,iadd,(cadd(iadd)%coefs(i3,1),& ! cadd(iadd)%tpows(i3,1),i3=1,3) ! multiply all terms in funref with the coefficient of this term ! within the current T-range ! It may be necessary to increase the T-ranges of ctpf ! write(*,*)'3Z addranges: ',ctpf(funref)%nranges,ccc do i3=1,maxnc do i4=1,ctpf(funref)%nranges cadd(iadd)%coefs(i3,i4)=ccc*cadd(iadd)%coefs(i3,i4) enddo enddo ! write(*,800)'3Z bb: ',funref,iadd,(cadd(iadd)%coefs(i3,1),& ! cadd(iadd)%tpows(i3,1),i3=1,3) else ! what about funref with no ranges? write(*,*)'3Z funref has no ranges? ',& trim(tpfuns(funref)%symbol),ctpf(funref)%nranges gx%bmperr=4399; goto 1000 endif funrefranges ! else ! when funref=0 it is OK to do nothing !! endif funrefif !800 format(a,2i3,3(1pe12.4,i5)) ! we have gone through all terms for the TPfun for this range enddo trange ! Check if there were function links in this range if(iadd.gt.0) then ! If iadd>1 we must first add together all the different functions referenced ! and possibly split the T range if these function have a different ranges ncc=3 ! write(*,*)'3Z adjusting ranges?',iadd ! This loop only if there are two or more function references within a range do i3=iadd,2,-1 nrr=caddnr(i3) ! write(*,16)'3Z there are coefficients to add!!',i3,iadd,nrr 16 format(a,6i4) ! add terms and adjust all ranges in cadd(i3-1) call adjustranges(nrr,cadd(i3-1),caddnr(i3),cadd(i3),& ctpf(1)%debug, ctpf(lfun)%name) if(gx%bmperr.ne.0) then write(*,*)'Error occured adding: ',caddid(i3-1),caddid(i3) goto 1000 endif ! note nrr may be updatad caddnr(i3-1)=nrr ! we may have more functions to add ... enddo if(ctpf(lfun)%debug.ne.0) call tpwrite('++',0,caddnr(1),cadd(1)) ! we have now added all links, now add the sum of all cadd to cfun1 range i1a ! adjust1ranges creates breakpoints only in the current range, i1a, of cfun1 ! and adds the coefficients from cadd(1) to this ! write(*,*)'3Z calling adjust1: ',i1a,jadd,i1b,nrangeb if(ctpf(lfun)%debug.ne.0) then call tpwrite('>1',lfun,nrangeb,ctpf(lfun)%cfun) call tpwrite('>2',0,caddnr(1),cadd(1)) endif call adjust_1range(lfun,jadd,nrangeb,krange,cfun1,caddnr(1),cadd(1),& ctpf(lfun)%debug) krange=krange+1 ! krange can have chnaged more then one ... make sure krange set correct ! if additional ranges needed nrangeb changed ! increment i1b but not i1a and nrange ! why -1 ?? jadd=nrangeb-i1a-1 i1b=i1b+nrangeb-2 if(ctpf(lfun)%debug.ne.0) then write(*,*)'3Z after adjust1x: ',i1a,jadd,i1b,nrangeb call tpwrite('<<',lfun,nrangeb,ctpf(lfun)%cfun) endif ! write(*,*)'deallocating cadd' deallocate(cadd) endif goto 100 ! we have gone through all ranges 700 continue ! write(*,*)'3Z 700: ',i1a,nrange,nrangeb ctpf(lfun)%nranges=nrangeb ! write(*,*)'3Z converted function with ranges: ',lfun,nrangeb ! Listing the final function ! call tpwrite('z1',lfun,nrange,ctpf(lfun)%cfun) 1000 continue return end subroutine tpf2cx !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ subroutine tpwrite(c2,lfun,nrange,cfun) ! temporary debug output ! ************************* ATTENTION ! IF I DO NOT CALL THIS THERE ARE BUGS !! IMPLICIT none integer nrange,lfun character c2*2 type(gtp_tpfun_as_coeff) :: cfun ! integer i1,i2 do i1=1,nrange write(*,800)c2,lfun,i1,nrange,cfun%tbreaks(i1),& (cfun%coefs(i2,i1),cfun%tpows(i2,i1),i2=1,10) enddo 800 format('3Z ',a,': ',i3,2i2,F9.2,3(1pe13.5,i5)/& (23x,e13.5,i5,e13.5,i5,e13.5,i5)) write(*,*)'3Z end of function -----------------' return end subroutine tpwrite !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ subroutine tpmult(lfun,mfun,ccc,ctpf) ! multiples all terms in cfpf(lfun) with the factor ccc and returns that ! in ctpf(mfun) ! cfun is not changed implicit none integer lfun,mfun double precision ccc type(gtp_tpfun2dat) :: ctpf(*) ! type(gtp_tpfun_as_coeff) :: cfun ! integer, parameter :: maxnc=15,maxnr=20 integer i1,i2 ctpf(mfun)%nranges=ctpf(lfun)%nranges if(.not.allocated(ctpf(mfun)%cfun%tbreaks)) then ! write(*,*)'3Z allocating mfun' allocate(ctpf(mfun)%cfun%tbreaks(maxnr)) allocate(ctpf(mfun)%cfun%coefs(maxnc,maxnr)) allocate(ctpf(mfun)%cfun%tpows(maxnc,maxnr)) endif ctpf(mfun)%cfun%tbreaks=zero ctpf(mfun)%cfun%coefs=zero ctpf(mfun)%cfun%tpows=0 do i1=1,ctpf(mfun)%nranges ctpf(mfun)%cfun%tbreaks(i1)=ctpf(lfun)%cfun%tbreaks(i1) do i2=1,maxnc ctpf(mfun)%cfun%coefs(i2,i1)=ccc*ctpf(lfun)%cfun%coefs(i2,i1) ctpf(mfun)%cfun%tpows(i2,i1)=ctpf(lfun)%cfun%tpows(i2,i1) enddo enddo return end subroutine tpmult !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine adjust_1range !\begin{verbatim} %- subroutine adjust_1range(lfun,nr1,nrange,krange,ctp1,nr2,ctp2,debug) ! check if ctp1 range nr1 must be split in more ranges due to tbreaks in ctp2 ! nrange is the total number of ranges of ctp1 ! There are 10 ranges allocated for all, nr1 and nr2 are the used ranges implicit none integer lfun,nr1,nr2,krange,nrange,debug type(gtp_tpfun_as_coeff) :: ctp1,ctp2 !\end{verbatim} %+ ! TYPE gtp_tpfun_as_coeff ! record for a TPFUN converted to coefficents without references to other funs ! Note ranges may increase when adding functions!! ! double precision, dimension(:), allocatable :: tbreaks ! double precision, dimension(:,:), allocatable :: coefs ! integer, dimension(:,:), allocatable :: tpows ! end type gtp_tpfun_as_coeff double precision, parameter :: tenth=1.0D-1 integer, parameter :: maxnc=15 integer i1,i2,i3,k1,nr3,nr0,j2,j3,mrange,kk,kpow double precision tlow1,thigh1,tlow2,thigh2,tmax logical nosplit type(gtp_tpfun_as_coeff) :: ctp3 ! nr0=nr1 if(debug.ne.0) then write(*,4)'3Z in adjust_1range 1: ',nr1,(ctp1%tbreaks(j2),j2=1,nr1) write(*,4)'3Z in adjust_1range 2: ',nr2,(ctp2%tbreaks(j2),j2=1,nr2) 4 format(a,i3,10(F10.2)) endif ! check highest T ............ unchanged ?? below tmax=ctp1%tbreaks(1) do i1=2,nr1 if(ctp1%tbreaks(i1).gt.tmax) tmax=ctp1%tbreaks(i1) enddo i2=nr2 do i1=nr2,1,-1 if(ctp2%tbreaks(i1).gt.tmax) then ! reduce the number of ranges i2=i2-1 endif enddo nr2=i2 if(nr2.lt.1) then ! high limit of ctp1 is lower than first breakpoint in ctp2 nr2=1 ctp2%tbreaks(nr2)=tmax endif tmax=ctp2%tbreaks(nr2) ctp1%tbreaks(nr1)=tmax if(debug.ne.0) write(*,'(a,2i3,F8.2)')'3Z coeffs and tmax: ',nr1,nr2,tmax if(nr1.eq.1) then tlow1=298.15 thigh1=ctp1%tbreaks(nr1) j2=1 else tlow1=ctp1%tbreaks(nr1-1) thigh1=ctp1%tbreaks(nr1) j2=nr1-1 endif ! if(debug.ne.0) write(*,7)'adjust_1range 3: ',nrange,nr1,nr2,j2,& ctp1%tbreaks(nr1),ctp2%tbreaks(nr2) 7 format(a,4i4,2F10.2) allocate(ctp3%tbreaks(1)) allocate(ctp3%coefs(maxnc,1)) allocate(ctp3%tpows(maxnc,1)) ctp3%tbreaks=zero nosplit=.true. ! search ctp2 for tbreaks in the range tlow1 to thigh1 i2=1 ! mrange=nrange-1 if(debug.ne.0) write(*,16)'In adjust_1range 4: ',nr1,i2,krange,& tlow1,thigh1,ctp2%tbreaks(i2) 16 format(/a,3i3,3F10.2) !100 continue split: do while(i2.lt.nr2) ! fine-tuning needed when breakpoints identical in parameter and GHSERxx ! write(*,*)'3Z in do while: ',i2,nr2,ctp2%tbreaks(i2),tlow1 if(ctp2%tbreaks(i2)-tlow1.gt.tenth) then ! write(*,16)'3Z check breakpoint ',nrange,i2,krange,& ! ctp2%tbreaks(i2),thigh1 ! fine-tuning needed when breakpoints identical in parameter and GHSERxx if(abs(ctp2%tbreaks(i2)-thigh1).lt.tenth) then ! breakpoints are identical mrange=nrange-1 ! write(*,*)'Identical breakpoints',ctp2%tbreaks(i2),thigh1 goto 800 elseif(ctp2%tbreaks(i2)-thigh1.lt.-tenth) then ! fine-tuning needed when breakpoints identical in parameter and GHSERxx ! there is a breakpoint in ctp2 between tlow1 and thigh1 ! we must add one range above nr1, shift the coefficients in higher ranges up if(debug.ne.0) then write(*,16)'3Z inserted new breakpoint ',& nrange,j2,0,ctp2%tbreaks(i2),thigh1 call tpwrite('--',0,nrange,ctp1) endif do k1=nrange,j2,-1 ctp1%tbreaks(k1+1)=ctp1%tbreaks(k1) do i3=1,maxnc ! copy the coefficients to the new range ctp1%coefs(i3,k1+1)=ctp1%coefs(i3,k1) ctp1%tpows(i3,k1+1)=ctp1%tpows(i3,k1) enddo enddo ! added coefficients to new range if(debug.ne.0) call tpwrite('-+',0,nrange,ctp1) nrange=nrange+1 if(debug.ne.0) call tpwrite('up',0,nrange,ctp1) ! now add coeffs from ctp1 range k1 and ctp2 in range i2 to ctp3 range 1 ! then replace range k1 in ctp1 by range 1 of ctp3 ctp3%tpows=-100 ctp3%coefs=zero ! the range in ctp1 that should be added to is j2+1 ?? ! j2=j2+1 if(debug.ne.0) then write(*,'(a,4i3,5F10.2)')'3Z add7: ',nr1,i2,nrange,j2,& (ctp1%tbreaks(j3),j3=1,nr1) call tpwrite('v1',0,nrange,ctp1) write(*,'(a,4i3,5F10.2)')'3Z add7: ',nr1,i2,nrange,j2,& (ctp1%tbreaks(j3),j3=1,nr1) call tpwrite('v2',0,nr2,ctp2) endif call add1tpcoeffs(j2,ctp1,i2,ctp2,1,ctp3) ! call tpwrite('v3',0,1,ctp3) do j3=1,maxnc ctp1%coefs(j3,j2)=ctp3%coefs(j3,1) ctp1%tpows(j3,j2)=ctp3%tpows(j3,1) enddo ! NEW: added a range to ctp1 !!! krange=krange+1 tlow1=min(ctp2%tbreaks(i2),thigh1) ctp1%tbreaks(j2)=tlow1 ! call tpwrite('q1',0,nrange,ctp1) ! we have added one range to ctp1 nosplit=.false. ! nrange=nrange+1 if(debug.ne.0) write(*,*)'adjust_1range 6:',& nrange,j2,ctp1%tbreaks(j2) else mrange=nrange-1 goto 800 endif else continue if(debug.ne.0) write(*,731)'adjust_1range 7:',& i2,nr2,ctp2%tbreaks(i2),tlow1 731 format(a,2i3,2F10.2) endif i2=i2+1 j2=j2+1 enddo split ! flyttat till efter label 800 !799 continue mrange=nrange 800 continue ! write(*,*)'Why??',nrange,mrange,nr1,nr2,nosplit if(debug.ne.0) call tpwrite('w0',0,nrange,ctp1) ! just add the terms (for the last range) ! ctp3%tpows=-100 ! ctp3%coefs=zero if(nosplit) then ! we have not split the range, store cp3 in range nr1 mrange=nr1 endif ! write(*,900)'3Z add8: ',nrange,i2,mrange,krange,& ! ctp1%tbreaks(nrange),ctp2%tbreaks(i2) !900 format(/a,4i3,2F10.2) ! these output w1..c4 are important for debugging if(debug.ne.0) then call tpwrite('w1',0,nrange,ctp1) call tpwrite('w2',0,nr2,ctp2) endif ! call add1tpcoeffs(mrange,ctp1,i2,ctp2,1,ctp3) call add1tpcoeffs(nrange,ctp1,i2,ctp2,1,ctp3) if(debug.ne.0) call tpwrite('w3',0,1,ctp3) ! skipping this loop if(krange.ne.nrange) then write(*,*)'3Z *** Check function: ',tpfuns(lfun)%symbol,nrange,krange ! call tpwrite('w3',0,1,ctp3) endif ! We need to know which range in ctp1 we should store ctp3 .... krange!! ! to handle problems with G(LIQ,U+4:O-2) parameter do j3=1,maxnc ctp1%coefs(j3,krange)=ctp3%coefs(j3,1) ctp1%tpows(j3,krange)=ctp3%tpows(j3,1) enddo 990 continue if(debug.ne.0) call tpwrite('w4',0,nrange,ctp1) !1000 continue ! if(nr3.gt.nr0) then ! write(*,*)'3Z inserted ',nrange-nr0,' ranges' ! endif return end subroutine adjust_1range !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine adjustranges !\begin{verbatim} %- subroutine adjustranges(nr1,ctp1,nr2,ctp2,debug,funame) ! add ctp2 to ctp1 which to have the same ranges and breakpoints ! nr1 and nr2 give the number of T-ranges and breakpoints ! add coefficients of ctp1 and ctp2 for each range ! NOTE these already multiplied with the coefficents!! ! There are 10 coefficients allocated for all functions. ! the added function is returned as ctp1 implicit none integer nr1,nr2,debug type(gtp_tpfun_as_coeff) :: ctp1,ctp2 character funame*(*) !\end{verbatim} %+ ! TYPE gtp_tpfun_as_coeff ! record for a TPFUN converted to coefficents without references to other funs ! Note ranges may increase when adding functions!! ! double precision, dimension(:), allocatable :: tbreaks ! double precision, dimension(:,:), allocatable :: coefs ! integer, dimension(:,:), allocatable :: tpows ! end type gtp_tpfun_as_coeff ! Max number of coefficients is maxnc, ranges is maxnr ! Previously I have used a maximum of 11 for any specific function ... ! I am not sure I can just allocate bigger .... but I will try integer, parameter :: maxnc=15,maxnr=20 double precision, parameter :: tenth=1.0D-1 integer i1,i2,i3,k1,k2,nr3 double precision tmax,tbreak,tlimit,tlim1,tlim2 type(gtp_tpfun_as_coeff) :: ctp3 ! if(debug.ne.0) then write(*,4)'3Z adjustranges 1: ',nr1,(ctp1%tbreaks(i1),i1=1,nr1) write(*,4)'3Z adjustranges 2: ',nr2,(ctp2%tbreaks(i1),i1=1,nr2) 4 format(a,i2,10(F8.2)) endif tmax=max(ctp1%tbreaks(nr1),ctp2%tbreaks(nr2)) tbreak=tmax ! tlimit can set a new tmax if some function has lower limit tlimit=min(ctp1%tbreaks(nr1),ctp2%tbreaks(nr2)) ! write(*,*)'3Z tmax: ',tmax i1=1 i2=1 i3=0 allocate(ctp3%tbreaks(maxnr)) allocate(ctp3%coefs(maxnc,maxnr)) allocate(ctp3%tpows(maxnc,maxnr)) ctp3%tpows=-100 !---------------------------------------------------------------- ! write(*,79)'3Z adding and adjusting ranges: ',nr1,nr2,tlimit,tmax 79 format(a,2i2,2F9.2) tlim1=ctp1%tbreaks(i1) tlim2=ctp2%tbreaks(i2) ! LOOP HERE 100 continue ! sometimes the normal loop exit does not work correcrly .... if(tlim1.le.zero) goto 200 i3=i3+1 if(i3.gt.maxnr) then write(*,*)'3Z too many ranges is summation function',i3 call tpwrite('!!',0,i3,ctp3) gx%bmperr=4391; goto 1000 endif ! new T-range ctp3%tbreaks(i3)=min(tlim1,tlim2) call add1tpcoeffs(i1,ctp1,i2,ctp2,i3,ctp3) if(gx%bmperr.ne.0) goto 1000 if(debug.ne.0) then write(*,170)'3Z calling add1tp: ',i1,i2,i3,nr1,nr2,& ctp1%tbreaks(i1),ctp2%tbreaks(i2),ctp3%tbreaks(i3) 170 format(a,5i5,3F10.2) call tpwrite('b1',0,i3,ctp3) endif if(abs(tlim1-tlim2).lt.one) then ! Problem here with the SGTE inary breakpoint at liquidus ! if the parameter has same breakpoints as the GHSER function if(tlim1.le.zero .or. tlim2.le.zero) then write(*,171)trim(funame) 171 format('3Z **** Warning T limits out of range for: ',a) goto 200 endif ! write(*,180)'3Z same breakpoint',i1,i2,tlim1,tlim2 180 format(a,2i3,2F10.2) ctp3%tbreaks(i3)=tlim1 if(tlim1.ge.6.0D3) goto 200 if(i1.lt.nr1) then i1=i1+1 tlim1=ctp1%tbreaks(i1) else tlim1=5.9D3 endif if(i2.lt.nr2) then i2=i2+1 tlim2=ctp2%tbreaks(i2) else tlim2=5.8D3 endif goto 100 endif ! bugfix around here 2021.10.15/BoS modified 2021.11.07 if(i1.eq.nr1) then ! no more ranges for ctp1 if(i2.eq.nr2) then ! no more ranges for ctp2 either, but there can a last range if(abs(tlim1-tlim2).gt.one) then i3=i3+1 ctp3%tbreaks(i3)=max(tlim1,tlim2) call add1tpcoeffs(i1,ctp1,i2,ctp2,i3,ctp3) if(gx%bmperr.ne.0) goto 1000 if(debug.ne.0) then write(*,170)'3Z calling add1tp: ',i1,i2,i3,nr1,nr2,& ctp1%tbreaks(i1),ctp2%tbreaks(i2),ctp3%tbreaks(i3) call tpwrite('b1',0,i3,ctp3) endif endif goto 200 else ! more ranges for ctp2, increment i2, set tlim1 same as tlim2 i2=i2+1; tlim2=ctp2%tbreaks(i2); tlim1=tlim2; goto 100 endif elseif(i2.eq.nr2) then ! no more ranges for cp2 but there are more ranges for cpt1 i1=i1+1; tlim1=ctp1%tbreaks(i1); tlim2=tlim1; goto 100 elseif(tlim1.lt.tlim2) then ! increment the function with lowest tlim, the other tlim same i1=i1+1; tlim1=ctp1%tbreaks(i1); goto 100 else i2=i2+1; tlim2=ctp2%tbreaks(i2); goto 100 endif !======================================================== 200 continue if(i3.le.0) then ! evidently i3 can be less than 1 here .... write(*,209)'3Z T-range adjustment: ',i3,tmax,tlimit,ctp3%tbreaks(1) 209 format(a,i3,5F10.2) i3=1 endif tbreak=ctp3%tbreaks(i3) tlimit=tbreak ! write(*,210)'3Z created ctp3 range: ',i3,ctp3%tbreaks(i3),tmax,tlimit 210 format(a,i3,3F9.2) ! How to know when we finished?? ! if(abs(ctp3%tbreaks(i3)-tmax).gt.tenth) goto 100 !------------------------------------------------------------- if(debug.ne.0) then call tpwrite('!!',0,i3,ctp3) endif ctp1=ctp3 nr1=i3 ! call tpwrite('hh',0,nr1,ctp1) ! I assume the arrays allocated for ctp3 will be deallocated automatically 1000 continue return end subroutine adjustranges !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine add1tpcoeffs !\begin{verbatim} %- subroutine add1tpcoeffs(i1,ctp1,i2,ctp2,i3,ctp3) ! ctp3 is created with added coefficents from range i1 in ctp1 ! and range i2 in cp2 with same tpower. Normally i3=1 implicit none integer i1,i2,i3 type(gtp_tpfun_as_coeff) :: ctp1,ctp2,ctp3 !\end{verbatim} %+ integer, parameter :: maxnc=15 integer j1,j2,j3,k1 ! first copy ctp1 to ctp3. Then add ctp3 coefficients with same powers ! write(*,16)'3Z add1tp1: ',i1,i2,i3,ctp1%coefs(1,i1),ctp2%coefs(1,i2) !16 format(a,3i3,2(1pe14.6)) ! write(*,17)(ctp1%tpows(j3,i1),j3=1,maxnc) ! write(*,17)(ctp2%tpows(j3,i2),j3=1,maxnc) ! write(*,17)(ctp3%tpows(j3,i3),j3=1,maxnc) !17 format('3Z tpows: ',10i5) j3=0 ! call tpwrite('x0',0,i1,ctp1) do j1=1,maxnc ! if(ctp1%tpows(j1,i1).gt.-100) then j3=j3+1 ctp3%coefs(j3,i3)=ctp1%coefs(j1,i1) ctp3%tpows(j3,i3)=ctp1%tpows(j1,i1) ! endif enddo ! call tpwrite('x1',0,1,ctp3) ! call tpwrite('x2',0,i2,ctp2) ! write(*,*)'3Z no terms in ctp1?',j3 f2: do j2=1,maxnc if(ctp2%tpows(j2,i2).gt.-100) then do j1=1,maxnc if(ctp2%tpows(j2,i2).eq.ctp3%tpows(j1,i3)) then ctp3%coefs(j1,i3)=ctp3%coefs(j1,i3)+ctp2%coefs(j2,i2) cycle f2 endif enddo ! there is a t-power in ctp2 not already present in ctp3 ! write(*,*)'3Z have we managed to add?',j2,j3 newpower: do j3=1,maxnc if(ctp3%tpows(j3,i3).le.-100) then ! write(*,*)'3Z now we insert!',j3,ctp2%tpows(j2,i2),& ! ctp2%coefs(j2,i2) ctp3%coefs(j3,i3)=ctp2%coefs(j2,i2) ctp3%tpows(j3,i3)=ctp2%tpows(j2,i2) exit newpower endif enddo newpower endif enddo f2 ! call tpwrite('x3',0,1,ctp3) ! that is all?? ! write(*,16)'3Z add1tp7: ',i1,i2,i3,ctp3%coefs(1,i3),ctp2%coefs(1,i2) ! the loops above may miss terms with same power ... suck ! check all terms in ctp3 do j1=1,maxnc if(ctp3%tpows(j1,i3).gt.-100) then do j2=j1+1,maxnc if(ctp3%tpows(j2,i3).eq.ctp3%tpows(j1,i3)) then ctp3%coefs(j1,i3)=ctp3%coefs(j1,i3)+ctp3%coefs(j2,i3) ctp3%tpows(j2,i3)=-100 ctp3%coefs(j2,i3)=zero endif enddo endif enddo ! call tpwrite('x4',0,1,ctp3) !1000 continue ! write(*,*)'3Z Exit add1tpcoefs' return end subroutine add1tpcoeffs !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine checkpowers !\begin{verbatim} %- subroutine checkpowers(nc1,lfun,tpow1,npow,usedpow) ! check powers used in TP functions ! There can be several terms with same power ... ! nc1 is the maximal number of coefficients for each range (maxnc in fact) implicit none integer tpow1(*),nc1,lfun,usedpow(*),npow !\end{verbatim} %+ ! if these powers changes change also in sortceffs ! integer, parameter :: fixpows(9)=[0,1,100,2,3,-1,7,-9,4] integer, parameter :: mmm=10 integer, parameter :: fixpows(mmm)=[0,1,100,2,3,-1,7,-9,-2,-3] ! ANY CHANGE IN POWERS ALSO IN ... SORTCOEFFS integer i1,j1 if(npow.eq.0) then do j1=1,nc1 usedpow(j1)=-100 enddo ! npow=9 npow=mmm do j1=1,npow usedpow(j1)=fixpows(j1) enddo ! write(*,17)'3Z inititated usedpow: ',(usedpow(j1),j1=1,npow),lfun !17 format(a,10i5,i3) endif loop1: do i1=1,nc1 if(tpow1(i1).gt.-100) then do j1=1,npow if(tpow1(i1).eq.usedpow(j1)) cycle loop1 enddo ! we have a non standard power npow=npow+1 usedpow(npow)=tpow1(i1) ! write(*,11)'3Z non-standard power: ',lfun,tpfuns(lfun)%symbol,& ! npow,tpow1(i1) !11 format(a,i5,2x,a,2i4) endif enddo loop1 1000 continue return end subroutine checkpowers !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine sortcoeffs !\begin{verbatim} %- subroutine sortcoeffs(nc1,lfun,coeff1,tpow1) ! sort the coefficients in order power: 0 1 TlnT 2 3 -1; 7 -9 -2 other1 other2 ! 1 2 3 4 5 6; 7 8 9 10 11 ! other powers are 3, 4, -8 (meaning sqrt(t)) and maybe more ! tpowi is array giving the T power for coeffi, 101 means T*ln(T) ! ANY CHANGE OF POWERS MUST BE MADE ALSO IN ... CHECKPOWERS ! There can be several terms with same power ... ! nc1 is the maximal number of coefficients for each range (maxnc in fact) implicit none integer tpow1(*),nc1,lfun double precision coeff1(*) !\end{verbatim} integer, parameter :: maxnc=15 integer z1,i2,lastc,rare,free(3) double precision xxx,cord(maxnc) cord=zero lastc=0 rare=0 free=0 ! write(*,80)'3Z sort: ',tpfuns(lfun)%symbol,nc1,(tpow1(z1),z1=1,nc1) loop1: do z1=1,nc1 if(tpow1(z1).eq.0) then cord(1)=cord(1)+coeff1(z1) if(lastc.lt.1) lastc=1 elseif(tpow1(z1).eq.1) then cord(2)=cord(2)+coeff1(z1) if(lastc.lt.2) lastc=2 elseif(tpow1(z1).eq.100) then cord(3)=cord(3)+coeff1(z1) if(lastc.lt.3) lastc=3 elseif(tpow1(z1).eq.2) then cord(4)=cord(4)+coeff1(z1) if(lastc.lt.4) lastc=4 elseif(tpow1(z1).eq.3) then cord(5)=cord(5)+coeff1(z1) if(lastc.lt.5) lastc=5 elseif(tpow1(z1).eq.-1) then cord(6)=cord(6)+coeff1(z1) if(lastc.lt.6) lastc=6 elseif(tpow1(z1).eq.7) then ! all powers from here are special ... if coeff(z1)=zero ignore on output cord(7)=cord(7)+coeff1(z1) ! write(*,77)z1,7,tpfuns(lfun)%symbol !77 format('3Z moving coefficient ',i2,' to ',i2,': ',a) coeff1(z1)=zero if(lastc.lt.7) lastc=7 elseif(tpow1(z1).eq.-9) then cord(8)=cord(8)+coeff1(z1) ! write(*,77)z1,8,tpfuns(lfun)%symbol coeff1(z1)=zero if(lastc.lt.8) lastc=8 elseif(tpow1(z1).eq.-2) then ! it seems power -2 occors in the TAFID database cord(9)=cord(9)+coeff1(z1) ! write(*,77)z1,9,tpfuns(lfun)%symbol coeff1(z1)=zero if(lastc.lt.9) lastc=9 elseif(tpow1(z1).le.-100) then ! ignore this term continue elseif(coeff1(z1).ne.zero) then ! here tpow1(z1) cannot be -100: max 2 rare or unusual power like 3, 4, -8 ... if(free(1).eq.0 .or. tpow1(z1).eq.tpow1(10)) then ! store in unused or add to to same rare power position in position 10 ! write(*,90)tpfuns(lfun)%symbol,& ! lfun,10,z1,tpow1(z1),coeff1(z1) !90 format('3Z function: ',a,' extra power: ',4i4,2x,1pe12.4) cord(10)=cord(10)+coeff1(z1) coeff1(z1)=zero tpow1(10)=tpow1(z1) free(1)=1 if(lastc.lt.10) lastc=10 elseif(free(2).eq.0 .or. tpow1(z1).eq.tpow1(11)) then ! store in unused or add to to same rare power position in position 11 ! same special power in position 11 ! write(*,90)tpfuns(lfun)%symbol,& ! lfun,11,z1,tpow1(z1),coeff1(z1) cord(11)=cord(11)+coeff1(z1) coeff1(z1)=zero tpow1(11)=tpow1(z1) free(2)=1 if(lastc.lt.11) lastc=11 elseif(free(3).eq.0 .or. tpow1(z1).eq.tpow1(12)) then ! store in unused or add to to same rare power position in position 12 ! same special power in position 12 ! write(*,90)tpfuns(lfun)%symbol,& ! lfun,11,z1,tpow1(z1),coeff1(z1) cord(12)=cord(12)+coeff1(z1) coeff1(z1)=zero tpow1(12)=tpow1(z1) free(3)=1 if(lastc.lt.11) lastc=11 else ! Too many rare powers in this expression write(*,89)tpfuns(lfun)%symbol,& tpow1(10),tpow1(11),tpow1(12),tpow1(z1) 89 format('3Z Cannot handle four different rare powers: ',a,3i4) stop ' *** power problems!' endif endif enddo loop1 ! write(*,91)'3Z powers 1: ',(tpow1(z1),z1=1,lastc) 91 format(a,11i5) ! return coefficients in order do z1=1,9 tpow1(z1)=-100 enddo do z1=1,nc1 coeff1(z1)=cord(z1) enddo tpow1(1)=0 tpow1(2)=1 tpow1(3)=100 tpow1(4)=2 tpow1(5)=3 tpow1(6)=-1 tpow1(7)=7 tpow1(8)=-9 tpow1(9)=-2 ! latsc is the last used power position if(lastc.lt.10) tpow1(10)=-100 if(lastc.lt.11) tpow1(11)=-100 if(lastc.lt.12) tpow1(12)=-100 tpow1(13)=-100; tpow1(13)=-100; tpow1(13)=-100 ! tpow1(10), 11 and 12 are free ! write(*,91)'3Z powers 2: ',(tpow1(z1),z1=1,lastc) ! write(*,80)'3Z sorted: ',tpfuns(lfun)%symbol,nc1,(tpow1(z1),z1=1,lastc) !80 format(a,1x,a,': ',i3,11i5) ! tpow1(11) keep its value. No provision for more than one extra power!! !1000 continue return end subroutine sortcoeffs !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ ! END MODULE TPFUNLIB !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ ================================================ FILE: src/models/gtp3_dd1.F90 ================================================ ! ! Data structures for the TPFUN package ! !================================================================= ! VARIABLES and STRUCTURES originally in TPFUN ! length of a function symbol integer, parameter :: lenfnsym=16 integer, private :: freetpfun ! ! \begin{verbatim} ! ************* this declaration moved to metlib4 ! TYPE gtp_parerr ! This record contains the global error code. In parallel processing each ! parallel processes has its own error code copied to this if nonzero ! it should be replaced by gtperr for separate errors in treads ! INTEGER :: bmperr ! END TYPE gtp_parerr ! TYPE(gtp_parerr) :: gx ! needed to have error code as private in threads, also moved to metlib4 !--- $OMP threadprivate(gx) ! \end{verbatim} !----------------------------------------------------------------- ! !\begin{verbatim} integer, parameter :: tpfun_expression_version=1 TYPE tpfun_expression ! Coefficients, T and P powers, unary functions and links to other functions integer noofcoeffs,nextfrex double precision, dimension(:), pointer :: coeffs ! each coefficient kan have powers of T and P/V and links to other TPFUNS ! and be multiplied with a following LOG or EXP term. ! wpow USED FOR MULTIPLYING WITH ANOTHER FUNCTION!! integer, dimension(:), pointer :: tpow integer, dimension(:), pointer :: ppow integer, dimension(:), pointer :: wpow integer, dimension(:), pointer :: plevel integer, dimension(:), pointer :: link END TYPE tpfun_expression ! These records are allocated when needed, not stored in arrays !\end{verbatim} !----------------------------------------------------------------- !\begin{verbatim} ! BITS in TPFUN ! TPCONST set if a constant value ! TPOPTCON set if optimizing value ! TPNOTENT set if referenced but not entered (when reading TDB files) ! TPVALUE set if evaluated only explicitly (keeping its value) ! TPEXPORT set if value should be exported to symbol ! TPIMPORT set if value should be imported from symbol (only for constants) ! TPINTEIN set if value should always be calculated integer, parameter :: & TPCONST=0, TPOPTCON=1, TPNOTENT=2, TPVALUE=3, & TPEXPORT=4, TPIMPORT=5 !\end{verbatim} !----------------------------------------------------------------- !\begin{verbatim} integer, parameter :: tpfun_root_version=1 TYPE tpfun_root ! Root of a TP function including name with links to coefficients and codes ! and results. Note that during calculations which can be parallelized ! the results can be different for each parallel process character*(lenfnsym) symbol ! Why are limits declared as pointers?? They cannot be properly deallocated ! limits are the low temperature limit for each range ! funlinks links to expression records for each range ! each range can have its own function, status indicate if T and P or T and V ! nextorsymbol is initiated to next index, then possible symbol link! ! forcenewcalc force new calculation when optimizing variable changed ! rewind is used to check for duplicates reading from TDB file ! not saved on unformatted files ! If bit TPIMPORT set the function must be a constant ! and nextorsymbol is index of symbol ! If bit TPEXPORT set then the value of the function (not the derivatives) ! and nextorsymbol is index of symbol ! integer noofranges,nextfree,status,forcenewcalc integer noofranges,nextorsymbol,status,forcenewcalc,rewind double precision, dimension(:), pointer :: limits TYPE(tpfun_expression), dimension(:), pointer :: funlinks double precision hightlimit END TYPE tpfun_root ! These records are stored in arrays as the actual function is global but each ! equilibrium has its own result array (tpfun_parres) depending on the local ! values of T and P/V. The same indiex is used in the global and local arrays. ! allocated in init_gtp TYPE(tpfun_root), private, dimension(:), pointer :: tpfuns !\end{verbatim} !----------------------------------------------------------------- !\begin{verbatim} integer, parameter :: tpfun_parres_version=1 TYPE tpfun_parres ! Contains TP results, 6 double for results and 2 doubles for T and P ! values used to calculate the results ! Note that during calculations which can be parallelized the ! results can be different for each tread integer forcenewcalc double precision, dimension(2) :: tpused double precision, dimension(6) :: results END TYPE tpfun_parres ! This array is local to the gtp_equilibrium_data record ! index is the same as the function !\end{verbatim} ! ! =============================== end of TPFUN data structures ! ================================================ FILE: src/models/gtp3_dd2.F90 ================================================ !************************************************************** ! General Thermodynamic Package (GTP) ! for thermodynamic modelling and calculations ! ! MODULE GENERAL_THERMODYNAMIC_PACKAGE ! ! Copyright 2011-2022, Bo Sundman, France ! ! This program is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 2 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this program; if not, write to the Free Software ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! contact person: bo.sundman@gmail.com ! !----------------------------------------------------------------------- ! ! for known unfinished/unchecked bugs and parallelization problems ! look for BEWARE ! !----------------------------------------------------------------------- ! ! Description of data structure ! ! For all elements, species and phases there are two arrays defined. ! The first (data) array contains the elements species etc and all their data ! in the order they were entered and the data are never moved. ! The second (index) array contain the elements, species etc in alphabetical ! (or whatever) order and is updated whenever a new element, species etc ! is added. This array is an integer array with the index of the data array. ! Most links inside the different records to elements, species etc ! are indices to the data array which is never changed. ! TPFUNS used in parameters are also stored in an array and the index ! to this array is stored in the property record to specify the function. ! ! For parameters inside each phase record there is one (or 2 if disordered set) ! lists with endmember parameters. Each endmember record can be the root ! of a binary tree with interaction parameters. Each of these records ! can have a property list with various data like G, TC, MQ etc. These ! records are created dynamically and can only be found by following the links. ! ! Each phase has one or more composition sets. These are part of the ! equilibrium data structure which also contains conditions, ! calculated values of TP functions and other symbols. To identify a ! phase+comp.set a phasetuple has been intoduced. This contains two ! integers, the first is the phase number, the second the composition ! set number. The second or higher composition set of a phase will ! have a tupel index higher than the number of phases(?). ! ! One equilibrium record is created in init_gtp and it is called ! FIRSTEQ which is a global variable. There is also an array EQLISTA ! which should contain all allocated equilibrium records, FIRSTEQ is a ! pointer to the first element in this array. More equilibrium ! records can be initiated by the enter_equilibrium subroutine. This ! copies the relevant data from FIRSTEQ. After a second equilibrium ! is created it is forbidden to enter elements, species and phases and ! create additional fraction sets, i.e. one must not change the data ! structure except to add/remove composition sets (but this should ! anyway be avoided). Composition sets must be created in all ! equilibrium records at the same time (if done in a thread then all ! threads must stop while this is done). During step/map calculation ! each calculated equilibria is saved for later use in plotting och ! other postprocessing. These saved equilibria may have different ! number of composition sets so great care must be taken using them. ! ! The equilibrium data record is "stand alone" and contains all necessary ! data to describe the equilibrium (except the model parameters and other ! static data). In parallel processing each thread will have its own ! equilibrium data record. ! ! The intention is that several equilibra can be created both to store ! individual experimental data in assessments and for each thread in ! parallel. In the equilibrium record there are conditions, ! components (with chemical potentials) and an error code and most ! important, the phase_varres record array with one or more record for ! each phase. This array must be identical in all equilibria recods. ! Each composition set has a phase_varres record and they are linked ! from the phase record by the LIKTOCS array. As the phase_varres ! records are in an array the link is simply an integer index of this ! array. There is a free list (in FIRSTEQ) in the phase_varres array ! to be used when adding or removing a composition set. The EQ_TPRES ! array is declared inside the equilibrium record for calculated ! results of the TPFUNS as these can be different in each equilibria. ! The index to a function in EQ_TPRES is the same as the index to the ! TPFUN array declared globally in TPFUN. The TPFUN array has the ! actual expression, and EQ_TPRES has the last calculated results, ! which can be different in each equilibrium. The TPFUN index is used ! in property records to specify the function of a parameter. ! ! In many subroutines the equilibrium record called CEQ (Current EQilibrium) ! is an argument which means it operates on the data in that ! equilibrium record only. ! ! In the record array PHASE_VARRES (including disordered) each phase ! and composition set has a record. If no parallel calculation and no ! experiments the equilibrium record FIRSTEQ is enough. ! ! In programming for parallel processing THREADPRIVATE ! should be avoided as it usually has a very slow implementation. ! ! Some routines exist both with and without the CEQ argument. A programmer ! can create his own array of equilibrium data records and use any of ! them in such calls. ???? Maybe not, then how to update when a new ! composition set is needed??? ! ! Thread specific data are needed for conditions, phase status, constitution, ! function values and calc results like G and derivatives for each phase, ! amounts of phases etc. When calling a subroutine to get mole frations etc ! the equilibrium record CEQ must be supplied. ! ! The global error code is defined in tpfunlib, that is not very good. There ! must be an error code specific to each equilibrium. Or can one declare ! the error code as "local" to the thread? ! !-------------------------------------------------------------------------- ! !CCI !use ocparam !CCI ! EXTERNAL MODULES ! metlib package for user i/f and various utilities ! use metlib ! ! routines for inverting matrix, solving system of eqs, eigenvalues etc ! use lukasnum ! for Lukas solver ! use ocnum ! for LAPACK and BLAS ! !================================================================= ! ! error messages ! numbers 4000 to 4220 defined. gx%bmperr is set to message index ! A lot of error flags set have no messages .... integer, parameter :: nooferm=4399 !-------------------------------------------------------------------------- ! ! Versions ! date item ! 2013.03.01 Release version 1 ! 2015.01.07 Release version 2 ! 2016.02.14 Release version 3 ! 2017.02.10 Release version 4 ! 2018.03.02 Release version 5 ! 2020.03.12 Release version 6 ! 2025.11.09 Still updating version 6 !--------------------------------------------------------------------------- character (len=64), dimension(4000:nooferm) :: bmperrmess ! The first 30 error messages mainly for TP functions data bmperrmess(4000:4199)& /'Too many coefficients in a TP function. ',& 'Illegal character in a TP function, digit expected. ',& 'Unknown symbol in TP function ',& 'Expected ( after unary function ',& 'Too many ) in a TP function ',& 'Illegal character in a TP function ',& 'Too few ) in a TP function ',& 'Too many ( in exponent ',& 'Illegally placed ( in the exponent of a TP function ',& 'No digits after ( in the exponent of a TP function ',& ! 4010: 'Illegally placed ) in exponent in TP function ',& 'Too high power in a TP function, max 99, min -99 ',& 'Missing ( or power or ) in the exponent of a TP function ',& 'Illegal termination of a TP function reading a TDB file ',& 'No more free TP root records ',& 'No more free TP expression records ',& 'Illegal expression inside unary argument of a TP function ',& 'Illegal code found when evaluating a TP function ',& 'Found a coefficent zero in a term of a TP function ',& 'Illegal code in a TP function ',& ! 4020: 'Negative argument to logarithm in a TP function ',& 'Unknown unary function in evaluation for a TP function ',& 'Too many symbols in a TP function term ',& 'Two unary functions in a TP function term ',& 'Too complicated TP function term ',& 'Too many temperature ranges in a TP function ',& 'TP function with same name already entered ',& 'Symbol referenced in a parameter does not exist ',& 'Missing separator between phase and constituent array in paramet',& 'Cannot enter disordered fraction set when several composition se',& ! These error mainly in GTP ! 4030 'Cannot enter disordered fraction set when suspended constituents',& 'Wildcards in interaction parameters not yet implemented ',& 'Interaction between 2 wildcards are illegal ',& 'Illegal character in element symbol ',& 'Element with this symbol already entered ',& 'Element symbol and name must start with letter A-Z ',& 'Reference state must start with letter A-Z ',& 'Element mass must not be negative ',& 'Enthalpy difference H298-H0 must be positive ',& 'Entropy at 298.15 must be positive ',& ! 4040 'Too many elements ',& 'Too many species ',& 'No such element ',& 'Text position outside text ',& 'Species symbol contain illegal letter or not letter A-Z as first',& 'No elements or too many elements in species formula ',& 'Unknown element in species formula ',& 'Negative stoichiometric factor in species ',& 'The charge must be the final "element" ',& 'Species already entered ',& ! 4050 'No such phase ',& 'Unknown or ambiguous species name ',& 'No such constituent ',& 'Phase name must start with letter A-Z ',& 'Phase already entered ',& 'Model not implemented yet ',& 'Too few or too many sublattices ',& 'Sites on a sublattice must be positive ',& 'Too few or too many constituents in a sublattice ',& 'Too many constituents ',& ! 4060 'No such TP function ',& 'Expected constituent array, found nothing ',& 'Illegal character in constituent array ',& 'Illegal degree of parameter, must be 0-9 ',& 'No free interaction records ',& 'Wrong number of sublattices ',& 'No such constituent in a sublattice ',& 'No such interacting constituent ',& 'This phase has no disordered fraction set ',& 'Wrong number of sublattices in disordered fraction set ',& ! 4070 'No free endmember records ',& 'No free property records ',& 'No such composition set ',& 'Inconsistent composition set specifications ',& 'Overflow in push ',& 'Undeflow in pop ',& 'Sublattice out of range for entering disordered fraction set ',& 'Disordered fraction set already entered ',& 'Not implemented yet ',& 'Ionic liquid Not implemented yet ',& ! 4080 'Suspended constituents not implemented yet ',& 'Stability factor not implemented yet ',& 'No such composition dependent property parameter ',& 'Empty line, expected species stoichiometry ',& 'No element in species stoichiometry ',& 'Species cannot be entered as it is implicitly suspended ',& 'Excess model not implemented yet ',& 'Bad name for a symbol ',& 'Too deeply nested TP functions ',& 'Reading unknown addition type from file ',& ! 4090 'Addition already entered ',& 'No more addition records ',& 'Maximum 9 composition sets ',& 'Illegal composition set number ',& 'No more records for phases or composition sets. ',& 'Hidden phase cannot be ENTERED, SUSPENDED, DORMANT or FIXED ',& 'Ambiguous or unknown constituent ',& 'Too many argument to a state variable ',& 'This state variable must have two arguments ',& 'First character of a state variable is wrong ',& ! 4100 'State variable starting with M not followed by U ',& 'State variable starting with L not followed by NAC ',& 'Missing ( for arguments of state variable ',& 'Missing ) after arguments of state variable ',& 'Unknown phase used as state variable argument ',& 'Unknown constituent used as state variable argument ',& 'Unknown component used as state variable argument ',& 'State variable starting with D not followed by G ',& 'State variable starting with T follwed by other character than C',& 'State variable starting with B missing P, MAG, M, V, W or F ',& ! 4110 'This state variable cannot not have two arguments ',& 'This state variable must have an argument ',& 'Impossible reference state for this component ',& 'No such property calculated for this phase ',& 'Property normallized by volume impossible as no volume data ',& 'Property per formula unit is phase specific ',& 'State variable number must be larger than zero ',& 'Only state variable Y can have 3 indices ',& 'Illegal normalization of state variable ',& 'Phase is hidden ',& ! 4120 'Wrong syntax for mobility variable ',& 'Ambiguous phase name ',& 'Illegal name for an equilibrium ',& 'Equilibrium with this name already entered ',& 'No such equilibrium ',& 'Not allowed to enter more model data ',& 'No state variable supplied ',& 'Illegal state variable for conditions ',& 'Only one kind of state variable in expressions ',& 'Illegal value for a state variable ',& ! 4130 line below 'Factor in front of a condition must be followed by * ',& 'No such condition or experiment ',& 'Function name must start with a letter A-Z ',& 'Function name and expression must be separated by "=" ',& 'Error in function expression (putfun) ',& 'Unknown symbol used in function ',& 'Symbol with this name already entered ',& 'Symbol name must start with letter A-Z and not be reserved ',& 'Illegal character in symbol name ',& 'Cannot check name of unknown kind of symbol ',& ! 4140 'No such symbol ',& 'Error evaluating symbol value ',& 'Error listing symbol expression ',& 'No conditions at all ',& 'Degrees of freedom not zero ',& 'Unknown type of addition ',& 'Quitting due to repeated input error ',& 'Gridminimizer found gridpoint outside range ',& 'Gridminimizer error when generating endmember values ',& 'Gridminimizer found an element without gridpoint ',& ! 4150 next line 'Gridminimizer have no gridpoint for a pure element ',& 'Conditions not only T, P and massbalance ',& 'Illegal to set all phases as fix ',& 'Cannot enter a new equilibrium if there are no phases ',& 'Trying to enter an illegal reference ',& 'A reference must have an identifier ',& 'Reference identifier already exists ',& 'Error in TDB file, species terminator error ',& 'Unknown potential ',& 'Cannot calculate potentials for charged constituents ',& ! 4160 next line 'Illegal endmember for reference state ',& 'End member without atoms ',& 'Same species twice in component list ',& 'Component stoichiometry matrix singular ',& 'Too many interaction levels ',& 'Error reading save file ',& 'Error reading save file at EOF ',& 'Composition set prefix must start with a letter ',& 'This property has no specifier ',& 'Parameter specifier missing ',& ! 4170 'Properties needed for Inden magnetic model not defined ',& 'Request for non-existing chemical potential ',& 'Removing current data not implemented ',& 'Grid minimization not allowed ',& 'Grid minimizer cannot be used with the current set of conditions',& 'Too many gridpoints ',& 'No phases and no gridpoints for grid minimization ',& 'Grid minimizer wants but must not create composition sets ',& 'Non-existing fix phase ',& 'N, X, B or W cannot have two indices for use of grid minimizer ',& ! 4180 'Condition on B is not allowed for grid minimizer ',& 'An element has no composition in grid minimizer ',& 'Too complicated mass balance conditions ',& 'Two mass balance conditions for same element ',& 'Cannot handle conditions on both N and B ',& 'No mole fractions when summing composition ',& 'Error in TDB file, missing function ',& 'Temperature (K) or pressure (Pa) values must be larger than 0.1 ',& 'No such state variable ',& 'Too many conditions on potentials ',& ! 4190 'File already exist, overwriting not allowed ',& 'Activity conditions must be larger than zero ',& 'Cannot handle two fix phases ',& 'Too many stable phases ',& 'This phase must not be stable ',& 'Attempt to remove the only stable phase ',& 'Enthalpy condition on unstable phase ',& 'Illegal wildcard constituent in ionic liquid model ',& 'No equilibrium calculated, cannot calculate dot derivative ',& 'Error calculating equilibrium matrix for dot derivative '/ ! 4200 mainly errors in minimizer data bmperrmess(4200:4399)& /'No phase that can be set stable ',& 'Attempt to set too many phases as stable ',& 'Total amount is negative ',& 'Error solving equilibrium matrix ',& 'Too many iterations ',& 'Phase matrix singular ',& 'Cannot handle models without analytical second derivativatives ',& 'This type of condition not yet implemented ',& 'This type of condition is not allowed ',& 'Error setting up system matrix, too many equations ',& ! 4210 'Phase change not allowed ',& 'Attempt to delete composition sets when many equilibria ',& 'Too many equation in equilibrium matrix ',& 'Derivatives with respect to T and P only are allowed ',& 'Error creating system matrix in initiate meqrec subroutine ',& 'This dot derivative not yet implemented ',& 'Wildcard not allowed in dot derivative ',& 'Use "calculate symbol" for state variable symbols ',& 'This experiment is not acivated ',& 'Too many equilibria in STEP/MAP, save on file not implemented ',& ! mainly errors in STEP/MAP ! 4220 step/map 'STEP/MAP error calculating node point, trying to decrease step ',& 'STEP/MAP error calculating node point, axis condition not found ',& 'STEP/MAP error calculating node point, another phase stable ',& 'STEP/MAP error calculating node point, too many stable phases ',& 'Cannot find start equilibrium for step/map ',& 'Startpoint for step/map outside axis limits ',& 'Cannot yet handle nodepoints with more than 2 exits ',& 'Phase set changed in start point ',& 'Only two axis implemented currently ',& 'Axis direction error, no such axis ',& ! 4230 'STEP/MAP tries to set the only stable phase as fix ',& 'Too many stable phases during mapping ',& 'Another phase wants to be stable at node point ',& 'No phase change searching along an axis for a start point ',& 'Internal error handling fix phases at node point ',& 'Too many phases set fix during mapping ',& 'Mapping cannot handle expressions as conditions ',& 'Node with no exit lines ',& 'Attempt to remove the only stable phase ',& 'A never never error ',& ! 4240 'Too many fix phases during mapping ',& 'More than one entered phase ',& 'Not a single entered phase ',& 'Whops, mapping without conditions ... ',& 'I give up on this line ',& 'Unknown problem ',& 'Two phases compete to be stable ',& 'Nothing to plot in ocplot ',& 'No data so no plot ',& 'No experiments ',& ! more error messages for GTP and other modules ! 4250 'Too many parameter identifiers, increase maxprop ',& 'Calling mass_of with illegal component number ',& 'No such phase tuple index ',& 'Internal error, not a single lattice for a phase ',& 'Illegal phase index ',& 'The partially ionic liquid model must have two sublattices ',& 'This phase cannot be reference phase for this component ',& 'Internal error, constituent index outside range ',& 'Same constituent twice in one sublattice ',& 'Too many phases, increase dimension of phlista ',& ! 4260 'The partially ionic liquid model has only cations in first subl.',& 'Illegal parameter with wildcards mixed with cations ',& 'The partially ionic liquid model not only wildcard on 2nd subl. ',& 'The partially ionic liquid model has no catioons on 2nd subl. ',& 'Only neutrals on 2nd sublattice of I2SL if wildcard on first ',& 'Illegal interaction parameter ',& 'Same constituent twice in interaction parameter ',& 'There must be at least 4 sublattices for a phase with F/B option',& 'Maximum two interaction levels using the F option ',& 'Internal error, unknown case for endmember permutation ',& ! 4270 'Interaction must be on first sublattice using option F or B ',& 'Cannot find endmember element for permutation ',& 'Internal error, unknown case for permutations ',& 'Internal error, too complicated ',& 'Internal error generating fcc permutations ',& 'This excess parameter not yet implemented in option F or B ',& 'Internal error generating permutations for option F ',& 'BCC permutations (TDB option B) not yet fully implemented ',& 'Subcommand error when enter many_equilibria ',& 'Too many columns when entering many_equilibria row ',& ! 4280 'Table row missing in column when entering many_equilbria ',& 'Number expected after specifying fix phase ',& 'Phase name expected after status command ',& 'Too many equilibra, increase dimension of eqlista ',& 'Equilibrium name must start with a letter A-Z ',& 'Cannot overwrite the default equilibrium ',& 'Illegal use of wildcard ',& 'Error in constituent dependence for parameter idenifier ',& 'Yet another never never error ',& 'Charge must be given as /+ or /- ',& ! 4290 'Error in parameter identifier ',& 'Phase missing in parameter ',& 'No such property name or index ',& 'Illegal to have a symbol as value of T or P ',& 'Illegal to set a fix phase as experiment ',& 'Calling locate_condition with illegal index ',& 'Calling apply_condition with illegal option ',& 'Species names must be surrounded by ( ) for set input_amounts ',& 'Illegal to enter property to a species that is an element ',& 'Saved file not same version as program ',& ! 4300 'Data record format on save file not the same as in program ',& 'Bibliographic record too long on save file ',& 'Error reading records for a phase from save file ',& 'Failed entering function from save file ',& 'Too long line on save file ',& 'No element symbol after ELEMENT keyword in TDB file ',& 'No information after SPECIES keyword on TDB file ',& 'No terminator after FUNCTION keyword on TDB file ',& 'The CONSTITUENT keyword must follow directly after PHASE keyword',& 'Error extracting constituents for a phase ',& ! 4310 'Error that final : for constituents missing ',& 'Empty line after FUNCTION keyword ',& 'Line with PARAMETER keyword does not finish with ! ',& 'Empty reference line on TDB file ',& 'References must be surrounded by citation marks ',& 'Function name must be on same line as FUNCTION keyword ',& 'End of file while searching for end of keyword in TDB file ',& 'Indices error in old state variable format ',& 'Unknown state variable or property ',& 'Character variable length insufficient for output of values ',& ! 4320 'State variable has illegal argument type ',& 'Error calculating eigenvalues of phase matrix ',& 'Only a single symbol allowed ',& 'Symbol must be a constant ',& 'Value of PHSTATE not correct ',& 'Illegal bit number for phase status ',& 'Illegal phase for setting status bit ',& 'Illegal selection of old phase status ',& 'Condition specified by number must be followed by := ',& 'Calling create_interaction with too many permutations ',& ! 4330 'No such addition type ',& 'Cp model not yet implemented ',& 'Magnetic model with separate Curie and Neel T not yet implement ',& 'Addition model not yet implemented ',& 'Not implemented this way ',& 'Model parameter identifier not found ',& 'Value for model parameter identifier not found ',& 'Flory-Huggins model must have one lattice and site ',& 'Too many parameter properties for this phase ',& 'Internal error, listprop not allocated ',& ! 4340 'Max two levels of interactions allowed ',& 'Wildcard parameters not allowed in 2nd sublattice of I2SL model ',& 'Composition dependent ternary parameter must have 3 degrees ',& 'Ternary cation interactions not yet implemented in I2SL ',& 'Too many phases for the global gridminimizer ',& 'Global minimization with a fix phase not possible ',& 'Internal problems in grid minimizer ',& 'Interaction levels more than 5 levels deep ',& 'A TP function with this name already entered ',& 'Illegal value of TP function index ',& ! 4350 'A never never error evaluating a TP function ',& 'Cannot find this TP function ',& 'Current equilibrium not global, gridmin found gridpoint below ',& 'Nodepoint not global, line ignored ',& 'Illegal numerical value in equilibrium matrix ',& 'Wrong version of data on unformatted file ',& 'Error reserving space for unformatted save ',& 'Error saving unformatted data file ',& 'Recalculate as gridpoint below current equilibrium ',& 'Slow convergence with same set of stable phases ',& ! 4360 'Too large change on axis, terminating mapping ',& 'Model parameter value not calculated ',& 'New set of components are not independent ',& 'No equilibrium, a restored phase should be stable ',& 'Two phases with same composition stable at nodepoint ',& 'Gridtest indicate global minimization needed ',& 'Gridtest request recalculation without gridminimizer ',& 'Missing property for calculating addition ',& 'Tried halfstep 3 times, giving up on this line ',& 'Repeated error calling map_calcnode, line terminated ',& ! 4370 'Error allocating data, no free memory ',& 'Nonlinear equation solver HYBRD1 error ',& 'Error from DGETRS/F generating isopleth invariant exits ',& 'Supressed value due to special circumstances ',& 'Mobility parameters must not have wildcard constituents ',& 'No EET temperature calculated for this system ',& ' ',& ' ',& ' ',& ' ',& ! 4380 ' ',& ' ',& ' ',& ' ',& ' ',& '5 ',& ' ',& ' ',& ' ',& ' ',& ! 4390 ' ',& ' ',& ' ',& ' ',& ' ',& '5 ',& ' ',& ' ',& ' ',& 'No message assigned '/ ! last used error codes above ! !================================================================= ! !\begin{verbatim} ! STATUS BITS are numbered 0-31 !-Bits in GLOBAL status word (GS) in globaldata record ! level of user: beginner, occational, advanced; NOGLOB: no global gridmin calc ! NOMERGE: no merge of gridmin result, ! NODATA: not any data, ! NOPHASE: no phase in system, ! NOACS: no automatic creation of composition set for any phase ! NOREMCS: do not remove any redundant unstable composition sets ! NOSAVE: data changed after last save command ! VERBOSE: maximum of listing ! SETVERB: permanent setting of verbose ! SILENT: as little output as possible ! NOAFTEREQ: no manipulations of results after equilibrium calculation ! XGRID: extra dense grid for all phases ! NOPAR: do not run in parallel ! NOSMGLOB do not test global equilibrium at node points ! NOTELCOMP the elements are not the components ! TGRID use grid minimizer to test if global after calculating equilibrium ! OGRID use old grid generator ! NORECALC do not recalculate equilibria even if global test after fails ! OLDMAP use old map algorithm ! NOAUTOSP do not generate automatic start points for mapping ! YGRID extra dense grid ! VIRTUAL (CCI) enables calculations with a virtual element ! >>>> some of these should be moved to the gtp_equilibrium_data record integer, parameter :: & GSBEG=0, GSOCC=1, GSADV=2, GSNOGLOB=3, & GSNOMERGE=4, GSNODATA=5, GSNOPHASE=6, GSNOACS=7, & GSNOREMCS=8, GSNOSAVE=9, GSVERBOSE=10, GSSETVERB=11,& GSSILENT=12, GSNOAFTEREQ=13, GSXGRID=14, GSNOPAR=15, & GSNOSMGLOB=16, GSNOTELCOMP=17, GSTGRID=18, GSOGRID=19, & GSNORECALC=20, GSOLDMAP=21, GSNOAUTOSP=22,GSYGRID=23, & GSVIRTUAL=24 !---------------------------------------------------------------- !-Bits in ELEMENT record integer, parameter :: & ELSUS=0, ELDEL=1 !---------------------------------------------------------------- !-Bits in SPECIES record ! SUS Suspended, ! IMSUS implicitly suspended (when element suspended) ! EL species is element, ! VA species is the vacancy ! ION species have charge, ! SYS species is (system) component ! UQAC species used in uniquac model (2 extra reals for area and volume) integer, parameter :: & SPSUS=0, SPIMSUS=1, SPEL=2, SPVA=3, & SPION=4, SPSYS=5, SPUQC=6 !\end{verbatim} !---------------------------------------------------------------- ! Many not implemented !\begin{verbatim} !-Bits in PHASE record STATUS1 there are also bits in each phase_varres record! ! HID phase is hidden (not implemented) ! IMHID phase is implictly hidden (not implemented) ! ID phase is ideal, substitutional and no interaction ! NOCV phase has no concentration variation ! HASP phase has at least one parameter entered ! FORD phase has 4 sublattice FCC ordering with parameter permutations ! BORD phase has 4 sublattice BCC ordering with parameter permutations ! SORD phase has TCP type ordering (do not subract ordered as disordered, NEVER) ! MFS phase has a disordered fraction set ! GAS this is the gas phase (first in phase list) ! LIQ phase is liquid (can be several but listed directly after gas) ! IONLIQ phase has ionic liquid model (I2SL) ! MQMQX phase with the MQMQA model with asymmetric excess (also MQMQA set) ! 2STATE elemental liquid twostate model parameters (not same as I2SL!) ! QCE phase has corrected quasichemical entropy (Hillerst-Selleby-Sundman) ! CVMCE phase has some CVM ordering entropy (used?) ! EXCB phase need explicit charge balance (has ions) ! XGRID use extra dense grid for this phase ! MQMQA (old FACTCE) phase has FACT quasichem SRO model - implementation pending ! NOCS not allowed to create composition sets for this phase ! HELM parameters are for a Helmholz energy model (not implemented), ! PHNODGDY2 phase has model with no analytical 2nd derivatives (not implemented) ! not implemented ELMA phase has elastic model A (not implemented) ! EECLIQ this is the condensed phase (liquid) that should have highest entropy ! PHSUBO special use testing models DO NOT USE ! PALM interaction records numbered by PALMTREE NEEDED FOR PERMUTATIONS !!! ! MULTI may be used with care ! BMAV Xion magnetic model with average Bohr magneton number ! UNIQUAC The UNIQUAC fluid model ! TISR phase has the TSIR entropy model (E Kremer) ! PHSSRO phase has the tetrahedral FCC model for SRO ! SROT phase has the tetrahedron quasichemical model ?? not MQMQMA ?? NOT USED ! CVMTFL phase has the tetrahedral FCC for LRO and SRO integer, parameter :: & PHHID=0, PHIMHID=1, PHID=2, PHNOCV=3, & ! 1 2 4 8 : 0/F PHHASP=4, PHFORD=5, PHBORD=6, PHSORD=7, & ! PHMFS=8, PHGAS=9, PHLIQ=10, PHIONLIQ=11, & ! PHMQMQX=12, PH2STATE=13, PHQCE=14, PHCVMCE=15,& ! PHEXCB=16, PHXGRID=17, PHMQMQA=18, PHNOCS=19,& ! PHHELM=20, PHNODGDY2=21, PHEECLIQ=22, PHSUBO=23,& ! PHPALM=24, PHMULTI=25, PHBMAV=26, PHUNIQUAC=27, & ! PHTISR=28, PHSSRO=29, PHSROT=30, PHCVMTFL=31 ! ! !---------------------------------------------------------------- !-Bits in PHASE_VARRES (constituent fraction) record STATUS2 ! CSDFS is set if record is for disordred fraction set, then one must use ! sublattices from fraction_set record ! CSDLNK: a disordred fraction set in this phase_varres record ! CSDUM2 and CSDUM3 not used ! CSCONSUS set if one or more constituents suspended (status array constat ! specify constituent status) ! CSORDER: set if fractions are ordered (only used for BCC/FCC ordering ! with a disordered fraction set). ! CSABLE: set if phase is stable after an equilibrium calculation ?? needed ! CSAUTO set if composition set created during calculations ! CSDEFCON set if there is a default constitution ! CSTEMPAR set if created by grid minimizer and can be suspended afterwards ! when running parallel ! CSDEL set if record is not used but has been and then deleted (by gridmin) ! CSADDG means there are terms to be added to G ! CSTEMPDOR means this compset was temporarily set dormant at an ! equilibrium calculation integer, parameter :: & CSDFS=0, CSDLNK=1, CSDUM2=2, CSDUM3=3, & CSCONSUS=4, CSORDER=5, CSABLE=6, CSAUTO=7, & CSDEFCON=8, CSTEMPAR=9,CSDEL=10, CSADDG=11,& CSTEMPDOR=12 !\end{verbatim} !---------------------------------------------------------------- !\begin{verbatim} !-Bits in CONSTAT array for each constituent ! For each constituent: ! SUS constituent is suspended (not implemented) ! IMSUS is implicitly suspended, ! VA is vacancy ! QCBOND the constituent is a binary quasichemical cluster integer, parameter :: & CONSUS=0, CONIMSUS=1, CONVA=2, CONQCBOND=3 !---------------------------------------------------------------- !-Bits in STATE VARIABLE FUNCTIONS (svflista) ! SVFVAL V symbol evaluated only when explicitly referenced (mode=1 in call) ! SVFEXT X symbol value taken from equilibrium %eqnoval ! SVCONST C symbol is a constant (can be changed with AMEND) ! SVFTPF - bit not used, replaced by export/import ! SVFDOT D symbol is a DOT function, like cp=h.t (also SVFVAL bit) ! SVFNOAM N symbol cannot be amended (only R, RT and T_C) ! SVEXPORT E symbol value exported to assessment coeff (TP constant) ! SVIMPORT I symbol value imported from TP-function (incl assessment coeff) ! ONLY ONE BIT CAN BE SET except for D and C+I and C+E, ! OTHER COMBINATIONS ARE NOT ALLOWED!! ! integer, parameter :: & SVFVAL=0, SVFEXT=1, SVCONST=2, SVFTPF=3,& SVFDOT=4, SVNOAM=5, SVEXPORT=6, SVIMPORT=7 !---------------------------------------------------------------- !-Bits in CEQ record (gtp_equilibrium_data) ! EQNOTHREAD set if equilibrium must be calculated before threading ! (in assessment) for example if a symbol must be evaluated in this ! equilibrium before used in another like H(T)-H298 ! EQNOGLOB set if no global minimization ! EQNOEQCAL set if no successful equilibrium calculation made ! EQINCON set if current conditions inconsistent with last calculation ! EQFAIL set if last calculation failed ! EQNOACS set if no automatic composition sets ?? not used !! see GSNOACS ! EQGRIDTEST set if grid minimizer should be used after equilibrium ! EQGRIDCAL set if last calculation was using only gridminimizer ! EQMIXED set if mixed reference state for the elements integer, parameter :: & EQNOTHREAD=0, EQNOGLOB=1, EQNOEQCAL=2, EQINCON=3, & EQFAIL=4, EQNOACS=5, EQGRIDTEST=6, EQGRIDCAL=7, & EQMIXED=8 !---------------------------------------------------------------- !-Bits in parameter property type record (gtp_propid) ! no T or P dependence (constant) ! only P dependence ! only T dependence ! there is an element suffix (like mobility), ! there is a constituent suffix ! Property has no addition (used when entering and listing data) integer, parameter :: & IDNOTP=0, IDONLYP=1, IDONLYT=2, IDELSUFFIX=3, IDCONSUFFIX=4,& IDNOADD=5 !---------------------------------------------------------------- !- Bits in condition status word (some set in onther ways??) ! singlevar means T=, x(el)= etc, singlevalue means value is a number ! phase means the condition is a fix phase integer, parameter :: & ACTIVE=0, SINGLEVAR=1, SINGLEVALUE=2, PHASE=3 !---------------------------------------------------------------- !- Bits in assessment head record status ! ahcoef set means coefficients are entered integer, parameter :: & AHCOEF=0 ! !---------------------------------------------------------------- !- Bits in addition record status word gtp_phase_add ! havepar set if the phase has parameters for this addition ! if not set the addition is not listed ! permol set if addition should be muliplied with number of atoms integer, parameter :: & ADDHAVEPAR=0, ADDPERMOL=1,ADDBCCMAG=2 ! ! >>> Bits for symbols and TP functions missing ??? !\end{verbatim} ! !---------------------------------------------------------------------- ! ! Defining the phase status is very important, maybe a status for MAPFIX ! should be added. Added EECDORM for solids with higher entropy than liquid !\begin{verbatim} ! some constants, phase status integer, parameter :: EECDORM=-5 integer, parameter :: PHHIDDEN=-4 integer, parameter :: PHSUS=-3 integer, parameter :: PHDORM=-2 integer, parameter :: PHENTUNST=-1 integer, parameter :: PHENTERED=0 integer, parameter :: PHENTSTAB=1 integer, parameter :: PHFIXED=2 character (len=12), dimension(-5:2), parameter :: phstate=& (/'EEC_DORMANT ','HIDDEN ','SUSPENDED ','DORMANT ',& 'ENTERED UNST','ENTERED ','ENTERED STBL','FIXED '/) !\end{verbatim} ! !---------------------------------------------------------------------- ! !================================================================= !\begin{verbatim} ! The number of additions to the Gibbs energy of a phase is increasing ! This is a way to try to organize them. Each addtion has a unique ! number identifying it when created, listed or calculated. These ! numbers are defined here integer, public, parameter :: INDENMAGNETIC=1 integer, public, parameter :: XIONGMAGNETIC=2 integer, public, parameter :: DEBYECP=3 integer, public, parameter :: EINSTEINCP=4 integer, public, parameter :: TWOSTATEMODEL1=5 integer, public, parameter :: ELASTICMODEL1=6 integer, public, parameter :: VOLMOD1=7 integer, public, parameter :: UNUSED_CRYSTALBREAKDOWNMOD=8 integer, public, parameter :: SECONDEINSTEIN=9 integer, public, parameter :: SCHOTTKYANOMALY=10 integer, public, parameter :: DIFFCOEFS=11 ! with composition independent G2 parameter NOT USED integer, public, parameter :: TWOSTATEMODEL2=12 ! name of additions: character(len=24) , public, dimension(12), parameter :: additioname=& ['Inden-Hillert magn model','Inden-Xiong magn model ',& 'Debye CP model ','Einstein Cp model ',& 'Liquid 2-state model ','Elastic model A ',& 'Volume model A ','Unused CBT model ',& 'Smooth CP step ','Schottky Anomaly ',& 'Diffusion coefficients ',' '] ! 123456789.123456789.1234 123456789.123456789.1234 ! Note that additions often use extra parameters like Curie or Debye ! temperatures defined by model parameter identifiers stored in gtp_propid !\end{verbatim} ! ================================================================= ! ! below here are data structures and global data in this module ! ! Those belonging to the TPFUN package are in gtp3_dd1.F90 ! ! Below here are thermodynamic model data structures ! !================================================================= ! !\begin{verbatim} TYPE gtp_global_data ! status should contain bits how advanced the user is and other defaults ! it also contain bits if new data can be entered (if more than one equilib) ! sysparam are variables for different things ! sysparam(1) unused ! sysparam(2) number of equilibria between each check of spinodal at STEP/MAP?? ! sysparam(3-10) unused ... ! sysreal(1) is the minimum T for EET check (equi-entopy T, Hickel) ! if zero no EET check ! sysreal(2..10) unused ... some used in debug integer status integer :: encrypted=0 character name*24 double precision rgas,rgasuser,pnorm,mqmqa1 ! these are explicitly set to zero in new_gtp double precision, dimension(10) :: sysreal=zero integer :: sysparam(10)=0 END TYPE gtp_global_data TYPE(gtp_global_data) :: globaldata !\end{verbatim} !========================================== !\begin{verbatim} ! In the data structure the gtp_xxx_version must be updated at any change ! It is saves together with the record data at unformatted save in gtp3E.F90 ! and tested on reading to avoid reading incompatible saved files ! ========================================== ! this constant must be incremented whenever a change is made in gtp_element INTEGER, parameter :: gtp_element_version=1 TYPE gtp_element ! data for each element: symbol, name, reference state, mass, h298-h0, s298 character :: symbol*2,name*12,ref_state*24 double precision :: mass,h298_h0,s298 ! splink: index of corresponding species in array splink ! Status bits are stored in the integer status ! alphaindex: the alphabetical order of this elements ! refstatesymbol: indicates H0 (1), H298 (0, default) or G (2) for endmembers integer :: splink,status,alphaindex,refstatesymbol END TYPE gtp_element ! allocated in init_gtp TYPE(gtp_element), private, allocatable :: ellista(:) ! elements are in alpabetical order ... ??? INTEGER, private, allocatable :: ELEMENTS(:) !\end{verbatim} !----------------------------------------------------------------- !\begin{verbatim} ! this constant must be incremented whenever a change is made in gtp_species ! INTEGER, parameter :: gtp_species_version=3 INTEGER, parameter :: gtp_species_version=2 TYPE gtp_species ! data for each species: symbol, mass, charge, extra, status ! mass is in principle redundant as calculated from element mass character :: symbol*24 double precision :: mass,charge ! alphaindex: the alphabetical order of this species ! noofel: number of elements ! nextra: number of extra properties (size of spextra) integer :: noofel,status,alphaindex ! Use an integer array ellinks to indicate the elements in the species ! The corresponing stoichiometry is in the array stochiometry integer, dimension(:), allocatable :: ellinks double precision, dimension(:), allocatable :: stoichiometry ! Can be used for extra species properties as in UNIQUAC models (area, volume) double precision, dimension(:), allocatable :: spextra ! new property, not included in unformatted save NEVER USED character(len=:), allocatable :: mqmqa1 ! Index in mqmqa_data%contyp ... must be updated after reading a database integer :: quadindex END TYPE gtp_species ! allocated in init_gtp TYPE(gtp_species), private, allocatable :: splista(:) INTEGER, private, allocatable :: SPECIES(:) !\end{verbatim} !----------------------------------------------------------------- !\begin{verbatim} ! this constant must be incremented whenever a change is made in gtp_component INTEGER, parameter :: gtp_component_version=1 TYPE gtp_components ! The components are simply an array of indices to species records ! the components must be "orthogonal". There is always a set of "systems ! components" that by default is the elements. ! Later one may implement that the user can define a different "user set" ! and maybe also specific sets for each phase. ! The reference state is set as a phase and value of T and P. ! The name of the phase and its link and the link to the constituent is stored ! the endmember array is for the reference phase to calculate GREF ! The last calculated values of the chemical potentials (for user defined ! and default reference states) should be stored here. ! molat is the number of moles of components in the defined reference state integer :: splink,phlink,status character*16 :: refstate integer, dimension(:), allocatable :: endmember double precision, dimension(2) :: tpref double precision, dimension(2) :: chempot double precision mass,molat END TYPE gtp_components ! allocated in gtp_equilibrium_data !\end{verbatim} !----------------------------------------------------------------- !\begin{verbatim} ! this constant must be incremented whenever a change is made in gtp_endmember INTEGER, parameter :: gtp_endmember_version=1 TYPE gtp_endmember ! end member parameter record, note ordered phases can have ! several permutations of fraction pointers like for B2: (Al:Fe) and (Fe:Al). ! There are links (i.e. indices) to next end member and to the interactio tree ! and to a list of property record ! The phase link is needed for SAVE/READ as one cannot know the number of ! sublattices otherwise. One could just store nsl but a link back to the ! phase record might be useful in other cases. ! noofpermut: number of permutations (for ordered phases: (Al:Fe) and (Fe:Al) ! phaselink: index of phase record ! antalem: sequenial order of creation, not used for anything exept ! for MQMQA it is the index in %contyp of endmember ! propointer: link to properties for this endmember ! nextem: link to next endmember ! intponter: root of interaction tree of parameters ! fraclinks: indices of fractions to be multiplied with the parameter integer :: noofpermut,phaselink,antalem TYPE(gtp_property), pointer :: propointer TYPE(gtp_endmember), pointer :: nextem TYPE(gtp_interaction), pointer :: intpointer ! there is at least one fraclinks per sublattice ! the second index of fraclinks is the permutation (normally only one) ! the first indec of fraclinks points to a fraction for each sublattice. ! The fractions are numbered sequentially independent of sublattices, a ! sigma phase with (FE:CR,MO:CR,FE,MO) has 6 fractions (incl one for FE in ! first sublattice) and the end member (FE:MO:CR) has the fraclinks 1,3,4 ! This means these values can be used as index to the array with fractions. ! The actual species can be found via the sublattice record ! integer, dimension(:,:), pointer :: fraclinks integer, dimension(:,:), allocatable :: fraclinks END TYPE gtp_endmember ! dynamically allocated when entering a parameter !\end{verbatim} !----------------------------------------------------------------- !\begin{verbatim} ! this constant must be incremented when a change is made in gtp_interaction INTEGER, parameter :: gtp_interaction_version=1 TYPE gtp_interaction ! this record constitutes the parameter tree. There are links to NEXT ! interaction on the same level (i.e. replace current fraction) and ! to HIGHER interactions (i.e. includes current fraction) ! There can be several permutations of the interactions (both sublattice ! and fraction permuted, like interaction in B2 (Al:Al,Fe) and (Al,Fe:Al)) ! The number of permutations of interactions can be the same, more or fewer ! comparared to the lower order parameter (endmember or other interaction). ! The necessary information is stored in noofip. It is not easy to keep ! track of permutations during calculations, the smart way to store the last ! permutation calculated is in this record ... but that will not work for ! parallel calculations as this record is static ... ! status: may be useful eventually ! antalint: sequential number of interaction record, to follow the structure ! order: for permutations one must have a sequential number in each node ! propointer: link to properties for this parameter ! nextlink: link to interaction on same level (replace interaction) ! highlink: link to interaction on higher level (include this interaction) ! tooprec: if the interaction involved in TOOP or KOHLER extrapolation ! sublattice: (array of) sublattices with interaction fraction ! fraclink: (array of) index of fraction to be multiplied with this parameter ! noofip: (array of) number of permutations, see above. integer status,antalint,order TYPE(gtp_property), pointer :: propointer TYPE(gtp_interaction), pointer :: nextlink,highlink TYPE(gtp_tooprec), pointer :: tooprec integer, dimension(:), allocatable :: sublattice,fraclink,noofip END TYPE gtp_interaction ! allocated dynamically and linked from endmember records and other ! interaction records (in a binary tree) !\end{verbatim} ! !\begin{verbatim} ! for storing interaction records when traversiong a parameter tree TYPE gtp_intstack type(gtp_interaction), pointer :: saved end type gtp_intstack !\end{verbatim} !--------------------- ! Below some structures needed for MQMQA excess model !------------------- !\begin{verbatim} ! type terdata type gtp_terdata ! use function findtersys(i,j,k,ncat) to find a ternary cation system ! a linear structure for ternary data, indexing by element order i>> added "listid" as a conection to the "state variable" listing here. ! This replaces TC, BMAG, MQ etc included as "state variables" in order to ! list their values. In this way all propids become available end TYPE gtp_propid ! the value TYPTY stored in property records is "idprop" or ! if IDELSUFFIX set then 100*"idprop"+ellista index of element ! if IDCONSUFFIX set then 100*"idprop"+constituent index ! When the parameter is read the suffix symbol is translated to the ! current element or constituent index TYPE(gtp_propid), dimension(:), private, allocatable :: propid ! These are the properties defined 2020-11-27/BoS defined in init_gtp ! 1 G T P 0 Energy ! 2 TC - P 2 Combined Curie/Neel T ! 3 BMAG - - 1 Average Bohr magneton numb ! 4 CTA - P 2 Curie temperature ! 5 NTA - P 2 Neel temperature ! 6 IBM - P &; 12 Individual Bohr magneton num ! 7 THET - P 2 Debye or Einstein temp ! 8 V0 - - 1 Volume at T0, P0 ! 9 VA T - 4 Thermal expansion ! 10 VB T P 0 Bulk modulus ! 11 VC T P 0 Alternative volume parameter ! 12 VS T P 0 Diffusion volume parameter ! 13 MQ T P &; 10 Mobility activation energy ! 14 MF T P &; 10 RT*ln(mobility freq.fact.) ! 15 MG T P &; 10 Magnetic mobility factor ! 16 G2 T P 0 Liquid two state parameter ! 17 THT2 - P 2 Smooth step function T ! 18 DCP2 - P 2 Smooth step function value ! 19 LPX T P 0 Lattice param X axis ! 20 LPY T P 0 Lattice param Y axis ! 21 LPZ T P 0 Lattice param Z axis ! 22 LPTH T P 0 Lattice angle TH ! 23 EC11 T P 0 Elastic const C11 ! 24 EC12 T P 0 Elastic const C12 ! 25 EC44 T P 0 Elastic const C44 ! 26 UQT T P &; 10 UNIQUAC residual parameter ! 27 RHO T P 0 Electric resistivity ! 28 VISC T P 0 Viscosity ! 29 LAMB T P 0 Thermal conductivity ! 30 HMVA T P 0 Enthalpy of vacancy form. ! 31 TSCH - P 2 Schottky anomaly T ! 32 CSCH - P 2 Schottky anomaly Cp/R. ! 33 QCM - - 1 Modif Quasichem model ratio ! 34 GG - - 0 MQMQA excess ! 35 GQ - - 0 MQMQA excess ! 36 GB - - 0 MQMQA excess ! !\end{verbatim} !----------------------------------------------------------------- !\begin{verbatim} ! this constant must be incremented when a change is made in gtp_phase_add INTEGER, parameter :: gtp_phase_add_version=2 TYPE gtp_phase_add ! record for additions to the Gibbs energy for a phase like magnetism ! addrecno: ? ! aff: antiferomagnetic factor (Inden model) ! constants: for some constants needed ?? NEW ! status: BIT 0 set if there are parameters ! BIT 1 set if magnetic model is for BCC ! need_property: depend on these properties (like Curie T) ! explink: function to calculate with the properties it need (not allocatable?) ! nextadd: link to another addition integer type,addrecno,aff,status integer, dimension(:), allocatable :: need_property double precision, dimension(:), allocatable :: constants TYPE(tpfun_expression), dimension(:), pointer :: explink ! The following declaration is illegal ... but above OK and I can allocate ! TYPE(tpfun_expression), dimension(:), allocatable, pointer :: explink TYPE(gtp_phase_add), pointer :: nextadd type(gtp_elastic_modela), pointer :: elastica type(gtp_diffusion_model), pointer :: diffcoefs ! ternary asymmetry record type(gtp_ternary_asymmetry), pointer :: asym3 ! calculated contribution to G, G.T, G.P, G.T.T, G.T.P and G.P.P double precision, dimension(6) :: propval END TYPE gtp_phase_add ! allocated when needed and linked from phase record !\end{verbatim} !----------------------------------------------------------------- !\begin{verbatim} ! Ternary asymmetry record. One or more sets of 3 constituent indices ! and an asymmetry code. codes are 3 letters T K and many M ! Used for the MQMQA phase but can be use for other phases ! There can be several sets integer, parameter :: gtp_ternary_asymmetry_version=1 type gtp_ternary_asymmetry integer, dimension(:,:), allocatable :: constindex character*3, dimension(:), allocatable :: asymcode end type gtp_ternary_asymmetry !\end{verbatim} !----------------------------------------------------------------- !\begin{verbatim} ! addition record to calculate the elastic energy contribution ! declared as allocatable in gtp_phase_add ! this constant must be incremented when a change is made in gtp_elastic_modela INTEGER, parameter :: gtp_elastic_modela_version=1 TYPE gtp_elastic_modela ! lattice parameters (configuration) in 3 dimensions double precision, dimension(3,3) :: latticepar ! epsilon in Voigt notation double precision, dimension(6) :: epsa ! elastic constant matrix in Voigt notation double precision, dimension(6,6) :: cmat ! calculated elastic energy addition (with derivative to T and P?) double precision, dimension(6) :: eeadd ! maybe more ... end TYPE gtp_elastic_modela !\end{verbatim} !----------------------------------------------------------------- !\begin{verbatim} ! addition record to calculate diffusion coefficients ! declared as allocatable in gtp_phase_add ! this constant must be incremented when a change is made in gtp_elastic_modela INTEGER, parameter :: gtp_diffusion_model_version=1 TYPE gtp_diffusion_model ! status bit 0 set means no calculation of this record ! dilute, simple or magnetic integer difftypemodel,status ! alpha values for magnetic diffusion (for interstitials in constituent order) double precision, allocatable, dimension(:) :: alpha ! indices of dependent constituent in each sublattices integer, allocatable, dimension(:) :: depcon ! indices of constituents with zerovolume integer, allocatable, dimension(:) :: zvcon ! calculated diffusion matrix double precision, allocatable, dimension(:,:) :: dcoef ! Maybe we need one for each composition set?? at least to save the matrix type(gtp_diffusion_model), pointer :: nextcompset ! maybe more ... end TYPE gtp_diffusion_model !\end{verbatim} !------------------------------------------------------------------ !\begin{verbatim} TYPE gtp_tpfun_as_coeff ! this is a TPFUN converted to coefficents without any references to other ! functions. Each function can have several T ranges and coefficents for T**n ! USED FOR SOLGASMIX double precision, dimension(:), allocatable :: tbreaks double precision, dimension(:,:), allocatable :: coefs integer, dimension(:,:), allocatable :: tpows ! this is used only during conversion ! type(gtp_tpfun_as_coeff), pointer :: nextcrec end type gtp_tpfun_as_coeff ! !-------------------------------------------------------------------------- INTEGER, parameter :: gtp_tpfun2dat_version=1 TYPE gtp_tpfun2dat ! this is a temporary storage of TP functions converted to arrays of ! coefficients. Allocated as an array when necessary and the index in ! this array is the same index as for the TPfun ! USED FOR SOLGASMIX calculations and it is very messily implemented ! if debug is nonzero there is additional output and name is displayed integer nranges,debug ! type(gtp_tpfun_as_coeff) :: tpfuncoef type(gtp_tpfun_as_coeff) :: cfun character*16 :: name end type gtp_tpfun2dat !\end{verbatim} !-------------------------------------------------------------------------- !\begin{verbatim} ! this constant must be incremented when a change is made in gtp_phasetuple INTEGER, parameter :: gtp_phasetuple_version=1 TYPE gtp_phasetuple ! for handling a single array with phases and composition sets ! ixphase is phase index (often lokph), compset is composition set index ! ADDED also index in phlista (lokph) and phase_varres (lokvares) and ! nextcs which is nonzero if there is a higher composition set of the phase ! A tuplet index always refer to the same phase+compset. New tuples with ! the same phase and other compsets are added at the end. ! BUT if a compset>1 is deleted tuples with higher index will be shifted down! ! CONFUSING ixphase is usually iph, phases in alphabetical order in phases ! lokph is usually lokph, location in phlista integer lokph,compset,ixphase,lokvares,nextcs ! >>>>>>>>>>>> old integer phaseix,compset,ixphase,lokvares,nextcs end TYPE gtp_phasetuple !\end{verbatim} TYPE(gtp_phasetuple), target, allocatable :: PHASETUPLE(:) ! ----------------------------------------------------------------- ! NOTE: if one wants to model bond energies beteween sites in a phase ! like in a 3 sublattice sigma one can enter parameters like ! G(sigma,A:B:*) which will mean the bond energy between an A atom in ! first sublattice and B in the second. The parameter G(sigma,B:A:*) ! will be different. Such parameters, multiplied with the fractions of ! the constutuents, are added to the Gibbs energy even if there are ! also endmember parameters like G(sigma,A:B:C) ! ----------------------------------------------------------------- !\begin{verbatim} ! a smart way to have an array of pointers used in gtp_phase TYPE endmemrecarray type(gtp_endmember), pointer :: p1 end TYPE endmemrecarray !----------------------------------------------------------------- ! this constant must be incremented when a change is made in gtp_phase INTEGER, parameter :: gtp_phase_version=1 TYPE gtp_phaserecord ! this is the record for phase model data. It points to many other records. ! Phases are stored in order of creation in phlista(i) and can be found ! in alphabetical order through the array phases(i) ! sublista is now removed and all data included in phlista ! sublattice and constituent data (they should be merged) ! The constituent link is the index to the splista(i), same function ! as LOKSP in iws. Species in alphabetcal order is in species(i) ! One can allocate a dynamic array for the constituent list, done ! by subroutine create_constitlist. ! Note that the phase has a dynamic status word status2 in gtp_phase_varres ! which can be differnt in different parallel calculations. ! This status word has the FIX/ENT/SUS/DORM status bits for example ! name: phase name, note composition sets can have pre and suffixes ! model: free text ! phletter: G for gas, L for liquid ! alphaindex: the alphabetcal order of the phase (gas and liquids first) character name*24,models*72,phletter*1 integer status1,alphaindex ! noofcs: number of composition sets, ! nooffs: number of fraction sets (replaces partitioned phases in TC) integer noofcs,nooffs ! additions: link to addition record list ! ordered: link to endmember record list ! disordered: link to endmember list for disordered fractions (if any) TYPE(gtp_phase_add), pointer :: additions TYPE(gtp_endmember), pointer :: ordered,disordered ! The Toop/Kohler record for each phase with such ternary extrapolation ! This is a link connecting all Toop/Kohler records for a phase. ! TYPE(gtp_tooprec), pointer :: tooplist ! integer lasttoopid ! TYPE(gtp_tooprec), pointer :: tooprec,tooplist ! To allow parallel processing of endmembers, store a pointer to each here integer noemr,ndemr TYPE(endmemrecarray), dimension(:), allocatable :: oendmemarr,dendmemarr ! noofsubl: number if sublattices ! tnooffr: total number of fractions (constituents) ! linktocs: array with indices to phase_varres records ! nooffr: array with number of constituents in each sublattice ! Note that sites are stored in phase_varres as they may vary with the ! constitution (for ionic liquid) integer noofsubl,tnooffr integer, dimension(9) :: linktocs integer, dimension(:), allocatable :: nooffr ! number of sites in phase_varres record as it can vary with composition ! constitlist: indices of species that are constituents (in all sublattices) integer, dimension(:), allocatable :: constitlist ! used in ionic liquid: ! i2slx(1) is index of Va, i2slx(2) is index if last anion (both can be zero) integer, dimension(2) :: i2slx ! Needed to list all Toop/Kohler ternary models ! The one used for calculations is the pointer in gtp_intrec (tooprec) TYPE(gtp_tooprec), pointer :: tooplast,toopfirst integer :: lasttoopid ! allocated in init_gtp. END TYPE gtp_phaserecord ! NOTE phase with index 0 is the reference phase for the elements ! allocated in init_gtp TYPE(gtp_phaserecord), private, allocatable :: phlista(:) INTEGER, private, allocatable :: PHASES(:) !\end{verbatim} !----------------------------------------------------------------- ! data for liquid phase with mqmqa model (only one but maybe composition sets) TYPE gtp_mqmqa ! contains special STATIC information for liquid MQMQA model ! nconst is number of phase const (quads), ncon1, ncon2 in subl, npair #of pairs ! nconst does not include anions ... these variables are used for the entropy integer nconst,ncon1,ncon2,npair,lcat !vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! MUST be careful with ncat and nan !!! USED IN MQMQA ! this is dangerous .... duplicates of nconst,ncon1,ncon2 also declared locally ! integer :: nquad,ncat,nan,lcat,lan integer :: nquad,ncat,nan,lan !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! some variables are also defined globally as ncat,nan,nquad ... confusing ! 2025/11/06 This seems OK but a lot of data missing for excess ! contyp(1..4,const) 1,2 species in first sublattice, -1,-2 in second sublattice ! contyp(5,const) non-zero for PAIR AA/XX, value same as pair index YES !! ! contyp(6,7,const) for PAIR species index ! contyp(6..9,const) index of constituent PAIRs ! contyp(10,const) index of itself ! contyp(11..14,const) index of sublattice constituent except: ! contyp(13..14,const) FOR PAIRS: species index of constituent integer, allocatable, dimension(:,:) :: contyp ! quady(i,j) indices of sublattice fractions ( replaced by 11..14 in contyp) ! integer, allocatable :: quady(:,:) ! for each pair, its index in %contyp is in PINQ ! integer, allocatable, dimension(:,:) :: pinq(:) integer, allocatable, dimension(:) :: pinq ! constoi(1..4,const) real with stoichiometry of species in quadrupole ! NOTE for pairs (with one constituent in each sublattice) only two values ! are needed for the stoichiometry. 2, 3 or 4 values ! Pairs initially have a third value, \zeta needed for entropy pair entropy double precision, allocatable, dimension(:,:) :: constoi ! ratio FCC/SNN for pairs, needed for pair entropy, copied from %constoi(3,q1) double precision, allocatable ::qfnnsnn(:) ! totstoi(const) double with real number of species (excl vacancies) in quad ! maybe not needed? Well it is used. double precision, allocatable :: totstoi(:) ! for each pair in a quad, needed for pair fraction and refstate %pp(1..4,quad) ! pp(i=1..4,jj) is stoichiometric factor of element i in constituent jj etc double precision, allocatable :: pp(:,:) ! At present excess only on cation sublattice, a single anion ! For binary excess parameters we need fractions: ! ksi1(AB) = ksi_AB/C= x_AA/(x_AA+x_AB+x_BB) and ! ksi2(AB) = ksi_BA/C= x_BB/(x_AA+x_AB+x_BB); these are ksi ! and derivatives wrt the constituents (2nd deriv are symmetric) ! double precision, allocatable :: ksi1(:),ksi2(:) ! double precision, allocatable :: dksi1(:,:),dksi2(:,:) ! double precision, allocatable :: d2ksi1(:,:),d2ksi2(:,:) ! no need for indexing ksi1 and ksi2 ...??? ! integer, allocatable :: ksiix(:) ! New implementation of mqmqa excess model started 2025/11/05 <<<<<<<<<<<<<<< ! if mqmqax=0 then old excess model integer :: exlevel=0 ! more data may be added later ... ! Ternary asymmetry is in a separate record gtp_asym_ternary ! linked in phase additions list. Several phases can have such a feature ! FNN/SNN ratio is qfnnsnn(:) ! ! for element j if el2ancat(j)>0 it is a cation index ! if -el2catan(j)>0 is is an anion index NOT USED ! ONLY ONE ANION ALLOWED, ! (positive) OC element index of the single anion as link and alpabetical integer xanione,xanionalpha ! index of element as cation (-1 for anion) integer, dimension(:), allocatable :: el2ancat ! xquad is declaraed as global but maybe it belongs to the mqmqa phase ! double precision, dimension(:), allocatable :: xquad only one mqmqaphase ! but there can be miscibility gaps ! convert from xquad index to constarray index and back ! in xquad the order is sequentail in the cation order: ! 1 2 3 4 .. n ! n+1 n+2 .. 2n-1 ! 2n ! ... ! n(n+1)/2 ! 1 1 1 1 1 ! 2 2 .. 2 ! 3 3 .. ! ... ! n ! 1 2 3 4 n ! 2 3 .. n ! 3 4 .. ! ... ! n ! where 1..n are cation indices i.e. element indices ignoring anions ! transfer of fractions from OC yfr to quad use integer, dimension(:), allocatable :: con2quad ! transfer y to quad order ! this is the indices of A/X quads in quad, 1, n, 2n-1 etc. integer, dimension(:), allocatable :: emquad ! emquad has indices of quads (i,i). ! Index of a quad (i,j) where j>=i is emquad(i)+j-i !------------------------------------------------------ NEW ! I realize I need an array tranforming quad indices to compvar indices integer, dimension(:), allocatable :: quad2compvar ! because the quad index is stored with the parameter and I need ! to convert this to an index for compvar to know the two cations !------------------------------------------------------ NEW ! these are constants depending of the elements in the quad double precision, dimension(:,:), allocatable :: dy_ik ! transfer of fractions from OC fraction array to xquad not needed ! integer, dimension(:), allocatable :: quad2con not needed ! end new stuff .... but more records below for example allinone end TYPE gtp_mqmqa !----------------------------------------------------------------- ! it should be made private when everything work and removed from pmon6 TYPE(gtp_mqmqa) :: mqmqa_data ! it is reset in pmon6 when a NEW command integer :: mqmqanend=-100 ! probably only one of these needed ... integer, parameter :: maxmqmqa=200 integer, parameter :: maxquads=99 ! because only 2 digits ! !----------------------------------------------------------------- ! data for liquid phase with mqmqa model (part of phase_varres record) ! separate records for each compset because the liquid may have miscibility gaps TYPE gtp_mqmqa_var ! The quadruplet fractions are the "normal" constituent fractions ! but in a differt order form the alphabetical species names. ! it is part of the phase_varres record ! size of arrays integer nquad,npair,ns1,ns2 !------------------------------------------ data for MQMQA new excess ! these are the quad fractions, same as mole fractions but ordered differntly ! used together with the compvar asymmetrical variables ! compvar has values of asymmetrical variables for excess ! in xquad the element index of corresponding quad index is in quadel_ijkl ! xquad index 1 2 3 .. n ! n+1 n+2 .. 2n-1 ! 2n .. ! n(n+1)/2 ! quadel_i e1 e1 e1 .. e1 ! e2 e2 e2 ! e3 .. ! en cations 1..n ! quadel_j e1 e2 e3 .. en ! e2 e3 .. en ! e3 .. ! en cations 1..n ! quadel_k el el el .. el ! el el .. el ! el .. ! el anion 1 ! function ijklx translates from cation/anion indices (i,j,k,l) to quad index ! The e1, e2 etc and el are saved in quadel_i _j _l ! The order of xquads is to simplify the handling of Toop/Kohler asymmetries double precision, allocatable, dimension(:) :: xquad ! The fractions in xquad are the same as in yfr but in differnt order! type(gtp_allinone), dimension(:), allocatable :: compvar ! the arrays above should be in the record (type) mqmqa_var ! y_ik are the fraction of each cation double precision, dimension(:), allocatable :: y_ik ! double precision, dimension(:,:), allocatable :: dy_ik in gtp_mqmqa !----------------------------------------------------------------- ! needed for access to phase data type(gtp_phase_varres), pointer :: phresq ! ! the variables below until the end of this TYPE are (probably) not used ! (dynamic) site fractions and derivatives double precision, allocatable :: yy1(:),yy2(:),dyy1(:,:),dyy2(:,:) double precision, allocatable :: d2yy1(:,:),d2yy2(:,:) ! charge equivalent fractions (per sublattice) double precision, allocatable :: ceqf1(:),ceqf2(:),dceqf1(:,:),dceqf2(:,:) ! normallized pair fractions and derivatives double precision, allocatable :: pair(:),dpair(:,:) ! constituent equivalent fractions, needed for excess parameters (NEW) double precision, allocatable :: eqf1(:),deqf1(:,:),d2eqf1(:,:) double precision, allocatable :: eqf2(:),deqf2(:,:),d2eqf2(:,:) end type gtp_mqmqa_var !=================================================================== ! ! below here are data structures for equilibrium description ! !=================================================================== ! !\begin{verbatim} ! this constant must be incremented when a change is made in gtp_state_variable INTEGER, parameter :: gtp_state_variable_version=1 TYPE gtp_state_variable ! this is to specify a formal or real argument to a function of state variables ! statevarid/istv: state variable index >=9 is extensive ! phref/iref: if a specified reference state (for chemical potential ! unit/iunit: 100 for percent, no other defined at present ! argtyp together with the next 4 integers represent the indices(4), only 0-4 ! argtyp=0: no indices (T or P) ! argtyp=1: component ! argtyp=2: phase and compset ! argtyp=3: phase and compset and component ! argtyp=4: phase and compset and constituent ! ?? what is norm ?? normalizing like M in HM ? integer statevarid,norm,unit,phref,argtyp ! these integers represent the previous indices(4) integer phase,compset,component,constituent ! a state variable can be part of an expression with coefficients ! the coefficient can be stored here. Default value is unity. ! In many cases it is ignored double precision coeff ! NOTE this is also used to store a condition of a fix phase ! In such a case statev is negative and the absolute value of statev ! is the phase index. The phase and compset indices are also stored in ! "phase" and "compset" ?? ! This is a temporary storage of the old state variable identifier integer oldstv end TYPE gtp_state_variable ! used for state variables/properties in various subroutines !\end{verbatim} ! statevarid: defined in decode_state_variable3 in gtp3F.F90 ! potentials: 1=T; 2=P; 3=MU; 4=AC; 5=LNAC ! extensive: 6=U; 7=S; 8=V; 9=H; 10=A; 11=G; ! phase: 12=NP; 13=BP; 14=Q ; 15=DG ! amounts: 16=N; 17=X; 18=B; 19=W; 20=Y !----------------------------------------------------------------- !\begin{verbatim} ! this constant must be incremented when a change is made in gtp_condition ! NOTE on unformatted SAVE files the conditions are written as texts INTEGER, parameter :: gtp_condition_version=1 TYPE gtp_condition ! these records form a circular list linked from gtp_equilibrium_data records ! each record contains a condition to be used for calculation ! it is a state variable equation or a phase to be fixed ! The state variable is stored as an integer with indices ! NOTE: some state variables cannot be used as conditions: Q=18, DG=19, 25, 26 ! There can be several terms in a condition (like x(liq,c)-x(fcc,c)=0) ! noofterms: number of terms in condition expression ! statev: the type of state variable (must be the same in all terms) ! negative value of statev means phase index for fix phase ! active: zero if condition is active, nonzero for other cases ! unit: is 100 if value in percent, can also be used for temperature unit etc. ! nid: identification sequential number (in order of creation), redundant ! iref: part of the state variable (iref can be comp.set number) ! iunit: ? confused with unit? ! seqz is a sequential index of conditions, used for axis variables ! experimettype: inequality (< 0 or > 0) and/or percentage (-101, 100 or 101) ! symlink: index of symbol for prescribed value (1) and uncertainty (2) ! condcoeff: there is a coefficient and set of indices for each term ! prescribed: the prescribed value ! NOTE: if there is a symlink value that is the prescribed value ! current: the current value (not used?) ! uncertainty: the uncertainty (for experiments) integer :: noofterms,statev,active,iunit,nid,iref,seqz,experimenttype ! TYPE(putfun_node), pointer :: symlink1,symlink2 ! better to let condition symbol be index in svflista array integer symlink1,symlink2 integer, dimension(:,:), allocatable :: indices double precision, dimension(:), allocatable :: condcoeff double precision prescribed, current, uncertainty ! confusing with record statevar and integer statev TYPE(gtp_state_variable), dimension(:), allocatable :: statvar TYPE(gtp_condition), pointer :: next, previous end TYPE gtp_condition ! used inside the gtp_equilibrium_data record and elsewhere !\end{verbatim} !----------------------------------------------------------------- !\begin{verbatim} ! this constant must be incremented when a change is made in gtp_putfun_lista INTEGER, parameter :: gtp_putfun_lista_version=2 TYPE gtp_putfun_lista ! these are records for STATE VARIABLE FUNCTIONS. The function itself ! is handelled by the putfun package. ! linkpnode: pointer to start node of putfun expression ! narg: number of symbols in the function ! nactarg: number of actual parameter specifications needed in call ! (like @P, @C and @S ! status: can be used for various things ! status bit SVFVAL set means value evaluated only when called with mode=1 ! SVCONST bit set if symbol is just a constant value (linknode is zero) ! eqnoval: used to specify the equilibrium the value should be taken from ! (for handling what is called "variables" in TC, SVFEXT set also) ! SVFTPF set if symbol is a TP function, eqnoval is TPFUN index ! if SVIMPORT set then the symbol is set equal to a TP function (only value ! no derivatives). TP function index is in TPLINK ! if SVEXPORT set the the value of the symbol is copied to a TP function ! (must be a constant). TP function index is in TPLINK ! name: name of symbol integer narg,nactarg,status,eqnoval,tplink type(putfun_node), pointer :: linkpnode character name*16 ! THIS IS OLY USED FOR CONSTANTS, VALUES ARE ALSO STORED IN CEQ%SVFUNRES double precision svfv ! this array has identification of state variable (and other function) symbols ! It is allocated in various subroutines, maybe be allocatable? 2020-08-31/BoS integer, dimension(:,:), pointer :: formal_arguments end TYPE gtp_putfun_lista ! this is the global array with state variable functions, "symbols" TYPE(gtp_putfun_lista), dimension(:), allocatable :: svflista ! NOTE the value of a function is stored locally in each equilibrium record ! in array svfunres. ! The number of entered state variable functions. Used when a new one stored integer, private :: nsvfun !\end{verbatim} !----------------------------------------------------------------- !\begin{verbatim} ! this constant must be incremented when a change is made in gtp_fraction_set INTEGER, parameter :: gtp_fraction_set_version=1 TYPE gtp_fraction_set ! info about disordered fractions for some phases like ordered fcc, sigma etc ! latd: the number of sublattices added to first disordred sublattice ! ndd: sublattices for this fraction set, ! tnoofxfr: number of disordered fractions ! tnoofyfr: same for ordered fractions (=same as in phlista). ! varreslink: index of disordered phase_varres, ! totdis: 0 indicates no total disorder (sigma), 1=fcc, bcc or hcp ! id: parameter suffix, D for disordered ! dsites: number of sites in sublattices, disordred fractions stored in ! another phase_varres record with index varreslink (above) ! splink: indices of species record for the constituents ! nooffr: the number of fractions in each sublattice ! y2x: the conversion from sublattice constituents to disordered and ! dxidyj: are the the coeff to multiply the y fractions to get the disordered ! xfra(y2x(i))=xfra(y2x(i))+dxidyj(i)*yfra(i) ! disordered fractions stored in the phase_varres record with index varreslink ! arrays originally declared as pointers now changed to allocatable integer latd,ndd,tnoofxfr,tnoofyfr,varreslink,totdis character*1 id double precision, dimension(:), allocatable :: dsites integer, dimension(:), allocatable :: nooffr integer, dimension(:), allocatable :: splink integer, dimension(:), allocatable :: y2x double precision, dimension(:), allocatable :: dxidyj ! formula unit factor needed when calculating G for disordered sigma etc double precision fsites END TYPE gtp_fraction_set ! these records are declared in the phase_varres record as DISFRA for ! each composition set and linked from the phase_varres record !\end{verbatim} !----------------------------------------------------------------- !\begin{verbatim} ! this constant must be incremented when a change is made in gtp_phase_varres ! added quasichemical bonds INTEGER, parameter :: gtp_phase_varres_version=2 TYPE gtp_phase_varres ! Data here must be different in equilibria representing different experiments ! or calculated in parallel or results saved from step or map. ! nextfree: In unused phase_varres record it is the index to next free record ! The global integer csfree is the index of the first free record ! The global integer highcs is the higest varres index used ! phlink: is index of phase record for this phase_varres record ! status2: has composition set status bits CSxyz ! phstate: indicate state: fix/stable/entered/unknown/dormant/suspended/hidden ! 2 1 0 -1 -2 -3 -4 ! phtupx: phase tuple index integer nextfree,phlink,status2,phstate,phtupx ! abnorm(1): moles of components per formula unit of the phase/composition set ! abnorm(2): mass of components per formula unit ! abnorm(3): moles atoms per formula unit (all abnorm set by SET_CONSTITUTION) ! prefix and suffix are added to the name for composition sets 2 and higher double precision, dimension(3) :: abnorm character*4 prefix,suffix ! constat: array with status word for each constituent, any can be suspended ! yfr: the site fraction array ! mmyfr: min/max fractions, negative is a minumum ! sites: site ratios (which can vary for ionic liquids) integer, dimension(:), allocatable :: constat double precision, dimension(:), allocatable :: yfr real, dimension(:), allocatable :: mmyfr double precision, dimension(:), allocatable :: sites ! for ionic liquid derivatives of sites wrt fractions (it is the charge), ! 2nd derivates only when one constituent is vacancy ! 1st sublattice P=\sum_j (-v_j)*y_j + Qy_Va ! 2nd sublattice Q=\sum_i v_i*y_i ! dpqdy is the abs(valency) of the species, set in set_constitution ! for the vacancy it is the same as the number of sites on second subl. ! used in the minimizer and maybe elsewhere double precision, dimension(:), allocatable :: dpqdy double precision, dimension(:), allocatable :: d2pqdvay ! disfra: a structure describing the disordered fraction set (if any) ! for extra fraction sets, better to go via phase record index above ! this TYPE(gtp_fraction_set) variable is a bit messy. Declaring it in this ! way means the record is stored inside this record. type(gtp_fraction_set) :: disfra !-------------------------------------------- IMPORTANT for MQMQA excess ! this is for saving fractions in the mqmqa liquid model type(gtp_mqmqa_var) :: mqmqaf ! --- ! stored calculated results for each phase (composition set) ! amfu: is amount formula units of the composition set (calculated result) ! netcharge: is net charge of phase ! dgm: driving force ! qcbonds: quasichemical bonds (NOT SAVED ON UNFORMATTED) double precision amfu,netcharge,dgm,qcbonds ! qcsro: current value of SRO (for quasichemical model) ?? double precision, allocatable, dimension(:) :: qcsro ! Other properties may be that: gval(*,2) is TC, (*,3) is BMAG, see listprop ! nprop: the number of different properties (set in allocate) ! listprop(1): is number of calculated properties ! listprop(2:listprop(1)): identifies the property stored in gval(1,ipy) etc ! 2=TC, 3=BMAG. Properties defined in the gtp_propid record integer nprop integer, dimension(:), allocatable :: listprop ! gval etc are for all composition dependent properties, gval(*,1) for G ! gval(*,1): is G, G.T, G.P, G.T.T, G.T.P and G.P.P ! dgval(1,j,1): is first derivatives of G wrt fractions j ! dgval(2,j,1): is second derivatives of G wrt fractions j and T ! dgval(3,j,1): is second derivatives of G wrt fractions j and P ! d2gval(ixsym(i,j),1): is second derivatives of G wrt fractions i and j double precision, dimension(:,:), allocatable :: gval double precision, dimension(:,:,:), allocatable :: dgval double precision, dimension(:,:), allocatable :: d2gval ! added for strain/stress, current values of lattice parameters double precision, dimension(3,3) :: curlat ! saved values from last equilibrium for dot derivative calculations double precision, dimension(:,:), allocatable :: cinvy double precision, dimension(:), allocatable :: cxmol double precision, dimension(:,:), allocatable :: cdxmol ! terms added to G if bit CSADDG nonzero double precision, dimension(:), allocatable :: addg ! integer containing the iteration when invsaved updated integer invsavediter ! arrays to save time in calc_dgdyterms, do not need to be saved on unformatted double precision, dimension(:,:), allocatable ::invsaved ! added to initiate calculations for CVMSRO model, maybe used elsewhere also? integer volatile END TYPE gtp_phase_varres ! this record is created inside the gtp_equilibrium_data record !\end{verbatim} !----------------------------------------------------------------- !\begin{verbatim} ! this must be incremented when a change is made in gtp_equilibrium_data INTEGER, parameter :: gtp_equilibrium_data_version=1 TYPE gtp_equilibrium_data ! this contains all data specific to an equilibrium like conditions, ! status, constitution and calculated values of all phases etc ! Several equilibria may be calculated simultaneously in parallel threads ! SO EACH EQUILIBRIUM MUST BE INDEPENDENT ! NOTE: the error code must be local to each equilibria!!!! ! During step and map each equilibrium record with results is saved ! values of T and P, conditions etc. ! Values here are normally set by external conditions or calculated from model ! local list of components, phase_varres with amounts and constitution ! lists of element, species, phases and thermodynamic parameters are global ! status: not used yet? ! multiuse: used for various things like direction in start equilibria ! eqno: sequential number assigned when created ! next: index of next free equilibrium record ! also index of next equilibrium in a list during step/map calculation. ! eqname: name of equilibrium ! comment: a free text, for example reference for experimental data. ! tpval(1) is T, tpval(2) is P, rgas is R, rtn is R*T ! rtn: value of R*T ! weight: weight value for this experiment, default unity ! integer status,multiuse,eqno,next integer status,multiuse,eqno,nexteq character eqname*24,comment*72 double precision tpval(2),rtn double precision :: weight=one ! svfunres: the values of state variable functions valid for this equilibrium double precision, dimension(:), allocatable :: svfunres ! the experiments are used in assessments and stored like conditions ! lastcondition: link to condition list ! lastexperiment: link to experiment list TYPE(gtp_condition), pointer :: lastcondition,lastexperiment ! components and conversion matrix from components to elements ! complist: array with components (species index or location)?? ! compstoi: stoichiometric matrix of compoents relative to elements ! invcompstoi: inverted stoichiometric matrix TYPE(gtp_components), dimension(:), allocatable :: complist double precision, dimension(:,:), allocatable :: compstoi double precision, dimension(:,:), allocatable :: invcompstoi ! one record for each phase+composition set that can be calculated ! phase_varres: here all calculated data for the phases are stored TYPE(gtp_phase_varres), dimension(:), allocatable :: phase_varres ! index to the tpfun_parres array is the same as in the global array tpres ! eq_tpres: here local calculated values of TP functions are stored ! should be allocatable, not a pointer TYPE(tpfun_parres), dimension(:), allocatable :: eq_tpres ! current values of chemical potentials stored in component record but ! duplicated here for easy acces by application software double precision, dimension(:), allocatable :: cmuval ! xconv: convergence criteria for constituent fractions and other things ! dgconv(1) is controlling decrease of DGM for unstable phases ! dgconv(2) not used (yet) double precision xconv,gdconv(2) ! delta-G value for merging gridpoints in grid minimizer ! smaller value creates problem for test step3.OCM, MC and austenite merged ! double precision :: gmindif=-5.0D-2 ! testing merging again 190604/BoS !CCI double precision :: gmindif !CCI ! maxiter: maximum number of iterations allowed integer :: maxiter ! CCI ! New parameters based on the work of Joao Pedro Teuber Carvalho (12/2020) ! To scale all changes in phase amount with total number of atoms. integer :: type_change_phase_amount double precision :: scale_change_phase_amount ! splitsolver : flag to allow the splitting resolution when conditions ! lead to a square mass matrix ! precondsolver : flag to allow the preconditionning of the matrix ! before solving linear system integer :: precondsolver integer :: splitsolver !CCI ! CCI number of iterations needed for the equilibrium calculation integer :: conv_iter ! This is to store additional things not really invented yet ... ! It may be used in ENTER MANY_EQUIL for things to calculate and list character (len=80), dimension(:), allocatable :: eqextra ! this is to save a copy of the last calculated system matrix, needed ?? ! to calculate dot derivatives, initiate to zero integer :: sysmatdim=0,nfixmu=0,nfixph=0 integer, allocatable :: fixmu(:) integer, allocatable :: fixph(:,:) double precision, allocatable :: savesysmat(:,:) ! This is temporary data for EEC but must be separate for parallelization ! index of phase_varres for liquid integer eecliq double precision eecliqs ! temporary array to handle converge problems with change of stable phase set integer, dimension(:,:), allocatable :: phaseremoved END TYPE gtp_equilibrium_data ! The primary copy of this structures is declared globally as FIRSTEQ here ! Others may be created when needed for storing experimental data or ! for parallel processing. A global array of these are TYPE(gtp_equilibrium_data), dimension(:), allocatable, target :: eqlista TYPE(gtp_equilibrium_data), pointer :: firsteq ! This array of equilibrium records are used for storing results during ! STEP and MAP calculations. TYPE(gtp_equilibrium_data), dimension(:), allocatable :: eqlines !\end{verbatim} !----------------------------------------------------------------- !\begin{verbatim} ! for each permutation in the binary interaction tree of an endmember one must ! keep track of the permutation and the permutation limit. ! It is not possible to push the value on pystack as one must remember ! them when changing the endmember permutation ! integer, parameter :: permstacklimit=150 ! this constant must be incremented when a change is made in gtp_parcalc INTEGER, parameter :: gtp_parcalc_version=1 TYPE gtp_parcalc ! This record contains temporary data that must be separate in different ! parallel processes when calculating G and derivatives for any phase. ! There is nothing here that need to be saved after the calculation is finished ! global variables used when calculating G and derivaties ! sublattice with interaction, interacting constituent, endmember constituents ! PRIVATE inside this structure not liked by some compilers.... ! endcon must have maxsubl dimension as it is used for all phases integer :: intlat(maxinter),intcon(maxinter),endcon(maxsubl) ! interaction level and number of fraction variables integer :: intlevel,nofc ! interacting constituents (max 4) for composition dependent interaction ! iq(j) indicate interacting constituents ! for binary RK+Muggianu iq(3)=iq(4)=iq(5)=0 ! for ternary Muggianu in same sublattice iq(4)=iq(5)=0 ! for reciprocal composition dependent iq(5)=0 ! 2020/BoS not used: Toop, Kohler and simular iq(5) non-zero (not implemented) integer :: iq(5) ! fraction variables in endmember (why +2?) and interaction double precision :: yfrem(maxsubl+2),yfrint(maxinter) ! local copy of T, P and RT for this equilibrium double precision :: tpv(2),rgast ! double precision :: ymin=1.0D-30 end TYPE gtp_parcalc ! this record is declared locally in subroutine calcg_nocheck !\end{verbatim} !------------------------------------------------------------------- !\begin{verbatim} ! this constant must be incremented when a change is made in gtp_pystack INTEGER, parameter :: gtp_pystack_version=1 TYPE gtp_pystack ! records created inside the subroutine push/pop_pystack ! data stored during calculations when entering an interaction record ! previous: link to previous record in stack ! ipermutsave: permutation must be saved ! intrecsave: link to interaction record ! pysave: saved value of product of all constituent fractions ! dpysave: saved value of product of all derivatives of constituent fractions ! d2pysave: saved value of product of all 2nd derivatives of constit fractions TYPE(gtp_pystack), pointer :: previous integer :: pmqsave TYPE(gtp_interaction), pointer :: intrecsave double precision :: pysave double precision, dimension(:), allocatable :: dpysave double precision, dimension(:), allocatable :: d2pysave end TYPE gtp_pystack ! declared inside the calcg_internal subroutine !\end{verbatim} !----------------------------------------------------------------- ! !=================================================================== ! ! below here are data structures for various applications ! They indicate data that may need to be saved together with ! the thermodynamic data. Exactly how this will be handelled ! will have to be solved later ! !=================================================================== ! !----------------------------------------------------------------- !\begin{verbatim} INTEGER, parameter :: gtp_eqnode_version=1 TYPE gtp_eqnode ! This record is to arrange calculated equilibria, for example results ! from a STEP or MAP calculation, in an ordered way. The equilibrium records ! linked from an eqnode record should normally represent one or more lines ! in a diagram but may be used for other purposes. ! ident is to be able to find a specific node ! nodedtype is to specify invariant, middle, end etc. ! status can be used to supress a line ! color can be used to sepecify color or linetypes (dotted, thick ... etc) ! exits are the number of lines that should exit from the node ! done are the number of calculated lines currently exiting from the node integer ident,nodetype,status,color,exits,done ! this node can be in a multilayerd list of eqnodes type(gtp_eqnode), pointer :: top,up,down,next,prev ! nodeq is a pointer to the equilibrium record at the node type(gtp_equilibrium_data), pointer :: nodeq ! eqlista are pointers to line of equilibria starting or ending at the node ! The equilibrium records are linked with a pointer inside themselves type(gtp_equilibrium_data), dimension(:), pointer :: eqlista ! axis is the independent axis variable for the line, negative means decrement ! noeqs gives the number of equilibria in each eqlista, a negative value ! indicates that the node is an endpoint (each line normally has a ! start point and an end point) integer, dimension(:), allocatable :: axis,noeqs ! This is a possibility to specify a status for each equilibria in each line ! integer, dimension(:,:), allocatable :: eqstatus end TYPE gtp_eqnode ! can be allocated in a gtp_applicationhead record !\end{verbatim} !------------------------------------------------------------------ !\begin{verbatim} ! a smart way to have an array of pointers used in gtp_assessmenthead TYPE equilibrium_array type(gtp_equilibrium_data), pointer :: p1 end TYPE equilibrium_array INTEGER, parameter :: gtp_assessment_version=1 TYPE gtp_assessmenthead ! This record should summarize the essential information about assessment data ! using GTP. How it should link to other information is not clear. ! status is status word, AHCOEF is used ! varcoef is the number of variable coefficients ! firstexpeq is the first equilibrium with experimental data ! lwam is allocated workspace at last call to lmdif1 integer status,varcoef,firstexpeq,lwam character*64 general,special type(gtp_assessmenthead), pointer :: nextash,prevash ! This is list of pointers to equilibria to be used in the assessnent ! size(eqlista) is the number of equilibria with experimental data type(equilibrium_array), dimension(:), allocatable :: eqlista ! These are the coefficients values that are optimized, ! current values, scaling, start values, RSD and optionally min and max double precision, dimension(:), allocatable :: coeffvalues double precision, dimension(:), allocatable :: coeffscale double precision, dimension(:), allocatable :: coeffstart double precision, dimension(:), allocatable :: coeffrsd double precision, dimension(:), allocatable :: coeffmin double precision, dimension(:), allocatable :: coeffmax ! These are the corresponding TP-function constants indices integer, dimension(:), allocatable :: coeffindex ! This array indicate currently optimized variables: ! -1=unused, 0=fix, 1=fix with min, 2=fix with max, 3=fix with min and max ! 10=optimized, 11=opt with min, 12=opt with max, 13=opt with min and max integer, dimension(:), allocatable :: coeffstate ! Work arrays ... double precision, dimension(:), allocatable :: wopt end TYPE gtp_assessmenthead ! this record should be allocated for assessments when necessary type(gtp_assessmenthead), allocatable :: ashrecord ! type(gtp_assessmenthead), pointer :: firstash,lastash ! but this is later allocated, to avoid memory loss ashrecord should be used ! and then this pointer should be set to that record type(gtp_assessmenthead), pointer :: firstash !\end{verbatim} !------------------------------------------------------------------ !\begin{verbatim} INTEGER, parameter :: gtp_applicationhead_version=1 TYPE gtp_applicationhead ! This record should summarize the essential information about an application ! using GTP. How it should link to other information is not clear. ! The character variables should be used to indicate that. integer apptyp,status character*64 general,special ! These can be used to define axis and other things integer, dimension(:), allocatable :: ivals double precision, dimension(:), allocatable :: rvals character*64, dimension(:), allocatable :: cvals type(gtp_applicationhead), pointer :: nextapp,prevapp ! The headnode can be the start of a structure of eqnodes with lines type(gtp_eqnode) :: headnode ! this is the start of a list of nodes with calculated lines or ! single equilibria that belong to the application. type(gtp_eqnode), dimension(:), allocatable :: nodlista end TYPE gtp_applicationhead ! this record is allocated when necessary type(gtp_applicationhead), pointer :: firstapp,lastapp !\end{verbatim} !----------------------------------------------------------------- ! !======================================================================= ! ! Below are private global variables like free lists etc. ! !=================================================================== ! ! Several arrays with lists have a free list: csfree,addrecs,eqfree,reffree ! it is not really consistent how to handle deleted equilibria etc ! as the eqlista or phase_varres arrays may have "holes" with deleted data ! !\begin{verbatim} ! counters for elements, species and phases initiated to zero integer, private :: noofel=0,noofsp=0,noofph=0 ! counter for phase tuples (combination of phase+compset) integer, private :: nooftuples=0 ! counters for property and interaction records, just for fun integer, private :: noofprop,noofint,noofem ! free lists in phase_varres records and addition records integer, private :: csfree,addrecs ! free list of references and equilibria integer, private :: reffree,eqfree ! maximum number of properties calculated for a phase integer, private :: maxcalcprop=20 ! highcs is highest used phase_varres record (for copy equil etc) integer, private :: highcs ! Trace for debugging (not used) logical, private :: ttrace ! Output for debugging gridmin integer, private :: lutbug=0 ! used for notallowlisting double precision :: proda=zero,privilege=zero ! minimum constituent fraction double precision :: bmpymin ! number of defined property types like TC, BMAG etc integer, private :: ndefprop ! this is the index of mobility data, set in init_gtp in subroutine gtp3A integer, private :: mqindex ! quasichemical model type, 1=classic, 2=corrceted type 1, 3=corrected type 2 integer :: qcmodel=1 ! this is to remember how manytimes find_gridmeen needs to search all gridp integer :: ngridseek ! this is to handle EEC in the grid minimizer NOT GOOD FOR PARALLELIZATION ! integer :: neecgrid double precision :: sliqmax,sliqmin,gliqeec,sliqeec ! this is for warnings about using unkown model parameter identifiers integer, parameter :: mundefmpi=10 integer nundefmpi character undefmpi(mundefmpi)*4 ! this is to give some debug information when reading a database logical :: dbcheck=.FALSE. ! this is set zero by new_gtp and incremented each time a Toop record ! is created in any phase ! REMOVED as global variable 241012/BoS Now local for each phase ! integer uniqid ! this is to allow to select_phases from database files integer nselph character (len=24), allocatable, dimension(:) :: seltdbph ! This is to indicate mobility parameters, no wildcared fractions allowed integer nowildcard(3) ! trying to extract configurational entropy double precision :: sconfmqmqa !\end{verbatim} ! undocumented debug indicator integer :: gtpdebug=0 !==================================================== ! This verbatim section is an Appendix about model parameter identifiers ! The actual models where these are used are explained elsewhere. !\begin{verbatim} ! Model parameter identifiers entered in gtp3A.F90 and used mainly in gtp3H ! to calculate additions. Used also in gtp3B when entering parameters ! Index Name Used in addition/model ! 1 G Gibbs energy for endmembers or interactions ! 2 TC Curie T in Inden-Hillert-Jarl magnetic model ! 3 BMAG - - 1 Average Bohr magneton numb ! 4 CTA - P 2 Curie temperature ! 5 NTA - P 2 Neel temperature ! 6 IBM - P &; 12 Individual Bohr magneton num ! 7 LNTH - P 2 ln(Debye or Einstein temp) ! 8 V0 - - 1 Volume at T0, P0 ! 9 VA T - 4 Thermal expansion ! 10 VB T P 0 Bulk modulus ! 11 VC T P 0 Alternative volume parameter ! 12 VS T P 0 Diffusion volume parameter ! 13 MQ T P &; 10 Mobility activation energy ! 14 MF T P &; 10 RT*ln(mobility freq.fact.) ! 15 MG T P &; 10 Magnetic mobility factor ! 16 G2 T P 0 Liquid two state parameter ! 17 THT2 - P 2 Smooth step function Tcrit ! 18 DCP2 - P 2 Smooth step function increm. ! 19 LPX T P 0 Lattice param X axis ! 20 LPY T P 0 Lattice param Y axis ! 21 LPZ T P 0 Lattice param Z axis ! 22 LPTH T P 0 Lattice angle TH ! 23 EC11 T P 0 Elastic const C11 ! 24 EC12 T P 0 Elastic const C12 ! 25 EC44 T P 0 Elastic const C44 ! 26 UQT T P &; 10 UNIQUAC residual parameter ! 27 RHO T P 0 Electric resistivity ! 28 VISC T P 0 Viscosity ! 29 LAMB T P 0 Thermal conductivity ! 30 HMVA T P 0 Enthalpy of vacancy form. ! 31 TSCH - P 2 Schottky anomaly T ! 32 CSCH - P 2 Schottky anomaly Cp/R. ! 33 QCZ - - 1 MQMQA cluster coord factor ! 34 GG - - 1 MQMQA excess maybe redundant ! 35 GQ - - 1 MQMQA excess maybe redundant ! 36 GB - - 1 MQMQA excess maybe redundant ! DO NOT CHANGE THE ORDER in gtp3A, that would require changes elsewhere too ! The table below is the current definition of model parameters!! character (len=4), dimension(40) :: MODPARID=& ['G ','TC ','BMAG','CTA ','NTA ','IBM ','LNTH','V0 ','VA ','VB ',& 'VC ','VS ','MQ ','MF ','MG ','G2 ','THT2','DCP2','LPX ','LPY ',& 'LPZ ','LPTH','EC11','EC12','EC44','UQT ','RHO ','VISC','LAMB','HMVA',& 'TSCH','CSCH','QCZ ','GG ','GQ ','GB ',' ',' ',' ',' '] ! 1 2 3 4 5 6 7 8 9 10 ! ['G ','LNTH','BMAG','TC ','NT ','G2 ','V0 ','VA ','VB ','XX ',& ! 'VC ','VS ','MQ ','MF ','MG ','YY ','THT2','DCP2','LPX ','LPY ',& ! 'LPZ ','LPTH','EC11','EC12','EC44','UQT ','RHO ','VISC','LAMB','HMVA',& ! 'TSCH','CSCH','QCZ ',' ',' ',' ',' ',' ',' ',' '] ! 1 2 3 4 5 6 7 8 9 10 ! The meaning of the model parameters is entered in init_gtp in gtp3A.F90 !\end{verbatim} !========================================== ! See gtp3_xml.F90 for new definition of model parameter identifiers ================================================ FILE: src/models/gtp3_xml.F90 ================================================ !*************************************************************** ! General Thermodynamic Package (GTP) ! for thermodynamic modelling and calculations ! ! MODULE GENERAL_THERMODYNAMIC_PACKAGE ! ! Copyright 2011-2022, Bo Sundman, France ! ! This program is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 2 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this program; if not, write to the Free Software ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! contact person: bo.sundman@gmail.com ! !----------------------------------------------------------------------- ! ! for known unfinished/unchecked bugs and parallelization problems ! look for BEWARE ! !----------------------------------------------------------------------- ! ! Description of the XTDB data structure ! definition of xml elements and attributes for XTDB files ! ! Versions ! 2024.11.19 Begun revise previous XTDB structure using TYPE ! 2025.01.13 Integrate with OC ! ! Some default values for the XTDB file, can be changed by user or read_xtdb ! These are also set in pmon6 when NEW Y command character (len=8), parameter :: XTDBversion='0.1.14 ' character (len=8) :: lowtdef ='298.15 ' character (len=8) :: hightdef ='6000 ' character (len=64) :: bibrefdef ='U.N. Known ' character (len=16) :: eldef ='VA /-' ! character (len=52) :: ModelAppendXTDB='C:\Users\bosun\Documents\OCHOME\ModelAppendXTDB.XTDB' character (len=20) :: ModelAppendXTDB='.\ModelOCAppend.XTDB' logical :: unary1991=.TRUE., includemodels=.FALSE. integer xtdberr ! this is set TRUE when MQMQA quads entered as species. If constituents .false. logical :: xtdbmqmqa=.true. ! ! Number of XDB tags integer, parameter :: nxtdbtags=36 ! contains all tag names in no particular order ! if tags extend 18 characters changes may be needed in gtp3EX.F90 character (len=18), dimension(nxtdbtags), parameter :: xtdbtags=& ! 123456789.123456789.123456789.123456789.123456789.123456789. ['XTDB ',& 'Defaults ',& 'DatabaseInfo ',& 'AppendXTDB ',& ! path to extra TDB file 'Element ',& 'Species ',& 'TPfun ',& 'Trange ',& ! 8 above ------------------------------------------ 'Phase ',& ! With several nested tags 'Sublattices ',& 'Constituents ',& 'CrystalStructure ',& 'AmendPhase ',& ! can have models as magnetic etc 'Appendix ',& ! Surround tags in an AppendXTDB file 'DisorderedPart ',& ! as TC DISORDERED_PART and/or NEVER model ' ',& ! chanded Disordered_3Part to attribute ! 16 above end of phase tags------------------ 'Parameter ',& ! if moved edit xmlpartag in gtp3EX.F90 'Parameter2 ',& ! maybe never implemented in OC, need more tags 'Bibliography ',& 'Bibitem ',& ! inside Bibliography ! 20 above Models ---------------------------- 'Models ',& ! With model tags following 'Magnetic ',& ! The modelss Model Parameter Identifiers MPID 'Einstein ',& 'Liquid2state ',& 'Volume ',& 'EEC ',& ! 'TernaryXpol ',& ! Ternary extrapolation tag ! 27 above I think EBEF is not needed as a model, it is defined the parameters 'UnarySystems ',& ! These tags are optional for arrangeing data 'BinarySystem ',& 'TernarySystem ',& ! 30 above, ------------------- add new tags below ' ',& ! Free ' ',& ' ',& ' ',& ' ',& ' '] !36 !------------------------------------ ! ! All tag attributes are defined below to be easy to modify ! They are in the order of the tags ! XTDB tag attributes ! character (len=18), dimension(nxmltags), parameter :: xmltags=& integer, parameter :: nxtdbatt=4 character (len=9), dimension(nxtdbatt), parameter :: xtdbatt=& ['Version ','Software ','Date ','Signature'] !........... ! Defaults 2 integer, parameter :: ndefatt=9 character (len=18), dimension(ndefatt), parameter :: defatt=& ['LowT ','HighT ','Bibref ',& 'Elements ','DefaultModels ','EEC ',& ' ',' ',' '] !............. ! DatabaseInfo 3 integer, parameter :: ninfoatt=3 character (len=16), dimension(ninfoatt), parameter :: infoatt=& ['Software ','Date ','Signature '] ! 123456789.123456...123456789.123456---123456789.123456 !........... ! AppendXTDB 4 integer, parameter :: nappatt=5,lenappatt=16 character (len=lenappatt), dimension(nappatt), parameter :: appatt=& ['Models ','Parameters ','TPfuns ',& 'Bibligraphy ','Miscellaneous '] ! 123456789.123456...123456789.123456---123456789.123456 !............ ! Element 5 integer, parameter :: nelatt=5 character (len=8), dimension(nelatt), parameter :: elatt=& ['Id ','Refstate','Mass ','H298 ','S298 '] ! 12345678...12345678---12345678---12345678---12345678 !................ ! Species 6 integer, parameter :: nspatt=4 character (len=16), dimension(nspatt), parameter :: spatt=& ['Id ','Stoichiometry ','MQMQA ',& 'UNIQUAC '] !................ ! Tpfun attributes 7 integer, parameter :: ntpatt=4 character (len=8),dimension(ntpatt), parameter :: tpatt=& ['Id ','LowT ','Expr ','HighT '] ! 12345678...12345678---12345678---12345678 ! Trange attributes 8 integer, parameter :: ntratt=2 character (len=8),dimension(ntratt), parameter :: tratt=& ['Expr ','HighT '] !............. ! Phase attributes 9 integer, parameter :: nphatt=3 character (len=16),dimension(nphatt), parameter :: phatt=& ['Id ','Configuration ','State '] ! 123456789.123456...123456789.123456---123456789.123456 !............. ! Sublattice attributes (nested in the Phase element) 10 integer, parameter :: nsubatt=3 character (len=16),dimension(nsubatt), parameter :: subatt=& ['NumberOf ','Multiplicities ','WyckoffPosition '] ! 123456789.123456...123456789.123456---123456789.123456 !............. ! Constituents attributes (used inside Phase element) maybe add NN index 11 integer, parameter :: nconatt=2 character (len=16),dimension(nconatt), parameter :: conatt=& ['Sublattice ','List '] !............... ! CrystalStructure attributes (used inside Phase element) 12 integer, parameter :: ncrystatt=4 character (len=16),dimension(ncrystatt), parameter :: crystatt=& ['Prototype ','PearsonSymbol ','SpaceGroup ',& 'StructurBericht '] !............. ! AmendPhase attributes 13 integer, parameter :: namphatt=2 character (len=12),dimension(namphatt), parameter :: amphatt=& ['Model ','Permutation '] ! 123456789.12---123456789.12---123456789.12 !.............. ! Appendix tag 14 ! Begin and end tag in an appended XTDB file (except Bibliograpy) ! integer, parameter :: npermatt=0 ! character (len=8),dimension(npermatt), parameter :: permatt=& !............... ! DisorderedPart tag both NEVER model and Disordered_3Parts with Subtract 15 integer, parameter :: ndis=3 character (len=12),dimension(ndis), parameter :: disatt=& ['Disordered ','Sum ','Subtract '] ! 123456789.12---123456789.12---123456789.12 !... ! Unused 16 ! integer, parameter :: ndis3=2 ! character (len=12),dimension(ndis3), parameter :: dis3att=& !................ ! Parameter attributes, Id is as in TDB files 17 integer, parameter :: npar=5 character (len=8),dimension(npar), parameter :: paratt=& ['Id ','LowT ','Expr ','HighT ','Bibref '] !.......... ! Parameter2 attributes (not supported by OC) 18 integer, parameter :: npar2=7 character (len=8),dimension(npar2), parameter :: par2att=& ['Id ','MPID ','Phase ','LowT ','Expr ',& 'HighT ','Bibref '] ! 12345678---12345678...12345678---12345678---12345678 !................ ! Bibliography has no attributes contains only Bibitem elements !................ ! Bibitem attributes. They provide reference to parameters and models 19 integer, parameter :: nbibatt=4 character (len=8),dimension(nbibatt), parameter :: bibattt=& ['Id ','Text ','Date ','Sign '] ! 12345678---12345678...12345678---12345678---12345678 !................... ! UnarySystem 20 integer, parameter :: nuniatt=2 character (len=8), dimension(nuniatt), parameter :: uniatt=& ['Element ','Bibref '] !.................... ! BinarySystem attributes. The Species is two elements separated by a space 21 ! The CalcDia attribute is a software depenednt command string integer, parameter :: nbinatt=3 character (len=8),dimension(nbinatt), parameter :: binatt=& ['Species ','Bibref ','CalcDia '] ! 12345678---12345678...12345678---12345678---12345678 !.................... ! TernarySystem attributes. The Species is 3 elements separated by a space 22 ! The CalcDia attribute is a software depenednt command string integer, parameter :: nteratt=3 character (len=8),dimension(nteratt), parameter :: teratt=& ['Species ','Bibref ','CalcDia '] ! 12345678---12345678...12345678---12345678---12345678 !================================================================ ! Attributes: !================================================================ ! The AmedPhase model attribute has these values !...................... ! Magnetic model attributes Id="IHJBCC" or IHJREST or IHJQX integer, parameter :: nmagatt=5 character (len=8),dimension(nmagatt), parameter :: magatt=& ['Id ','MPID1 ','MPID2 ','MPID3 ','Bibref '] ! 12345678---12345678...12345678---12345678---12345678 !...................... ! Einstein attributes Id="GEIN" integer, parameter :: ngeinatt=3 character (len=8),dimension(ngeinatt), parameter :: geinatt=& ['Id ','MPID ','Bibref '] ! 12345678---12345678...12345678 !..................... ! Liquid2state attributes, Id="LIQ2STATE" integer, parameter :: nliq2att=4 character (len=8), dimension(nliq2att), parameter :: liq2att=& ['Id ','MPID1 ','MPID2 ','Bibref '] !....................... ! Volume, ID="XGL05" not implemented in OC integer, parameter :: nvolatt=5 character (len=8),dimension(nvolatt), parameter :: volattt=& ['Id ','MPID1 ','MPID2 ','MPID3 ','Bibref '] ! 12345678...12345678...12345678...12345678...12345678 !................... ! EEC attributes, Id="EEC" integer, parameter :: neccatt=2 character (len=8), dimension(neccatt), parameter :: eecatt=& ['Id ','Bibref '] !.................. ! TernaryXpol attributes. integer, parameter :: nterxpolatt=3 character (len=8), dimension(nterxpolatt), parameter :: terxpolatt=& ['Phase ','System ','Xmode '] ! 12345678---12345678...12345678---12345678---12345678 !.................... !========================================================= ! ! Current list of MPID in OC, related to the models integer, parameter :: noofmpid=9 character (len=8), dimension(noofmpid), parameter :: mpidok=& ['G ','TC ','BMAG ','CT ','NT ','IBM ',& 'LNTH ','G2 ','L '] ! 8 12345678---12345678...12345678---12345678---12345678---12345678 ! The L is in princple allowed only for excess G parameters but treated as G ! IBM was intended for element specific magneton number .... ! model MPID index ! IHJBCC 2 3 ! IHJREST 2 3 ! IHJQX 3 4 5 ! GEIN 7 ! LIQUD2STATE 7 8 ! ! OLD list of MPID, some may have a constituent/element ! character (len=8), dimension(36), parameter :: mpidw=& ! ['G ','TC ','BMAG ','CT ','NT ','IBM ',& ! 'LNTH ','V0 ','VA ','VB ','VC ','VS ',& ! 'MQ ','MF ','MG ','G2 ','THT2 ','DCP2 ',& ! 'LPX ','LPY ','LPZ ','LPTH ','EC11 ','EC12 ',& ! 'RHO ','VISC ','LAMB ','HMVA ','TSCH ','CSCH ',& ! ' ',' ',' ',' ',' ',' '] ! 8 12345678---12345678...12345678---12345678---12345678---12345678 ! ! The meaning of the model parameters is entered in init_gtp in gtp3A.F90 ! ! An attempt to reconcile XTDB handling of models and additions with OC ! Some models/additions has no parameters. Those which has are listed below. ! - DisorderdPart and EBEF has 2 separate sets of parameters (software) ! - Permutations usually use wildcard parameters (with *) to reduce the ! number of duplicate model parameters (software) ! - EBEF is the same as DisorderedPart ! ! All parameters i OC has an MPID index, The parameters for the Gibbs energy ! G (or L) has index 1 (one) !------------------------------------------------ ! ! In OC each parameter has an MPID index stored which is summed ! independently and later used to calculate the addition. ! ! XTDB identifier and MPID OC MPID index and name ! IHJBCC and IHJREST Inden-Hillert-Jarl magnetic model, AFF=-1 and AFF=-3 ! TC 2 TC 4 Curie/Neel T ! BMAGN 3 BMAG 3 Bohr magneton number ! IHJQX Inden-Hillert-Jarl-Qing-Xiong magnetic model, AFF=0 ! CT 4 CTA 4 Curie T ! NT 5 NTA 5 Neel T ! BMAGN 3 BMAG 3 Aver. Bohr magneton num ! GEIN Einstein low T vibrational energy ! LNTH 7 LNTH 2 Einstein T ! LIQ2STATE Merging amorphous low T phase and liguid ! LNTH 7 LNTH 2 Einstein T for amorph. ! GD 16 G2 6 Melting energy of amorph ! FCC4PERM ! BCC4PERM ! FCC4PERM ! FCC4PERM !================================================== ! For the moment we have 9 models ...? INTEGER, parameter :: gtp_xtdbcompatibility_version=1 type gtp_xtdbcompatibility character(len=:), allocatable :: modelid ! this character has the MPID used in the xtdb file character*8, dimension(:), allocatable :: mpid integer nmpid ! this character has the default MPID used by oc character*8, dimension(:), allocatable :: ocmpid integer, dimension(:), allocatable :: ocix end type gtp_xtdbcompatibility type(gtp_xtdbcompatibility), dimension(:), allocatable :: xtdbmodel integer, parameter :: nxtdbmpids=9 ! !-------------------------- old below ! Models accepted by OC in the AmendPhase tag integer, parameter ::noofmodels=5 character (len=16), dimension(noofmodels), parameter :: amphmodel=& ! 8 123456789.123456---123456789.123456---123456789.123456 ['IHJBCC ','IHJREST ','IHJQX ',& 'GEIN ','LIQ2STATE '] ! Permutations accepted by OC in the AmendPhase tag integer, parameter :: noofpermut=2 character (len=16), dimension(noofpermut), parameter :: amphpermut=& ['FCC4PERM ','BCC4PERM '] ! ! IHJBCC 1 Inden-Hillert-Jarl for BCC with Aff=-1 ! IHJREST 1 Inden-Hillert-Jarl for other with Aff=-3 ! IHJQX 2 Inden-Hillert-Jarl-Qing-Xiong with Aff=0 ! GEIN 4 Einstein low T ! LIQ2STATE 5 Liquid 2 state model ! VLOWP1 7 Low P volome model according to Lu? ! ! These have no parameters and are treated in another way ! DISORDEREDPART same as TDB file DISORDERED_PART and NEVER ! FCC4PERM FCC symmetric tetrahedron permutations ! BCC4PERM BCC asymmetric tetrahedron permutations ! EEC Equi Entropy Criterion is set by Delfaults ! EBEF Effective Bond Energy Formalism may use "species@sublattice" ! !--------------- end of old !========================================================= ! Predefined functions in TPfuns integer, parameter :: predeftpfun=5 character*8, dimension(predeftpfun), parameter :: nottpfun= & ['LN ','LOG ','EXP ','ERF ','GEIN '] ! LN and LOG is the same thing, LOG10 is not used. ! TPfun have these hardcoded in xmlmake ! !========================================================= ! There is a need to handle the Model feature of XTDB with different ! software and data structure in applocation software. The data structures ! here and below is for temporary use reading xtdb file !======================================================== ! type const ! list of constituents in each sublattice of a phase, used in phnest character (len=:), allocatable :: subx character (len=:), allocatable :: list end type const ! type(const), allocatable, target :: constrec type phnest ! all data needed to create the phase record before entering parameters integer ncon character*1 state character (len=:), allocatable :: id character (len=:), allocatable :: confent ! when reading Noof here one allocates the dimension of clist !! character (len=:), allocatable :: Noof ! The mult remain character until the phase recond is allocated character (len=:), allocatable :: mult ! for each sublattice clist will be allocated with the constituents! ! Each array element can have a differnt number of characters!! type(const), dimension(:), pointer :: clist character (len=:), allocatable :: crystal ! The model Id is the amendph character (len=:), allocatable :: amendph ! this is the attributes from the XTDB file for disordered part ! disordered phase, sublattices to sum and if subtract ordered as disordered character (len=:), allocatable :: dispar end type phnest type(phnest), allocatable :: phrec ! ! Attributes for AppendXTDB files. The *appy indicate if todo (-1) or done 1 character*64 modelappx,parappx,tpfunappx,biblioappx,miscappx integer modelappy,parappy,tpfunappy,biblioappy,miscappy,allappy ! !------------------------------------------------------------ ! global parameter copied from modile xtdblib in xtdbread.F90 itself ! ! ! used positions in attpos ?? line number in current file integer attpos,fline ! maximum number of nested tags integer, parameter :: maxlevels=10,commenttag=999 ! tagnest(level) is negative, -tagno, if more attributes for tagno to read integer, dimension(maxlevels) :: tagnest ! tagnames have max length 18, the endoftag is set to '' character(len=21), dimension(maxlevels) :: endoftag ! ! an expression will be concatinated from TPfun/Trange and Parameter/Trange tags character(len=:), allocatable :: wholexpr character(len=:), allocatable :: cc ! set to .true. when reading subsets of the XTDB file logical ignorEOT ! TPfuns are used in parameters. All TPfun for entered parameters must be found integer, parameter :: maxtpfun=500 integer ntp,missingtp,missingbib ! alltpfun are names of all tpfuns missing or entered ! the extracted data for software stored in these records ! these integers are the last entered element, species etc. ! integer nselel,nselsp,nselph,nselpar,nseltp,nselbib ! nselph already defined in gtp3 integer nselel,nselsp,nselpar,nseltp,nselbib type ocelement character*2 elname character(len=:), allocatable :: data end type ocelement type(ocelement), dimension(:), allocatable :: selel type ocspecies character*24 species character(len=:), allocatable :: data character*2, dimension(:), allocatable :: elnames double precision, dimension(:), allocatable :: stoicc ! electric charge double precision :: charge ! mqmqa or uniquac character(len=:), allocatable :: extra end type ocspecies type(ocspecies), dimension(:), allocatable :: selsp ! this array will have the selsp indices in alpahetical order integer, dimension(:), allocatable :: selspord type ocphases character*24 phasename integer nsublat ! in this array only selected constituents are entered character(len=:), allocatable :: mult character(len=:), allocatable :: const character(len=:), allocatable :: confent character(len=:), allocatable :: amendph character(len=:), allocatable :: dispar character(len=:), allocatable :: data type(octerxpol), pointer :: terxpol end type ocphases type(ocphases), dimension(:), allocatable :: selph type ocxparam character*64 parname character(len=:), allocatable :: data end type ocxparam type(ocxparam), dimension(:), allocatable :: selpar type octpfun character*16 tpfunname character(len=:), allocatable :: data ! seltp(*)%tatus is negative if missing integer status end type octpfun type(octpfun), dimension(:), allocatable :: seltpfun type ocbib character*8 bibitem character(len=:), allocatable :: data integer status end type ocbib type(ocbib), dimension(:), allocatable :: selbib character(len=:), allocatable :: defaultbib type octerxpol ! ternary extrapolation linked from the phase ! The ternaryXpol tags with selected constituents are stored in these records. ! If the phase is already selected they are added to the texpol list ! otherwise kept in the firstxpol list until the phase is entered character(len=:), allocatable :: phase character(len=:), allocatable :: sps character(len=:), allocatable :: xpol type(octerxpol), pointer :: next end type octerxpol logical debug ! this is the start of a linked list of ternary extrapolations ! waiting for the phase to be selected. Typically it contains TernaryXpol ! what are defined inside the Phase tag itself type(octerxpol), pointer :: firstxpol,lastxpol,xpol ! When first phase entered we must not enter more elements/species logical nomorelements ! for dimensioning these arrays and amount used integer maxtdbel, maxtdbsp, maxtdbph, maxpar, maxtp, maxbib ================================================ FILE: src/models/ocparam.F90 ================================================ MODULE OCPARAM IMPLICIT NONE !\begin{verbatim} !---------------------------------------------------------------------- ! Version numbers !---------------------------------------------------------------------- ! version number of GTP (not OC) character*8, parameter :: gtpversion='GTP-3.31' ! THIS MUST BE CHANGED WHENEVER THE UNFORMATTED FILE FORMAT CHANGES!!! character*8, parameter :: savefile='OCF-3.20' ! !---------------------------------------------------------------------- ! ! Parameters defining the size of arrays etc. ! max elements, species, phases, sublattices, constituents (ideal phase) ! NOTE increasing maxph to 600 and maxtpf to 80*maxph made the equilibrium ! record very big and created problems storing equilibria at STEP/MAP!!! integer, parameter :: maxel=100,maxsp=1000,maxph=600,maxsubl=10,maxconst=1000 ! maximum number of constituents in non-ideal phase integer, parameter :: maxcons2=300 ! maximum number of elements in a species integer, parameter :: maxspel=10 ! maximum number of references integer, parameter :: maxrefs=1000 ! maximum number of equilibria integer, parameter :: maxeq=900 ! some dp values, default precision of Y and default minimum value of Y ! zero and one set in tpfun double precision, parameter :: YPRECD=1.0D-6,YMIND=1.0D-30 ! dimension for push/pop in calcg, max composition dependent interaction integer, parameter :: maxpp=1000,maxinter=3 ! max number of TP symbols, TOO BIG VALUE MAKES SAVE AT STEP/MAP DIFFICULT integer, parameter :: maxtpf=20*maxph ! integer, private, parameter :: maxtpf=80*maxph ! max number of properties (G, TC, BMAG MQ%(...) etc) integer, parameter :: maxprop=50 ! max number of state variable functions integer, parameter :: maxsvfun=500 double precision, parameter :: zero=0.0D0,one=1.0D0,two=2.0D0,ten=1.D1 !---------------------------------------------------------------------- ! Numerical parameters !---------------------------------------------------------------------- integer, parameter :: default_splitsolver = 0 ! 1 to allow to split the linear system when conditions leads to square matrix integer, parameter :: default_precondsolver = 0 ! 1 to allow to use a Jacobi preconditionner for solving the linear system ! !---------------------------------------------------------------------- ! convergence criteria used in matsmin.F90 !---------------------------------------------------------------------- ! !!!!!!! !! meq_phaseset subroutine !!!!!!! integer, parameter :: default_nochange = 4 ! minimum number of iterations between a change of the set of stable phases ! should not be smaller than default_minadd/default_minrem integer, parameter :: default_minadd=4 integer, parameter :: default_minrem=4 ! double precision, parameter :: default_addchargedphase = 1.D-2 !Used to verify: charge(phase) > 1.0D-2 !That is, checking that the phase to be added does not have a net charge ! !!!!!!! !! meq_sameset subroutine !!!!!!! integer, parameter :: default_typechangephaseamount = 0 ! By default, 0 leads to default_scalechangephaseamount=1.0 ! 1 leads to default_scalechangephaseamount=sum of prescribed conditions -/+ 1 ! 2 leads to default_scalechangephaseamount=max of (1, max of prescribed conditions) double precision, parameter :: default_scalechangephaseamount = 1.0 ! scale all changes in phase amount with total number of atoms. By default, ! assume this is unity. double precision, parameter :: default_ylow = 1.D-3 ! parameter added to avoid too drastic jumps in small site fractions ! normalizing factor, if y < ylow .... ! double precision, parameter :: default_ymin = 1.D-12 ! parameter added to avoid too drastic jumps in small site fractions ! double precision, parameter :: default_ymingas = 1.D-30 ! parameter added for gases, since the phase one must allow smaller ! constituent fracs normalizing factor, if y < critymingas then y = cirtymingas ! double precision, parameter :: default_ionliqyfact = 3.D-1 ! this is an emergecy fix to improve convergence for ionic liquid ! correction to site fractions in ionic liquids ! double precision, parameter :: default_deltaTycond=2.5D1 ! this is set each time the set of phases changes, controls change in T ! when there is a condition on y ! integer, parameter :: default_nophasechange = 100 !Criterion on the maximum number of iterations that should go by with ! no change in the set of phases. That is, the system should have at least ! one phase change every default_nophasechange iterations ! double precision, parameter :: default_maxphaseamountchange = 1.0E-10 !Criterion on the minimum of amount of phase change (DeltaN) vis-a-vis ! slow convergence. That is, if the set of stable phases doesn't change, ! and the change in stable phases is lower than default_maxphaseamountchange, ! then this is considered a 'slow convergence case' ! double precision, parameter :: default_bigvalues = 1.0D+50 !Criterion on the maximum element of smat matrix ! Most probably, if something in smat is bigger than default_bigvalues, ! a calculation error has occurred double precision, parameter :: default_minimalchangesT = 1.0D-2 ! minimal change in Temperature allowed when Temperature is variable ! double precision, parameter :: default_limitchangesT = 0.2D0 double precision, parameter :: default_deltaT = 1.0D1 !modified xconv criterion CHECK !Used to verify: DeltaT > default_delatT*%xconv (converged = 8) !Case where T is variable ! double precision, parameter :: default_limitchangesP = 0.2D0 double precision, parameter :: default_deltaP = 1.0D4 !modified xconv criterion CHECK !Used to verify: DeltaP > default_deltaP*%xconv (converged = 8) !Case where P is variable ! double precision, parameter :: default_minimalchangesP = 1.0D-2 ! minimal change in Pressure allowed when Pressure is variable ! double precision, parameter :: default_chargefact = 1.0 ! term added to the correction in site fraction due to electric charge ! integer, parameter :: default_noremove=3 !Criterion on the minimum number of iterations with ! N-DeltaN<0 Before removing the phase in question ! That is, the phase must have a negative quantity for default_noremove ! iterations before being removed ! double precision, parameter :: default_yvar1 = 1.0D-4 ! first limitation to change in site fraction ! double precision, parameter :: default_yvar2 = 1.0D-13 ! second limitation to change in site fraction ! double precision, parameter :: default_upperyvar1 = 1.0D-3 ! limitation to change in site fraction ! normalizing factor, if yvar1 > default_upperyvar1 .... ! then yvar1 = default_upperyvar1 ! double precision, parameter :: default_upperyvar2 = 1.0D-13 ! limitation to change in site fraction ! normalizing factor, if yvar2 > default_upperyvar2 .... ! then yvar2 = default_upperyvar2 ! double precision, parameter :: default_correctionfactorYS = 1.0D1 !multiplier in a criterion !Used to verify: !|Delta y(phase, constituent)(recursion =k)| > ! default_correctionfactorYS*|Delta y(phase, constituent)(recursion =k-1)| ! (converged = 3) ! double precision, parameter :: default_correctionfactorXCONV = 1.0D2 !multiplier in a criterion CHECK !Used to verify: In an unstable phase: ! Delta y(phase, constituent) > default_correctionfactorXCONV*%xconv(converged = 4) ! double precision, parameter :: default_correctionfactorDGM = 1.0 !default_correctionfactorDGM criterion !Used to verify: ! dgm(recursion=k) - dgm(recursion=k-1) > default_correctionfactorDGM ! *gdconv(1) (converged = 4) !Case where more than 10 constituents in the phases are present, ! (apparently) warranting a bigger gdconv(1) ! double precision, parameter :: default_upperycormax2 = 1.0D-4 ! check on max stepsize, determining whether or not it is too small ! integer, parameter :: default_minimaliterations = 4 !Criterion on the minimum number of iterations for the code as a whole ! !!!!!!! !! userif/pmon6.F90, gtp3A.F90 Fortran files !!!!!!! double precision, parameter :: default_maxiter = 500 ! default maximum number of iteration ! double precision, parameter :: default_xconv = 1.D-6 double precision, parameter :: default_minxconv = 1.D-30 ! default and minimal values for ceq%xconv criterion ! double precision, parameter :: default_mingdconv = 1.D-5 double precision, parameter :: default_gdconv1 = 4.D-3 double precision, parameter :: default_gdconv2 = 0.D0 ! default and minimal value for ceq%gdconv(1) criterion ! double precision, parameter :: default_mingridmin = -1.D-2 ! minimal value for ceq%gmindif criterion ! !---------------------------------------------------------------------- ! Physical parameters !---------------------------------------------------------------------- double precision, parameter :: PI = 3.141592653589793D0 !\end{verbatim} END MODULE OCPARAM ================================================ FILE: src/numlib/minpack1.F90 ================================================ ! This extract from MINPACK contains: ! LMDIF1: least square routine ! HYBRD1: solving systems of non-linear equations ! and some support routines ! and calfun calling OC for assessment_calfun for optimization ! !MODULE LIBOCEQPLUS ! MODULE MINPACK ! ! use liboceq ! use minpack2 ! ! ! Minpack Copyright Notice (1999) University of Chicago. All rights reserved ! ! Redistribution and use in source and binary forms, with or ! without modification, are permitted provided that the ! following conditions are met: ! ! 1. Redistributions of source code must retain the above ! copyright notice, this list of conditions and the following ! disclaimer. ! ! 2. Redistributions in binary form must reproduce the above ! copyright notice, this list of conditions and the following ! disclaimer in the documentation and/or other materials ! provided with the distribution. ! ! 3. The end-user documentation included with the ! redistribution, if any, must include the following ! acknowledgment: ! ! "This product includes software developed by the ! University of Chicago, as Operator of Argonne National ! Laboratory. ! ! Alternately, this acknowledgment may appear in the software ! itself, if and wherever such third-party acknowledgments ! normally appear. ! ! 4. WARRANTY DISCLAIMER. THE SOFTWARE IS SUPPLIED "AS IS" ! WITHOUT WARRANTY OF ANY KIND. THE COPYRIGHT HOLDER, THE ! UNITED STATES, THE UNITED STATES DEPARTMENT OF ENERGY, AND ! THEIR EMPLOYEES: (1) DISCLAIM ANY WARRANTIES, EXPRESS OR ! IMPLIED, INCLUDING BUT NOT LIMITED TO ANY IMPLIED WARRANTIES ! OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, TITLE ! OR NON-INFRINGEMENT, (2) DO NOT ASSUME ANY LEGAL LIABILITY ! OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS, OR ! USEFULNESS OF THE SOFTWARE, (3) DO NOT REPRESENT THAT USE OF ! THE SOFTWARE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS, (4) ! DO NOT WARRANT THAT THE SOFTWARE WILL FUNCTION ! UNINTERRUPTED, THAT IT IS ERROR-FREE OR THAT ANY ERRORS WILL ! BE CORRECTED. ! ! 5. LIMITATION OF LIABILITY. IN NO EVENT WILL THE COPYRIGHT ! HOLDER, THE UNITED STATES, THE UNITED STATES DEPARTMENT OF ! ENERGY, OR THEIR EMPLOYEES: BE LIABLE FOR ANY INDIRECT, ! INCIDENTAL, CONSEQUENTIAL, SPECIAL OR PUNITIVE DAMAGES OF ! ANY KIND OR NATURE, INCLUDING BUT NOT LIMITED TO LOSS OF ! PROFITS OR LOSS OF DATA, FOR ANY REASON WHATSOEVER, WHETHER ! SUCH LIABILITY IS ASSERTED ON THE BASIS OF CONTRACT, TORT ! (INCLUDING NEGLIGENCE OR STRICT LIABILITY), OR OTHERWISE, ! EVEN IF ANY OF SAID PARTIES HAS BEEN WARNED OF THE ! POSSIBILITY OF SUCH LOSS OR DAMAGES. ! implicit none double precision, parameter, private :: zero=0.0d0 ! contains ! ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ subroutine lmdif1(fcn,m,n,x,fvec,tol,info,nfev,iwa,wa,lwa,fjac,err0) ! call modified by Bo Sundman 2017, modified again 2018 to include fcn ! nfev is number of calls to fcn ! subroutine lmdif1( m,n,x,fvec,tol,info,nfev,iwa,wa,lwa,fjac,err0) ! original: ! subroutine lmdif1(fcn,m,n,x,fvec,tol,info, iwa,wa,lwa) implicit none integer m,n,info,lwa integer iwa(n) double precision tol double precision x(n),fvec(m),wa(lwa),fjac(m,*) external fcn ! ********** ! ! subroutine lmdif1 ! ! the purpose of lmdif1 is to minimize the sum of the squares of ! m nonlinear functions in n variables by a modification of the ! levenberg-marquardt algorithm. this is done by using the more ! general least-squares solver lmdif. the user must provide a ! subroutine which calculates the functions. the jacobian is ! then calculated by a forward-difference approximation. ! ! the subroutine statement is ! ! subroutine lmdif1(fcn,m,n,x,fvec,tol,info,iwa,wa,lwa) ! ! where ! ! fcn is the name of the user-supplied subroutine which ! calculates the functions. fcn must be declared ! in an external statement in the user calling ! program, and should be written as follows. ! ! subroutine fcn(m,n,x,fvec,iflag) ! modified to include iterations: subroutine fcn(m,n,x,fvec,iflag,nfev) ! integer m,n,iflag,nfev ! double precision x(n),fvec(m) ! ---------- ! calculate the functions at x and ! return this vector in fvec. ! ---------- ! return ! end ! ! the value of iflag should not be changed by fcn unless ! the user wants to terminate execution of lmdif1. ! in this case set iflag to a negative integer. ! ! m is a positive integer input variable set to the number ! of functions. ! ! n is a positive integer input variable set to the number ! of variables. n must not exceed m. ! ! x is an array of length n. on input x must contain ! an initial estimate of the solution vector. on output x ! contains the final estimate of the solution vector. ! ! fvec is an output array of length m which contains ! the functions evaluated at the output x. ! ! tol is a nonnegative input variable. termination occurs ! when the algorithm estimates either that the relative ! error in the sum of squares is at most tol or that ! the relative error between x and the solution is at ! most tol. ! ! info is an integer output variable. if the user has ! terminated execution, info is set to the (negative) ! value of iflag. see description of fcn. otherwise, ! info is set as follows. ! ! info = 0 improper input parameters. ! ! info = 1 algorithm estimates that the relative error ! in the sum of squares is at most tol. ! ! info = 2 algorithm estimates that the relative error ! between x and the solution is at most tol. ! ! info = 3 conditions for info = 1 and info = 2 both hold. ! ! info = 4 fvec is orthogonal to the columns of the ! jacobian to machine precision. ! ! info = 5 number of calls to fcn has reached or ! exceeded 200*(n+1). ! ! info = 6 tol is too small. no further reduction in ! the sum of squares is possible. ! ! info = 7 tol is too small. no further improvement in ! the approximate solution x is possible. ! ! iwa is an integer work array of length n. ! ! wa is a work array of length lwa. ! ! lwa is a positive integer input variable not less than ! m*n+5*n+m. ! ! fjac added to calculate relative standard deviation (SD) ! ! subprograms called ! ! user-supplied ...... fcn ! ! minpack-supplied ... lmdif ! ! argonne national laboratory. minpack project. march 1980. ! burton s. garbow, kenneth e. hillstrom, jorge j. more ! ! ********** integer maxfev,mode,mp5n,nfev,nprint ! double precision epsfcn,factor,ftol,gtol,xtol,zero ! err0 contains intitial sum of error and last sum of errors double precision epsfcn,ftol,gtol,xtol,err0(*) ! data factor,zero /1.0d2,0.0d0/ ! zero already defined globally double precision :: factor=1.0D2,zero=0.0D0 ! number of iterations passed through infor maxfev=info info = 0 ! write(*,*)'in lmdif1',maxfev,m,n ! ! check the input parameters for errors. ! if (n .le. 0 .or. m .lt. n .or. tol .lt. zero & .or. lwa .lt. m*n + 5*n + m) then write(*,12)n,m,lwa,m*n+5*n+m,tol 12 format(' *** LMDIF1 error: illegal call: ',4i6,1pe12.4) go to 10 endif ! ! call lmdif. ! info=0 ! several of these moved to lmdif ... as well as allocating workspace ftol = tol xtol = tol gtol = zero epsfcn = zero mode = 1 ! This controls output during optimization, output must be added to calfun ! nprint = 0 nprint=1 mp5n = m + 5*n ! write(*,*)'Calling lmdif1',maxfev ! call lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn,wa(1), & ! mode,factor,nprint,info,nfev,wa(mp5n+1),m,iwa, & ! wa(n+1),wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1)) ! remove fcn and reduce number of arguments and linker chokes ... ! write(*,*)'minpack: lmdif1 call lmdif',m,n call lmdif(fcn,m,n,x,fvec,tol,maxfev, & mode,factor,nprint,info,nfev,fjac,iwa,err0) ! call lmdif(m,n,x,fvec,tol,maxfev, & ! mode,factor,nprint,info,nfev,fjac,iwa,err0) if (info .eq. 8) info = 4 ! write(*,*)'Return from lmdif with info= ',info 10 continue return ! ! last card of subroutine lmdif1. ! end subroutine lmdif1 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ ! subroutine fdjac2(m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa) subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa) implicit none integer m,n,ldfjac,iflag double precision epsfcn double precision x(n),fvec(m),fjac(ldfjac,n),wa(m) ! ********** ! ! subroutine fdjac2 ! ! this subroutine computes a forward-difference approximation ! to the m by n jacobian matrix associated with a specified ! problem of m functions in n variables. ! ! the subroutine statement is ! ! subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa) ! ! where ! ! fcn is the name of the user-supplied subroutine which ! calculates the functions. fcn must be declared ! in an external statement in the user calling ! program, and should be written as follows. ! ! subroutine fcn(m,n,x,fvec,iflag) ! BOSSE modified to include iterations: subroutine fcn(m,n,x,fvec,iflag,nfevdum) ! integer m,n,iflag,niter ! double precision x(n),fvec(m) ! ---------- ! calculate the functions at x and ! return this vector in fvec. ! ---------- ! return ! end ! ! the value of iflag should not be changed by fcn unless ! the user wants to terminate execution of fdjac2. ! in this case set iflag to a negative integer. ! ! m is a positive integer input variable set to the number ! of functions. ! ! n is a positive integer input variable set to the number ! of variables. n must not exceed m. ! ! x is an input array of length n. ! ! fvec is an input array of length m which must contain the ! functions evaluated at x. ! ! fjac is an output m by n array which contains the ! approximation to the jacobian matrix evaluated at x. ! ! ldfjac is a positive integer input variable not less than m ! which specifies the leading dimension of the array fjac. ! ! iflag is an integer variable which can be used to terminate ! the execution of fdjac2. see description of fcn. ! ! epsfcn is an input variable used in determining a suitable ! step length for the forward-difference approximation. this ! approximation assumes that the relative errors in the ! functions are of the order of epsfcn. if epsfcn is less ! than the machine precision, it is assumed that the relative ! errors in the functions are of the order of the machine ! precision. ! ! wa is a work array of length m. ! ! subprograms called ! ! user-supplied ...... fcn ! ! minpack-supplied ... dpmpar ! ! fortran-supplied ... dabs,dmax1,dsqrt ! ! argonne national laboratory. minpack project. march 1980. ! burton s. garbow, kenneth e. hillstrom, jorge j. more ! ! ********** integer i,j double precision eps,epsmch,h,temp ! double precision eps,epsmch,h,temp,zero ! integer, parameter :: niter=0 ! added as argumnet added to fcn but treated as dummy in fcn ... integer :: nfevdum=-100 ! missing external declaration external fcn ! double precision dpmpar ! data zero /0.0d0/ ! ! epsmch is the machine precision. ! epsmch = dpmpar(1) ! eps = dsqrt(dmax1(epsfcn,epsmch)) ! write(*,17)'epsis: ',0,epsfcn,epsmch,eps ! eps=1.0D-4 ! do 20 j = 1, n do j = 1, n temp = x(j) h = eps*dabs(temp) if (h .eq. zero) h = eps ! write(*,17)'In fdjac2: ',j,temp,h,eps !17 format(a,i2,6(1pe12.4)) x(j) = temp + h ! call fcn(m,n,x,wa,iflag) <<<<<<<<<<<< original ! NOTE dummy should be ignored when -100 in fcn (CALFUN) call fcn(m,n,x,wa,iflag,nfevdum) ! call calfun(m,n,x,wa,iflag,niter) if (iflag .lt. 0) go to 30 x(j) = temp ! do 10 i = 1, m do i = 1, m fjac(i,j) = (wa(i) - fvec(i))/h enddo enddo ! 10 continue ! 20 continue 30 continue return ! ! last card of subroutine fdjac2. ! end subroutine fdjac2 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ ! subroutine lmdif(m,n,x,fvec,xtol,maxfev, & subroutine lmdif(fcn,m,n,x,fvec,xtol,maxfev, & mode,factor,nprint,info,nfev,fjac,ipvt,err0) ! removed arguments as linker chokes ... ! subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn,diag, & ! mode,factor,nprint,info,nfev,fjac,ldfjac, & ! ipvt,qtf,wa1,wa2,wa3,wa4) implicit none integer m,n,maxfev,mode,nprint,info,nfev,ldfjac integer ipvt(n) double precision ftol,xtol,gtol,epsfcn,factor,err0(*) double precision x(n),fvec(m),fjac(m,*) ! double precision x(n),fvec(m),diag(n),fjac(ldfjac,n),qtf(n), & ! double precision x(n),fvec(m),diag(n),fjac(ldfjac,n),qtf(n), & ! wa1(n),wa2(n),wa3(n),wa4(m) external fcn ! ********** double precision, dimension(:), allocatable :: diag,qtf,wa1,wa2,wa3,wa4 ! double precision, dimension(:,:), allocatable :: fjac ! ! subroutine lmdif ! ! the purpose of lmdif is to minimize the sum of the squares of ! m nonlinear functions in n variables by a modification of ! the levenberg-marquardt algorithm. the user must provide a ! subroutine which calculates the functions. the jacobian is ! then calculated by a forward-difference approximation. ! ! the subroutine statement is ! ! subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn, ! diag,mode,factor,nprint,info,nfev,fjac, ! ldfjac,ipvt,qtf,wa1,wa2,wa3,wa4) ! ! where ! ! fcn is the name of the user-supplied subroutine which ! calculates the functions. fcn must be declared ! in an external statement in the user calling ! program, and should be written as follows. ! ! subroutine fcn(m,n,x,fvec,iflag) ! modified to iiterations: subroutine fcn(m,n,x,fvec,iflag,niter) ! integer m,n,iflag,niter ! double precision x(n),fvec(m) ! ---------- ! calculate the functions at x and ! return this vector in fvec. ! ---------- ! return ! end ! ! the value of iflag should not be changed by fcn unless ! the user wants to terminate execution of lmdif. ! in this case set iflag to a negative integer. ! ! m is a positive integer input variable set to the number ! of functions. ! ! n is a positive integer input variable set to the number ! of variables. n must not exceed m. ! ! x is an array of length n. on input x must contain ! an initial estimate of the solution vector. on output x ! contains the final estimate of the solution vector. ! ! fvec is an output array of length m which contains ! the functions evaluated at the output x. ! ! ftol is a nonnegative input variable. termination ! occurs when both the actual and predicted relative ! reductions in the sum of squares are at most ftol. ! therefore, ftol measures the relative error desired ! in the sum of squares. ! ! xtol is a nonnegative input variable. termination ! occurs when the relative error between two consecutive ! iterates is at most xtol. therefore, xtol measures the ! relative error desired in the approximate solution. ! ! gtol is a nonnegative input variable. termination ! occurs when the cosine of the angle between fvec and ! any column of the jacobian is at most gtol in absolute ! value. therefore, gtol measures the orthogonality ! desired between the function vector and the columns ! of the jacobian. ! ! maxfev is a positive integer input variable. termination ! occurs when the number of calls to fcn is at least ! maxfev by the end of an iteration. ! ! epsfcn is an input variable used in determining a suitable ! step length for the forward-difference approximation. this ! approximation assumes that the relative errors in the ! functions are of the order of epsfcn. if epsfcn is less ! than the machine precision, it is assumed that the relative ! errors in the functions are of the order of the machine ! precision. ! ! diag is an array of length n. if mode = 1 (see ! below), diag is internally set. if mode = 2, diag ! must contain positive entries that serve as ! multiplicative scale factors for the variables. ! ! mode is an integer input variable. if mode = 1, the ! variables will be scaled internally. if mode = 2, ! the scaling is specified by the input diag. other ! values of mode are equivalent to mode = 1. ! ! factor is a positive input variable used in determining the ! initial step bound. this bound is set to the product of ! factor and the euclidean norm of diag*x if nonzero, or else ! to factor itself. in most cases factor should lie in the ! interval (.1,100.). 100. is a generally recommended value. ! ! nprint is an integer input variable that enables controlled ! printing of iterates if it is positive. in this case, ! fcn is called with iflag = 0 at the beginning of the first ! iteration and every nprint iterations thereafter and ! immediately prior to return, with x and fvec available ! for printing. if nprint is not positive, no special calls ! of fcn with iflag = 0 are made. ! ! info is an integer output variable. if the user has ! terminated execution, info is set to the (negative) ! value of iflag. see description of fcn. otherwise, ! info is set as follows. ! ! info = 0 improper input parameters. ! ! info = 1 both actual and predicted relative reductions ! in the sum of squares are at most ftol. ! ! info = 2 relative error between two consecutive iterates ! is at most xtol. ! ! info = 3 conditions for info = 1 and info = 2 both hold. ! ! info = 4 the cosine of the angle between fvec and any ! column of the jacobian is at most gtol in ! absolute value. ! ! info = 5 number of calls to fcn has reached or ! exceeded maxfev. ! ! info = 6 ftol is too small. no further reduction in ! the sum of squares is possible. ! ! info = 7 xtol is too small. no further improvement in ! the approximate solution x is possible. ! ! info = 8 gtol is too small. fvec is orthogonal to the ! columns of the jacobian to machine precision. ! ! nfev is an integer output variable set to the number of ! calls to fcn. ! ! fjac is an output m by n array. the upper n by n submatrix ! of fjac contains an upper triangular matrix r with ! diagonal elements of nonincreasing magnitude such that ! ! t t t ! p *(jac *jac)*p = r *r, ! ! where p is a permutation matrix and jac is the final ! calculated jacobian. column j of p is column ipvt(j) ! (see below) of the identity matrix. the lower trapezoidal ! part of fjac contains information generated during ! the computation of r. ! ! ldfjac is a positive integer input variable not less than m ! which specifies the leading dimension of the array fjac. ! ! ipvt is an integer output array of length n. ipvt ! defines a permutation matrix p such that jac*p = q*r, ! where jac is the final calculated jacobian, q is ! orthogonal (not stored), and r is upper triangular ! with diagonal elements of nonincreasing magnitude. ! column j of p is column ipvt(j) of the identity matrix. ! ! qtf is an output array of length n which contains ! the first n elements of the vector (q transpose)*fvec. ! ! wa1, wa2, and wa3 are work arrays of length n. ! ! wa4 is a work array of length m. ! ! subprograms called ! ! user-supplied ...... fcn ! ! minpack-supplied ... dpmpar,enorm,fdjac2,lmpar,qrfac ! ! fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod ! ! argonne national laboratory. minpack project. march 1980. ! burton s. garbow, kenneth e. hillstrom, jorge j. more ! ! ********** integer i,iflag,iter,j,l double precision actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm, & par,pnorm,prered,ratio, & sum,temp,temp1,temp2,xnorm,bosum ! removed variables one line above ! one,par,pnorm,prered,p1,p5,p25,p75,p0001,ratio, & ! if the functions dpmpar and enorm are declared here strange link error ... ! double precision dpmpar,enorm ! data one,p1,p5,p25,p75,p0001,zero & ! /1.0d0,1.0d-1,5.0d-1,2.5d-1,7.5d-1,1.0d-4,0.0d0/ double precision :: one=1.0D0 double precision :: p1=1.0D-1,p5=5.0D-1,p25=2.5D-1,p75=7.5D-1,p0001=1.0D-4 ! ! write(*,*)'minpack: in lmdif A: ',n,m ! replace removed arguments ldfjac=m ftol=xtol gtol=zero epsfcn=zero allocate(diag(n)) allocate(qtf(n)) allocate(wa1(n)) allocate(wa2(n)) allocate(wa3(n)) allocate(wa4(m)) ! now included in call ! allocate(fjac(ldfjac,n)) ! ! epsmch is the machine precision. ! epsmch = dpmpar(1) ! info = 0 iflag = 0 nfev = 0 ! ! check the input parameters for errors. ! ! modified to run once if maxfev=0 (dry run) ! write(*,*)'In lmdif C: maxfev=',maxfev,m,n if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. m & .or. ftol .lt. zero .or. xtol .lt. zero .or. gtol .lt. zero & .or. maxfev .lt. 0 .or. factor .le. zero) go to 300 if (mode .ne. 2) go to 20 do j = 1, n if (diag(j) .le. zero) go to 300 enddo ! 10 continue 20 continue ! ! evaluate the function at the starting point ! and calculate its norm. ! iflag = 1 ! call fcn(m,n,x,fvec,iflag) <<<<<<<<<<< original ! call calfun(m,n,x,fvec,iflag,nfev) ! write(*,*)'minpack: lmdif call fcn 1: ',n,m call fcn(m,n,x,fvec,iflag,nfev) ! calculate intial sum of errors ! write(*,*)'lmdif back from calfun',nfev bosum=zero do j=1,m bosum=bosum+fvec(j)**2 enddo err0(1)=bosum !-------------------------- nfev = 1 if (iflag .lt. 0) go to 300 if(maxfev .eq. 0) goto 300 fnorm = enorm(m,fvec) ! ! initialize levenberg-marquardt parameter and iteration counter. ! par = zero iter = 1 ! ! beginning of the outer loop. ! 30 continue ! ! calculate the jacobian matrix. ! iflag = 2 ! write(*,*)'minpack: lmdif call fdjac2 1: ',n,m call fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa4) ! call fdjac2(m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa4) nfev = nfev + n if (iflag .lt. 0) go to 300 ! ! if requested, call fcn to enable printing of iterates. ! if (nprint .le. 0) go to 40 iflag = 0 if (mod(iter-1,nprint) .eq. 0) then ! call calfun(m,n,x,fvec,iflag,nfev) ! write(*,*)'minpack: lmdif call fcn 3: ',n,m call fcn(m,n,x,fvec,iflag,nfev) endif ! if (mod(iter-1,nprint) .eq. 0) call fcn(m,n,x,fvec,iflag) if (iflag .lt. 0) go to 300 40 continue ! ! compute the qr factorization of the jacobian. ! call qrfac(m,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2,wa3) ! ! on the first iteration and if mode is 1, scale according ! to the norms of the columns of the initial jacobian. ! if (iter .ne. 1) go to 80 if (mode .eq. 2) go to 60 ! do 50 j = 1, n do j = 1, n diag(j) = wa2(j) if (wa2(j) .eq. zero) diag(j) = one enddo ! 50 continue 60 continue ! ! on the first iteration, calculate the norm of the scaled x ! and initialize the step bound delta. ! do j = 1, n wa3(j) = diag(j)*x(j) enddo ! 70 continue xnorm = enorm(n,wa3) delta = factor*xnorm if (delta .eq. zero) delta = factor 80 continue ! ! form (q transpose)*fvec and store the first n components in ! qtf. ! do i = 1, m wa4(i) = fvec(i) enddo !90 continue ! do 130 j = 1, n do j = 1, n if (fjac(j,j) .eq. zero) go to 120 sum = zero ! do 100 i = j, m do i = j, m sum = sum + fjac(i,j)*wa4(i) enddo !100 continue temp = -sum/fjac(j,j) do i = j, m wa4(i) = wa4(i) + fjac(i,j)*temp enddo ! 110 continue 120 continue fjac(j,j) = wa1(j) qtf(j) = wa4(j) enddo !130 continue ! ! compute the norm of the scaled gradient. ! gnorm = zero if (fnorm .eq. zero) go to 170 ! do 160 j = 1, n do j = 1, n l = ipvt(j) if (wa2(l) .eq. zero) go to 150 sum = zero do i = 1, j sum = sum + fjac(i,j)*(qtf(i)/fnorm) enddo ! 140 continue gnorm = dmax1(gnorm,dabs(sum/wa2(l))) 150 continue enddo !160 continue 170 continue ! ! test for convergence of the gradient norm. ! if (gnorm .le. gtol) info = 4 if (info .ne. 0) go to 300 ! ! rescale if necessary. ! if (mode .eq. 2) go to 190 do j = 1, n diag(j) = dmax1(diag(j),wa2(j)) enddo !180 continue 190 continue ! ! beginning of the inner loop. ! 200 continue ! ! determine the levenberg-marquardt parameter. ! call lmpar(n,fjac,ldfjac,ipvt,diag,qtf,delta,par,wa1,wa2, & wa3,wa4) ! ! store the direction p and x + p. calculate the norm of p. ! ! do 210 j = 1, n do j = 1, n wa1(j) = -wa1(j) wa2(j) = x(j) + wa1(j) wa3(j) = diag(j)*wa1(j) enddo !210 continue pnorm = enorm(n,wa3) ! ! on the first iteration, adjust the initial step bound. ! if (iter .eq. 1) delta = dmin1(delta,pnorm) ! ! evaluate the function at x + p and calculate its norm. ! iflag = 1 ! call fcn(m,n,wa2,wa4,iflag) ! call calfun(m,n,wa2,wa4,iflag,nfev) ! write(*,*)'minpack: lmdif call fcn 3: ',n,m call fcn(m,n,wa2,wa4,iflag,nfev) nfev = nfev + 1 if (iflag .lt. 0) go to 300 fnorm1 = enorm(m,wa4) ! ! compute the scaled actual reduction. ! actred = -one if (p1*fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 ! ! compute the scaled predicted reduction and ! the scaled directional derivative. ! ! do 230 j = 1, n do j = 1, n wa3(j) = zero l = ipvt(j) temp = wa1(l) do i = 1, j wa3(i) = wa3(i) + fjac(i,j)*temp enddo enddo !220 continue !230 continue temp1 = enorm(n,wa3)/fnorm temp2 = (dsqrt(par)*pnorm)/fnorm prered = temp1**2 + temp2**2/p5 dirder = -(temp1**2 + temp2**2) ! ! compute the ratio of the actual to the predicted ! reduction. ! ratio = zero if (prered .ne. zero) ratio = actred/prered ! ! update the step bound. ! if (ratio .gt. p25) go to 240 if (actred .ge. zero) temp = p5 if (actred .lt. zero) & temp = p5*dirder/(dirder + p5*actred) if (p1*fnorm1 .ge. fnorm .or. temp .lt. p1) temp = p1 delta = temp*dmin1(delta,pnorm/p1) par = par/temp go to 260 240 continue if (par .ne. zero .and. ratio .lt. p75) go to 250 delta = pnorm/p5 par = p5*par 250 continue 260 continue ! ! test for successful iteration. ! if (ratio .lt. p0001) go to 290 ! ! successful iteration. update x, fvec, and their norms. ! do j = 1, n x(j) = wa2(j) wa2(j) = diag(j)*x(j) enddo !270 continue do i = 1, m fvec(i) = wa4(i) enddo !280 continue xnorm = enorm(n,wa2) fnorm = fnorm1 iter = iter + 1 290 continue ! ! tests for convergence. ! if (dabs(actred) .le. ftol .and. prered .le. ftol & .and. p5*ratio .le. one) info = 1 if (delta .le. xtol*xnorm) info = 2 if (dabs(actred) .le. ftol .and. prered .le. ftol & .and. p5*ratio .le. one .and. info .eq. 2) info = 3 if (info .ne. 0) go to 300 ! ! tests for termination and stringent tolerances. ! if (nfev .ge. maxfev) info = 5 if (dabs(actred) .le. epsmch .and. prered .le. epsmch & .and. p5*ratio .le. one) info = 6 if (delta .le. epsmch*xnorm) info = 7 if (gnorm .le. epsmch) info = 8 if (info .ne. 0) go to 300 ! ! end of the inner loop. repeat if iteration unsuccessful. ! if (ratio .lt. p0001) go to 200 ! ! end of the outer loop. ! go to 30 300 continue ! ! termination, either normal or user imposed. ! if (iflag .lt. 0) info = iflag iflag = 0 ! write(*,*)'minpack: lmdif call fcn 4: ',n,m,info,maxfev if(maxfev.gt.0) then ! Bosse corrected missing nfev argument 2022.07.12 if (nprint .gt. 0) call fcn(m,n,x,fvec,iflag,nfev) ! if (nprint .gt. 0) call calfun(m,n,x,fvec,iflag,-nfev) else ! Add that calfun called once if maxfev=0 to calculate all errors ! if (maxfev .eq. 0) call calfun(m,n,x,fvec,1,0) call fcn(m,n,x,fvec,1,0) endif ! write(*,*)'minpack: lmdif call fcn 5: ',n,m,maxfev return ! ! last card of subroutine lmdif. ! end subroutine lmdif !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag,wa1, & wa2) implicit none integer n,ldr integer ipvt(n) double precision delta,par double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa1(n), & wa2(n) ! ********** ! ! subroutine lmpar ! ! given an m by n matrix a, an n by n nonsingular diagonal ! matrix d, an m-vector b, and a positive number delta, ! the problem is to determine a value for the parameter ! par such that if x solves the system ! ! a*x = b , sqrt(par)*d*x = 0 , ! ! in the least squares sense, and dxnorm is the euclidean ! norm of d*x, then either par is zero and ! ! (dxnorm-delta) .le. 0.1*delta , ! ! or par is positive and ! ! abs(dxnorm-delta) .le. 0.1*delta . ! ! this subroutine completes the solution of the problem ! if it is provided with the necessary information from the ! qr factorization, with column pivoting, of a. that is, if ! a*p = q*r, where p is a permutation matrix, q has orthogonal ! columns, and r is an upper triangular matrix with diagonal ! elements of nonincreasing magnitude, then lmpar expects ! the full upper triangle of r, the permutation matrix p, ! and the first n components of (q transpose)*b. on output ! lmpar also provides an upper triangular matrix s such that ! ! t t t ! p *(a *a + par*d*d)*p = s *s . ! ! s is employed within lmpar and may be of separate interest. ! ! only a few iterations are generally needed for convergence ! of the algorithm. if, however, the limit of 10 iterations ! is reached, then the output par will contain the best ! value obtained so far. ! ! the subroutine statement is ! ! subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag, ! wa1,wa2) ! ! where ! ! n is a positive integer input variable set to the order of r. ! ! r is an n by n array. on input the full upper triangle ! must contain the full upper triangle of the matrix r. ! on output the full upper triangle is unaltered, and the ! strict lower triangle contains the strict upper triangle ! (transposed) of the upper triangular matrix s. ! ! ldr is a positive integer input variable not less than n ! which specifies the leading dimension of the array r. ! ! ipvt is an integer input array of length n which defines the ! permutation matrix p such that a*p = q*r. column j of p ! is column ipvt(j) of the identity matrix. ! ! diag is an input array of length n which must contain the ! diagonal elements of the matrix d. ! ! qtb is an input array of length n which must contain the first ! n elements of the vector (q transpose)*b. ! ! delta is a positive input variable which specifies an upper ! bound on the euclidean norm of d*x. ! ! par is a nonnegative variable. on input par contains an ! initial estimate of the levenberg-marquardt parameter. ! on output par contains the final estimate. ! ! x is an output array of length n which contains the least ! squares solution of the system a*x = b, sqrt(par)*d*x = 0, ! for the output par. ! ! sdiag is an output array of length n which contains the ! diagonal elements of the upper triangular matrix s. ! ! wa1 and wa2 are work arrays of length n. ! ! subprograms called ! ! minpack-supplied ... dpmpar,enorm,qrsolv ! ! fortran-supplied ... dabs,dmax1,dmin1,dsqrt ! ! argonne national laboratory. minpack project. march 1980. ! burton s. garbow, kenneth e. hillstrom, jorge j. more ! ! ********** integer i,iter,j,jm1,jp1,k,l,nsing double precision dxnorm,dwarf,fp,gnorm,parc,parl,paru,p1,p001, & sum,temp,zero ! double precision dpmpar,enorm data p1,p001,zero /1.0d-1,1.0d-3,0.0d0/ ! ! dwarf is the smallest positive magnitude. ! dwarf = dpmpar(2) ! ! compute and store in x the gauss-newton direction. if the ! jacobian is rank-deficient, obtain a least squares solution. ! nsing = n do j = 1, n wa1(j) = qtb(j) if (r(j,j) .eq. zero .and. nsing .eq. n) nsing = j - 1 if (nsing .lt. n) wa1(j) = zero enddo ! 10 continue if (nsing .lt. 1) go to 50 ! do 40 k = 1, nsing do k = 1, nsing j = nsing - k + 1 wa1(j) = wa1(j)/r(j,j) temp = wa1(j) jm1 = j - 1 if (jm1 .lt. 1) go to 30 do i = 1, jm1 wa1(i) = wa1(i) - r(i,j)*temp enddo !20 continue 30 continue enddo !40 continue 50 continue do j = 1, n l = ipvt(j) x(l) = wa1(j) enddo !60 continue ! ! initialize the iteration counter. ! evaluate the function at the origin, and test ! for acceptance of the gauss-newton direction. ! iter = 0 do j = 1, n wa2(j) = diag(j)*x(j) enddo !70 continue dxnorm = enorm(n,wa2) fp = dxnorm - delta if (fp .le. p1*delta) go to 220 ! ! if the jacobian is not rank deficient, the newton ! step provides a lower bound, parl, for the zero of ! the function. otherwise set this bound to zero. ! parl = zero if (nsing .lt. n) go to 120 do j = 1, n l = ipvt(j) wa1(j) = diag(l)*(wa2(l)/dxnorm) enddo !80 continue ! do 110 j = 1, n do j = 1, n sum = zero jm1 = j - 1 if (jm1 .lt. 1) go to 100 do i = 1, jm1 sum = sum + r(i,j)*wa1(i) enddo !90 continue 100 continue wa1(j) = (wa1(j) - sum)/r(j,j) enddo !110 continue temp = enorm(n,wa1) parl = ((fp/delta)/temp)/temp 120 continue ! ! calculate an upper bound, paru, for the zero of the function. ! ! do 140 j = 1, n do j = 1, n sum = zero do i = 1, j sum = sum + r(i,j)*qtb(i) enddo !130 continue l = ipvt(j) wa1(j) = sum/diag(l) enddo !140 continue gnorm = enorm(n,wa1) paru = gnorm/delta if (paru .eq. zero) paru = dwarf/dmin1(delta,p1) ! ! if the input par lies outside of the interval (parl,paru), ! set par to the closer endpoint. ! par = dmax1(par,parl) par = dmin1(par,paru) if (par .eq. zero) par = gnorm/dxnorm ! ! beginning of an iteration. ! 150 continue iter = iter + 1 ! ! evaluate the function at the current value of par. ! if (par .eq. zero) par = dmax1(dwarf,p001*paru) temp = dsqrt(par) do j = 1, n wa1(j) = temp*diag(j) enddo !160 continue call qrsolv(n,r,ldr,ipvt,wa1,qtb,x,sdiag,wa2) do j = 1, n wa2(j) = diag(j)*x(j) enddo !170 continue dxnorm = enorm(n,wa2) temp = fp fp = dxnorm - delta ! ! if the function is small enough, accept the current value ! of par. also test for the exceptional cases where parl ! is zero or the number of iterations has reached 10. ! if (dabs(fp) .le. p1*delta & .or. parl .eq. zero .and. fp .le. temp & .and. temp .lt. zero .or. iter .eq. 10) go to 220 ! ! compute the newton correction. ! do j = 1, n l = ipvt(j) wa1(j) = diag(l)*(wa2(l)/dxnorm) enddo !180 continue ! do 210 j = 1, n do j = 1, n wa1(j) = wa1(j)/sdiag(j) temp = wa1(j) jp1 = j + 1 if (n .lt. jp1) go to 200 do i = jp1, n wa1(i) = wa1(i) - r(i,j)*temp enddo !190 continue 200 continue enddo !210 continue temp = enorm(n,wa1) parc = ((fp/delta)/temp)/temp ! ! depending on the sign of the function, update parl or paru. ! if (fp .gt. zero) parl = dmax1(parl,par) if (fp .lt. zero) paru = dmin1(paru,par) ! ! compute an improved estimate for par. ! par = dmax1(parl,par+parc) ! ! end of an iteration. ! go to 150 220 continue ! ! termination. ! if (iter .eq. 0) par = zero return ! ! last card of subroutine lmpar. ! end subroutine lmpar !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa) implicit none integer n,ldr integer ipvt(n) double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa(n) ! ********** ! ! subroutine qrsolv ! ! given an m by n matrix a, an n by n diagonal matrix d, ! and an m-vector b, the problem is to determine an x which ! solves the system ! ! a*x = b , d*x = 0 , ! ! in the least squares sense. ! ! this subroutine completes the solution of the problem ! if it is provided with the necessary information from the ! qr factorization, with column pivoting, of a. that is, if ! a*p = q*r, where p is a permutation matrix, q has orthogonal ! columns, and r is an upper triangular matrix with diagonal ! elements of nonincreasing magnitude, then qrsolv expects ! the full upper triangle of r, the permutation matrix p, ! and the first n components of (q transpose)*b. the system ! a*x = b, d*x = 0, is then equivalent to ! ! t t ! r*z = q *b , p *d*p*z = 0 , ! ! where x = p*z. if this system does not have full rank, ! then a least squares solution is obtained. on output qrsolv ! also provides an upper triangular matrix s such that ! ! t t t ! p *(a *a + d*d)*p = s *s . ! ! s is computed within qrsolv and may be of separate interest. ! ! the subroutine statement is ! ! subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa) ! ! where ! ! n is a positive integer input variable set to the order of r. ! ! r is an n by n array. on input the full upper triangle ! must contain the full upper triangle of the matrix r. ! on output the full upper triangle is unaltered, and the ! strict lower triangle contains the strict upper triangle ! (transposed) of the upper triangular matrix s. ! ! ldr is a positive integer input variable not less than n ! which specifies the leading dimension of the array r. ! ! ipvt is an integer input array of length n which defines the ! permutation matrix p such that a*p = q*r. column j of p ! is column ipvt(j) of the identity matrix. ! ! diag is an input array of length n which must contain the ! diagonal elements of the matrix d. ! ! qtb is an input array of length n which must contain the first ! n elements of the vector (q transpose)*b. ! ! x is an output array of length n which contains the least ! squares solution of the system a*x = b, d*x = 0. ! ! sdiag is an output array of length n which contains the ! diagonal elements of the upper triangular matrix s. ! ! wa is a work array of length n. ! ! subprograms called ! ! fortran-supplied ... dabs,dsqrt ! ! argonne national laboratory. minpack project. march 1980. ! burton s. garbow, kenneth e. hillstrom, jorge j. more ! ! ********** integer i,j,jp1,k,kp1,l,nsing double precision cos,cotan,p5,p25,qtbpj,sin,sum,tan,temp,zero data p5,p25,zero /5.0d-1,2.5d-1,0.0d0/ ! ! copy r and (q transpose)*b to preserve input and initialize s. ! in particular, save the diagonal elements of r in x. ! ! do 20 j = 1, n do j = 1, n do i = j, n r(i,j) = r(j,i) enddo !10 continue x(j) = r(j,j) wa(j) = qtb(j) enddo !20 continue ! ! eliminate the diagonal matrix d using a givens rotation. ! ! do 100 j = 1, n do j = 1, n ! ! prepare the row of d to be eliminated, locating the ! diagonal element using p from the qr factorization. ! l = ipvt(j) if (diag(l) .eq. zero) go to 90 do k = j, n sdiag(k) = zero enddo !30 continue sdiag(j) = diag(l) ! ! the transformations to eliminate the row of d ! modify only a single element of (q transpose)*b ! beyond the first n, which is initially zero. ! qtbpj = zero ! do 80 k = j, n do k = j, n ! ! determine a givens rotation which eliminates the ! appropriate element in the current row of d. ! if (sdiag(k) .eq. zero) go to 70 if (dabs(r(k,k)) .ge. dabs(sdiag(k))) go to 40 cotan = r(k,k)/sdiag(k) sin = p5/dsqrt(p25+p25*cotan**2) cos = sin*cotan go to 50 40 continue tan = sdiag(k)/r(k,k) cos = p5/dsqrt(p25+p25*tan**2) sin = cos*tan 50 continue ! ! compute the modified diagonal element of r and ! the modified element of ((q transpose)*b,0). ! r(k,k) = cos*r(k,k) + sin*sdiag(k) temp = cos*wa(k) + sin*qtbpj qtbpj = -sin*wa(k) + cos*qtbpj wa(k) = temp ! ! accumulate the tranformation in the row of s. ! kp1 = k + 1 if (n .lt. kp1) go to 70 do i = kp1, n temp = cos*r(i,k) + sin*sdiag(i) sdiag(i) = -sin*r(i,k) + cos*sdiag(i) r(i,k) = temp enddo !60 continue 70 continue enddo !80 continue 90 continue ! ! store the diagonal element of s and restore ! the corresponding diagonal element of r. ! sdiag(j) = r(j,j) r(j,j) = x(j) enddo 100 continue ! ! solve the triangular system for z. if the system is ! singular, then obtain a least squares solution. ! nsing = n do j = 1, n if (sdiag(j) .eq. zero .and. nsing .eq. n) nsing = j - 1 if (nsing .lt. n) wa(j) = zero enddo !110 continue if (nsing .lt. 1) go to 150 ! do 140 k = 1, nsing do k = 1, nsing j = nsing - k + 1 sum = zero jp1 = j + 1 if (nsing .lt. jp1) go to 130 do i = jp1, nsing sum = sum + r(i,j)*wa(i) enddo !120 continue 130 continue wa(j) = (wa(j) - sum)/sdiag(j) enddo !140 continue 150 continue ! ! permute the components of z back to components of x. ! do j = 1, n l = ipvt(j) x(l) = wa(j) enddo !160 continue return ! ! last card of subroutine qrsolv. ! end subroutine qrsolv !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ subroutine hybrd1(fcn,n,x,fvec,tol,info,wa,lwa) implicit none integer n,info,lwa double precision tol double precision x(n),fvec(n),wa(lwa) external fcn ! ********** ! ! subroutine hybrd1 ! ! the purpose of hybrd1 is to find a zero of a system of ! n nonlinear functions in n variables by a modification ! of the powell hybrid method. this is done by using the ! more general nonlinear equation solver hybrd. the user ! must provide a subroutine which calculates the functions. ! the jacobian is then calculated by a forward-difference ! approximation. ! ! the subroutine statement is ! ! subroutine hybrd1(fcn,n,x,fvec,tol,info,wa,lwa) ! ! where ! ! fcn is the name of the user-supplied subroutine which ! calculates the functions. fcn must be declared ! in an external statement in the user calling ! program, and should be written as follows. ! ! subroutine fcn(n,x,fvec,iflag) ! integer n,iflag ! double precision x(n),fvec(n) ! ---------- ! calculate the functions at x and ! return this vector in fvec. ! --------- ! return ! end ! ! the value of iflag should not be changed by fcn unless ! the user wants to terminate execution of hybrd1. ! in this case set iflag to a negative integer. ! ! n is a positive integer input variable set to the number ! of functions and variables. ! ! x is an array of length n. on input x must contain ! an initial estimate of the solution vector. on output x ! contains the final estimate of the solution vector. ! ! fvec is an output array of length n which contains ! the functions evaluated at the output x. ! ! tol is a nonnegative input variable. termination occurs ! when the algorithm estimates that the relative error ! between x and the solution is at most tol. ! ! info is an integer output variable. if the user has ! terminated execution, info is set to the (negative) ! value of iflag. see description of fcn. otherwise, ! info is set as follows. ! ! info = 0 improper input parameters. ! ! info = 1 algorithm estimates that the relative error ! between x and the solution is at most tol. ! ! info = 2 number of calls to fcn has reached or exceeded ! 200*(n+1). ! ! info = 3 tol is too small. no further improvement in ! the approximate solution x is possible. ! ! info = 4 iteration is not making good progress. ! ! wa is a work array of length lwa. ! ! lwa is a positive integer input variable not less than ! (n*(3*n+13))/2. ! ! subprograms called ! ! user-supplied ...... fcn ! ! minpack-supplied ... hybrd ! ! argonne national laboratory. minpack project. march 1980. ! burton s. garbow, kenneth e. hillstrom, jorge j. more ! ! ********** integer index,j,lr,maxfev,ml,mode,mu,nfev,nprint double precision epsfcn,factor,one,xtol,zero data factor,one,zero /1.0d2,1.0d0,0.0d0/ info = 0 ! ! check the input parameters for errors. ! if (n .le. 0 .or. tol .lt. zero .or. lwa .lt. (n*(3*n + 13))/2) & go to 20 ! ! call hybrd. ! maxfev = 200*(n + 1) xtol = tol ml = n - 1 mu = n - 1 epsfcn = zero mode = 2 do j = 1, n wa(j) = one enddo nprint = 0 lr = (n*(n + 1))/2 index = 6*n + lr call hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,wa(1),mode, & factor,nprint,info,nfev,wa(index+1),n,wa(6*n+1),lr, & wa(n+1),wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1)) if (info .eq. 5) info = 4 20 continue return ! ! last card of subroutine hybrd1. ! end subroutine hybrd1 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ subroutine hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,diag, & mode,factor,nprint,info,nfev,fjac,ldfjac,r,lr, & qtf,wa1,wa2,wa3,wa4) implicit none integer n,maxfev,ml,mu,mode,nprint,info,nfev,ldfjac,lr double precision xtol,epsfcn,factor double precision x(n),fvec(n),diag(n),fjac(ldfjac,n),r(lr), & qtf(n),wa1(n),wa2(n),wa3(n),wa4(n) external fcn ! ********** ! ! subroutine hybrd ! ! the purpose of hybrd is to find a zero of a system of ! n nonlinear functions in n variables by a modification ! of the powell hybrid method. the user must provide a ! subroutine which calculates the functions. the jacobian is ! then calculated by a forward-difference approximation. ! ! the subroutine statement is ! ! subroutine hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn, ! diag,mode,factor,nprint,info,nfev,fjac, ! ldfjac,r,lr,qtf,wa1,wa2,wa3,wa4) ! ! where ! ! fcn is the name of the user-supplied subroutine which ! calculates the functions. fcn must be declared ! in an external statement in the user calling ! program, and should be written as follows. ! ! subroutine fcn(n,x,fvec,iflag) ! integer n,iflag ! double precision x(n),fvec(n) ! ---------- ! calculate the functions at x and ! return this vector in fvec. ! --------- ! return ! end ! ! the value of iflag should not be changed by fcn unless ! the user wants to terminate execution of hybrd. ! in this case set iflag to a negative integer. ! ! n is a positive integer input variable set to the number ! of functions and variables. ! ! x is an array of length n. on input x must contain ! an initial estimate of the solution vector. on output x ! contains the final estimate of the solution vector. ! ! fvec is an output array of length n which contains ! the functions evaluated at the output x. ! ! xtol is a nonnegative input variable. termination ! occurs when the relative error between two consecutive ! iterates is at most xtol. ! ! maxfev is a positive integer input variable. termination ! occurs when the number of calls to fcn is at least maxfev ! by the end of an iteration. ! ! ml is a nonnegative integer input variable which specifies ! the number of subdiagonals within the band of the ! jacobian matrix. if the jacobian is not banded, set ! ml to at least n - 1. ! ! mu is a nonnegative integer input variable which specifies ! the number of superdiagonals within the band of the ! jacobian matrix. if the jacobian is not banded, set ! mu to at least n - 1. ! ! epsfcn is an input variable used in determining a suitable ! step length for the forward-difference approximation. this ! approximation assumes that the relative errors in the ! functions are of the order of epsfcn. if epsfcn is less ! than the machine precision, it is assumed that the relative ! errors in the functions are of the order of the machine ! precision. ! ! diag is an array of length n. if mode = 1 (see ! below), diag is internally set. if mode = 2, diag ! must contain positive entries that serve as ! multiplicative scale factors for the variables. ! ! mode is an integer input variable. if mode = 1, the ! variables will be scaled internally. if mode = 2, ! the scaling is specified by the input diag. other ! values of mode are equivalent to mode = 1. ! ! factor is a positive input variable used in determining the ! initial step bound. this bound is set to the product of ! factor and the euclidean norm of diag*x if nonzero, or else ! to factor itself. in most cases factor should lie in the ! interval (.1,100.). 100. is a generally recommended value. ! ! nprint is an integer input variable that enables controlled ! printing of iterates if it is positive. in this case, ! fcn is called with iflag = 0 at the beginning of the first ! iteration and every nprint iterations thereafter and ! immediately prior to return, with x and fvec available ! for printing. if nprint is not positive, no special calls ! of fcn with iflag = 0 are made. ! ! info is an integer output variable. if the user has ! terminated execution, info is set to the (negative) ! value of iflag. see description of fcn. otherwise, ! info is set as follows. ! ! info = 0 improper input parameters. ! ! info = 1 relative error between two consecutive iterates ! is at most xtol. ! ! info = 2 number of calls to fcn has reached or exceeded ! maxfev. ! ! info = 3 xtol is too small. no further improvement in ! the approximate solution x is possible. ! ! info = 4 iteration is not making good progress, as ! measured by the improvement from the last ! five jacobian evaluations. ! ! info = 5 iteration is not making good progress, as ! measured by the improvement from the last ! ten iterations. ! ! nfev is an integer output variable set to the number of ! calls to fcn. ! ! fjac is an output n by n array which contains the ! orthogonal matrix q produced by the qr factorization ! of the final approximate jacobian. ! ! ldfjac is a positive integer input variable not less than n ! which specifies the leading dimension of the array fjac. ! ! r is an output array of length lr which contains the ! upper triangular matrix produced by the qr factorization ! of the final approximate jacobian, stored rowwise. ! ! lr is a positive integer input variable not less than ! (n*(n+1))/2. ! ! qtf is an output array of length n which contains ! the vector (q transpose)*fvec. ! ! wa1, wa2, wa3, and wa4 are work arrays of length n. ! ! subprograms called ! ! user-supplied ...... fcn ! ! minpack-supplied ... dogleg,dpmpar,enorm,fdjac1, ! qform,qrfac,r1mpyq,r1updt ! ! fortran-supplied ... dabs,dmax1,dmin1,min0,mod ! ! argonne national laboratory. minpack project. march 1980. ! burton s. garbow, kenneth e. hillstrom, jorge j. more ! ! ********** integer i,iflag,iter,j,jm1,l,msum,ncfail,ncsuc,nslow1,nslow2 integer iwa(1) logical jeval,sing double precision actred,delta,epsmch,fnorm,fnorm1,one,pnorm, & prered,p1,p5,p001,p0001,ratio,sum,temp,xnorm, & zero ! double precision dpmpar,enorm data one,p1,p5,p001,p0001,zero & /1.0d0,1.0d-1,5.0d-1,1.0d-3,1.0d-4,0.0d0/ ! ! epsmch is the machine precision. ! epsmch = dpmpar(1) ! info = 0 iflag = 0 nfev = 0 ! ! check the input parameters for errors. ! if (n .le. 0 .or. xtol .lt. zero .or. maxfev .le. 0 & .or. ml .lt. 0 .or. mu .lt. 0 .or. factor .le. zero & .or. ldfjac .lt. n .or. lr .lt. (n*(n + 1))/2) go to 300 if (mode .ne. 2) go to 20 do j = 1, n if (diag(j) .le. zero) go to 300 enddo 20 continue ! ! evaluate the function at the starting point ! and calculate its norm. ! iflag = 1 ! This is not CALFUN for assessments call fcn(n,x,fvec,iflag) nfev = 1 if (iflag .lt. 0) go to 300 fnorm = enorm(n,fvec) ! ! determine the number of calls to fcn needed to compute ! the jacobian matrix. ! msum = min0(ml+mu+1,n) ! ! initialize iteration counter and monitors. ! iter = 1 ncsuc = 0 ncfail = 0 nslow1 = 0 nslow2 = 0 ! ! beginning of the outer loop. ! 30 continue jeval = .true. ! ! calculate the jacobian matrix. ! iflag = 2 call fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn,wa1, & wa2) nfev = nfev + msum if (iflag .lt. 0) go to 300 ! ! compute the qr factorization of the jacobian. ! call qrfac(n,n,fjac,ldfjac,.false.,iwa,1,wa1,wa2,wa3) ! ! on the first iteration and if mode is 1, scale according ! to the norms of the columns of the initial jacobian. ! if (iter .ne. 1) go to 70 if (mode .eq. 2) go to 50 do j = 1, n diag(j) = wa2(j) if (wa2(j) .eq. zero) diag(j) = one enddo 50 continue ! ! on the first iteration, calculate the norm of the scaled x ! and initialize the step bound delta. ! do j = 1, n wa3(j) = diag(j)*x(j) enddo xnorm = enorm(n,wa3) delta = factor*xnorm if (delta .eq. zero) delta = factor 70 continue ! ! form (q transpose)*fvec and store in qtf. ! do i = 1, n qtf(i) = fvec(i) enddo do j = 1, n if (fjac(j,j) .eq. zero) go to 110 sum = zero do i = j, n sum = sum + fjac(i,j)*qtf(i) enddo temp = -sum/fjac(j,j) do i = j, n qtf(i) = qtf(i) + fjac(i,j)*temp enddo 110 continue enddo ! ! copy the triangular factor of the qr factorization into r. ! sing = .false. do j = 1, n l = j jm1 = j - 1 if (jm1 .lt. 1) go to 140 do i = 1, jm1 r(l) = fjac(i,j) l = l + n - i enddo 140 continue r(l) = wa1(j) if (wa1(j) .eq. zero) sing = .true. enddo ! ! accumulate the orthogonal factor in fjac. ! call qform(n,n,fjac,ldfjac,wa1) ! ! rescale if necessary. ! if (mode .eq. 2) go to 170 do j = 1, n diag(j) = dmax1(diag(j),wa2(j)) enddo 170 continue ! ! beginning of the inner loop. ! 180 continue ! ! if requested, call fcn to enable printing of iterates. ! if (nprint .le. 0) go to 190 iflag = 0 ! This is not CALFUN for assessments if (mod(iter-1,nprint) .eq. 0) call fcn(n,x,fvec,iflag) if (iflag .lt. 0) go to 300 190 continue ! ! determine the direction p. ! call dogleg(n,r,lr,diag,qtf,delta,wa1,wa2,wa3) ! ! store the direction p and x + p. calculate the norm of p. ! do j = 1, n wa1(j) = -wa1(j) wa2(j) = x(j) + wa1(j) wa3(j) = diag(j)*wa1(j) enddo pnorm = enorm(n,wa3) ! ! on the first iteration, adjust the initial step bound. ! if (iter .eq. 1) delta = dmin1(delta,pnorm) ! ! evaluate the function at x + p and calculate its norm. ! iflag = 1 ! This is not CALFUN call fcn(n,wa2,wa4,iflag) nfev = nfev + 1 if (iflag .lt. 0) go to 300 fnorm1 = enorm(n,wa4) ! ! compute the scaled actual reduction. ! actred = -one if (fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 ! ! compute the scaled predicted reduction. ! l = 1 do i = 1, n sum = zero do j = i, n sum = sum + r(l)*wa1(j) l = l + 1 enddo wa3(i) = qtf(i) + sum enddo temp = enorm(n,wa3) prered = zero if (temp .lt. fnorm) prered = one - (temp/fnorm)**2 ! ! compute the ratio of the actual to the predicted ! reduction. ! ratio = zero if (prered .gt. zero) ratio = actred/prered ! ! update the step bound. ! if (ratio .ge. p1) go to 230 ncsuc = 0 ncfail = ncfail + 1 delta = p5*delta go to 240 230 continue ncfail = 0 ncsuc = ncsuc + 1 if (ratio .ge. p5 .or. ncsuc .gt. 1) & delta = dmax1(delta,pnorm/p5) if (dabs(ratio-one) .le. p1) delta = pnorm/p5 240 continue ! ! test for successful iteration. ! if (ratio .lt. p0001) go to 260 ! ! successful iteration. update x, fvec, and their norms. ! do j = 1, n x(j) = wa2(j) wa2(j) = diag(j)*x(j) fvec(j) = wa4(j) enddo xnorm = enorm(n,wa2) fnorm = fnorm1 iter = iter + 1 260 continue ! ! determine the progress of the iteration. ! nslow1 = nslow1 + 1 if (actred .ge. p001) nslow1 = 0 if (jeval) nslow2 = nslow2 + 1 if (actred .ge. p1) nslow2 = 0 ! ! test for convergence. ! if (delta .le. xtol*xnorm .or. fnorm .eq. zero) info = 1 if (info .ne. 0) go to 300 ! ! tests for termination and stringent tolerances. ! if (nfev .ge. maxfev) info = 2 if (p1*dmax1(p1*delta,pnorm) .le. epsmch*xnorm) info = 3 if (nslow2 .eq. 5) info = 4 if (nslow1 .eq. 10) info = 5 if (info .ne. 0) go to 300 ! ! criterion for recalculating jacobian approximation ! by forward differences. ! if (ncfail .eq. 2) go to 290 ! ! calculate the rank one modification to the jacobian ! and update qtf if necessary. ! do j = 1, n sum = zero do i = 1, n sum = sum + fjac(i,j)*wa4(i) enddo wa2(j) = (sum - wa3(j))/pnorm wa1(j) = diag(j)*((diag(j)*wa1(j))/pnorm) if (ratio .ge. p0001) qtf(j) = sum enddo ! ! compute the qr factorization of the updated jacobian. ! call r1updt(n,n,r,lr,wa1,wa2,wa3,sing) call r1mpyq(n,n,fjac,ldfjac,wa2,wa3) call r1mpyq(1,n,qtf,1,wa2,wa3) ! ! end of the inner loop. ! jeval = .false. go to 180 290 continue ! ! end of the outer loop. ! go to 30 300 continue ! ! termination, either normal or user imposed. ! if (iflag .lt. 0) info = iflag iflag = 0 ! this is not CALFUN if (nprint .gt. 0) call fcn(n,x,fvec,iflag) return ! ! last card of subroutine hybrd. ! end subroutine hybrd !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2) implicit none integer n,lr double precision delta double precision r(lr),diag(n),qtb(n),x(n),wa1(n),wa2(n) ! ********** ! ! subroutine dogleg ! ! given an m by n matrix a, an n by n nonsingular diagonal ! matrix d, an m-vector b, and a positive number delta, the ! problem is to determine the convex combination x of the ! gauss-newton and scaled gradient directions that minimizes ! (a*x - b) in the least squares sense, subject to the ! restriction that the euclidean norm of d*x be at most delta. ! ! this subroutine completes the solution of the problem ! if it is provided with the necessary information from the ! qr factorization of a. that is, if a = q*r, where q has ! orthogonal columns and r is an upper triangular matrix, ! then dogleg expects the full upper triangle of r and ! the first n components of (q transpose)*b. ! ! the subroutine statement is ! ! subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2) ! ! where ! ! n is a positive integer input variable set to the order of r. ! ! r is an input array of length lr which must contain the upper ! triangular matrix r stored by rows. ! ! lr is a positive integer input variable not less than ! (n*(n+1))/2. ! ! diag is an input array of length n which must contain the ! diagonal elements of the matrix d. ! ! qtb is an input array of length n which must contain the first ! n elements of the vector (q transpose)*b. ! ! delta is a positive input variable which specifies an upper ! bound on the euclidean norm of d*x. ! ! x is an output array of length n which contains the desired ! convex combination of the gauss-newton direction and the ! scaled gradient direction. ! ! wa1 and wa2 are work arrays of length n. ! ! subprograms called ! ! minpack-supplied ... dpmpar,enorm ! ! fortran-supplied ... dabs,dmax1,dmin1,dsqrt ! ! argonne national laboratory. minpack project. march 1980. ! burton s. garbow, kenneth e. hillstrom, jorge j. more ! ! ********** integer i,j,jj,jp1,k,l double precision alpha,bnorm,epsmch,gnorm,one,qnorm,sgnorm,sum, & temp,zero ! double precision dpmpar,enorm data one,zero /1.0d0,0.0d0/ ! ! epsmch is the machine precision. ! epsmch = dpmpar(1) ! ! first, calculate the gauss-newton direction. ! jj = (n*(n + 1))/2 + 1 do k = 1, n j = n - k + 1 jp1 = j + 1 jj = jj - k l = jj + 1 sum = zero if (n .lt. jp1) go to 20 do i = jp1, n sum = sum + r(l)*x(i) l = l + 1 enddo 20 continue temp = r(jj) if (temp .ne. zero) go to 40 l = j do i = 1, j temp = dmax1(temp,dabs(r(l))) l = l + n - i enddo temp = epsmch*temp if (temp .eq. zero) temp = epsmch 40 continue x(j) = (qtb(j) - sum)/temp enddo ! ! test whether the gauss-newton direction is acceptable. ! do j = 1, n wa1(j) = zero wa2(j) = diag(j)*x(j) enddo qnorm = enorm(n,wa2) if (qnorm .le. delta) go to 140 ! ! the gauss-newton direction is not acceptable. ! next, calculate the scaled gradient direction. ! l = 1 do j = 1, n temp = qtb(j) do i = j, n wa1(i) = wa1(i) + r(l)*temp l = l + 1 enddo wa1(j) = wa1(j)/diag(j) enddo ! ! calculate the norm of the scaled gradient and test for ! the special case in which the scaled gradient is zero. ! gnorm = enorm(n,wa1) sgnorm = zero alpha = delta/qnorm if (gnorm .eq. zero) go to 120 ! ! calculate the point along the scaled gradient ! at which the quadratic is minimized. ! do j = 1, n wa1(j) = (wa1(j)/gnorm)/diag(j) enddo l = 1 do j = 1, n sum = zero do i = j, n sum = sum + r(l)*wa1(i) l = l + 1 enddo wa2(j) = sum enddo temp = enorm(n,wa2) sgnorm = (gnorm/temp)/temp ! ! test whether the scaled gradient direction is acceptable. ! alpha = zero if (sgnorm .ge. delta) go to 120 ! ! the scaled gradient direction is not acceptable. ! finally, calculate the point along the dogleg ! at which the quadratic is minimized. ! bnorm = enorm(n,qtb) temp = (bnorm/gnorm)*(bnorm/qnorm)*(sgnorm/delta) temp = temp - (delta/qnorm)*(sgnorm/delta)**2 & + dsqrt((temp-(delta/qnorm))**2 & +(one-(delta/qnorm)**2)*(one-(sgnorm/delta)**2)) alpha = ((delta/qnorm)*(one - (sgnorm/delta)**2))/temp 120 continue ! ! form appropriate convex combination of the gauss-newton ! direction and the scaled gradient direction. ! temp = (one - alpha)*dmin1(sgnorm,delta) do j = 1, n x(j) = temp*wa1(j) + alpha*x(j) enddo 140 continue return ! ! last card of subroutine dogleg. ! end subroutine dogleg !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ subroutine fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn,& wa1,wa2) implicit none integer n,ldfjac,iflag,ml,mu double precision epsfcn double precision x(n),fvec(n),fjac(ldfjac,n),wa1(n),wa2(n) ! added external fcn external fcn ! ********** ! ! subroutine fdjac1 ! ! this subroutine computes a forward-difference approximation ! to the n by n jacobian matrix associated with a specified ! problem of n functions in n variables. if the jacobian has ! a banded form, then function evaluations are saved by only ! approximating the nonzero terms. ! ! the subroutine statement is ! ! subroutine fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn, ! wa1,wa2) ! ! where ! ! fcn is the name of the user-supplied subroutine which ! calculates the functions. fcn must be declared ! in an external statement in the user calling ! program, and should be written as follows. ! ! subroutine fcn(n,x,fvec,iflag) ! integer n,iflag ! double precision x(n),fvec(n) ! ---------- ! calculate the functions at x and ! return this vector in fvec. ! ---------- ! return ! end ! ! the value of iflag should not be changed by fcn unless ! the user wants to terminate execution of fdjac1. ! in this case set iflag to a negative integer. ! ! n is a positive integer input variable set to the number ! of functions and variables. ! ! x is an input array of length n. ! ! fvec is an input array of length n which must contain the ! functions evaluated at x. ! ! fjac is an output n by n array which contains the ! approximation to the jacobian matrix evaluated at x. ! ! ldfjac is a positive integer input variable not less than n ! which specifies the leading dimension of the array fjac. ! ! iflag is an integer variable which can be used to terminate ! the execution of fdjac1. see description of fcn. ! ! ml is a nonnegative integer input variable which specifies ! the number of subdiagonals within the band of the ! jacobian matrix. if the jacobian is not banded, set ! ml to at least n - 1. ! ! epsfcn is an input variable used in determining a suitable ! step length for the forward-difference approximation. this ! approximation assumes that the relative errors in the ! functions are of the order of epsfcn. if epsfcn is less ! than the machine precision, it is assumed that the relative ! errors in the functions are of the order of the machine ! precision. ! ! mu is a nonnegative integer input variable which specifies ! the number of superdiagonals within the band of the ! jacobian matrix. if the jacobian is not banded, set ! mu to at least n - 1. ! ! wa1 and wa2 are work arrays of length n. if ml + mu + 1 is at ! least n, then the jacobian is considered dense, and wa2 is ! not referenced. ! ! subprograms called ! ! minpack-supplied ... dpmpar ! ! fortran-supplied ... dabs,dmax1,dsqrt ! ! argonne national laboratory. minpack project. march 1980. ! burton s. garbow, kenneth e. hillstrom, jorge j. more ! ! ********** integer i,j,k,msum double precision eps,epsmch,h,temp,zero ! double precision dpmpar data zero /0.0d0/ ! ! epsmch is the machine precision. ! epsmch = dpmpar(1) ! eps = dsqrt(dmax1(epsfcn,epsmch)) msum = ml + mu + 1 if (msum .lt. n) go to 40 ! ! computation of dense approximate jacobian. ! do j = 1, n temp = x(j) h = eps*dabs(temp) if (h .eq. zero) h = eps x(j) = temp + h ! This is not CALFUN for assessments call fcn(n,x,wa1,iflag) if (iflag .lt. 0) go to 30 x(j) = temp do i = 1, n fjac(i,j) = (wa1(i) - fvec(i))/h enddo enddo 30 continue go to 110 40 continue ! ! computation of banded approximate jacobian. ! do k = 1, msum do j = k, n, msum wa2(j) = x(j) h = eps*dabs(wa2(j)) if (h .eq. zero) h = eps x(j) = wa2(j) + h enddo ! This is not CALFUN for assessments call fcn(n,x,wa1,iflag) if (iflag .lt. 0) go to 100 do j = k, n, msum x(j) = wa2(j) h = eps*dabs(wa2(j)) if (h .eq. zero) h = eps do i = 1, n fjac(i,j) = zero if (i .ge. j - mu .and. i .le. j + ml) & fjac(i,j) = (wa1(i) - fvec(i))/h enddo enddo enddo 100 continue 110 continue return ! ! last card of subroutine fdjac1. ! end subroutine fdjac1 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ subroutine qform(m,n,q,ldq,wa) implicit none integer m,n,ldq double precision q(ldq,m),wa(m) ! ********** ! ! subroutine qform ! ! this subroutine proceeds from the computed qr factorization of ! an m by n matrix a to accumulate the m by m orthogonal matrix ! q from its factored form. ! ! the subroutine statement is ! ! subroutine qform(m,n,q,ldq,wa) ! ! where ! ! m is a positive integer input variable set to the number ! of rows of a and the order of q. ! ! n is a positive integer input variable set to the number ! of columns of a. ! ! q is an m by m array. on input the full lower trapezoid in ! the first min(m,n) columns of q contains the factored form. ! on output q has been accumulated into a square matrix. ! ! ldq is a positive integer input variable not less than m ! which specifies the leading dimension of the array q. ! ! wa is a work array of length m. ! ! subprograms called ! ! fortran-supplied ... min0 ! ! argonne national laboratory. minpack project. march 1980. ! burton s. garbow, kenneth e. hillstrom, jorge j. more ! ! ********** integer i,j,jm1,k,l,minmn,np1 double precision one,sum,temp,zero data one,zero /1.0d0,0.0d0/ ! ! zero out upper triangle of q in the first min(m,n) columns. ! minmn = min0(m,n) if (minmn .lt. 2) go to 30 do j = 2, minmn jm1 = j - 1 do i = 1, jm1 q(i,j) = zero enddo enddo 30 continue ! ! initialize remaining columns to those of the identity matrix. ! np1 = n + 1 if (m .lt. np1) go to 60 do j = np1, m do i = 1, m q(i,j) = zero enddo q(j,j) = one enddo 60 continue ! ! accumulate q from its factored form. ! do l = 1, minmn k = minmn - l + 1 do i = k, m wa(i) = q(i,k) q(i,k) = zero enddo q(k,k) = one if (wa(k) .eq. zero) go to 110 do j = k, m sum = zero do i = k, m sum = sum + q(i,j)*wa(i) enddo temp = sum/wa(k) do i = k, m q(i,j) = q(i,j) - temp*wa(i) enddo enddo 110 continue enddo return ! ! last card of subroutine qform. ! end subroutine qform !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) implicit none integer m,n,lda,lipvt integer ipvt(lipvt) logical pivot double precision a(lda,n),rdiag(n),acnorm(n),wa(n) ! ********** ! ! subroutine qrfac ! ! this subroutine uses householder transformations with column ! pivoting (optional) to compute a qr factorization of the ! m by n matrix a. that is, qrfac determines an orthogonal ! matrix q, a permutation matrix p, and an upper trapezoidal ! matrix r with diagonal elements of nonincreasing magnitude, ! such that a*p = q*r. the householder transformation for ! column k, k = 1,2,...,min(m,n), is of the form ! ! t ! i - (1/u(k))*u*u ! ! where u has zeros in the first k-1 positions. the form of ! this transformation and the method of pivoting first ! appeared in the corresponding linpack subroutine. ! ! the subroutine statement is ! ! subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) ! ! where ! ! m is a positive integer input variable set to the number ! of rows of a. ! ! n is a positive integer input variable set to the number ! of columns of a. ! ! a is an m by n array. on input a contains the matrix for ! which the qr factorization is to be computed. on output ! the strict upper trapezoidal part of a contains the strict ! upper trapezoidal part of r, and the lower trapezoidal ! part of a contains a factored form of q (the non-trivial ! elements of the u vectors described above). ! ! lda is a positive integer input variable not less than m ! which specifies the leading dimension of the array a. ! ! pivot is a logical input variable. if pivot is set true, ! then column pivoting is enforced. if pivot is set false, ! then no column pivoting is done. ! ! ipvt is an integer output array of length lipvt. ipvt ! defines the permutation matrix p such that a*p = q*r. ! column j of p is column ipvt(j) of the identity matrix. ! if pivot is false, ipvt is not referenced. ! ! lipvt is a positive integer input variable. if pivot is false, ! then lipvt may be as small as 1. if pivot is true, then ! lipvt must be at least n. ! ! rdiag is an output array of length n which contains the ! diagonal elements of r. ! ! acnorm is an output array of length n which contains the ! norms of the corresponding columns of the input matrix a. ! if this information is not needed, then acnorm can coincide ! with rdiag. ! ! wa is a work array of length n. if pivot is false, then wa ! can coincide with rdiag. ! ! subprograms called ! ! minpack-supplied ... dpmpar,enorm ! ! fortran-supplied ... dmax1,dsqrt,min0 ! ! argonne national laboratory. minpack project. march 1980. ! burton s. garbow, kenneth e. hillstrom, jorge j. more ! ! ********** integer i,j,jp1,k,kmax,minmn double precision ajnorm,epsmch,one,p05,sum,temp,zero ! double precision dpmpar,enorm data one,p05,zero /1.0d0,5.0d-2,0.0d0/ ! ! epsmch is the machine precision. ! epsmch = dpmpar(1) ! ! compute the initial column norms and initialize several arrays. ! do j = 1, n acnorm(j) = enorm(m,a(1,j)) rdiag(j) = acnorm(j) wa(j) = rdiag(j) if (pivot) ipvt(j) = j enddo !10 continue ! ! reduce a to r with householder transformations. ! minmn = min0(m,n) ! do 110 j = 1, minmn do j = 1, minmn if (.not.pivot) go to 40 ! ! bring the column of largest norm into the pivot position. ! kmax = j do k = j, n if (rdiag(k) .gt. rdiag(kmax)) kmax = k enddo !20 continue if (kmax .eq. j) go to 40 do i = 1, m temp = a(i,j) a(i,j) = a(i,kmax) a(i,kmax) = temp enddo !30 continue rdiag(kmax) = rdiag(j) wa(kmax) = wa(j) k = ipvt(j) ipvt(j) = ipvt(kmax) ipvt(kmax) = k 40 continue ! ! compute the householder transformation to reduce the ! j-th column of a to a multiple of the j-th unit vector. ! ajnorm = enorm(m-j+1,a(j,j)) if (ajnorm .eq. zero) go to 100 if (a(j,j) .lt. zero) ajnorm = -ajnorm do i = j, m a(i,j) = a(i,j)/ajnorm enddo !50 continue a(j,j) = a(j,j) + one ! ! apply the transformation to the remaining columns ! and update the norms. ! jp1 = j + 1 if (n .lt. jp1) go to 100 ! do 90 k = jp1, n do k = jp1, n sum = zero do i = j, m sum = sum + a(i,j)*a(i,k) enddo !60 continue temp = sum/a(j,j) do i = j, m a(i,k) = a(i,k) - temp*a(i,j) enddo !70 continue if (.not.pivot .or. rdiag(k) .eq. zero) go to 80 temp = a(j,k)/rdiag(k) rdiag(k) = rdiag(k)*dsqrt(dmax1(zero,one-temp**2)) if (p05*(rdiag(k)/wa(k))**2 .gt. epsmch) go to 80 rdiag(k) = enorm(m-j,a(jp1,k)) wa(k) = rdiag(k) 80 continue enddo !90 continue 100 continue rdiag(j) = -ajnorm enddo !110 continue return ! ! last card of subroutine qrfac. ! end subroutine qrfac !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ subroutine r1mpyq(m,n,a,lda,v,w) implicit none integer m,n,lda double precision a(lda,n),v(n),w(n) ! ********** ! ! subroutine r1mpyq ! ! given an m by n matrix a, this subroutine computes a*q where ! q is the product of 2*(n - 1) transformations ! ! gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1) ! ! and gv(i), gw(i) are givens rotations in the (i,n) plane which ! eliminate elements in the i-th and n-th planes, respectively. ! q itself is not given, rather the information to recover the ! gv, gw rotations is supplied. ! ! the subroutine statement is ! ! subroutine r1mpyq(m,n,a,lda,v,w) ! ! where ! ! m is a positive integer input variable set to the number ! of rows of a. ! ! n is a positive integer input variable set to the number ! of columns of a. ! ! a is an m by n array. on input a must contain the matrix ! to be postmultiplied by the orthogonal matrix q ! described above. on output a*q has replaced a. ! ! lda is a positive integer input variable not less than m ! which specifies the leading dimension of the array a. ! ! v is an input array of length n. v(i) must contain the ! information necessary to recover the givens rotation gv(i) ! described above. ! ! w is an input array of length n. w(i) must contain the ! information necessary to recover the givens rotation gw(i) ! described above. ! ! subroutines called ! ! fortran-supplied ... dabs,dsqrt ! ! argonne national laboratory. minpack project. march 1980. ! burton s. garbow, kenneth e. hillstrom, jorge j. more ! ! ********** integer i,j,nmj,nm1 double precision cos,one,sin,temp data one /1.0d0/ ! ! apply the first set of givens rotations to a. ! nm1 = n - 1 if (nm1 .lt. 1) go to 50 do nmj = 1, nm1 j = n - nmj if (dabs(v(j)) .gt. one) cos = one/v(j) if (dabs(v(j)) .gt. one) sin = dsqrt(one-cos**2) if (dabs(v(j)) .le. one) sin = v(j) if (dabs(v(j)) .le. one) cos = dsqrt(one-sin**2) do i = 1, m temp = cos*a(i,j) - sin*a(i,n) a(i,n) = sin*a(i,j) + cos*a(i,n) a(i,j) = temp enddo enddo ! ! apply the second set of givens rotations to a. ! do j = 1, nm1 if (dabs(w(j)) .gt. one) cos = one/w(j) if (dabs(w(j)) .gt. one) sin = dsqrt(one-cos**2) if (dabs(w(j)) .le. one) sin = w(j) if (dabs(w(j)) .le. one) cos = dsqrt(one-sin**2) do i = 1, m temp = cos*a(i,j) + sin*a(i,n) a(i,n) = -sin*a(i,j) + cos*a(i,n) a(i,j) = temp enddo enddo 50 continue return ! ! last card of subroutine r1mpyq. ! end subroutine r1mpyq !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ subroutine r1updt(m,n,s,ls,u,v,w,sing) implicit none integer m,n,ls logical sing double precision s(ls),u(m),v(n),w(m) ! ********** ! ! subroutine r1updt ! ! given an m by n lower trapezoidal matrix s, an m-vector u, ! and an n-vector v, the problem is to determine an ! orthogonal matrix q such that ! ! t ! (s + u*v )*q ! ! is again lower trapezoidal. ! ! this subroutine determines q as the product of 2*(n - 1) ! transformations ! ! gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1) ! ! where gv(i), gw(i) are givens rotations in the (i,n) plane ! which eliminate elements in the i-th and n-th planes, ! respectively. q itself is not accumulated, rather the ! information to recover the gv, gw rotations is returned. ! ! the subroutine statement is ! ! subroutine r1updt(m,n,s,ls,u,v,w,sing) ! ! where ! ! m is a positive integer input variable set to the number ! of rows of s. ! ! n is a positive integer input variable set to the number ! of columns of s. n must not exceed m. ! ! s is an array of length ls. on input s must contain the lower ! trapezoidal matrix s stored by columns. on output s contains ! the lower trapezoidal matrix produced as described above. ! ! ls is a positive integer input variable not less than ! (n*(2*m-n+1))/2. ! ! u is an input array of length m which must contain the ! vector u. ! ! v is an array of length n. on input v must contain the vector ! v. on output v(i) contains the information necessary to ! recover the givens rotation gv(i) described above. ! ! w is an output array of length m. w(i) contains information ! necessary to recover the givens rotation gw(i) described ! above. ! ! sing is a logical output variable. sing is set true if any ! of the diagonal elements of the output s are zero. otherwise ! sing is set false. ! ! subprograms called ! ! minpack-supplied ... dpmpar ! ! fortran-supplied ... dabs,dsqrt ! ! argonne national laboratory. minpack project. march 1980. ! burton s. garbow, kenneth e. hillstrom, jorge j. more, ! john l. nazareth ! ! ********** integer i,j,jj,l,nmj,nm1 double precision cos,cotan,giant,one,p5,p25,sin,tan,tau,temp, & zero ! double precision dpmpar data one,p5,p25,zero /1.0d0,5.0d-1,2.5d-1,0.0d0/ ! ! giant is the largest magnitude. ! giant = dpmpar(3) ! ! initialize the diagonal element pointer. ! jj = (n*(2*m - n + 1))/2 - (m - n) ! ! move the nontrivial part of the last column of s into w. ! l = jj do i = n, m w(i) = s(l) l = l + 1 enddo ! ! rotate the vector v into a multiple of the n-th unit vector ! in such a way that a spike is introduced into w. ! nm1 = n - 1 if (nm1 .lt. 1) go to 70 do nmj = 1, nm1 j = n - nmj jj = jj - (m - j + 1) w(j) = zero if (v(j) .eq. zero) go to 50 ! ! determine a givens rotation which eliminates the ! j-th element of v. ! if (dabs(v(n)) .ge. dabs(v(j))) go to 20 cotan = v(n)/v(j) sin = p5/dsqrt(p25+p25*cotan**2) cos = sin*cotan tau = one if (dabs(cos)*giant .gt. one) tau = one/cos go to 30 20 continue tan = v(j)/v(n) cos = p5/dsqrt(p25+p25*tan**2) sin = cos*tan tau = sin 30 continue ! ! apply the transformation to v and store the information ! necessary to recover the givens rotation. ! v(n) = sin*v(j) + cos*v(n) v(j) = tau ! ! apply the transformation to s and extend the spike in w. ! l = jj do i = j, m temp = cos*s(l) - sin*w(i) w(i) = sin*s(l) + cos*w(i) s(l) = temp l = l + 1 enddo 50 continue enddo 70 continue ! ! add the spike from the rank 1 update to w. ! do i = 1, m w(i) = w(i) + v(n)*u(i) enddo ! ! eliminate the spike. ! sing = .false. if (nm1 .lt. 1) go to 140 do j = 1, nm1 if (w(j) .eq. zero) go to 120 ! ! determine a givens rotation which eliminates the ! j-th element of the spike. ! if (dabs(s(jj)) .ge. dabs(w(j))) go to 90 cotan = s(jj)/w(j) sin = p5/dsqrt(p25+p25*cotan**2) cos = sin*cotan tau = one if (dabs(cos)*giant .gt. one) tau = one/cos go to 100 90 continue tan = w(j)/s(jj) cos = p5/dsqrt(p25+p25*tan**2) sin = cos*tan tau = sin 100 continue ! ! apply the transformation to s and reduce the spike in w. ! l = jj do i = j, m temp = cos*s(l) + sin*w(i) w(i) = -sin*s(l) + cos*w(i) s(l) = temp l = l + 1 enddo ! ! store the information necessary to recover the ! givens rotation. ! w(j) = tau 120 continue ! ! test for zero diagonal elements in the output s. ! if (s(jj) .eq. zero) sing = .true. jj = jj + (m - j + 1) enddo 140 continue ! ! move w back into the last column of the output s. ! l = jj do i = n, m s(l) = w(i) l = l + 1 enddo if (s(jj) .eq. zero) sing = .true. return ! ! last card of subroutine r1updt. ! end subroutine r1updt !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ double precision function dpmpar(i) implicit none integer i ! ********** ! ! Function dpmpar ! ! This function provides double precision machine parameters ! when the appropriate set of data statements is activated (by ! removing the c from column 1) and all other data statements are ! rendered inactive. Most of the parameter values were obtained ! from the corresponding Bell Laboratories Port Library function. ! ! The function statement is ! ! double precision function dpmpar(i) ! ! where ! ! i is an integer input variable set to 1, 2, or 3 which ! selects the desired machine parameter. If the machine has ! t base b digits and its smallest and largest exponents are ! emin and emax, respectively, then these parameters are ! ! dpmpar(1) = b**(1 - t), the machine precision, ! ! dpmpar(2) = b**(emin - 1), the smallest magnitude, ! ! dpmpar(3) = b**emax*(1 - b**(-t)), the largest magnitude. ! ! Argonne National Laboratory. MINPACK Project. November 1996. ! Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More' ! ! ********** integer mcheps(4) integer minmag(4) integer maxmag(4) double precision dmach(3) equivalence (dmach(1),mcheps(1)) equivalence (dmach(2),minmag(1)) equivalence (dmach(3),maxmag(1)) ! ! Machine constants for the IBM 360/370 series, ! the Amdahl 470/V6, the ICL 2900, the Itel AS/6, ! the Xerox Sigma 5/7/9 and the Sel systems 85/86. ! ! data mcheps(1),mcheps(2) / z34100000, z00000000 / ! data minmag(1),minmag(2) / z00100000, z00000000 / ! data maxmag(1),maxmag(2) / z7fffffff, zffffffff / ! ! Machine constants for the Honeywell 600/6000 series. ! ! data mcheps(1),mcheps(2) / o606400000000, o000000000000 / ! data minmag(1),minmag(2) / o402400000000, o000000000000 / ! data maxmag(1),maxmag(2) / o376777777777, o777777777777 / ! ! Machine constants for the CDC 6000/7000 series. ! ! data mcheps(1) / 15614000000000000000b / ! data mcheps(2) / 15010000000000000000b / ! ! data minmag(1) / 00604000000000000000b / ! data minmag(2) / 00000000000000000000b / ! ! data maxmag(1) / 37767777777777777777b / ! data maxmag(2) / 37167777777777777777b / ! ! Machine constants for the PDP-10 (KA processor). ! ! data mcheps(1),mcheps(2) / "114400000000, "000000000000 / ! data minmag(1),minmag(2) / "033400000000, "000000000000 / ! data maxmag(1),maxmag(2) / "377777777777, "344777777777 / ! ! Machine constants for the PDP-10 (KI processor). ! ! data mcheps(1),mcheps(2) / "104400000000, "000000000000 / ! data minmag(1),minmag(2) / "000400000000, "000000000000 / ! data maxmag(1),maxmag(2) / "377777777777, "377777777777 / ! ! Machine constants for the PDP-11. ! ! data mcheps(1),mcheps(2) / 9472, 0 / ! data mcheps(3),mcheps(4) / 0, 0 / ! ! data minmag(1),minmag(2) / 128, 0 / ! data minmag(3),minmag(4) / 0, 0 / ! ! data maxmag(1),maxmag(2) / 32767, -1 / ! data maxmag(3),maxmag(4) / -1, -1 / ! ! Machine constants for the Burroughs 6700/7700 systems. ! ! data mcheps(1) / o1451000000000000 / ! data mcheps(2) / o0000000000000000 / ! ! data minmag(1) / o1771000000000000 / ! data minmag(2) / o7770000000000000 / ! ! data maxmag(1) / o0777777777777777 / ! data maxmag(2) / o7777777777777777 / ! ! Machine constants for the Burroughs 5700 system. ! ! data mcheps(1) / o1451000000000000 / ! data mcheps(2) / o0000000000000000 / ! ! data minmag(1) / o1771000000000000 / ! data minmag(2) / o0000000000000000 / ! ! data maxmag(1) / o0777777777777777 / ! data maxmag(2) / o0007777777777777 / ! ! Machine constants for the Burroughs 1700 system. ! ! data mcheps(1) / zcc6800000 / ! data mcheps(2) / z000000000 / ! ! data minmag(1) / zc00800000 / ! data minmag(2) / z000000000 / ! ! data maxmag(1) / zdffffffff / ! data maxmag(2) / zfffffffff / ! ! Machine constants for the Univac 1100 series. ! ! data mcheps(1),mcheps(2) / o170640000000, o000000000000 / ! data minmag(1),minmag(2) / o000040000000, o000000000000 / ! data maxmag(1),maxmag(2) / o377777777777, o777777777777 / ! ! Machine constants for the Data General Eclipse S/200. ! ! Note - it may be appropriate to include the following card - ! static dmach(3) ! ! data minmag/20k,3*0/,maxmag/77777k,3*177777k/ ! data mcheps/32020k,3*0/ ! ! Machine constants for the Harris 220. ! ! data mcheps(1),mcheps(2) / '20000000, '00000334 / ! data minmag(1),minmag(2) / '20000000, '00000201 / ! data maxmag(1),maxmag(2) / '37777777, '37777577 / ! ! Machine constants for the Cray-1. ! ! data mcheps(1) / 0376424000000000000000b / ! data mcheps(2) / 0000000000000000000000b / ! ! data minmag(1) / 0200034000000000000000b / ! data minmag(2) / 0000000000000000000000b / ! ! data maxmag(1) / 0577777777777777777777b / ! data maxmag(2) / 0000007777777777777776b / ! ! Machine constants for the Prime 400. ! ! data mcheps(1),mcheps(2) / :10000000000, :00000000123 / ! data minmag(1),minmag(2) / :10000000000, :00000100000 / ! data maxmag(1),maxmag(2) / :17777777777, :37777677776 / ! ! Machine constants for the VAX-11. ! ! data mcheps(1),mcheps(2) / 9472, 0 / ! data minmag(1),minmag(2) / 128, 0 / ! data maxmag(1),maxmag(2) / -32769, -1 / ! ! Machine constants for IEEE machines. ! data dmach(1) /2.22044604926d-16/ data dmach(2) /2.22507385852d-308/ data dmach(3) /1.79769313485d+308/ ! dpmpar = dmach(i) return ! ! Last card of function dpmpar. ! end function dpmpar !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ double precision function enorm(n,x) implicit none integer n double precision x(n) ! ********** ! ! function enorm ! ! given an n-vector x, this function calculates the ! euclidean norm of x. ! ! the euclidean norm is computed by accumulating the sum of ! squares in three different sums. the sums of squares for the ! small and large components are scaled so that no overflows ! occur. non-destructive underflows are permitted. underflows ! and overflows do not occur in the computation of the unscaled ! sum of squares for the intermediate components. ! the definitions of small, intermediate and large components ! depend on two constants, rdwarf and rgiant. the main ! restrictions on these constants are that rdwarf**2 not ! underflow and rgiant**2 not overflow. the constants ! given here are suitable for every known computer. ! ! the function statement is ! ! double precision function enorm(n,x) ! ! where ! ! n is a positive integer input variable. ! ! x is an input array of length n. ! ! subprograms called ! ! fortran-supplied ... dabs,dsqrt ! ! argonne national laboratory. minpack project. march 1980. ! burton s. garbow, kenneth e. hillstrom, jorge j. more ! ! ********** integer i double precision agiant,floatn,one,rdwarf,rgiant,s1,s2,s3,xabs, & x1max,x3max,zero data one,zero,rdwarf,rgiant /1.0d0,0.0d0,3.834d-20,1.304d19/ s1 = zero s2 = zero s3 = zero x1max = zero x3max = zero floatn = n agiant = rgiant/floatn ! do 90 i = 1, n do i = 1, n xabs = dabs(x(i)) if (xabs .gt. rdwarf .and. xabs .lt. agiant) go to 70 if (xabs .le. rdwarf) go to 30 ! ! sum for large components. ! if (xabs .le. x1max) go to 10 s1 = one + s1*(x1max/xabs)**2 x1max = xabs go to 20 10 continue s1 = s1 + (xabs/x1max)**2 20 continue go to 60 30 continue ! ! sum for small components. ! if (xabs .le. x3max) go to 40 s3 = one + s3*(x3max/xabs)**2 x3max = xabs go to 50 40 continue if (xabs .ne. zero) s3 = s3 + (xabs/x3max)**2 50 continue 60 continue go to 80 70 continue ! ! sum for intermediate components. ! s2 = s2 + xabs**2 80 continue enddo !90 continue ! ! calculation of norm. ! if (s1 .eq. zero) go to 100 enorm = x1max*dsqrt(s1+(s2/x1max)/x1max) go to 130 100 continue if (s2 .eq. zero) go to 110 if (s2 .ge. x3max) & enorm = dsqrt(s2*(one+(x3max/s2)*(x3max*s3))) if (s2 .lt. x3max) & enorm = dsqrt(x3max*((s2/x3max)+(x3max*s3))) go to 120 110 continue enorm = x3max*dsqrt(s3) 120 continue 130 continue return ! ! last card of function enorm. ! end function enorm !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ end MODULE MINPACK ================================================ FILE: src/numlib/oclablas.F90 ================================================ ! MODULE OCLABLAS ! ! This is an extract of a fews routines from LAPACK and BLAS version 3.6.0 ! used to invert a symmetric matrix and to solve a system of linear equations ! and some more things in DOUBLE PRECISION used in OpenCalphad ! ! LAPACk and BLAS are free software libraries ! Both converted from F77 to F90 in a minimal way (comments and ! continuation lines modified). ! CONTAINS ! ! list of all subroutines/functions at the end ! ! ------------------------------------------------------------------------- ! ! LAPACK/BLAS routines converted from F77 to F90 below ! ! !> \brief \b DGETRI ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DGETRI + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) ! ! .. Scalar Arguments .. ! INTEGER INFO, LDA, LWORK, N ! .. ! .. Array Arguments .. ! INTEGER IPIV( * ) ! DOUBLE PRECISION A( LDA, * ), WORK( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DGETRI computes the inverse of a matrix using the LU factorization !> computed by DGETRF. !> !> This method inverts U and then computes inv(A) by solving the system !> inv(A)*L = inv(U) for inv(A). !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] N !> \verbatim !> N is INTEGER !> The order of the matrix A. N >= 0. !> \endverbatim !> !> \param[in,out] A !> \verbatim !> A is DOUBLE PRECISION array, dimension (LDA,N) !> On entry, the factors L and U from the factorization !> A = P*L*U as computed by DGETRF. !> On exit, if INFO = 0, the inverse of the original matrix A. !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,N). !> \endverbatim !> !> \param[in] IPIV !> \verbatim !> IPIV is INTEGER array, dimension (N) !> The pivot indices from DGETRF; for 1<=i<=N, row i of the !> matrix was interchanged with row IPIV(i). !> \endverbatim !> !> \param[out] WORK !> \verbatim !> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) !> On exit, if INFO=0, then WORK(1) returns the optimal LWORK. !> \endverbatim !> !> \param[in] LWORK !> \verbatim !> LWORK is INTEGER !> The dimension of the array WORK. LWORK >= max(1,N). !> For optimal performance LWORK >= N*NB, where NB is !> the optimal blocksize returned by ILAENV. !> !> If LWORK = -1, then a workspace query is assumed; the routine !> only calculates the optimal size of the WORK array, returns !> this value as the first entry of the WORK array, and no error !> message related to LWORK is issued by XERBLA. !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument had an illegal value !> > 0: if INFO = i, U(i,i) is exactly zero; the matrix is !> singular and its inverse could not be computed. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup doubleGEcomputational ! ! ===================================================================== SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) ! ! -- LAPACK computational routine (version 3.4.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, N ! .. ! .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), WORK( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) ! .. ! .. Local Scalars .. LOGICAL LQUERY INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB,& NBMIN, NN ! .. ! .. External Functions .. ! INTEGER ILAENV ! EXTERNAL ILAENV ! .. ! .. External Subroutines .. ! EXTERNAL DGEMM, DGEMV, DSWAP, DTRSM, DTRTRI, XERBLA ! .. ! .. Intrinsic Functions .. ! INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! INFO = 0 NB = ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 ) LWKOPT = N*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( N.LT.0 ) THEN INFO = -1 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -3 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGETRI', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF ! ! Quick return if possible ! IF( N.EQ.0 ) RETURN ! ! Form inv(U). If INFO > 0 from DTRTRI, then U is singular, ! and the inverse is not computed. ! CALL DTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO ) IF( INFO.GT.0 ) RETURN ! NBMIN = 2 LDWORK = N IF( NB.GT.1 .AND. NB.LT.N ) THEN IWS = MAX( LDWORK*NB, 1 ) IF( LWORK.LT.IWS ) THEN NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DGETRI', ' ', N, -1, -1, -1 ) ) END IF ELSE IWS = N END IF ! ! Solve the equation inv(A)*L = inv(U) for inv(A). ! IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN ! ! Use unblocked code. ! DO 20 J = N, 1, -1 ! ! Copy current column of L to WORK and replace with zeros. ! DO 10 I = J + 1, N WORK( I ) = A( I, J ) A( I, J ) = ZERO 10 CONTINUE ! ! Compute current column of inv(A). ! IF( J.LT.N ) & CALL DGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ),& LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 ) 20 CONTINUE ELSE ! ! Use blocked code. ! NN = ( ( N-1 ) / NB )*NB + 1 DO 50 J = NN, 1, -NB JB = MIN( NB, N-J+1 ) ! ! Copy current block column of L to WORK and replace with ! zeros. ! DO 40 JJ = J, J + JB - 1 DO 30 I = JJ + 1, N WORK( I+( JJ-J )*LDWORK ) = A( I, JJ ) A( I, JJ ) = ZERO 30 CONTINUE 40 CONTINUE ! ! Compute current block column of inv(A). ! IF( J+JB.LE.N ) & CALL DGEMM( 'No transpose', 'No transpose', N, JB,& N-J-JB+1, -ONE, A( 1, J+JB ), LDA,& WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA ) CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB,& ONE, WORK( J ), LDWORK, A( 1, J ), LDA ) 50 CONTINUE END IF ! ! Apply column interchanges. ! DO 60 J = N - 1, 1, -1 JP = IPIV( J ) IF( JP.NE.J ) CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) 60 CONTINUE ! WORK( 1 ) = IWS RETURN ! ! End of DGETRI ! END SUBROUTINE DGETRI ! != ! !> \brief \b DTRTRI ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DTRTRI + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) ! ! .. Scalar Arguments .. ! CHARACTER DIAG, UPLO ! INTEGER INFO, LDA, N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION A( LDA, * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DTRTRI computes the inverse of a real upper or lower triangular !> matrix A. !> !> This is the Level 3 BLAS version of the algorithm. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> = 'U': A is upper triangular; !> = 'L': A is lower triangular. !> \endverbatim !> !> \param[in] DIAG !> \verbatim !> DIAG is CHARACTER*1 !> = 'N': A is non-unit triangular; !> = 'U': A is unit triangular. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The order of the matrix A. N >= 0. !> \endverbatim !> !> \param[in,out] A !> \verbatim !> A is DOUBLE PRECISION array, dimension (LDA,N) !> On entry, the triangular matrix A. If UPLO = 'U', the !> leading N-by-N upper triangular part of the array A contains !> the upper triangular matrix, and the strictly lower !> triangular part of A is not referenced. If UPLO = 'L', the !> leading N-by-N lower triangular part of the array A contains !> the lower triangular matrix, and the strictly upper !> triangular part of A is not referenced. If DIAG = 'U', the !> diagonal elements of A are also not referenced and are !> assumed to be 1. !> On exit, the (triangular) inverse of the original matrix, in !> the same storage format. !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,N). !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument had an illegal value !> > 0: if INFO = i, A(i,i) is exactly zero. The triangular !> matrix is singular and its inverse can not be computed. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup doubleOTHERcomputational ! ! ===================================================================== SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) ! ! -- LAPACK computational routine (version 3.4.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. CHARACTER DIAG, UPLO INTEGER INFO, LDA, N ! .. ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) ! .. ! .. Local Scalars .. LOGICAL NOUNIT, UPPER INTEGER J, JB, NB, NN ! .. ! .. External Functions .. ! LOGICAL LSAME ! INTEGER ILAENV ! EXTERNAL LSAME, ILAENV ! .. ! .. External Subroutines .. ! EXTERNAL DTRMM, DTRSM, DTRTI2, XERBLA ! .. ! .. Intrinsic Functions .. ! INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOUNIT = LSAME( DIAG, 'N' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTRTRI', -INFO ) RETURN END IF ! ! Quick return if possible ! IF( N.EQ.0 ) RETURN ! ! Check for singularity if non-unit. ! IF( NOUNIT ) THEN DO 10 INFO = 1, N IF( A( INFO, INFO ).EQ.ZERO ) RETURN 10 CONTINUE INFO = 0 END IF ! ! Determine the block size for this environment. ! NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 ) IF( NB.LE.1 .OR. NB.GE.N ) THEN ! ! Use unblocked code ! CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) ELSE ! ! Use blocked code ! IF( UPPER ) THEN ! ! Compute inverse of upper triangular matrix ! DO 20 J = 1, N, NB JB = MIN( NB, N-J+1 ) ! ! Compute rows 1:j-1 of current block column ! CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1,& JB, ONE, A, LDA, A( 1, J ), LDA ) CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1,& JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA ) ! ! Compute inverse of current diagonal block ! CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO ) 20 CONTINUE ELSE ! ! Compute inverse of lower triangular matrix ! NN = ( ( N-1 ) / NB )*NB + 1 DO 30 J = NN, 1, -NB JB = MIN( NB, N-J+1 ) IF( J+JB.LE.N ) THEN ! ! Compute rows j+jb:n of current block column ! CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG,& N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA,& A( J+JB, J ), LDA ) CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG,& N-J-JB+1, JB, -ONE, A( J, J ), LDA,& A( J+JB, J ), LDA ) END IF ! ! Compute inverse of current diagonal block ! CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO ) 30 CONTINUE END IF END IF ! RETURN ! ! End of DTRTRI ! END SUBROUTINE DTRTRI ! != ! !> \brief \b DTRTI2 computes the inverse of a triangular matrix (unblocked algorithm). ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DTRTI2 + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) ! ! .. Scalar Arguments .. ! CHARACTER DIAG, UPLO ! INTEGER INFO, LDA, N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION A( LDA, * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DTRTI2 computes the inverse of a real upper or lower triangular !> matrix. !> !> This is the Level 2 BLAS version of the algorithm. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> Specifies whether the matrix A is upper or lower triangular. !> = 'U': Upper triangular !> = 'L': Lower triangular !> \endverbatim !> !> \param[in] DIAG !> \verbatim !> DIAG is CHARACTER*1 !> Specifies whether or not the matrix A is unit triangular. !> = 'N': Non-unit triangular !> = 'U': Unit triangular !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The order of the matrix A. N >= 0. !> \endverbatim !> !> \param[in,out] A !> \verbatim !> A is DOUBLE PRECISION array, dimension (LDA,N) !> On entry, the triangular matrix A. If UPLO = 'U', the !> leading n by n upper triangular part of the array A contains !> the upper triangular matrix, and the strictly lower !> triangular part of A is not referenced. If UPLO = 'L', the !> leading n by n lower triangular part of the array A contains !> the lower triangular matrix, and the strictly upper !> triangular part of A is not referenced. If DIAG = 'U', the !> diagonal elements of A are also not referenced and are !> assumed to be 1. !> !> On exit, the (triangular) inverse of the original matrix, in !> the same storage format. !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,N). !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -k, the k-th argument had an illegal value !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup doubleOTHERcomputational ! ! ===================================================================== SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) ! ! -- LAPACK computational routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. CHARACTER DIAG, UPLO INTEGER INFO, LDA, N ! .. ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) ! .. ! .. Local Scalars .. LOGICAL NOUNIT, UPPER INTEGER J DOUBLE PRECISION AJJ ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL DSCAL, DTRMV, XERBLA ! .. ! .. Intrinsic Functions .. ! INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOUNIT = LSAME( DIAG, 'N' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTRTI2', -INFO ) RETURN END IF ! IF( UPPER ) THEN ! ! Compute inverse of upper triangular matrix. ! DO 10 J = 1, N IF( NOUNIT ) THEN A( J, J ) = ONE / A( J, J ) AJJ = -A( J, J ) ELSE AJJ = -ONE END IF ! ! Compute elements 1:j-1 of j-th column. ! CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA,& A( 1, J ), 1 ) CALL DSCAL( J-1, AJJ, A( 1, J ), 1 ) 10 CONTINUE ELSE ! ! Compute inverse of lower triangular matrix. ! DO 20 J = N, 1, -1 IF( NOUNIT ) THEN A( J, J ) = ONE / A( J, J ) AJJ = -A( J, J ) ELSE AJJ = -ONE END IF IF( J.LT.N ) THEN ! ! Compute elements j+1:n of j-th column. ! CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J,& A( J+1, J+1 ), LDA, A( J+1, J ), 1 ) CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 ) END IF 20 CONTINUE END IF ! RETURN ! ! End of DTRTI2 ! END SUBROUTINE DTRTI2 ! != ! !> \brief \b DCOPY ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! ! Definition: ! =========== ! ! SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) ! ! .. Scalar Arguments .. ! INTEGER INCX,INCY,N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION DX(*),DY(*) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DCOPY copies a vector, x, to a vector, y. !> uses unrolled loops for increments equal to one. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup double_blas_level1 ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> jack dongarra, linpack, 3/11/78. !> modified 12/3/93, array(1) declarations changed to array(*) !> \endverbatim !> ! ===================================================================== SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) ! ! -- Reference BLAS level1 routine (version 3.4.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. INTEGER INCX,INCY,N ! .. ! .. Array Arguments .. DOUBLE PRECISION DX(*),DY(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. INTEGER I,IX,IY,M,MP1 ! .. ! .. Intrinsic Functions .. INTRINSIC MOD ! .. IF (N.LE.0) RETURN IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN ! ! code for both increments equal to 1 ! ! ! clean-up loop ! M = MOD(N,7) IF (M.NE.0) THEN DO I = 1,M DY(I) = DX(I) END DO IF (N.LT.7) RETURN END IF MP1 = M + 1 DO I = MP1,N,7 DY(I) = DX(I) DY(I+1) = DX(I+1) DY(I+2) = DX(I+2) DY(I+3) = DX(I+3) DY(I+4) = DX(I+4) DY(I+5) = DX(I+5) DY(I+6) = DX(I+6) END DO ELSE ! ! code for unequal increments or equal increments ! not equal to 1 ! IX = 1 IY = 1 IF (INCX.LT.0) IX = (-N+1)*INCX + 1 IF (INCY.LT.0) IY = (-N+1)*INCY + 1 DO I = 1,N DY(IY) = DX(IX) IX = IX + INCX IY = IY + INCY END DO END IF RETURN END SUBROUTINE DCOPY !> \brief \b DDOT ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! ! Definition: ! =========== ! ! DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) ! ! .. Scalar Arguments .. ! INTEGER INCX,INCY,N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION DX(*),DY(*) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DDOT forms the dot product of two vectors. !> uses unrolled loops for increments equal to one. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup double_blas_level1 ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> jack dongarra, linpack, 3/11/78. !> modified 12/3/93, array(1) declarations changed to array(*) !> \endverbatim !> ! ===================================================================== DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) ! ! -- Reference BLAS level1 routine (version 3.4.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. INTEGER INCX,INCY,N ! .. ! .. Array Arguments .. DOUBLE PRECISION DX(*),DY(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. DOUBLE PRECISION DTEMP INTEGER I,IX,IY,M,MP1 ! .. ! .. Intrinsic Functions .. INTRINSIC MOD ! .. DDOT = 0.0d0 DTEMP = 0.0d0 IF (N.LE.0) RETURN IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN ! ! code for both increments equal to 1 ! ! ! clean-up loop ! M = MOD(N,5) IF (M.NE.0) THEN DO I = 1,M DTEMP = DTEMP + DX(I)*DY(I) END DO IF (N.LT.5) THEN DDOT=DTEMP RETURN END IF END IF MP1 = M + 1 DO I = MP1,N,5 DTEMP = DTEMP + DX(I)*DY(I) + DX(I+1)*DY(I+1) + & DX(I+2)*DY(I+2) + DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4) END DO ELSE ! ! code for unequal increments or equal increments ! not equal to 1 ! IX = 1 IY = 1 IF (INCX.LT.0) IX = (-N+1)*INCX + 1 IF (INCY.LT.0) IY = (-N+1)*INCY + 1 DO I = 1,N DTEMP = DTEMP + DX(IX)*DY(IY) IX = IX + INCX IY = IY + INCY END DO END IF DDOT = DTEMP RETURN END FUNCTION DDOT ! !> \brief \b DGEMM ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! ! Definition: ! =========== ! ! SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) ! ! .. Scalar Arguments .. ! DOUBLE PRECISION ALPHA,BETA ! INTEGER K,LDA,LDB,LDC,M,N ! CHARACTER TRANSA,TRANSB ! .. ! .. Array Arguments .. ! DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DGEMM performs one of the matrix-matrix operations !> !> C := alpha*op( A )*op( B ) + beta*C, !> !> where op( X ) is one of !> !> op( X ) = X or op( X ) = X**T, !> !> alpha and beta are scalars, and A, B and C are matrices, with op( A ) !> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] TRANSA !> \verbatim !> TRANSA is CHARACTER*1 !> On entry, TRANSA specifies the form of op( A ) to be used in !> the matrix multiplication as follows: !> !> TRANSA = 'N' or 'n', op( A ) = A. !> !> TRANSA = 'T' or 't', op( A ) = A**T. !> !> TRANSA = 'C' or 'c', op( A ) = A**T. !> \endverbatim !> !> \param[in] TRANSB !> \verbatim !> TRANSB is CHARACTER*1 !> On entry, TRANSB specifies the form of op( B ) to be used in !> the matrix multiplication as follows: !> !> TRANSB = 'N' or 'n', op( B ) = B. !> !> TRANSB = 'T' or 't', op( B ) = B**T. !> !> TRANSB = 'C' or 'c', op( B ) = B**T. !> \endverbatim !> !> \param[in] M !> \verbatim !> M is INTEGER !> On entry, M specifies the number of rows of the matrix !> op( A ) and of the matrix C. M must be at least zero. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> On entry, N specifies the number of columns of the matrix !> op( B ) and the number of columns of the matrix C. N must be !> at least zero. !> \endverbatim !> !> \param[in] K !> \verbatim !> K is INTEGER !> On entry, K specifies the number of columns of the matrix !> op( A ) and the number of rows of the matrix op( B ). K must !> be at least zero. !> \endverbatim !> !> \param[in] ALPHA !> \verbatim !> ALPHA is DOUBLE PRECISION. !> On entry, ALPHA specifies the scalar alpha. !> \endverbatim !> !> \param[in] A !> \verbatim !> A is DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is !> k when TRANSA = 'N' or 'n', and is m otherwise. !> Before entry with TRANSA = 'N' or 'n', the leading m by k !> part of the array A must contain the matrix A, otherwise !> the leading k by m part of the array A must contain the !> matrix A. !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> On entry, LDA specifies the first dimension of A as declared !> in the calling (sub) program. When TRANSA = 'N' or 'n' then !> LDA must be at least max( 1, m ), otherwise LDA must be at !> least max( 1, k ). !> \endverbatim !> !> \param[in] B !> \verbatim !> B is DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is !> n when TRANSB = 'N' or 'n', and is k otherwise. !> Before entry with TRANSB = 'N' or 'n', the leading k by n !> part of the array B must contain the matrix B, otherwise !> the leading n by k part of the array B must contain the !> matrix B. !> \endverbatim !> !> \param[in] LDB !> \verbatim !> LDB is INTEGER !> On entry, LDB specifies the first dimension of B as declared !> in the calling (sub) program. When TRANSB = 'N' or 'n' then !> LDB must be at least max( 1, k ), otherwise LDB must be at !> least max( 1, n ). !> \endverbatim !> !> \param[in] BETA !> \verbatim !> BETA is DOUBLE PRECISION. !> On entry, BETA specifies the scalar beta. When BETA is !> supplied as zero then C need not be set on input. !> \endverbatim !> !> \param[in,out] C !> \verbatim !> C is DOUBLE PRECISION array of DIMENSION ( LDC, n ). !> Before entry, the leading m by n part of the array C must !> contain the matrix C, except when beta is zero, in which !> case C need not be set on entry. !> On exit, the array C is overwritten by the m by n matrix !> ( alpha*op( A )*op( B ) + beta*C ). !> \endverbatim !> !> \param[in] LDC !> \verbatim !> LDC is INTEGER !> On entry, LDC specifies the first dimension of C as declared !> in the calling (sub) program. LDC must be at least !> max( 1, m ). !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2015 ! !> \ingroup double_blas_level3 ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> Level 3 Blas routine. !> !> -- Written on 8-February-1989. !> Jack Dongarra, Argonne National Laboratory. !> Iain Duff, AERE Harwell. !> Jeremy Du Croz, Numerical Algorithms Group Ltd. !> Sven Hammarling, Numerical Algorithms Group Ltd. !> \endverbatim !> ! ===================================================================== SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) ! ! -- Reference BLAS level3 routine (version 3.6.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2015 ! ! .. Scalar Arguments .. DOUBLE PRECISION ALPHA,BETA INTEGER K,LDA,LDB,LDC,M,N CHARACTER TRANSA,TRANSB ! .. ! .. Array Arguments .. DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB LOGICAL NOTA,NOTB ! .. ! .. Parameters .. DOUBLE PRECISION ONE,ZERO PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) ! .. ! ! Set NOTA and NOTB as true if A and B respectively are not ! transposed and set NROWA, NCOLA and NROWB as the number of rows ! and columns of A and the number of rows of B respectively. ! NOTA = LSAME(TRANSA,'N') NOTB = LSAME(TRANSB,'N') IF (NOTA) THEN NROWA = M NCOLA = K ELSE NROWA = K NCOLA = M END IF IF (NOTB) THEN NROWB = K ELSE NROWB = N END IF ! ! Test the input parameters. ! INFO = 0 IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. & (.NOT.LSAME(TRANSA,'T'))) THEN INFO = 1 ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. & (.NOT.LSAME(TRANSB,'T'))) THEN INFO = 2 ELSE IF (M.LT.0) THEN INFO = 3 ELSE IF (N.LT.0) THEN INFO = 4 ELSE IF (K.LT.0) THEN INFO = 5 ELSE IF (LDA.LT.MAX(1,NROWA)) THEN INFO = 8 ELSE IF (LDB.LT.MAX(1,NROWB)) THEN INFO = 10 ELSE IF (LDC.LT.MAX(1,M)) THEN INFO = 13 END IF IF (INFO.NE.0) THEN CALL XERBLA('DGEMM ',INFO) RETURN END IF ! ! Quick return if possible. ! IF ((M.EQ.0) .OR. (N.EQ.0) .OR. & (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN ! ! And if alpha.eq.zero. ! IF (ALPHA.EQ.ZERO) THEN IF (BETA.EQ.ZERO) THEN DO 20 J = 1,N DO 10 I = 1,M C(I,J) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40 J = 1,N DO 30 I = 1,M C(I,J) = BETA*C(I,J) 30 CONTINUE 40 CONTINUE END IF RETURN END IF ! ! Start the operations. ! IF (NOTB) THEN IF (NOTA) THEN ! ! Form C := alpha*A*B + beta*C. ! DO 90 J = 1,N IF (BETA.EQ.ZERO) THEN DO 50 I = 1,M C(I,J) = ZERO 50 CONTINUE ELSE IF (BETA.NE.ONE) THEN DO 60 I = 1,M C(I,J) = BETA*C(I,J) 60 CONTINUE END IF DO 80 L = 1,K TEMP = ALPHA*B(L,J) DO 70 I = 1,M C(I,J) = C(I,J) + TEMP*A(I,L) 70 CONTINUE 80 CONTINUE 90 CONTINUE ELSE ! ! Form C := alpha*A**T*B + beta*C ! DO 120 J = 1,N DO 110 I = 1,M TEMP = ZERO DO 100 L = 1,K TEMP = TEMP + A(L,I)*B(L,J) 100 CONTINUE IF (BETA.EQ.ZERO) THEN C(I,J) = ALPHA*TEMP ELSE C(I,J) = ALPHA*TEMP + BETA*C(I,J) END IF 110 CONTINUE 120 CONTINUE END IF ELSE IF (NOTA) THEN ! ! Form C := alpha*A*B**T + beta*C ! DO 170 J = 1,N IF (BETA.EQ.ZERO) THEN DO 130 I = 1,M C(I,J) = ZERO 130 CONTINUE ELSE IF (BETA.NE.ONE) THEN DO 140 I = 1,M C(I,J) = BETA*C(I,J) 140 CONTINUE END IF DO 160 L = 1,K TEMP = ALPHA*B(J,L) DO 150 I = 1,M C(I,J) = C(I,J) + TEMP*A(I,L) 150 CONTINUE 160 CONTINUE 170 CONTINUE ELSE ! ! Form C := alpha*A**T*B**T + beta*C ! DO 200 J = 1,N DO 190 I = 1,M TEMP = ZERO DO 180 L = 1,K TEMP = TEMP + A(L,I)*B(J,L) 180 CONTINUE IF (BETA.EQ.ZERO) THEN C(I,J) = ALPHA*TEMP ELSE C(I,J) = ALPHA*TEMP + BETA*C(I,J) END IF 190 CONTINUE 200 CONTINUE END IF END IF ! RETURN ! ! End of DGEMM . ! END SUBROUTINE DGEMM ! !> \brief \b DGEMV ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! ! Definition: ! =========== ! ! SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) ! ! .. Scalar Arguments .. ! DOUBLE PRECISION ALPHA,BETA ! INTEGER INCX,INCY,LDA,M,N ! CHARACTER TRANS ! .. ! .. Array Arguments .. ! DOUBLE PRECISION A(LDA,*),X(*),Y(*) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DGEMV performs one of the matrix-vector operations !> !> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, !> !> where alpha and beta are scalars, x and y are vectors and A is an !> m by n matrix. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] TRANS !> \verbatim !> TRANS is CHARACTER*1 !> On entry, TRANS specifies the operation to be performed as !> follows: !> !> TRANS = 'N' or 'n' y := alpha*A*x + beta*y. !> !> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. !> !> TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y. !> \endverbatim !> !> \param[in] M !> \verbatim !> M is INTEGER !> On entry, M specifies the number of rows of the matrix A. !> M must be at least zero. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> On entry, N specifies the number of columns of the matrix A. !> N must be at least zero. !> \endverbatim !> !> \param[in] ALPHA !> \verbatim !> ALPHA is DOUBLE PRECISION. !> On entry, ALPHA specifies the scalar alpha. !> \endverbatim !> !> \param[in] A !> \verbatim !> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ). !> Before entry, the leading m by n part of the array A must !> contain the matrix of coefficients. !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> On entry, LDA specifies the first dimension of A as declared !> in the calling (sub) program. LDA must be at least !> max( 1, m ). !> \endverbatim !> !> \param[in] X !> \verbatim !> X is DOUBLE PRECISION array of DIMENSION at least !> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' !> and at least !> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. !> Before entry, the incremented array X must contain the !> vector x. !> \endverbatim !> !> \param[in] INCX !> \verbatim !> INCX is INTEGER !> On entry, INCX specifies the increment for the elements of !> X. INCX must not be zero. !> \endverbatim !> !> \param[in] BETA !> \verbatim !> BETA is DOUBLE PRECISION. !> On entry, BETA specifies the scalar beta. When BETA is !> supplied as zero then Y need not be set on input. !> \endverbatim !> !> \param[in,out] Y !> \verbatim !> Y is DOUBLE PRECISION array of DIMENSION at least !> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' !> and at least !> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. !> Before entry with BETA non-zero, the incremented array Y !> must contain the vector y. On exit, Y is overwritten by the !> updated vector y. !> \endverbatim !> !> \param[in] INCY !> \verbatim !> INCY is INTEGER !> On entry, INCY specifies the increment for the elements of !> Y. INCY must not be zero. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2015 ! !> \ingroup double_blas_level2 ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> Level 2 Blas routine. !> The vector and matrix arguments are not referenced when N = 0, or M = 0 !> !> -- Written on 22-October-1986. !> Jack Dongarra, Argonne National Lab. !> Jeremy Du Croz, Nag Central Office. !> Sven Hammarling, Nag Central Office. !> Richard Hanson, Sandia National Labs. !> \endverbatim !> ! ===================================================================== SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) ! ! -- Reference BLAS level2 routine (version 3.6.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2015 ! ! .. Scalar Arguments .. DOUBLE PRECISION ALPHA,BETA INTEGER INCX,INCY,LDA,M,N CHARACTER TRANS ! .. ! .. Array Arguments .. DOUBLE PRECISION A(LDA,*),X(*),Y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE,ZERO PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) ! .. ! .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! ! Test the input parameters. ! INFO = 0 IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. & .NOT.LSAME(TRANS,'C')) THEN INFO = 1 ELSE IF (M.LT.0) THEN INFO = 2 ELSE IF (N.LT.0) THEN INFO = 3 ELSE IF (LDA.LT.MAX(1,M)) THEN INFO = 6 ELSE IF (INCX.EQ.0) THEN INFO = 8 ELSE IF (INCY.EQ.0) THEN INFO = 11 END IF IF (INFO.NE.0) THEN CALL XERBLA('DGEMV ',INFO) RETURN END IF ! ! Quick return if possible. ! IF ((M.EQ.0) .OR. (N.EQ.0) .OR. & ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN ! ! Set LENX and LENY, the lengths of the vectors x and y, and set ! up the start points in X and Y. ! IF (LSAME(TRANS,'N')) THEN LENX = N LENY = M ELSE LENX = M LENY = N END IF IF (INCX.GT.0) THEN KX = 1 ELSE KX = 1 - (LENX-1)*INCX END IF IF (INCY.GT.0) THEN KY = 1 ELSE KY = 1 - (LENY-1)*INCY END IF ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! ! First form y := beta*y. ! IF (BETA.NE.ONE) THEN IF (INCY.EQ.1) THEN IF (BETA.EQ.ZERO) THEN DO 10 I = 1,LENY Y(I) = ZERO 10 CONTINUE ELSE DO 20 I = 1,LENY Y(I) = BETA*Y(I) 20 CONTINUE END IF ELSE IY = KY IF (BETA.EQ.ZERO) THEN DO 30 I = 1,LENY Y(IY) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40 I = 1,LENY Y(IY) = BETA*Y(IY) IY = IY + INCY 40 CONTINUE END IF END IF END IF IF (ALPHA.EQ.ZERO) RETURN IF (LSAME(TRANS,'N')) THEN ! ! Form y := alpha*A*x + y. ! JX = KX IF (INCY.EQ.1) THEN DO 60 J = 1,N TEMP = ALPHA*X(JX) DO 50 I = 1,M Y(I) = Y(I) + TEMP*A(I,J) 50 CONTINUE JX = JX + INCX 60 CONTINUE ELSE DO 80 J = 1,N TEMP = ALPHA*X(JX) IY = KY DO 70 I = 1,M Y(IY) = Y(IY) + TEMP*A(I,J) IY = IY + INCY 70 CONTINUE JX = JX + INCX 80 CONTINUE END IF ELSE ! ! Form y := alpha*A**T*x + y. ! JY = KY IF (INCX.EQ.1) THEN DO 100 J = 1,N TEMP = ZERO DO 90 I = 1,M TEMP = TEMP + A(I,J)*X(I) 90 CONTINUE Y(JY) = Y(JY) + ALPHA*TEMP JY = JY + INCY 100 CONTINUE ELSE DO 120 J = 1,N TEMP = ZERO IX = KX DO 110 I = 1,M TEMP = TEMP + A(I,J)*X(IX) IX = IX + INCX 110 CONTINUE Y(JY) = Y(JY) + ALPHA*TEMP JY = JY + INCY 120 CONTINUE END IF END IF ! RETURN ! ! End of DGEMV . ! END SUBROUTINE DGEMV ! !> \brief \b DGETRF ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DGETRF + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) ! ! .. Scalar Arguments .. ! INTEGER INFO, LDA, M, N ! .. ! .. Array Arguments .. ! INTEGER IPIV( * ) ! DOUBLE PRECISION A( LDA, * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DGETRF computes an LU factorization of a general M-by-N matrix A !> using partial pivoting with row interchanges. !> !> The factorization has the form !> A = P * L * U !> where P is a permutation matrix, L is lower triangular with unit !> diagonal elements (lower trapezoidal if m > n), and U is upper !> triangular (upper trapezoidal if m < n). !> !> This is the right-looking Level 3 BLAS version of the algorithm. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] M !> \verbatim !> M is INTEGER !> The number of rows of the matrix A. M >= 0. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The number of columns of the matrix A. N >= 0. !> \endverbatim !> !> \param[in,out] A !> \verbatim !> A is DOUBLE PRECISION array, dimension (LDA,N) !> On entry, the M-by-N matrix to be factored. !> On exit, the factors L and U from the factorization !> A = P*L*U; the unit diagonal elements of L are not stored. !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,M). !> \endverbatim !> !> \param[out] IPIV !> \verbatim !> IPIV is INTEGER array, dimension (min(M,N)) !> The pivot indices; for 1 <= i <= min(M,N), row i of the !> matrix was interchanged with row IPIV(i). !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument had an illegal value !> > 0: if INFO = i, U(i,i) is exactly zero. The factorization !> has been completed, but the factor U is exactly !> singular, and division by zero will occur if it is used !> to solve a system of equations. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2015 ! !> \ingroup doubleGEcomputational ! ! ===================================================================== SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) ! ! -- LAPACK computational routine (version 3.6.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2015 ! ! .. Scalar Arguments .. INTEGER INFO, LDA, M, N ! .. ! .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) ! .. ! .. Local Scalars .. INTEGER I, IINFO, J, JB, NB ! .. ! .. External Subroutines .. ! EXTERNAL DGEMM, DGETRF2, DLASWP, DTRSM, XERBLA ! .. ! .. External Functions .. ! INTEGER ILAENV ! EXTERNAL ILAENV ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGETRF', -INFO ) RETURN END IF ! ! Quick return if possible ! IF( M.EQ.0 .OR. N.EQ.0 ) RETURN ! ! Determine the block size for this environment. ! NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN ! ! Use unblocked code. ! CALL DGETRF2( M, N, A, LDA, IPIV, INFO ) ELSE ! ! Use blocked code. ! DO 20 J = 1, MIN( M, N ), NB JB = MIN( MIN( M, N )-J+1, NB ) ! ! Factor diagonal and subdiagonal blocks and test for exact ! singularity. ! CALL DGETRF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) ! ! Adjust INFO and the pivot indices. ! IF( INFO.EQ.0 .AND. IINFO.GT.0 ) & INFO = IINFO + J - 1 DO 10 I = J, MIN( M, J+JB-1 ) IPIV( I ) = J - 1 + IPIV( I ) 10 CONTINUE ! ! Apply interchanges to columns 1:J-1. ! CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) ! IF( J+JB.LE.N ) THEN ! ! Apply interchanges to columns J+JB:N. ! CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, & IPIV, 1 ) ! ! Compute block row of U. ! CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, & N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), & LDA ) IF( J+JB.LE.M ) THEN ! ! Update trailing submatrix. ! CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, & N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, & A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), & LDA ) END IF END IF 20 CONTINUE END IF RETURN ! ! End of DGETRF ! END SUBROUTINE DGETRF ! !> \brief \b DGETRF2 ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! ! Definition: ! =========== ! ! RECURSIVE SUBROUTINE DGETRF2( M, N, A, LDA, IPIV, INFO ) ! ! .. Scalar Arguments .. ! INTEGER INFO, LDA, M, N ! .. ! .. Array Arguments .. ! INTEGER IPIV( * ) ! DOUBLE PRECISION A( LDA, * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DGETRF2 computes an LU factorization of a general M-by-N matrix A !> using partial pivoting with row interchanges. !> !> The factorization has the form !> A = P * L * U !> where P is a permutation matrix, L is lower triangular with unit !> diagonal elements (lower trapezoidal if m > n), and U is upper !> triangular (upper trapezoidal if m < n). !> !> This is the recursive version of the algorithm. It divides !> the matrix into four submatrices: !> !> [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2 !> A = [ -----|----- ] with n1 = min(m,n) !> [ A21 | A22 ] n2 = n-n1 !> !> [ A11 ] !> The subroutine calls itself to factor [ --- ], !> [ A12 ] !> [ A12 ] !> do the swaps on [ --- ], solve A12, update A22, !> [ A22 ] !> !> then calls itself to factor A22 and do the swaps on A21. !> !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] M !> \verbatim !> M is INTEGER !> The number of rows of the matrix A. M >= 0. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The number of columns of the matrix A. N >= 0. !> \endverbatim !> !> \param[in,out] A !> \verbatim !> A is DOUBLE PRECISION array, dimension (LDA,N) !> On entry, the M-by-N matrix to be factored. !> On exit, the factors L and U from the factorization !> A = P*L*U; the unit diagonal elements of L are not stored. !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,M). !> \endverbatim !> !> \param[out] IPIV !> \verbatim !> IPIV is INTEGER array, dimension (min(M,N)) !> The pivot indices; for 1 <= i <= min(M,N), row i of the !> matrix was interchanged with row IPIV(i). !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument had an illegal value !> > 0: if INFO = i, U(i,i) is exactly zero. The factorization !> has been completed, but the factor U is exactly !> singular, and division by zero will occur if it is used !> to solve a system of equations. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2015 ! !> \ingroup doubleGEcomputational ! ! ===================================================================== RECURSIVE SUBROUTINE DGETRF2( M, N, A, LDA, IPIV, INFO ) ! ! -- LAPACK computational routine (version 3.6.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2015 ! ! .. Scalar Arguments .. INTEGER INFO, LDA, M, N ! .. ! .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) ! .. ! .. Local Scalars .. DOUBLE PRECISION SFMIN, TEMP INTEGER I, IINFO, N1, N2 ! .. ! .. External Functions .. ! DOUBLE PRECISION DLAMCH ! INTEGER IDAMAX ! EXTERNAL DLAMCH, IDAMAX ! .. ! .. External Subroutines .. ! EXTERNAL DGEMM, DSCAL, DLASWP, DTRSM, XERBLA ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input parameters ! INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGETRF2', -INFO ) RETURN END IF ! ! Quick return if possible ! IF( M.EQ.0 .OR. N.EQ.0 ) RETURN IF ( M.EQ.1 ) THEN ! ! Use unblocked code for one row case ! Just need to handle IPIV and INFO ! IPIV( 1 ) = 1 IF ( A(1,1).EQ.ZERO ) INFO = 1 ! ELSE IF( N.EQ.1 ) THEN ! ! Use unblocked code for one column case ! ! ! Compute machine safe minimum ! SFMIN = DLAMCH('S') ! ! Find pivot and test for singularity ! I = IDAMAX( M, A( 1, 1 ), 1 ) IPIV( 1 ) = I IF( A( I, 1 ).NE.ZERO ) THEN ! ! Apply the interchange ! IF( I.NE.1 ) THEN TEMP = A( 1, 1 ) A( 1, 1 ) = A( I, 1 ) A( I, 1 ) = TEMP END IF ! ! Compute elements 2:M of the column ! IF( ABS(A( 1, 1 )) .GE. SFMIN ) THEN CALL DSCAL( M-1, ONE / A( 1, 1 ), A( 2, 1 ), 1 ) ELSE DO 10 I = 1, M-1 A( 1+I, 1 ) = A( 1+I, 1 ) / A( 1, 1 ) 10 CONTINUE END IF ! ELSE INFO = 1 END IF ! ELSE ! ! Use recursive code ! N1 = MIN( M, N ) / 2 N2 = N-N1 ! ! [ A11 ] ! Factor [ --- ] ! [ A21 ] ! CALL DGETRF2( M, N1, A, LDA, IPIV, IINFO ) IF ( INFO.EQ.0 .AND. IINFO.GT.0 ) INFO = IINFO ! ! [ A12 ] ! Apply interchanges to [ --- ] ! [ A22 ] ! CALL DLASWP( N2, A( 1, N1+1 ), LDA, 1, N1, IPIV, 1 ) ! ! Solve A12 ! CALL DTRSM( 'L', 'L', 'N', 'U', N1, N2, ONE, A, LDA, & A( 1, N1+1 ), LDA ) ! ! Update A22 ! CALL DGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( N1+1, 1 ), LDA, & A( 1, N1+1 ), LDA, ONE, A( N1+1, N1+1 ), LDA ) ! ! Factor A22 ! CALL DGETRF2( M-N1, N2, A( N1+1, N1+1 ), LDA, IPIV( N1+1 ), & IINFO ) ! ! Adjust INFO and the pivot indices ! IF ( INFO.EQ.0 .AND. IINFO.GT.0 ) INFO = IINFO + N1 DO 20 I = N1+1, MIN( M, N ) IPIV( I ) = IPIV( I ) + N1 20 CONTINUE ! ! Apply interchanges to A21 ! CALL DLASWP( N1, A( 1, 1 ), LDA, N1+1, MIN( M, N), IPIV, 1 ) ! END IF RETURN ! ! End of DGETRF2 ! END SUBROUTINE DGETRF2 ! !> \brief \b DGETRS ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DGETRS + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) ! ! .. Scalar Arguments .. ! CHARACTER TRANS ! INTEGER INFO, LDA, LDB, N, NRHS ! .. ! .. Array Arguments .. ! INTEGER IPIV( * ) ! DOUBLE PRECISION A( LDA, * ), B( LDB, * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DGETRS solves a system of linear equations !> A * X = B or A**T * X = B !> with a general N-by-N matrix A using the LU factorization computed !> by DGETRF. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] TRANS !> \verbatim !> TRANS is CHARACTER*1 !> Specifies the form of the system of equations: !> = 'N': A * X = B (No transpose) !> = 'T': A**T* X = B (Transpose) !> = 'C': A**T* X = B (Conjugate transpose = Transpose) !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The order of the matrix A. N >= 0. !> \endverbatim !> !> \param[in] NRHS !> \verbatim !> NRHS is INTEGER !> The number of right hand sides, i.e., the number of columns !> of the matrix B. NRHS >= 0. !> \endverbatim !> !> \param[in] A !> \verbatim !> A is DOUBLE PRECISION array, dimension (LDA,N) !> The factors L and U from the factorization A = P*L*U !> as computed by DGETRF. !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,N). !> \endverbatim !> !> \param[in] IPIV !> \verbatim !> IPIV is INTEGER array, dimension (N) !> The pivot indices from DGETRF; for 1<=i<=N, row i of the !> matrix was interchanged with row IPIV(i). !> \endverbatim !> !> \param[in,out] B !> \verbatim !> B is DOUBLE PRECISION array, dimension (LDB,NRHS) !> On entry, the right hand side matrix B. !> On exit, the solution matrix X. !> \endverbatim !> !> \param[in] LDB !> \verbatim !> LDB is INTEGER !> The leading dimension of the array B. LDB >= max(1,N). !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument had an illegal value !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup doubleGEcomputational ! ! ===================================================================== SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) ! ! -- LAPACK computational routine (version 3.4.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. CHARACTER TRANS INTEGER INFO, LDA, LDB, N, NRHS ! .. ! .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) ! .. ! .. Local Scalars .. LOGICAL NOTRAN ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL DLASWP, DTRSM, XERBLA ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! INFO = 0 NOTRAN = LSAME( TRANS, 'N' ) IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. & LSAME( TRANS, 'C' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NRHS.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGETRS', -INFO ) RETURN END IF ! ! Quick return if possible ! IF( N.EQ.0 .OR. NRHS.EQ.0 ) RETURN ! IF( NOTRAN ) THEN ! ! Solve A * X = B. ! ! Apply row interchanges to the right hand sides. ! CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) ! ! Solve L*X = B, overwriting B with X. ! CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, & ONE, A, LDA, B, LDB ) ! ! Solve U*X = B, overwriting B with X. ! CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, & NRHS, ONE, A, LDA, B, LDB ) ELSE ! ! Solve A**T * X = B. ! ! Solve U**T *X = B, overwriting B with X. ! CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, & ONE, A, LDA, B, LDB ) ! ! Solve L**T *X = B, overwriting B with X. ! CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, & A, LDA, B, LDB ) ! ! Apply row interchanges to the solution vectors. ! CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) END IF ! RETURN ! ! End of DGETRS ! END SUBROUTINE DGETRS !> \brief \b DISNAN tests input for NaN. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DISNAN + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! LOGICAL FUNCTION DISNAN( DIN ) ! ! .. Scalar Arguments .. ! DOUBLE PRECISION DIN ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DISNAN returns .TRUE. if its argument is NaN, and .FALSE. !> otherwise. To be replaced by the Fortran 2003 intrinsic in the !> future. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] DIN !> \verbatim !> DIN is DOUBLE PRECISION !> Input to test for NaN. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup auxOTHERauxiliary ! ! ===================================================================== LOGICAL FUNCTION DISNAN( DIN ) ! ! -- LAPACK auxiliary routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. DOUBLE PRECISION DIN ! .. ! != ! ! .. External Functions .. ! LOGICAL DLAISNAN ! EXTERNAL DLAISNAN ! .. ! .. Executable Statements .. DISNAN = DLAISNAN(DIN,DIN) RETURN END FUNCTION DISNAN ! !> \brief \b DLAISNAN tests input for NaN by comparing two arguments for inequality. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLAISNAN + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) ! ! .. Scalar Arguments .. ! DOUBLE PRECISION DIN1, DIN2 ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> This routine is not for general use. It exists solely to avoid !> over-optimization in DISNAN. !> !> DLAISNAN checks for NaNs by comparing its two arguments for !> inequality. NaN is the only floating-point value where NaN != NaN !> returns .TRUE. To check for NaNs, pass the same variable as both !> arguments. !> !> A compiler must assume that the two arguments are !> not the same variable, and the test will not be optimized away. !> Interprocedural or whole-program optimization may delete this !> test. The ISNAN functions will be replaced by the correct !> Fortran 03 intrinsic once the intrinsic is widely available. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] DIN1 !> \verbatim !> DIN1 is DOUBLE PRECISION !> \endverbatim !> !> \param[in] DIN2 !> \verbatim !> DIN2 is DOUBLE PRECISION !> Two numbers to compare for inequality. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup auxOTHERauxiliary ! ! ===================================================================== LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) ! ! -- LAPACK auxiliary routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. DOUBLE PRECISION DIN1, DIN2 ! .. ! ! ===================================================================== ! ! .. Executable Statements .. DLAISNAN = (DIN1.NE.DIN2) RETURN END FUNCTION DLAISNAN ! !> \brief \b DLAMCH ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! ! Definition: ! =========== ! ! DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLAMCH determines double precision machine parameters. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] CMACH !> \verbatim !> Specifies the value to be returned by DLAMCH: !> = 'E' or 'e', DLAMCH := eps !> = 'S' or 's , DLAMCH := sfmin !> = 'B' or 'b', DLAMCH := base !> = 'P' or 'p', DLAMCH := eps*base !> = 'N' or 'n', DLAMCH := t !> = 'R' or 'r', DLAMCH := rnd !> = 'M' or 'm', DLAMCH := emin !> = 'U' or 'u', DLAMCH := rmin !> = 'L' or 'l', DLAMCH := emax !> = 'O' or 'o', DLAMCH := rmax !> where !> eps = relative machine precision !> sfmin = safe minimum, such that 1/sfmin does not overflow !> base = base of the machine !> prec = eps*base !> t = number of (base) digits in the mantissa !> rnd = 1.0 when rounding occurs in addition, 0.0 otherwise !> emin = minimum exponent before (gradual) underflow !> rmin = underflow threshold - base**(emin-1) !> emax = largest exponent before overflow !> rmax = overflow threshold - (base**emax)*(1-eps) !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2015 ! !> \ingroup auxOTHERauxiliary ! ! ===================================================================== DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) ! ! -- LAPACK auxiliary routine (version 3.6.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2015 ! ! .. Scalar Arguments .. CHARACTER CMACH ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) ! .. ! .. Local Scalars .. DOUBLE PRECISION RND, EPS, SFMIN, SMALL, RMACH ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. Intrinsic Functions .. INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT, & MINEXPONENT, RADIX, TINY ! .. ! .. Executable Statements .. ! ! ! Assume rounding, not chopping. Always. ! RND = ONE ! IF( ONE.EQ.RND ) THEN EPS = EPSILON(ZERO) * 0.5 ELSE EPS = EPSILON(ZERO) END IF ! IF( LSAME( CMACH, 'E' ) ) THEN RMACH = EPS ELSE IF( LSAME( CMACH, 'S' ) ) THEN SFMIN = TINY(ZERO) SMALL = ONE / HUGE(ZERO) IF( SMALL.GE.SFMIN ) THEN ! ! Use SMALL plus a bit, to avoid the possibility of rounding ! causing overflow when computing 1/sfmin. ! SFMIN = SMALL*( ONE+EPS ) END IF RMACH = SFMIN ELSE IF( LSAME( CMACH, 'B' ) ) THEN RMACH = RADIX(ZERO) ELSE IF( LSAME( CMACH, 'P' ) ) THEN RMACH = EPS * RADIX(ZERO) ELSE IF( LSAME( CMACH, 'N' ) ) THEN RMACH = DIGITS(ZERO) ELSE IF( LSAME( CMACH, 'R' ) ) THEN RMACH = RND ELSE IF( LSAME( CMACH, 'M' ) ) THEN RMACH = MINEXPONENT(ZERO) ELSE IF( LSAME( CMACH, 'U' ) ) THEN RMACH = tiny(zero) ELSE IF( LSAME( CMACH, 'L' ) ) THEN RMACH = MAXEXPONENT(ZERO) ELSE IF( LSAME( CMACH, 'O' ) ) THEN RMACH = HUGE(ZERO) ELSE RMACH = ZERO END IF ! DLAMCH = RMACH RETURN ! ! End of DLAMCH ! END FUNCTION DLAMCH ! !*********************************************************************** !> \brief \b DLAMC3 !> \details !> \b Purpose: !> \verbatim !> DLAMC3 is intended to force A and B to be stored prior to doing !> the addition of A and B , for use in situations where optimizers !> might hold one of these in a register. !> \endverbatim !> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. !> \date November 2015 !> \ingroup auxOTHERauxiliary !> !> \param[in] A !> \verbatim !> A is a DOUBLE PRECISION !> \endverbatim !> !> \param[in] B !> \verbatim !> B is a DOUBLE PRECISION !> The values A and B. !> \endverbatim !> DOUBLE PRECISION FUNCTION DLAMC3( A, B ) ! ! -- LAPACK auxiliary routine (version 3.6.0) -- ! Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! November 2010 ! ! .. Scalar Arguments .. DOUBLE PRECISION A, B ! .. ! ===================================================================== ! ! .. Executable Statements .. ! DLAMC3 = A + B ! RETURN ! ! End of DLAMC3 ! END FUNCTION DLAMC3 ! !*********************************************************************** !> \brief \b DLAMRG creates a permutation list to merge the entries of two independently sorted sets into a single set sorted in ascending order. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLAMRG + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX ) ! ! .. Scalar Arguments .. ! INTEGER DTRD1, DTRD2, N1, N2 ! .. ! .. Array Arguments .. ! INTEGER INDEX( * ) ! DOUBLE PRECISION A( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLAMRG will create a permutation list which will merge the elements !> of A (which is composed of two independently sorted sets) into a !> single set which is sorted in ascending order. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] N1 !> \verbatim !> N1 is INTEGER !> \endverbatim !> !> \param[in] N2 !> \verbatim !> N2 is INTEGER !> These arguements contain the respective lengths of the two !> sorted lists to be merged. !> \endverbatim !> !> \param[in] A !> \verbatim !> A is DOUBLE PRECISION array, dimension (N1+N2) !> The first N1 elements of A contain a list of numbers which !> are sorted in either ascending or descending order. Likewise !> for the final N2 elements. !> \endverbatim !> !> \param[in] DTRD1 !> \verbatim !> DTRD1 is INTEGER !> \endverbatim !> !> \param[in] DTRD2 !> \verbatim !> DTRD2 is INTEGER !> These are the strides to be taken through the array A. !> Allowable strides are 1 and -1. They indicate whether a !> subset of A is sorted in ascending (DTRDx = 1) or descending !> (DTRDx = -1) order. !> \endverbatim !> !> \param[out] INDEX !> \verbatim !> INDEX is INTEGER array, dimension (N1+N2) !> On exit this array will contain a permutation such that !> if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be !> sorted in ascending order. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup auxOTHERcomputational ! ! ===================================================================== SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX ) ! ! -- LAPACK computational routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. INTEGER DTRD1, DTRD2, N1, N2 ! .. ! .. Array Arguments .. INTEGER INDEX( * ) DOUBLE PRECISION A( * ) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. INTEGER I, IND1, IND2, N1SV, N2SV ! .. ! .. Executable Statements .. ! N1SV = N1 N2SV = N2 IF( DTRD1.GT.0 ) THEN IND1 = 1 ELSE IND1 = N1 END IF IF( DTRD2.GT.0 ) THEN IND2 = 1 + N1 ELSE IND2 = N1 + N2 END IF I = 1 ! while ( (N1SV > 0) & (N2SV > 0) ) 10 CONTINUE IF( N1SV.GT.0 .AND. N2SV.GT.0 ) THEN IF( A( IND1 ).LE.A( IND2 ) ) THEN INDEX( I ) = IND1 I = I + 1 IND1 = IND1 + DTRD1 N1SV = N1SV - 1 ELSE INDEX( I ) = IND2 I = I + 1 IND2 = IND2 + DTRD2 N2SV = N2SV - 1 END IF GO TO 10 END IF ! end while IF( N1SV.EQ.0 ) THEN DO 20 N1SV = 1, N2SV INDEX( I ) = IND2 I = I + 1 IND2 = IND2 + DTRD2 20 CONTINUE ELSE ! N2SV .EQ. 0 DO 30 N2SV = 1, N1SV INDEX( I ) = IND1 I = I + 1 IND1 = IND1 + DTRD1 30 CONTINUE END IF ! RETURN ! ! End of DLAMRG ! END SUBROUTINE DLAMRG ! !> \brief \b DLASWP performs a series of row interchanges on a general rectangular matrix. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLASWP + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) ! ! .. Scalar Arguments .. ! INTEGER INCX, K1, K2, LDA, N ! .. ! .. Array Arguments .. ! INTEGER IPIV( * ) ! DOUBLE PRECISION A( LDA, * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLASWP performs a series of row interchanges on the matrix A. !> One row interchange is initiated for each of rows K1 through K2 of A. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] N !> \verbatim !> N is INTEGER !> The number of columns of the matrix A. !> \endverbatim !> !> \param[in,out] A !> \verbatim !> A is DOUBLE PRECISION array, dimension (LDA,N) !> On entry, the matrix of column dimension N to which the row !> interchanges will be applied. !> On exit, the permuted matrix. !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> The leading dimension of the array A. !> \endverbatim !> !> \param[in] K1 !> \verbatim !> K1 is INTEGER !> The first element of IPIV for which a row interchange will !> be done. !> \endverbatim !> !> \param[in] K2 !> \verbatim !> K2 is INTEGER !> The last element of IPIV for which a row interchange will !> be done. !> \endverbatim !> !> \param[in] IPIV !> \verbatim !> IPIV is INTEGER array, dimension (K2*abs(INCX)) !> The vector of pivot indices. Only the elements in positions !> K1 through K2 of IPIV are accessed. !> IPIV(K) = L implies rows K and L are to be interchanged. !> \endverbatim !> !> \param[in] INCX !> \verbatim !> INCX is INTEGER !> The increment between successive values of IPIV. If IPIV !> is negative, the pivots are applied in reverse order. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup doubleOTHERauxiliary ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> Modified by !> R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA !> \endverbatim !> ! ===================================================================== SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) ! ! -- LAPACK auxiliary routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. INTEGER INCX, K1, K2, LDA, N ! .. ! .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 DOUBLE PRECISION TEMP ! .. ! .. Executable Statements .. ! ! Interchange row I with row IPIV(I) for each of rows K1 through K2. ! IF( INCX.GT.0 ) THEN IX0 = K1 I1 = K1 I2 = K2 INC = 1 ELSE IF( INCX.LT.0 ) THEN IX0 = 1 + ( 1-K2 )*INCX I1 = K2 I2 = K1 INC = -1 ELSE RETURN END IF ! N32 = ( N / 32 )*32 IF( N32.NE.0 ) THEN DO 30 J = 1, N32, 32 IX = IX0 DO 20 I = I1, I2, INC IP = IPIV( IX ) IF( IP.NE.I ) THEN DO 10 K = J, J + 31 TEMP = A( I, K ) A( I, K ) = A( IP, K ) A( IP, K ) = TEMP 10 CONTINUE END IF IX = IX + INCX 20 CONTINUE 30 CONTINUE END IF IF( N32.NE.N ) THEN N32 = N32 + 1 IX = IX0 DO 50 I = I1, I2, INC IP = IPIV( IX ) IF( IP.NE.I ) THEN DO 40 K = N32, N TEMP = A( I, K ) A( I, K ) = A( IP, K ) A( IP, K ) = TEMP 40 CONTINUE END IF IX = IX + INCX 50 CONTINUE END IF ! RETURN ! ! End of DLASWP ! END SUBROUTINE DLASWP ! !> \brief \b DLASYF computes a partial factorization of a real symmetric matrix using the Bunch-Kaufman diagonal pivoting method. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLASYF + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) ! ! .. Scalar Arguments .. ! CHARACTER UPLO ! INTEGER INFO, KB, LDA, LDW, N, NB ! .. ! .. Array Arguments .. ! INTEGER IPIV( * ) ! DOUBLE PRECISION A( LDA, * ), W( LDW, * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLASYF computes a partial factorization of a real symmetric matrix A !> using the Bunch-Kaufman diagonal pivoting method. The partial !> factorization has the form: !> !> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: !> ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) !> !> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L' !> ( L21 I ) ( 0 A22 ) ( 0 I ) !> !> where the order of D is at most NB. The actual order is returned in !> the argument KB, and is either NB or NB-1, or N if N <= NB. !> !> DLASYF is an auxiliary routine called by DSYTRF. It uses blocked code !> (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or !> A22 (if UPLO = 'L'). !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> Specifies whether the upper or lower triangular part of the !> symmetric matrix A is stored: !> = 'U': Upper triangular !> = 'L': Lower triangular !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The order of the matrix A. N >= 0. !> \endverbatim !> !> \param[in] NB !> \verbatim !> NB is INTEGER !> The maximum number of columns of the matrix A that should be !> factored. NB should be at least 2 to allow for 2-by-2 pivot !> blocks. !> \endverbatim !> !> \param[out] KB !> \verbatim !> KB is INTEGER !> The number of columns of A that were actually factored. !> KB is either NB-1 or NB, or N if N <= NB. !> \endverbatim !> !> \param[in,out] A !> \verbatim !> A is DOUBLE PRECISION array, dimension (LDA,N) !> On entry, the symmetric matrix A. If UPLO = 'U', the leading !> n-by-n upper triangular part of A contains the upper !> triangular part of the matrix A, and the strictly lower !> triangular part of A is not referenced. If UPLO = 'L', the !> leading n-by-n lower triangular part of A contains the lower !> triangular part of the matrix A, and the strictly upper !> triangular part of A is not referenced. !> On exit, A contains details of the partial factorization. !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,N). !> \endverbatim !> !> \param[out] IPIV !> \verbatim !> IPIV is INTEGER array, dimension (N) !> Details of the interchanges and the block structure of D. !> !> If UPLO = 'U': !> Only the last KB elements of IPIV are set. !> !> If IPIV(k) > 0, then rows and columns k and IPIV(k) were !> interchanged and D(k,k) is a 1-by-1 diagonal block. !> !> If IPIV(k) = IPIV(k-1) < 0, then rows and columns !> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) !> is a 2-by-2 diagonal block. !> !> If UPLO = 'L': !> Only the first KB elements of IPIV are set. !> !> If IPIV(k) > 0, then rows and columns k and IPIV(k) were !> interchanged and D(k,k) is a 1-by-1 diagonal block. !> !> If IPIV(k) = IPIV(k+1) < 0, then rows and columns !> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1) !> is a 2-by-2 diagonal block. !> \endverbatim !> !> \param[out] W !> \verbatim !> W is DOUBLE PRECISION array, dimension (LDW,NB) !> \endverbatim !> !> \param[in] LDW !> \verbatim !> LDW is INTEGER !> The leading dimension of the array W. LDW >= max(1,N). !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit !> > 0: if INFO = k, D(k,k) is exactly zero. The factorization !> has been completed, but the block diagonal matrix D is !> exactly singular. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2013 ! !> \ingroup doubleSYcomputational ! !> \par Contributors: ! ================== !> !> \verbatim !> !> November 2013, Igor Kozachenko, !> Computer Science Division, !> University of California, Berkeley !> \endverbatim ! ! ===================================================================== SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) ! ! -- LAPACK computational routine (version 3.5.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2013 ! ! .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, KB, LDA, LDW, N, NB ! .. ! .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), W( LDW, * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION EIGHT, SEVTEN PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) ! .. ! .. Local Scalars .. INTEGER IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP, & KSTEP, KW DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D21, D22, R1, & ROWMAX, T ! .. ! .. External Functions .. ! LOGICAL LSAME ! INTEGER IDAMAX ! EXTERNAL LSAME, IDAMAX ! .. ! .. External Subroutines .. ! EXTERNAL DCOPY, DGEMM, DGEMV, DSCAL, DSWAP ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! INFO = 0 ! ! Initialize ALPHA for use in choosing pivot block size. ! ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT ! IF( LSAME( UPLO, 'U' ) ) THEN ! ! Factorize the trailing columns of A using the upper triangle ! of A and working backwards, and compute the matrix W = U12*D ! for use in updating A11 ! ! K is the main loop index, decreasing from N in steps of 1 or 2 ! ! KW is the column of W which corresponds to column K of A ! K = N 10 CONTINUE KW = NB + K - N ! ! Exit from loop ! IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) GO TO 30 ! ! Copy column K of A to column KW of W and update it ! CALL DCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 ) IF( K.LT.N ) & CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), LDA, & W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 ) ! KSTEP = 1 ! ! Determine rows and columns to be interchanged and whether ! a 1-by-1 or 2-by-2 pivot block will be used ! ABSAKK = ABS( W( K, KW ) ) ! ! IMAX is the row-index of the largest off-diagonal element in ! column K, and COLMAX is its absolute value. ! Determine both COLMAX and IMAX. ! IF( K.GT.1 ) THEN IMAX = IDAMAX( K-1, W( 1, KW ), 1 ) COLMAX = ABS( W( IMAX, KW ) ) ELSE COLMAX = ZERO END IF ! IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN ! ! Column K is zero or underflow: set INFO and continue ! IF( INFO.EQ.0 ) INFO = K KP = K ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN ! ! no interchange, use 1-by-1 pivot block ! KP = K ELSE ! ! Copy column IMAX to column KW-1 of W and update it ! CALL DCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 ) CALL DCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, & W( IMAX+1, KW-1 ), 1 ) IF( K.LT.N ) & CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), & LDA, W( IMAX, KW+1 ), LDW, ONE, & W( 1, KW-1 ), 1 ) ! ! JMAX is the column-index of the largest off-diagonal ! element in row IMAX, and ROWMAX is its absolute value ! JMAX = IMAX + IDAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 ) ROWMAX = ABS( W( JMAX, KW-1 ) ) IF( IMAX.GT.1 ) THEN JMAX = IDAMAX( IMAX-1, W( 1, KW-1 ), 1 ) ROWMAX = MAX( ROWMAX, ABS( W( JMAX, KW-1 ) ) ) END IF ! IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN ! ! no interchange, use 1-by-1 pivot block ! KP = K ELSE IF( ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX ) THEN ! ! interchange rows and columns K and IMAX, use 1-by-1 ! pivot block ! KP = IMAX ! ! copy column KW-1 of W to column KW of W ! CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) ELSE ! ! interchange rows and columns K-1 and IMAX, use 2-by-2 ! pivot block ! KP = IMAX KSTEP = 2 END IF END IF ! ! ============================================================ ! ! KK is the column of A where pivoting step stopped ! KK = K - KSTEP + 1 ! ! KKW is the column of W which corresponds to column KK of A ! KKW = NB + KK - N ! ! Interchange rows and columns KP and KK. ! Updated column KP is already stored in column KKW of W. ! IF( KP.NE.KK ) THEN ! ! Copy non-updated column KK to column KP of submatrix A ! at step K. No need to copy element into column K ! (or K and K-1 for 2-by-2 pivot) of A, since these columns ! will be later overwritten. ! A( KP, KP ) = A( KK, KK ) CALL DCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), & LDA ) IF( KP.GT.1 ) & CALL DCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) ! ! Interchange rows KK and KP in last K+1 to N columns of A ! (columns K (or K and K-1 for 2-by-2 pivot) of A will be ! later overwritten). Interchange rows KK and KP ! in last KKW to NB columns of W. ! IF( K.LT.N ) & CALL DSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ), & LDA ) CALL DSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), & LDW ) END IF ! IF( KSTEP.EQ.1 ) THEN ! ! 1-by-1 pivot block D(k): column kw of W now holds ! ! W(kw) = U(k)*D(k), ! ! where U(k) is the k-th column of U ! ! Store subdiag. elements of column U(k) ! and 1-by-1 block D(k) in column k of A. ! NOTE: Diagonal element U(k,k) is a UNIT element ! and not stored. ! A(k,k) := D(k,k) = W(k,kw) ! A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k) ! CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) R1 = ONE / A( K, K ) CALL DSCAL( K-1, R1, A( 1, K ), 1 ) ! ELSE ! ! 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold ! ! ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k) ! ! where U(k) and U(k-1) are the k-th and (k-1)-th columns ! of U ! ! Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2 ! block D(k-1:k,k-1:k) in columns k-1 and k of A. ! NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT ! block and not stored. ! A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw) ! A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) = ! = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) ) ! IF( K.GT.2 ) THEN ! ! Compose the columns of the inverse of 2-by-2 pivot ! block D in the following way to reduce the number ! of FLOPS when we myltiply panel ( W(kw-1) W(kw) ) by ! this inverse ! ! D**(-1) = ( d11 d21 )**(-1) = ! ( d21 d22 ) ! ! = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) = ! ( (-d21 ) ( d11 ) ) ! ! = 1/d21 * 1/((d11/d21)*(d22/d21)-1) * ! ! * ( ( d22/d21 ) ( -1 ) ) = ! ( ( -1 ) ( d11/d21 ) ) ! ! = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) = ! ( ( -1 ) ( D22 ) ) ! ! = 1/d21 * T * ( ( D11 ) ( -1 ) ) ! ( ( -1 ) ( D22 ) ) ! ! = D21 * ( ( D11 ) ( -1 ) ) ! ( ( -1 ) ( D22 ) ) ! D21 = W( K-1, KW ) D11 = W( K, KW ) / D21 D22 = W( K-1, KW-1 ) / D21 T = ONE / ( D11*D22-ONE ) D21 = T / D21 ! ! Update elements in columns A(k-1) and A(k) as ! dot products of rows of ( W(kw-1) W(kw) ) and columns ! of D**(-1) ! DO 20 J = 1, K - 2 A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) ) 20 CONTINUE END IF ! ! Copy D(k) to A ! A( K-1, K-1 ) = W( K-1, KW-1 ) A( K-1, K ) = W( K-1, KW ) A( K, K ) = W( K, KW ) ! END IF ! END IF ! ! Store details of the interchanges in IPIV ! IF( KSTEP.EQ.1 ) THEN IPIV( K ) = KP ELSE IPIV( K ) = -KP IPIV( K-1 ) = -KP END IF ! ! Decrease K and return to the start of the main loop ! K = K - KSTEP GO TO 10 ! 30 CONTINUE ! ! Update the upper triangle of A11 (= A(1:k,1:k)) as ! ! A11 := A11 - U12*D*U12**T = A11 - U12*W**T ! ! computing blocks of NB columns at a time ! DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB JB = MIN( NB, K-J+1 ) ! ! Update the upper triangle of the diagonal block ! DO 40 JJ = J, J + JB - 1 CALL DGEMV( 'No transpose', JJ-J+1, N-K, -ONE, & A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE, & A( J, JJ ), 1 ) 40 CONTINUE ! ! Update the rectangular superdiagonal block ! CALL DGEMM( 'No transpose', 'Transpose', J-1, JB, N-K, -ONE, & A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, ONE, & A( 1, J ), LDA ) 50 CONTINUE ! ! Put U12 in standard form by partially undoing the interchanges ! in columns k+1:n looping backwards from k+1 to n ! J = K + 1 60 CONTINUE ! ! Undo the interchanges (if any) of rows JJ and JP at each ! step J ! ! (Here, J is a diagonal index) JJ = J JP = IPIV( J ) IF( JP.LT.0 ) THEN JP = -JP ! (Here, J is a diagonal index) J = J + 1 END IF ! (NOTE: Here, J is used to determine row length. Length N-J+1 ! of the rows to swap back doesn't include diagonal element) J = J + 1 IF( JP.NE.JJ .AND. J.LE.N ) & CALL DSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA ) IF( J.LT.N ) GO TO 60 ! ! Set KB to the number of columns factorized ! KB = N - K ! ELSE ! ! Factorize the leading columns of A using the lower triangle ! of A and working forwards, and compute the matrix W = L21*D ! for use in updating A22 ! ! K is the main loop index, increasing from 1 in steps of 1 or 2 ! K = 1 70 CONTINUE ! ! Exit from loop ! IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N ) GO TO 90 ! ! Copy column K of A to column K of W and update it ! CALL DCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 ) CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), LDA, & W( K, 1 ), LDW, ONE, W( K, K ), 1 ) ! KSTEP = 1 ! ! Determine rows and columns to be interchanged and whether ! a 1-by-1 or 2-by-2 pivot block will be used ! ABSAKK = ABS( W( K, K ) ) ! ! IMAX is the row-index of the largest off-diagonal element in ! column K, and COLMAX is its absolute value. ! Determine both COLMAX and IMAX. ! IF( K.LT.N ) THEN IMAX = K + IDAMAX( N-K, W( K+1, K ), 1 ) COLMAX = ABS( W( IMAX, K ) ) ELSE COLMAX = ZERO END IF ! IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN ! ! Column K is zero or underflow: set INFO and continue ! IF( INFO.EQ.0 ) INFO = K KP = K ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN ! ! no interchange, use 1-by-1 pivot block ! KP = K ELSE ! ! Copy column IMAX to column K+1 of W and update it ! CALL DCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 ) CALL DCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, K+1 ), & 1 ) CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), & LDA, W( IMAX, 1 ), LDW, ONE, W( K, K+1 ), 1 ) ! ! JMAX is the column-index of the largest off-diagonal ! element in row IMAX, and ROWMAX is its absolute value ! JMAX = K - 1 + IDAMAX( IMAX-K, W( K, K+1 ), 1 ) ROWMAX = ABS( W( JMAX, K+1 ) ) IF( IMAX.LT.N ) THEN JMAX = IMAX + IDAMAX( N-IMAX, W( IMAX+1, K+1 ), 1 ) ROWMAX = MAX( ROWMAX, ABS( W( JMAX, K+1 ) ) ) END IF ! IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN ! ! no interchange, use 1-by-1 pivot block ! KP = K ELSE IF( ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX ) THEN ! ! interchange rows and columns K and IMAX, use 1-by-1 ! pivot block ! KP = IMAX ! ! copy column K+1 of W to column K of W ! CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) ELSE ! ! interchange rows and columns K+1 and IMAX, use 2-by-2 ! pivot block ! KP = IMAX KSTEP = 2 END IF END IF ! ! ============================================================ ! ! KK is the column of A where pivoting step stopped ! KK = K + KSTEP - 1 ! ! Interchange rows and columns KP and KK. ! Updated column KP is already stored in column KK of W. ! IF( KP.NE.KK ) THEN ! ! Copy non-updated column KK to column KP of submatrix A ! at step K. No need to copy element into column K ! (or K and K+1 for 2-by-2 pivot) of A, since these columns ! will be later overwritten. ! A( KP, KP ) = A( KK, KK ) CALL DCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), & LDA ) IF( KP.LT.N ) & CALL DCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) ! ! Interchange rows KK and KP in first K-1 columns of A ! (columns K (or K and K+1 for 2-by-2 pivot) of A will be ! later overwritten). Interchange rows KK and KP ! in first KK columns of W. ! IF( K.GT.1 ) & CALL DSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) CALL DSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) END IF ! IF( KSTEP.EQ.1 ) THEN ! ! 1-by-1 pivot block D(k): column k of W now holds ! ! W(k) = L(k)*D(k), ! ! where L(k) is the k-th column of L ! ! Store subdiag. elements of column L(k) ! and 1-by-1 block D(k) in column k of A. ! (NOTE: Diagonal element L(k,k) is a UNIT element ! and not stored) ! A(k,k) := D(k,k) = W(k,k) ! A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k) ! CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) IF( K.LT.N ) THEN R1 = ONE / A( K, K ) CALL DSCAL( N-K, R1, A( K+1, K ), 1 ) END IF ! ELSE ! ! 2-by-2 pivot block D(k): columns k and k+1 of W now hold ! ! ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) ! ! where L(k) and L(k+1) are the k-th and (k+1)-th columns ! of L ! ! Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2 ! block D(k:k+1,k:k+1) in columns k and k+1 of A. ! (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT ! block and not stored) ! A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1) ! A(k+2:N,k:k+1) := L(k+2:N,k:k+1) = ! = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) ) ! IF( K.LT.N-1 ) THEN ! ! Compose the columns of the inverse of 2-by-2 pivot ! block D in the following way to reduce the number ! of FLOPS when we myltiply panel ( W(k) W(k+1) ) by ! this inverse ! ! D**(-1) = ( d11 d21 )**(-1) = ! ( d21 d22 ) ! ! = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) = ! ( (-d21 ) ( d11 ) ) ! ! = 1/d21 * 1/((d11/d21)*(d22/d21)-1) * ! ! * ( ( d22/d21 ) ( -1 ) ) = ! ( ( -1 ) ( d11/d21 ) ) ! ! = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) = ! ( ( -1 ) ( D22 ) ) ! ! = 1/d21 * T * ( ( D11 ) ( -1 ) ) ! ( ( -1 ) ( D22 ) ) ! ! = D21 * ( ( D11 ) ( -1 ) ) ! ( ( -1 ) ( D22 ) ) ! D21 = W( K+1, K ) D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / D21 T = ONE / ( D11*D22-ONE ) D21 = T / D21 ! ! Update elements in columns A(k) and A(k+1) as ! dot products of rows of ( W(k) W(k+1) ) and columns ! of D**(-1) ! DO 80 J = K + 2, N A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) ) A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) ) 80 CONTINUE END IF ! ! Copy D(k) to A ! A( K, K ) = W( K, K ) A( K+1, K ) = W( K+1, K ) A( K+1, K+1 ) = W( K+1, K+1 ) ! END IF ! END IF ! ! Store details of the interchanges in IPIV ! IF( KSTEP.EQ.1 ) THEN IPIV( K ) = KP ELSE IPIV( K ) = -KP IPIV( K+1 ) = -KP END IF ! ! Increase K and return to the start of the main loop ! K = K + KSTEP GO TO 70 ! 90 CONTINUE ! ! Update the lower triangle of A22 (= A(k:n,k:n)) as ! ! A22 := A22 - L21*D*L21**T = A22 - L21*W**T ! ! computing blocks of NB columns at a time ! DO 110 J = K, N, NB JB = MIN( NB, N-J+1 ) ! ! Update the lower triangle of the diagonal block ! DO 100 JJ = J, J + JB - 1 CALL DGEMV( 'No transpose', J+JB-JJ, K-1, -ONE, & A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE, & A( JJ, JJ ), 1 ) 100 CONTINUE ! ! Update the rectangular subdiagonal block ! IF( J+JB.LE.N ) & CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, & K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW, & ONE, A( J+JB, J ), LDA ) 110 CONTINUE ! ! Put L21 in standard form by partially undoing the interchanges ! of rows in columns 1:k-1 looping backwards from k-1 to 1 ! J = K - 1 120 CONTINUE ! ! Undo the interchanges (if any) of rows JJ and JP at each ! step J ! ! (Here, J is a diagonal index) JJ = J JP = IPIV( J ) IF( JP.LT.0 ) THEN JP = -JP ! (Here, J is a diagonal index) J = J - 1 END IF ! (NOTE: Here, J is used to determine row length. Length J ! of the rows to swap back doesn't include diagonal element) J = J - 1 IF( JP.NE.JJ .AND. J.GE.1 ) & CALL DSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA ) IF( J.GT.1 ) GO TO 120 ! ! Set KB to the number of columns factorized ! KB = K - 1 ! END IF RETURN ! ! End of DLASYF ! END SUBROUTINE DLASYF !> \brief \b DSCAL ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! ! Definition: ! =========== ! ! SUBROUTINE DSCAL(N,DA,DX,INCX) ! ! .. Scalar Arguments .. ! DOUBLE PRECISION DA ! INTEGER INCX,N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION DX(*) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DSCAL scales a vector by a constant. !> uses unrolled loops for increment equal to one. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup double_blas_level1 ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> jack dongarra, linpack, 3/11/78. !> modified 3/93 to return if incx .le. 0. !> modified 12/3/93, array(1) declarations changed to array(*) !> \endverbatim !> ! ===================================================================== SUBROUTINE DSCAL(N,DA,DX,INCX) ! ! -- Reference BLAS level1 routine (version 3.4.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. DOUBLE PRECISION DA INTEGER INCX,N ! .. ! .. Array Arguments .. DOUBLE PRECISION DX(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. INTEGER I,M,MP1,NINCX ! .. ! .. Intrinsic Functions .. INTRINSIC MOD ! .. IF (N.LE.0 .OR. INCX.LE.0) RETURN IF (INCX.EQ.1) THEN ! ! code for increment equal to 1 ! ! ! clean-up loop ! M = MOD(N,5) IF (M.NE.0) THEN DO I = 1,M DX(I) = DA*DX(I) END DO IF (N.LT.5) RETURN END IF MP1 = M + 1 DO I = MP1,N,5 DX(I) = DA*DX(I) DX(I+1) = DA*DX(I+1) DX(I+2) = DA*DX(I+2) DX(I+3) = DA*DX(I+3) DX(I+4) = DA*DX(I+4) END DO ELSE ! ! code for increment not equal to 1 ! NINCX = N*INCX DO I = 1,NINCX,INCX DX(I) = DA*DX(I) END DO END IF RETURN END SUBROUTINE DSCAL ! !> \brief \b DSWAP ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! ! Definition: ! =========== ! ! SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) ! ! .. Scalar Arguments .. ! INTEGER INCX,INCY,N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION DX(*),DY(*) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> interchanges two vectors. !> uses unrolled loops for increments equal one. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup double_blas_level1 ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> jack dongarra, linpack, 3/11/78. !> modified 12/3/93, array(1) declarations changed to array(*) !> \endverbatim !> ! ===================================================================== SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) ! ! -- Reference BLAS level1 routine (version 3.4.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. INTEGER INCX,INCY,N ! .. ! .. Array Arguments .. DOUBLE PRECISION DX(*),DY(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. DOUBLE PRECISION DTEMP INTEGER I,IX,IY,M,MP1 ! .. ! .. Intrinsic Functions .. INTRINSIC MOD ! .. IF (N.LE.0) RETURN IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN ! ! code for both increments equal to 1 ! ! ! clean-up loop ! M = MOD(N,3) IF (M.NE.0) THEN DO I = 1,M DTEMP = DX(I) DX(I) = DY(I) DY(I) = DTEMP END DO IF (N.LT.3) RETURN END IF MP1 = M + 1 DO I = MP1,N,3 DTEMP = DX(I) DX(I) = DY(I) DY(I) = DTEMP DTEMP = DX(I+1) DX(I+1) = DY(I+1) DY(I+1) = DTEMP DTEMP = DX(I+2) DX(I+2) = DY(I+2) DY(I+2) = DTEMP END DO ELSE ! ! code for unequal increments or equal increments not equal ! to 1 ! IX = 1 IY = 1 IF (INCX.LT.0) IX = (-N+1)*INCX + 1 IF (INCY.LT.0) IY = (-N+1)*INCY + 1 DO I = 1,N DTEMP = DX(IX) DX(IX) = DY(IY) DY(IY) = DTEMP IX = IX + INCX IY = IY + INCY END DO END IF RETURN END SUBROUTINE DSWAP ! !> \brief \b DSYMV ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! ! Definition: ! =========== ! ! SUBROUTINE DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) ! ! .. Scalar Arguments .. ! DOUBLE PRECISION ALPHA,BETA ! INTEGER INCX,INCY,LDA,N ! CHARACTER UPLO ! .. ! .. Array Arguments .. ! DOUBLE PRECISION A(LDA,*),X(*),Y(*) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DSYMV performs the matrix-vector operation !> !> y := alpha*A*x + beta*y, !> !> where alpha and beta are scalars, x and y are n element vectors and !> A is an n by n symmetric matrix. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> On entry, UPLO specifies whether the upper or lower !> triangular part of the array A is to be referenced as !> follows: !> !> UPLO = 'U' or 'u' Only the upper triangular part of A !> is to be referenced. !> !> UPLO = 'L' or 'l' Only the lower triangular part of A !> is to be referenced. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> On entry, N specifies the order of the matrix A. !> N must be at least zero. !> \endverbatim !> !> \param[in] ALPHA !> \verbatim !> ALPHA is DOUBLE PRECISION. !> On entry, ALPHA specifies the scalar alpha. !> \endverbatim !> !> \param[in] A !> \verbatim !> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ). !> Before entry with UPLO = 'U' or 'u', the leading n by n !> upper triangular part of the array A must contain the upper !> triangular part of the symmetric matrix and the strictly !> lower triangular part of A is not referenced. !> Before entry with UPLO = 'L' or 'l', the leading n by n !> lower triangular part of the array A must contain the lower !> triangular part of the symmetric matrix and the strictly !> upper triangular part of A is not referenced. !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> On entry, LDA specifies the first dimension of A as declared !> in the calling (sub) program. LDA must be at least !> max( 1, n ). !> \endverbatim !> !> \param[in] X !> \verbatim !> X is DOUBLE PRECISION array of dimension at least !> ( 1 + ( n - 1 )*abs( INCX ) ). !> Before entry, the incremented array X must contain the n !> element vector x. !> \endverbatim !> !> \param[in] INCX !> \verbatim !> INCX is INTEGER !> On entry, INCX specifies the increment for the elements of !> X. INCX must not be zero. !> \endverbatim !> !> \param[in] BETA !> \verbatim !> BETA is DOUBLE PRECISION. !> On entry, BETA specifies the scalar beta. When BETA is !> supplied as zero then Y need not be set on input. !> \endverbatim !> !> \param[in,out] Y !> \verbatim !> Y is DOUBLE PRECISION array of dimension at least !> ( 1 + ( n - 1 )*abs( INCY ) ). !> Before entry, the incremented array Y must contain the n !> element vector y. On exit, Y is overwritten by the updated !> vector y. !> \endverbatim !> !> \param[in] INCY !> \verbatim !> INCY is INTEGER !> On entry, INCY specifies the increment for the elements of !> Y. INCY must not be zero. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup double_blas_level2 ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> Level 2 Blas routine. !> The vector and matrix arguments are not referenced when N = 0, or M = 0 !> !> -- Written on 22-October-1986. !> Jack Dongarra, Argonne National Lab. !> Jeremy Du Croz, Nag Central Office. !> Sven Hammarling, Nag Central Office. !> Richard Hanson, Sandia National Labs. !> \endverbatim !> ! ===================================================================== SUBROUTINE DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) ! ! -- Reference BLAS level2 routine (version 3.4.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. DOUBLE PRECISION ALPHA,BETA INTEGER INCX,INCY,LDA,N CHARACTER UPLO ! .. ! .. Array Arguments .. DOUBLE PRECISION A(LDA,*),X(*),Y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE,ZERO PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) ! .. ! .. Local Scalars .. DOUBLE PRECISION TEMP1,TEMP2 INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! ! Test the input parameters. ! INFO = 0 IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN INFO = 1 ELSE IF (N.LT.0) THEN INFO = 2 ELSE IF (LDA.LT.MAX(1,N)) THEN INFO = 5 ELSE IF (INCX.EQ.0) THEN INFO = 7 ELSE IF (INCY.EQ.0) THEN INFO = 10 END IF IF (INFO.NE.0) THEN CALL XERBLA('DSYMV ',INFO) RETURN END IF ! ! Quick return if possible. ! IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN ! ! Set up the start points in X and Y. ! IF (INCX.GT.0) THEN KX = 1 ELSE KX = 1 - (N-1)*INCX END IF IF (INCY.GT.0) THEN KY = 1 ELSE KY = 1 - (N-1)*INCY END IF ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through the triangular part ! of A. ! ! First form y := beta*y. ! IF (BETA.NE.ONE) THEN IF (INCY.EQ.1) THEN IF (BETA.EQ.ZERO) THEN DO 10 I = 1,N Y(I) = ZERO 10 CONTINUE ELSE DO 20 I = 1,N Y(I) = BETA*Y(I) 20 CONTINUE END IF ELSE IY = KY IF (BETA.EQ.ZERO) THEN DO 30 I = 1,N Y(IY) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40 I = 1,N Y(IY) = BETA*Y(IY) IY = IY + INCY 40 CONTINUE END IF END IF END IF IF (ALPHA.EQ.ZERO) RETURN IF (LSAME(UPLO,'U')) THEN ! ! Form y when A is stored in upper triangle. ! IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN DO 60 J = 1,N TEMP1 = ALPHA*X(J) TEMP2 = ZERO DO 50 I = 1,J - 1 Y(I) = Y(I) + TEMP1*A(I,J) TEMP2 = TEMP2 + A(I,J)*X(I) 50 CONTINUE Y(J) = Y(J) + TEMP1*A(J,J) + ALPHA*TEMP2 60 CONTINUE ELSE JX = KX JY = KY DO 80 J = 1,N TEMP1 = ALPHA*X(JX) TEMP2 = ZERO IX = KX IY = KY DO 70 I = 1,J - 1 Y(IY) = Y(IY) + TEMP1*A(I,J) TEMP2 = TEMP2 + A(I,J)*X(IX) IX = IX + INCX IY = IY + INCY 70 CONTINUE Y(JY) = Y(JY) + TEMP1*A(J,J) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY 80 CONTINUE END IF ELSE ! ! Form y when A is stored in lower triangle. ! IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN DO 100 J = 1,N TEMP1 = ALPHA*X(J) TEMP2 = ZERO Y(J) = Y(J) + TEMP1*A(J,J) DO 90 I = J + 1,N Y(I) = Y(I) + TEMP1*A(I,J) TEMP2 = TEMP2 + A(I,J)*X(I) 90 CONTINUE Y(J) = Y(J) + ALPHA*TEMP2 100 CONTINUE ELSE JX = KX JY = KY DO 120 J = 1,N TEMP1 = ALPHA*X(JX) TEMP2 = ZERO Y(JY) = Y(JY) + TEMP1*A(J,J) IX = JX IY = JY DO 110 I = J + 1,N IX = IX + INCX IY = IY + INCY Y(IY) = Y(IY) + TEMP1*A(I,J) TEMP2 = TEMP2 + A(I,J)*X(IX) 110 CONTINUE Y(JY) = Y(JY) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY 120 CONTINUE END IF END IF ! RETURN ! ! End of DSYMV . ! END SUBROUTINE DSYMV ! !> \brief \b DSYR ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! ! Definition: ! =========== ! ! SUBROUTINE DSYR(UPLO,N,ALPHA,X,INCX,A,LDA) ! ! .. Scalar Arguments .. ! DOUBLE PRECISION ALPHA ! INTEGER INCX,LDA,N ! CHARACTER UPLO ! .. ! .. Array Arguments .. ! DOUBLE PRECISION A(LDA,*),X(*) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DSYR performs the symmetric rank 1 operation !> !> A := alpha*x*x**T + A, !> !> where alpha is a real scalar, x is an n element vector and A is an !> n by n symmetric matrix. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> On entry, UPLO specifies whether the upper or lower !> triangular part of the array A is to be referenced as !> follows: !> !> UPLO = 'U' or 'u' Only the upper triangular part of A !> is to be referenced. !> !> UPLO = 'L' or 'l' Only the lower triangular part of A !> is to be referenced. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> On entry, N specifies the order of the matrix A. !> N must be at least zero. !> \endverbatim !> !> \param[in] ALPHA !> \verbatim !> ALPHA is DOUBLE PRECISION. !> On entry, ALPHA specifies the scalar alpha. !> \endverbatim !> !> \param[in] X !> \verbatim !> X is DOUBLE PRECISION array of dimension at least !> ( 1 + ( n - 1 )*abs( INCX ) ). !> Before entry, the incremented array X must contain the n !> element vector x. !> \endverbatim !> !> \param[in] INCX !> \verbatim !> INCX is INTEGER !> On entry, INCX specifies the increment for the elements of !> X. INCX must not be zero. !> \endverbatim !> !> \param[in,out] A !> \verbatim !> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ). !> Before entry with UPLO = 'U' or 'u', the leading n by n !> upper triangular part of the array A must contain the upper !> triangular part of the symmetric matrix and the strictly !> lower triangular part of A is not referenced. On exit, the !> upper triangular part of the array A is overwritten by the !> upper triangular part of the updated matrix. !> Before entry with UPLO = 'L' or 'l', the leading n by n !> lower triangular part of the array A must contain the lower !> triangular part of the symmetric matrix and the strictly !> upper triangular part of A is not referenced. On exit, the !> lower triangular part of the array A is overwritten by the !> lower triangular part of the updated matrix. !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> On entry, LDA specifies the first dimension of A as declared !> in the calling (sub) program. LDA must be at least !> max( 1, n ). !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup double_blas_level2 ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> Level 2 Blas routine. !> !> -- Written on 22-October-1986. !> Jack Dongarra, Argonne National Lab. !> Jeremy Du Croz, Nag Central Office. !> Sven Hammarling, Nag Central Office. !> Richard Hanson, Sandia National Labs. !> \endverbatim !> ! ===================================================================== SUBROUTINE DSYR(UPLO,N,ALPHA,X,INCX,A,LDA) ! ! -- Reference BLAS level2 routine (version 3.4.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. DOUBLE PRECISION ALPHA INTEGER INCX,LDA,N CHARACTER UPLO ! .. ! .. Array Arguments .. DOUBLE PRECISION A(LDA,*),X(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ZERO PARAMETER (ZERO=0.0D+0) ! .. ! .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I,INFO,IX,J,JX,KX ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! ! Test the input parameters. ! INFO = 0 IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN INFO = 1 ELSE IF (N.LT.0) THEN INFO = 2 ELSE IF (INCX.EQ.0) THEN INFO = 5 ELSE IF (LDA.LT.MAX(1,N)) THEN INFO = 7 END IF IF (INFO.NE.0) THEN CALL XERBLA('DSYR ',INFO) RETURN END IF ! ! Quick return if possible. ! IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN ! ! Set the start point in X if the increment is not unity. ! IF (INCX.LE.0) THEN KX = 1 - (N-1)*INCX ELSE IF (INCX.NE.1) THEN KX = 1 END IF ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through the triangular part ! of A. ! IF (LSAME(UPLO,'U')) THEN ! ! Form A when A is stored in upper triangle. ! IF (INCX.EQ.1) THEN DO 20 J = 1,N IF (X(J).NE.ZERO) THEN TEMP = ALPHA*X(J) DO 10 I = 1,J A(I,J) = A(I,J) + X(I)*TEMP 10 CONTINUE END IF 20 CONTINUE ELSE JX = KX DO 40 J = 1,N IF (X(JX).NE.ZERO) THEN TEMP = ALPHA*X(JX) IX = KX DO 30 I = 1,J A(I,J) = A(I,J) + X(IX)*TEMP IX = IX + INCX 30 CONTINUE END IF JX = JX + INCX 40 CONTINUE END IF ELSE ! ! Form A when A is stored in lower triangle. ! IF (INCX.EQ.1) THEN DO 60 J = 1,N IF (X(J).NE.ZERO) THEN TEMP = ALPHA*X(J) DO 50 I = J,N A(I,J) = A(I,J) + X(I)*TEMP 50 CONTINUE END IF 60 CONTINUE ELSE JX = KX DO 80 J = 1,N IF (X(JX).NE.ZERO) THEN TEMP = ALPHA*X(JX) IX = JX DO 70 I = J,N A(I,J) = A(I,J) + X(IX)*TEMP IX = IX + INCX 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF END IF ! RETURN ! ! End of DSYR . ! END SUBROUTINE DSYR ! !> \brief \b DSYTF2 computes the factorization of a real symmetric indefinite matrix, using the diagonal pivoting method (unblocked algorithm). ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DSYTF2 + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) ! ! .. Scalar Arguments .. ! CHARACTER UPLO ! INTEGER INFO, LDA, N ! .. ! .. Array Arguments .. ! INTEGER IPIV( * ) ! DOUBLE PRECISION A( LDA, * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DSYTF2 computes the factorization of a real symmetric matrix A using !> the Bunch-Kaufman diagonal pivoting method: !> !> A = U*D*U**T or A = L*D*L**T !> !> where U (or L) is a product of permutation and unit upper (lower) !> triangular matrices, U**T is the transpose of U, and D is symmetric and !> block diagonal with 1-by-1 and 2-by-2 diagonal blocks. !> !> This is the unblocked version of the algorithm, calling Level 2 BLAS. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> Specifies whether the upper or lower triangular part of the !> symmetric matrix A is stored: !> = 'U': Upper triangular !> = 'L': Lower triangular !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The order of the matrix A. N >= 0. !> \endverbatim !> !> \param[in,out] A !> \verbatim !> A is DOUBLE PRECISION array, dimension (LDA,N) !> On entry, the symmetric matrix A. If UPLO = 'U', the leading !> n-by-n upper triangular part of A contains the upper !> triangular part of the matrix A, and the strictly lower !> triangular part of A is not referenced. If UPLO = 'L', the !> leading n-by-n lower triangular part of A contains the lower !> triangular part of the matrix A, and the strictly upper !> triangular part of A is not referenced. !> !> On exit, the block diagonal matrix D and the multipliers used !> to obtain the factor U or L (see below for further details). !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,N). !> \endverbatim !> !> \param[out] IPIV !> \verbatim !> IPIV is INTEGER array, dimension (N) !> Details of the interchanges and the block structure of D. !> !> If UPLO = 'U': !> If IPIV(k) > 0, then rows and columns k and IPIV(k) were !> interchanged and D(k,k) is a 1-by-1 diagonal block. !> !> If IPIV(k) = IPIV(k-1) < 0, then rows and columns !> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) !> is a 2-by-2 diagonal block. !> !> If UPLO = 'L': !> If IPIV(k) > 0, then rows and columns k and IPIV(k) were !> interchanged and D(k,k) is a 1-by-1 diagonal block. !> !> If IPIV(k) = IPIV(k+1) < 0, then rows and columns !> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1) !> is a 2-by-2 diagonal block. !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -k, the k-th argument had an illegal value !> > 0: if INFO = k, D(k,k) is exactly zero. The factorization !> has been completed, but the block diagonal matrix D is !> exactly singular, and division by zero will occur if it !> is used to solve a system of equations. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2013 ! !> \ingroup doubleSYcomputational ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> If UPLO = 'U', then A = U*D*U**T, where !> U = P(n)*U(n)* ... *P(k)U(k)* ..., !> i.e., U is a product of terms P(k)*U(k), where k decreases from n to !> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 !> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as !> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such !> that if the diagonal block D(k) is of order s (s = 1 or 2), then !> !> ( I v 0 ) k-s !> U(k) = ( 0 I 0 ) s !> ( 0 0 I ) n-k !> k-s s n-k !> !> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). !> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), !> and A(k,k), and v overwrites A(1:k-2,k-1:k). !> !> If UPLO = 'L', then A = L*D*L**T, where !> L = P(1)*L(1)* ... *P(k)*L(k)* ..., !> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to !> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 !> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as !> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such !> that if the diagonal block D(k) is of order s (s = 1 or 2), then !> !> ( I 0 0 ) k-1 !> L(k) = ( 0 I 0 ) s !> ( 0 v I ) n-k-s+1 !> k-1 s n-k-s+1 !> !> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). !> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), !> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). !> \endverbatim ! !> \par Contributors: ! ================== !> !> \verbatim !> !> 09-29-06 - patch from !> Bobby Cheng, MathWorks !> !> Replace l.204 and l.372 !> IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN !> by !> IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN !> !> 01-01-96 - Based on modifications by !> J. Lewis, Boeing Computer Services Company !> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA !> 1-96 - Based on modifications by J. Lewis, Boeing Computer Services !> Company !> \endverbatim ! ! ===================================================================== SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) ! ! -- LAPACK computational routine (version 3.5.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2013 ! ! .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N ! .. ! .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION EIGHT, SEVTEN PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) ! .. ! .. Local Scalars .. LOGICAL UPPER INTEGER I, IMAX, J, JMAX, K, KK, KP, KSTEP DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1, & ROWMAX, T, WK, WKM1, WKP1 ! .. ! .. External Functions .. ! LOGICAL LSAME, DISNAN ! INTEGER IDAMAX ! EXTERNAL LSAME, IDAMAX, DISNAN ! .. ! .. External Subroutines .. ! EXTERNAL DSCAL, DSWAP, DSYR, XERBLA ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYTF2', -INFO ) RETURN END IF ! ! Initialize ALPHA for use in choosing pivot block size. ! ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT ! IF( UPPER ) THEN ! ! Factorize A as U*D*U**T using the upper triangle of A ! ! K is the main loop index, decreasing from N to 1 in steps of ! 1 or 2 ! K = N 10 CONTINUE ! ! If K < 1, exit from loop ! IF( K.LT.1 ) GO TO 70 KSTEP = 1 ! ! Determine rows and columns to be interchanged and whether ! a 1-by-1 or 2-by-2 pivot block will be used ! ABSAKK = ABS( A( K, K ) ) ! ! IMAX is the row-index of the largest off-diagonal element in ! column K, and COLMAX is its absolute value. ! Determine both COLMAX and IMAX. ! IF( K.GT.1 ) THEN IMAX = IDAMAX( K-1, A( 1, K ), 1 ) COLMAX = ABS( A( IMAX, K ) ) ELSE COLMAX = ZERO END IF ! IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN ! ! Column K is zero or underflow, or contains a NaN: ! set INFO and continue ! IF( INFO.EQ.0 ) INFO = K KP = K ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN ! ! no interchange, use 1-by-1 pivot block ! KP = K ELSE ! ! JMAX is the column-index of the largest off-diagonal ! element in row IMAX, and ROWMAX is its absolute value ! JMAX = IMAX + IDAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA ) ROWMAX = ABS( A( IMAX, JMAX ) ) IF( IMAX.GT.1 ) THEN JMAX = IDAMAX( IMAX-1, A( 1, IMAX ), 1 ) ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) ) END IF ! IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN ! ! no interchange, use 1-by-1 pivot block ! KP = K ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN ! ! interchange rows and columns K and IMAX, use 1-by-1 ! pivot block ! KP = IMAX ELSE ! ! interchange rows and columns K-1 and IMAX, use 2-by-2 ! pivot block ! KP = IMAX KSTEP = 2 END IF END IF ! KK = K - KSTEP + 1 IF( KP.NE.KK ) THEN ! ! Interchange rows and columns KK and KP in the leading ! submatrix A(1:k,1:k) ! CALL DSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), & LDA ) T = A( KK, KK ) A( KK, KK ) = A( KP, KP ) A( KP, KP ) = T IF( KSTEP.EQ.2 ) THEN T = A( K-1, K ) A( K-1, K ) = A( KP, K ) A( KP, K ) = T END IF END IF ! ! Update the leading submatrix ! IF( KSTEP.EQ.1 ) THEN ! ! 1-by-1 pivot block D(k): column k now holds ! ! W(k) = U(k)*D(k) ! ! where U(k) is the k-th column of U ! ! Perform a rank-1 update of A(1:k-1,1:k-1) as ! ! A := A - U(k)*D(k)*U(k)**T = A - W(k)*1/D(k)*W(k)**T ! R1 = ONE / A( K, K ) CALL DSYR( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA ) ! ! Store U(k) in column k ! CALL DSCAL( K-1, R1, A( 1, K ), 1 ) ELSE ! ! 2-by-2 pivot block D(k): columns k and k-1 now hold ! ! ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) ! ! where U(k) and U(k-1) are the k-th and (k-1)-th columns ! of U ! ! Perform a rank-2 update of A(1:k-2,1:k-2) as ! ! A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T ! = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )**T ! IF( K.GT.2 ) THEN ! D12 = A( K-1, K ) D22 = A( K-1, K-1 ) / D12 D11 = A( K, K ) / D12 T = ONE / ( D11*D22-ONE ) D12 = T / D12 ! DO 30 J = K - 2, 1, -1 WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) ) WK = D12*( D22*A( J, K )-A( J, K-1 ) ) DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*WK - & A( I, K-1 )*WKM1 20 CONTINUE A( J, K ) = WK A( J, K-1 ) = WKM1 30 CONTINUE ! END IF ! END IF END IF ! ! Store details of the interchanges in IPIV ! IF( KSTEP.EQ.1 ) THEN IPIV( K ) = KP ELSE IPIV( K ) = -KP IPIV( K-1 ) = -KP END IF ! ! Decrease K and return to the start of the main loop ! K = K - KSTEP GO TO 10 ! ELSE ! ! Factorize A as L*D*L**T using the lower triangle of A ! ! K is the main loop index, increasing from 1 to N in steps of ! 1 or 2 ! K = 1 40 CONTINUE ! ! If K > N, exit from loop ! IF( K.GT.N ) GO TO 70 KSTEP = 1 ! ! Determine rows and columns to be interchanged and whether ! a 1-by-1 or 2-by-2 pivot block will be used ! ABSAKK = ABS( A( K, K ) ) ! ! IMAX is the row-index of the largest off-diagonal element in ! column K, and COLMAX is its absolute value. ! Determine both COLMAX and IMAX. ! IF( K.LT.N ) THEN IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 ) COLMAX = ABS( A( IMAX, K ) ) ELSE COLMAX = ZERO END IF ! IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN ! ! Column K is zero or underflow, or contains a NaN: ! set INFO and continue ! IF( INFO.EQ.0 ) INFO = K KP = K ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN ! ! no interchange, use 1-by-1 pivot block ! KP = K ELSE ! ! JMAX is the column-index of the largest off-diagonal ! element in row IMAX, and ROWMAX is its absolute value ! JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), LDA ) ROWMAX = ABS( A( IMAX, JMAX ) ) IF( IMAX.LT.N ) THEN JMAX = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 ) ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) ) END IF ! IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN ! ! no interchange, use 1-by-1 pivot block ! KP = K ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN ! ! interchange rows and columns K and IMAX, use 1-by-1 ! pivot block ! KP = IMAX ELSE ! ! interchange rows and columns K+1 and IMAX, use 2-by-2 ! pivot block ! KP = IMAX KSTEP = 2 END IF END IF ! KK = K + KSTEP - 1 IF( KP.NE.KK ) THEN ! ! Interchange rows and columns KK and KP in the trailing ! submatrix A(k:n,k:n) ! IF( KP.LT.N ) & CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), & LDA ) T = A( KK, KK ) A( KK, KK ) = A( KP, KP ) A( KP, KP ) = T IF( KSTEP.EQ.2 ) THEN T = A( K+1, K ) A( K+1, K ) = A( KP, K ) A( KP, K ) = T END IF END IF ! ! Update the trailing submatrix ! IF( KSTEP.EQ.1 ) THEN ! ! 1-by-1 pivot block D(k): column k now holds ! ! W(k) = L(k)*D(k) ! ! where L(k) is the k-th column of L ! IF( K.LT.N ) THEN ! ! Perform a rank-1 update of A(k+1:n,k+1:n) as ! ! A := A - L(k)*D(k)*L(k)**T = A - W(k)*(1/D(k))*W(k)**T ! D11 = ONE / A( K, K ) CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1, & A( K+1, K+1 ), LDA ) ! ! Store L(k) in column K ! CALL DSCAL( N-K, D11, A( K+1, K ), 1 ) END IF ELSE ! ! 2-by-2 pivot block D(k) ! IF( K.LT.N-1 ) THEN ! ! Perform a rank-2 update of A(k+2:n,k+2:n) as ! ! A := A - ( (A(k) A(k+1))*D(k)**(-1) ) * (A(k) A(k+1))**T ! ! where L(k) and L(k+1) are the k-th and (k+1)-th ! columns of L ! D21 = A( K+1, K ) D11 = A( K+1, K+1 ) / D21 D22 = A( K, K ) / D21 T = ONE / ( D11*D22-ONE ) D21 = T / D21 ! DO 60 J = K + 2, N ! WK = D21*( D11*A( J, K )-A( J, K+1 ) ) WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) ) ! DO 50 I = J, N A( I, J ) = A( I, J ) - A( I, K )*WK - & A( I, K+1 )*WKP1 50 CONTINUE ! A( J, K ) = WK A( J, K+1 ) = WKP1 ! 60 CONTINUE END IF END IF END IF ! ! Store details of the interchanges in IPIV ! IF( KSTEP.EQ.1 ) THEN IPIV( K ) = KP ELSE IPIV( K ) = -KP IPIV( K+1 ) = -KP END IF ! ! Increase K and return to the start of the main loop ! K = K + KSTEP GO TO 40 ! END IF ! 70 CONTINUE ! RETURN ! ! End of DSYTF2 ! END SUBROUTINE DSYTF2 !> \brief \b DSYTRF ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DSYTRF + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) ! ! .. Scalar Arguments .. ! CHARACTER UPLO ! INTEGER INFO, LDA, LWORK, N ! .. ! .. Array Arguments .. ! INTEGER IPIV( * ) ! DOUBLE PRECISION A( LDA, * ), WORK( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DSYTRF computes the factorization of a real symmetric matrix A using !> the Bunch-Kaufman diagonal pivoting method. The form of the !> factorization is !> !> A = U*D*U**T or A = L*D*L**T !> !> where U (or L) is a product of permutation and unit upper (lower) !> triangular matrices, and D is symmetric and block diagonal with !> 1-by-1 and 2-by-2 diagonal blocks. !> !> This is the blocked version of the algorithm, calling Level 3 BLAS. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> = 'U': Upper triangle of A is stored; !> = 'L': Lower triangle of A is stored. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The order of the matrix A. N >= 0. !> \endverbatim !> !> \param[in,out] A !> \verbatim !> A is DOUBLE PRECISION array, dimension (LDA,N) !> On entry, the symmetric matrix A. If UPLO = 'U', the leading !> N-by-N upper triangular part of A contains the upper !> triangular part of the matrix A, and the strictly lower !> triangular part of A is not referenced. If UPLO = 'L', the !> leading N-by-N lower triangular part of A contains the lower !> triangular part of the matrix A, and the strictly upper !> triangular part of A is not referenced. !> !> On exit, the block diagonal matrix D and the multipliers used !> to obtain the factor U or L (see below for further details). !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,N). !> \endverbatim !> !> \param[out] IPIV !> \verbatim !> IPIV is INTEGER array, dimension (N) !> Details of the interchanges and the block structure of D. !> If IPIV(k) > 0, then rows and columns k and IPIV(k) were !> interchanged and D(k,k) is a 1-by-1 diagonal block. !> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and !> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) !> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = !> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were !> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. !> \endverbatim !> !> \param[out] WORK !> \verbatim !> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) !> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. !> \endverbatim !> !> \param[in] LWORK !> \verbatim !> LWORK is INTEGER !> The length of WORK. LWORK >=1. For best performance !> LWORK >= N*NB, where NB is the block size returned by ILAENV. !> !> If LWORK = -1, then a workspace query is assumed; the routine !> only calculates the optimal size of the WORK array, returns !> this value as the first entry of the WORK array, and no error !> message related to LWORK is issued by XERBLA. !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument had an illegal value !> > 0: if INFO = i, D(i,i) is exactly zero. The factorization !> has been completed, but the block diagonal matrix D is !> exactly singular, and division by zero will occur if it !> is used to solve a system of equations. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup doubleSYcomputational ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> If UPLO = 'U', then A = U*D*U**T, where !> U = P(n)*U(n)* ... *P(k)U(k)* ..., !> i.e., U is a product of terms P(k)*U(k), where k decreases from n to !> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 !> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as !> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such !> that if the diagonal block D(k) is of order s (s = 1 or 2), then !> !> ( I v 0 ) k-s !> U(k) = ( 0 I 0 ) s !> ( 0 0 I ) n-k !> k-s s n-k !> !> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). !> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), !> and A(k,k), and v overwrites A(1:k-2,k-1:k). !> !> If UPLO = 'L', then A = L*D*L**T, where !> L = P(1)*L(1)* ... *P(k)*L(k)* ..., !> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to !> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 !> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as !> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such !> that if the diagonal block D(k) is of order s (s = 1 or 2), then !> !> ( I 0 0 ) k-1 !> L(k) = ( 0 I 0 ) s !> ( 0 v I ) n-k-s+1 !> k-1 s n-k-s+1 !> !> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). !> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), !> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). !> \endverbatim !> ! ===================================================================== SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) ! ! -- LAPACK computational routine (version 3.4.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LWORK, N ! .. ! .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), WORK( * ) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. LOGICAL LQUERY, UPPER INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN ! .. ! .. External Functions .. ! LOGICAL LSAME ! INTEGER ILAENV ! EXTERNAL LSAME, ILAENV ! .. ! .. External Subroutines .. ! EXTERNAL DLASYF, DSYTF2, XERBLA ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! INFO = 0 UPPER = LSAME( UPLO, 'U' ) LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN INFO = -7 END IF ! IF( INFO.EQ.0 ) THEN ! ! Determine the block size ! NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 ) LWKOPT = N*NB WORK( 1 ) = LWKOPT END IF ! IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYTRF', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF ! NBMIN = 2 LDWORK = N IF( NB.GT.1 .AND. NB.LT.N ) THEN IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN NB = MAX( LWORK / LDWORK, 1 ) NBMIN = MAX( 2, ILAENV( 2, 'DSYTRF', UPLO, N, -1, -1, -1 ) ) END IF ELSE IWS = 1 END IF IF( NB.LT.NBMIN ) NB = N ! IF( UPPER ) THEN ! ! Factorize A as U*D*U**T using the upper triangle of A ! ! K is the main loop index, decreasing from N to 1 in steps of ! KB, where KB is the number of columns factorized by DLASYF; ! KB is either NB or NB-1, or K for the last block ! K = N 10 CONTINUE ! ! If K < 1, exit from loop ! IF( K.LT.1 ) GO TO 40 ! IF( K.GT.NB ) THEN ! ! Factorize columns k-kb+1:k of A and use blocked code to ! update columns 1:k-kb ! CALL DLASYF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, LDWORK, & IINFO ) ELSE ! ! Use unblocked code to factorize columns 1:k of A ! CALL DSYTF2( UPLO, K, A, LDA, IPIV, IINFO ) KB = K END IF ! ! Set INFO on the first occurrence of a zero pivot ! IF( INFO.EQ.0 .AND. IINFO.GT.0 ) & INFO = IINFO ! ! Decrease K and return to the start of the main loop ! K = K - KB GO TO 10 ! ELSE ! ! Factorize A as L*D*L**T using the lower triangle of A ! ! K is the main loop index, increasing from 1 to N in steps of ! KB, where KB is the number of columns factorized by DLASYF; ! KB is either NB or NB-1, or N-K+1 for the last block ! K = 1 20 CONTINUE ! ! If K > N, exit from loop ! IF( K.GT.N ) GO TO 40 ! IF( K.LE.N-NB ) THEN ! ! Factorize columns k:k+kb-1 of A and use blocked code to ! update columns k+kb:n ! CALL DLASYF( UPLO, N-K+1, NB, KB, A( K, K ), LDA, IPIV( K ), & WORK, LDWORK, IINFO ) ELSE ! ! Use unblocked code to factorize columns k:n of A ! CALL DSYTF2( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ), IINFO ) KB = N - K + 1 END IF ! ! Set INFO on the first occurrence of a zero pivot ! IF( INFO.EQ.0 .AND. IINFO.GT.0 ) INFO = IINFO + K - 1 ! ! Adjust IPIV ! DO 30 J = K, K + KB - 1 IF( IPIV( J ).GT.0 ) THEN IPIV( J ) = IPIV( J ) + K - 1 ELSE IPIV( J ) = IPIV( J ) - K + 1 END IF 30 CONTINUE ! ! Increase K and return to the start of the main loop ! K = K + KB GO TO 20 ! END IF ! 40 CONTINUE WORK( 1 ) = LWKOPT RETURN ! ! End of DSYTRF ! END SUBROUTINE DSYTRF !> \brief \b DSYTRI ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DSYTRI + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) ! ! .. Scalar Arguments .. ! CHARACTER UPLO ! INTEGER INFO, LDA, N ! .. ! .. Array Arguments .. ! INTEGER IPIV( * ) ! DOUBLE PRECISION A( LDA, * ), WORK( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DSYTRI computes the inverse of a real symmetric indefinite matrix !> A using the factorization A = U*D*U**T or A = L*D*L**T computed by !> DSYTRF. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> Specifies whether the details of the factorization are stored !> as an upper or lower triangular matrix. !> = 'U': Upper triangular, form is A = U*D*U**T; !> = 'L': Lower triangular, form is A = L*D*L**T. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The order of the matrix A. N >= 0. !> \endverbatim !> !> \param[in,out] A !> \verbatim !> A is DOUBLE PRECISION array, dimension (LDA,N) !> On entry, the block diagonal matrix D and the multipliers !> used to obtain the factor U or L as computed by DSYTRF. !> !> On exit, if INFO = 0, the (symmetric) inverse of the original !> matrix. If UPLO = 'U', the upper triangular part of the !> inverse is formed and the part of A below the diagonal is not !> referenced; if UPLO = 'L' the lower triangular part of the !> inverse is formed and the part of A above the diagonal is !> not referenced. !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,N). !> \endverbatim !> !> \param[in] IPIV !> \verbatim !> IPIV is INTEGER array, dimension (N) !> Details of the interchanges and the block structure of D !> as determined by DSYTRF. !> \endverbatim !> !> \param[out] WORK !> \verbatim !> WORK is DOUBLE PRECISION array, dimension (N) !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument had an illegal value !> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its !> inverse could not be computed. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup doubleSYcomputational ! ! ===================================================================== SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) ! ! -- LAPACK computational routine (version 3.4.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N ! .. ! .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), WORK( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) ! .. ! .. Local Scalars .. LOGICAL UPPER INTEGER K, KP, KSTEP DOUBLE PRECISION AK, AKKP1, AKP1, D, T, TEMP ! .. ! .. External Functions .. ! LOGICAL LSAME ! DOUBLE PRECISION DDOT ! EXTERNAL LSAME, DDOT ! .. ! .. External Subroutines .. ! EXTERNAL DCOPY, DSWAP, DSYMV, XERBLA ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYTRI', -INFO ) RETURN END IF ! ! Quick return if possible ! IF( N.EQ.0 ) RETURN ! ! Check that the diagonal matrix D is nonsingular. ! IF( UPPER ) THEN ! ! Upper triangular storage: examine D from bottom to top ! DO 10 INFO = N, 1, -1 IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) RETURN 10 CONTINUE ELSE ! ! Lower triangular storage: examine D from top to bottom. ! DO 20 INFO = 1, N IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) RETURN 20 CONTINUE END IF INFO = 0 ! IF( UPPER ) THEN ! ! Compute inv(A) from the factorization A = U*D*U**T. ! ! K is the main loop index, increasing from 1 to N in steps of ! 1 or 2, depending on the size of the diagonal blocks. ! K = 1 30 CONTINUE ! ! If K > N, exit from loop. ! IF( K.GT.N ) GO TO 40 ! IF( IPIV( K ).GT.0 ) THEN ! ! 1 x 1 diagonal block ! ! Invert the diagonal block. ! A( K, K ) = ONE / A( K, K ) ! ! Compute column K of the inverse. ! IF( K.GT.1 ) THEN CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 ) CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, & A( 1, K ), 1 ) A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ), & 1 ) END IF KSTEP = 1 ELSE ! ! 2 x 2 diagonal block ! ! Invert the diagonal block. ! T = ABS( A( K, K+1 ) ) AK = A( K, K ) / T AKP1 = A( K+1, K+1 ) / T AKKP1 = A( K, K+1 ) / T D = T*( AK*AKP1-ONE ) A( K, K ) = AKP1 / D A( K+1, K+1 ) = AK / D A( K, K+1 ) = -AKKP1 / D ! ! Compute columns K and K+1 of the inverse. ! IF( K.GT.1 ) THEN CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 ) CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, & A( 1, K ), 1 ) A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ), & 1 ) A( K, K+1 ) = A( K, K+1 ) -& DDOT( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 ) CALL DCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 ) CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, & A( 1, K+1 ), 1 ) A( K+1, K+1 ) = A( K+1, K+1 ) -& DDOT( K-1, WORK, 1, A( 1, K+1 ), 1 ) END IF KSTEP = 2 END IF ! KP = ABS( IPIV( K ) ) IF( KP.NE.K ) THEN ! ! Interchange rows and columns K and KP in the leading ! submatrix A(1:k+1,1:k+1) ! CALL DSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) CALL DSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) TEMP = A( K, K ) A( K, K ) = A( KP, KP ) A( KP, KP ) = TEMP IF( KSTEP.EQ.2 ) THEN TEMP = A( K, K+1 ) A( K, K+1 ) = A( KP, K+1 ) A( KP, K+1 ) = TEMP END IF END IF ! K = K + KSTEP GO TO 30 40 CONTINUE ! ELSE ! ! Compute inv(A) from the factorization A = L*D*L**T. ! ! K is the main loop index, increasing from 1 to N in steps of ! 1 or 2, depending on the size of the diagonal blocks. ! K = N 50 CONTINUE ! ! If K < 1, exit from loop. ! IF( K.LT.1 ) GO TO 60 ! IF( IPIV( K ).GT.0 ) THEN ! ! 1 x 1 diagonal block ! ! Invert the diagonal block. ! A( K, K ) = ONE / A( K, K ) ! ! Compute column K of the inverse. ! IF( K.LT.N ) THEN CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, & ZERO, A( K+1, K ), 1 ) A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ), & 1 ) END IF KSTEP = 1 ELSE ! ! 2 x 2 diagonal block ! ! Invert the diagonal block. ! T = ABS( A( K, K-1 ) ) AK = A( K-1, K-1 ) / T AKP1 = A( K, K ) / T AKKP1 = A( K, K-1 ) / T D = T*( AK*AKP1-ONE ) A( K-1, K-1 ) = AKP1 / D A( K, K ) = AK / D A( K, K-1 ) = -AKKP1 / D ! ! Compute columns K-1 and K of the inverse. ! IF( K.LT.N ) THEN CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, & ZERO, A( K+1, K ), 1 ) A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ), & 1 ) A( K, K-1 ) = A( K, K-1 ) -& DDOT( N-K, A( K+1, K ), 1, A( K+1, K-1 ), & 1 ) CALL DCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 ) CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, & ZERO, A( K+1, K-1 ), 1 ) A( K-1, K-1 ) = A( K-1, K-1 ) - & DDOT( N-K, WORK, 1, A( K+1, K-1 ), 1 ) END IF KSTEP = 2 END IF ! KP = ABS( IPIV( K ) ) IF( KP.NE.K ) THEN ! ! Interchange rows and columns K and KP in the trailing ! submatrix A(k-1:n,k-1:n) ! IF( KP.LT.N ) & CALL DSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) CALL DSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA ) TEMP = A( K, K ) A( K, K ) = A( KP, KP ) A( KP, KP ) = TEMP IF( KSTEP.EQ.2 ) THEN TEMP = A( K, K-1 ) A( K, K-1 ) = A( KP, K-1 ) A( KP, K-1 ) = TEMP END IF END IF ! K = K - KSTEP GO TO 50 60 CONTINUE END IF ! RETURN ! ! End of DSYTRI ! END SUBROUTINE DSYTRI !> \brief \b DTRSM ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! ! Definition: ! =========== ! ! SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) ! ! .. Scalar Arguments .. ! DOUBLE PRECISION ALPHA ! INTEGER LDA,LDB,M,N ! CHARACTER DIAG,SIDE,TRANSA,UPLO ! .. ! .. Array Arguments .. ! DOUBLE PRECISION A(LDA,*),B(LDB,*) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DTRSM solves one of the matrix equations !> !> op( A )*X = alpha*B, or X*op( A ) = alpha*B, !> !> where alpha is a scalar, X and B are m by n matrices, A is a unit, or !> non-unit, upper or lower triangular matrix and op( A ) is one of !> !> op( A ) = A or op( A ) = A**T. !> !> The matrix X is overwritten on B. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] SIDE !> \verbatim !> SIDE is CHARACTER*1 !> On entry, SIDE specifies whether op( A ) appears on the left !> or right of X as follows: !> !> SIDE = 'L' or 'l' op( A )*X = alpha*B. !> !> SIDE = 'R' or 'r' X*op( A ) = alpha*B. !> \endverbatim !> !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> On entry, UPLO specifies whether the matrix A is an upper or !> lower triangular matrix as follows: !> !> UPLO = 'U' or 'u' A is an upper triangular matrix. !> !> UPLO = 'L' or 'l' A is a lower triangular matrix. !> \endverbatim !> !> \param[in] TRANSA !> \verbatim !> TRANSA is CHARACTER*1 !> On entry, TRANSA specifies the form of op( A ) to be used in !> the matrix multiplication as follows: !> !> TRANSA = 'N' or 'n' op( A ) = A. !> !> TRANSA = 'T' or 't' op( A ) = A**T. !> !> TRANSA = 'C' or 'c' op( A ) = A**T. !> \endverbatim !> !> \param[in] DIAG !> \verbatim !> DIAG is CHARACTER*1 !> On entry, DIAG specifies whether or not A is unit triangular !> as follows: !> !> DIAG = 'U' or 'u' A is assumed to be unit triangular. !> !> DIAG = 'N' or 'n' A is not assumed to be unit !> triangular. !> \endverbatim !> !> \param[in] M !> \verbatim !> M is INTEGER !> On entry, M specifies the number of rows of B. M must be at !> least zero. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> On entry, N specifies the number of columns of B. N must be !> at least zero. !> \endverbatim !> !> \param[in] ALPHA !> \verbatim !> ALPHA is DOUBLE PRECISION. !> On entry, ALPHA specifies the scalar alpha. When alpha is !> zero then A is not referenced and B need not be set before !> entry. !> \endverbatim !> !> \param[in] A !> \verbatim !> A is DOUBLE PRECISION array of DIMENSION ( LDA, k ), !> where k is m when SIDE = 'L' or 'l' !> and k is n when SIDE = 'R' or 'r'. !> Before entry with UPLO = 'U' or 'u', the leading k by k !> upper triangular part of the array A must contain the upper !> triangular matrix and the strictly lower triangular part of !> A is not referenced. !> Before entry with UPLO = 'L' or 'l', the leading k by k !> lower triangular part of the array A must contain the lower !> triangular matrix and the strictly upper triangular part of !> A is not referenced. !> Note that when DIAG = 'U' or 'u', the diagonal elements of !> A are not referenced either, but are assumed to be unity. !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> On entry, LDA specifies the first dimension of A as declared !> in the calling (sub) program. When SIDE = 'L' or 'l' then !> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' !> then LDA must be at least max( 1, n ). !> \endverbatim !> !> \param[in,out] B !> \verbatim !> B is DOUBLE PRECISION array of DIMENSION ( LDB, n ). !> Before entry, the leading m by n part of the array B must !> contain the right-hand side matrix B, and on exit is !> overwritten by the solution matrix X. !> \endverbatim !> !> \param[in] LDB !> \verbatim !> LDB is INTEGER !> On entry, LDB specifies the first dimension of B as declared !> in the calling (sub) program. LDB must be at least !> max( 1, m ). !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup double_blas_level3 ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> Level 3 Blas routine. !> !> !> -- Written on 8-February-1989. !> Jack Dongarra, Argonne National Laboratory. !> Iain Duff, AERE Harwell. !> Jeremy Du Croz, Numerical Algorithms Group Ltd. !> Sven Hammarling, Numerical Algorithms Group Ltd. !> \endverbatim !> ! ===================================================================== SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) ! ! -- Reference BLAS level3 routine (version 3.4.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. DOUBLE PRECISION ALPHA INTEGER LDA,LDB,M,N CHARACTER DIAG,SIDE,TRANSA,UPLO ! .. ! .. Array Arguments .. DOUBLE PRECISION A(LDA,*),B(LDB,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. ! INTRINSIC MAX ! .. ! .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I,INFO,J,K,NROWA LOGICAL LSIDE,NOUNIT,UPPER ! .. ! .. Parameters .. DOUBLE PRECISION ONE,ZERO PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) ! .. ! ! Test the input parameters. ! LSIDE = LSAME(SIDE,'L') IF (LSIDE) THEN NROWA = M ELSE NROWA = N END IF NOUNIT = LSAME(DIAG,'N') UPPER = LSAME(UPLO,'U') ! INFO = 0 IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN INFO = 1 ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN INFO = 2 ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. & (.NOT.LSAME(TRANSA,'T')) .AND. & (.NOT.LSAME(TRANSA,'C'))) THEN INFO = 3 ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN INFO = 4 ELSE IF (M.LT.0) THEN INFO = 5 ELSE IF (N.LT.0) THEN INFO = 6 ELSE IF (LDA.LT.MAX(1,NROWA)) THEN INFO = 9 ELSE IF (LDB.LT.MAX(1,M)) THEN INFO = 11 END IF IF (INFO.NE.0) THEN CALL XERBLA('DTRSM ',INFO) RETURN END IF ! ! Quick return if possible. ! IF (M.EQ.0 .OR. N.EQ.0) RETURN ! ! And when alpha.eq.zero. ! IF (ALPHA.EQ.ZERO) THEN DO 20 J = 1,N DO 10 I = 1,M B(I,J) = ZERO 10 CONTINUE 20 CONTINUE RETURN END IF ! ! Start the operations. ! IF (LSIDE) THEN IF (LSAME(TRANSA,'N')) THEN ! ! Form B := alpha*inv( A )*B. ! IF (UPPER) THEN DO 60 J = 1,N IF (ALPHA.NE.ONE) THEN DO 30 I = 1,M B(I,J) = ALPHA*B(I,J) 30 CONTINUE END IF DO 50 K = M,1,-1 IF (B(K,J).NE.ZERO) THEN IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) DO 40 I = 1,K - 1 B(I,J) = B(I,J) - B(K,J)*A(I,K) 40 CONTINUE END IF 50 CONTINUE 60 CONTINUE ELSE DO 100 J = 1,N IF (ALPHA.NE.ONE) THEN DO 70 I = 1,M B(I,J) = ALPHA*B(I,J) 70 CONTINUE END IF DO 90 K = 1,M IF (B(K,J).NE.ZERO) THEN IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) DO 80 I = K + 1,M B(I,J) = B(I,J) - B(K,J)*A(I,K) 80 CONTINUE END IF 90 CONTINUE 100 CONTINUE END IF ELSE ! ! Form B := alpha*inv( A**T )*B. ! IF (UPPER) THEN DO 130 J = 1,N DO 120 I = 1,M TEMP = ALPHA*B(I,J) DO 110 K = 1,I - 1 TEMP = TEMP - A(K,I)*B(K,J) 110 CONTINUE IF (NOUNIT) TEMP = TEMP/A(I,I) B(I,J) = TEMP 120 CONTINUE 130 CONTINUE ELSE DO 160 J = 1,N DO 150 I = M,1,-1 TEMP = ALPHA*B(I,J) DO 140 K = I + 1,M TEMP = TEMP - A(K,I)*B(K,J) 140 CONTINUE IF (NOUNIT) TEMP = TEMP/A(I,I) B(I,J) = TEMP 150 CONTINUE 160 CONTINUE END IF END IF ELSE IF (LSAME(TRANSA,'N')) THEN ! ! Form B := alpha*B*inv( A ). ! IF (UPPER) THEN DO 210 J = 1,N IF (ALPHA.NE.ONE) THEN DO 170 I = 1,M B(I,J) = ALPHA*B(I,J) 170 CONTINUE END IF DO 190 K = 1,J - 1 IF (A(K,J).NE.ZERO) THEN DO 180 I = 1,M B(I,J) = B(I,J) - A(K,J)*B(I,K) 180 CONTINUE END IF 190 CONTINUE IF (NOUNIT) THEN TEMP = ONE/A(J,J) DO 200 I = 1,M B(I,J) = TEMP*B(I,J) 200 CONTINUE END IF 210 CONTINUE ELSE DO 260 J = N,1,-1 IF (ALPHA.NE.ONE) THEN DO 220 I = 1,M B(I,J) = ALPHA*B(I,J) 220 CONTINUE END IF DO 240 K = J + 1,N IF (A(K,J).NE.ZERO) THEN DO 230 I = 1,M B(I,J) = B(I,J) - A(K,J)*B(I,K) 230 CONTINUE END IF 240 CONTINUE IF (NOUNIT) THEN TEMP = ONE/A(J,J) DO 250 I = 1,M B(I,J) = TEMP*B(I,J) 250 CONTINUE END IF 260 CONTINUE END IF ELSE ! ! Form B := alpha*B*inv( A**T ). ! IF (UPPER) THEN DO 310 K = N,1,-1 IF (NOUNIT) THEN TEMP = ONE/A(K,K) DO 270 I = 1,M B(I,K) = TEMP*B(I,K) 270 CONTINUE END IF DO 290 J = 1,K - 1 IF (A(J,K).NE.ZERO) THEN TEMP = A(J,K) DO 280 I = 1,M B(I,J) = B(I,J) - TEMP*B(I,K) 280 CONTINUE END IF 290 CONTINUE IF (ALPHA.NE.ONE) THEN DO 300 I = 1,M B(I,K) = ALPHA*B(I,K) 300 CONTINUE END IF 310 CONTINUE ELSE DO 360 K = 1,N IF (NOUNIT) THEN TEMP = ONE/A(K,K) DO 320 I = 1,M B(I,K) = TEMP*B(I,K) 320 CONTINUE END IF DO 340 J = K + 1,N IF (A(J,K).NE.ZERO) THEN TEMP = A(J,K) DO 330 I = 1,M B(I,J) = B(I,J) - TEMP*B(I,K) 330 CONTINUE END IF 340 CONTINUE IF (ALPHA.NE.ONE) THEN DO 350 I = 1,M B(I,K) = ALPHA*B(I,K) 350 CONTINUE END IF 360 CONTINUE END IF END IF END IF ! RETURN ! ! End of DTRSM . ! END SUBROUTINE DTRSM ! !> \brief \b IDAMAX ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! ! Definition: ! =========== ! ! INTEGER FUNCTION IDAMAX(N,DX,INCX) ! ! .. Scalar Arguments .. ! INTEGER INCX,N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION DX(*) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> IDAMAX finds the index of the first element having maximum absolute value. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2015 ! !> \ingroup aux_blas ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> jack dongarra, linpack, 3/11/78. !> modified 3/93 to return if incx .le. 0. !> modified 12/3/93, array(1) declarations changed to array(*) !> \endverbatim !> ! ===================================================================== INTEGER FUNCTION IDAMAX(N,DX,INCX) ! ! -- Reference BLAS level1 routine (version 3.6.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2015 ! ! .. Scalar Arguments .. INTEGER INCX,N ! .. ! .. Array Arguments .. DOUBLE PRECISION DX(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. DOUBLE PRECISION DMAX INTEGER I,IX ! .. ! .. Intrinsic Functions .. INTRINSIC DABS ! .. IDAMAX = 0 IF (N.LT.1 .OR. INCX.LE.0) RETURN IDAMAX = 1 IF (N.EQ.1) RETURN IF (INCX.EQ.1) THEN ! ! code for increment equal to 1 ! DMAX = DABS(DX(1)) DO I = 2,N IF (DABS(DX(I)).GT.DMAX) THEN IDAMAX = I DMAX = DABS(DX(I)) END IF END DO ELSE ! ! code for increment not equal to 1 ! IX = 1 DMAX = DABS(DX(1)) IX = IX + INCX DO I = 2,N IF (DABS(DX(IX)).GT.DMAX) THEN IDAMAX = I DMAX = DABS(DX(IX)) END IF IX = IX + INCX END DO END IF RETURN END FUNCTION IDAMAX !> \brief \b IEEECK ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download IEEECK + dependencies !> [TGZ] !> [ZIP] !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) ! ! .. Scalar Arguments .. ! INTEGER ISPEC ! REAL ONE, ZERO ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> IEEECK is called from the ILAENV to verify that Infinity and !> possibly NaN arithmetic is safe (i.e. will not trap). !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] ISPEC !> \verbatim !> ISPEC is INTEGER !> Specifies whether to test just for inifinity arithmetic !> or whether to test for infinity and NaN arithmetic. !> = 0: Verify infinity arithmetic only. !> = 1: Verify infinity and NaN arithmetic. !> \endverbatim !> !> \param[in] ZERO !> \verbatim !> ZERO is REAL !> Must contain the value 0.0 !> This is passed to prevent the compiler from optimizing !> away this code. !> \endverbatim !> !> \param[in] ONE !> \verbatim !> ONE is REAL !> Must contain the value 1.0 !> This is passed to prevent the compiler from optimizing !> away this code. !> !> RETURN VALUE: INTEGER !> = 0: Arithmetic failed to produce the correct answers !> = 1: Arithmetic produced the correct answers !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup auxOTHERauxiliary ! ! ===================================================================== INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) ! ! -- LAPACK auxiliary routine (version 3.4.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. INTEGER ISPEC REAL ONE, ZERO ! .. ! ! ===================================================================== ! ! .. Local Scalars .. REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, & NEGZRO, NEWZRO, POSINF ! .. ! .. Executable Statements .. IEEECK = 1 ! POSINF = ONE / ZERO IF( POSINF.LE.ONE ) THEN IEEECK = 0 RETURN END IF ! NEGINF = -ONE / ZERO IF( NEGINF.GE.ZERO ) THEN IEEECK = 0 RETURN END IF ! NEGZRO = ONE / ( NEGINF+ONE ) IF( NEGZRO.NE.ZERO ) THEN IEEECK = 0 RETURN END IF ! NEGINF = ONE / NEGZRO IF( NEGINF.GE.ZERO ) THEN IEEECK = 0 RETURN END IF ! NEWZRO = NEGZRO + ZERO IF( NEWZRO.NE.ZERO ) THEN IEEECK = 0 RETURN END IF ! POSINF = ONE / NEWZRO IF( POSINF.LE.ONE ) THEN IEEECK = 0 RETURN END IF ! NEGINF = NEGINF*POSINF IF( NEGINF.GE.ZERO ) THEN IEEECK = 0 RETURN END IF ! POSINF = POSINF*POSINF IF( POSINF.LE.ONE ) THEN IEEECK = 0 RETURN END IF ! ! ! ! ! Return if we were only asked to check infinity arithmetic ! IF( ISPEC.EQ.0 ) RETURN ! NAN1 = POSINF + NEGINF ! NAN2 = POSINF / NEGINF ! NAN3 = POSINF / POSINF ! NAN4 = POSINF*ZERO ! NAN5 = NEGINF*NEGZRO ! NAN6 = NAN5*ZERO ! IF( NAN1.EQ.NAN1 ) THEN IEEECK = 0 RETURN END IF ! IF( NAN2.EQ.NAN2 ) THEN IEEECK = 0 RETURN END IF ! IF( NAN3.EQ.NAN3 ) THEN IEEECK = 0 RETURN END IF ! IF( NAN4.EQ.NAN4 ) THEN IEEECK = 0 RETURN END IF ! IF( NAN5.EQ.NAN5 ) THEN IEEECK = 0 RETURN END IF ! IF( NAN6.EQ.NAN6 ) THEN IEEECK = 0 RETURN END IF ! RETURN END FUNCTION IEEECK ! !> \brief \b ILAENV ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download ILAENV + dependencies !> [TGZ] !> [ZIP] !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) ! ! .. Scalar Arguments .. ! CHARACTER*( * ) NAME, OPTS ! INTEGER ISPEC, N1, N2, N3, N4 ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> ILAENV is called from the LAPACK routines to choose problem-dependent !> parameters for the local environment. See ISPEC for a description of !> the parameters. !> !> ILAENV returns an INTEGER !> if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC !> if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value. !> !> This version provides a set of parameters which should give good, !> but not optimal, performance on many of the currently available !> computers. Users are encouraged to modify this subroutine to set !> the tuning parameters for their particular machine using the option !> and problem size information in the arguments. !> !> This routine will not function correctly if it is converted to all !> lower case. Converting it to all upper case is allowed. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] ISPEC !> \verbatim !> ISPEC is INTEGER !> Specifies the parameter to be returned as the value of !> ILAENV. !> = 1: the optimal blocksize; if this value is 1, an unblocked !> algorithm will give the best performance. !> = 2: the minimum block size for which the block routine !> should be used; if the usable block size is less than !> this value, an unblocked routine should be used. !> = 3: the crossover point (in a block routine, for N less !> than this value, an unblocked routine should be used) !> = 4: the number of shifts, used in the nonsymmetric !> eigenvalue routines (DEPRECATED) !> = 5: the minimum column dimension for blocking to be used; !> rectangular blocks must have dimension at least k by m, !> where k is given by ILAENV(2,...) and m by ILAENV(5,...) !> = 6: the crossover point for the SVD (when reducing an m by n !> matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds !> this value, a QR factorization is used first to reduce !> the matrix to a triangular form.) !> = 7: the number of processors !> = 8: the crossover point for the multishift QR method !> for nonsymmetric eigenvalue problems (DEPRECATED) !> = 9: maximum size of the subproblems at the bottom of the !> computation tree in the divide-and-conquer algorithm !> (used by xGELSD and xGESDD) !> =10: ieee NaN arithmetic can be trusted not to trap !> =11: infinity arithmetic can be trusted not to trap !> 12 <= ISPEC <= 16: !> xHSEQR or related subroutines, !> see IPARMQ for detailed explanation !> \endverbatim !> !> \param[in] NAME !> \verbatim !> NAME is CHARACTER*(*) !> The name of the calling subroutine, in either upper case or !> lower case. !> \endverbatim !> !> \param[in] OPTS !> \verbatim !> OPTS is CHARACTER*(*) !> The character options to the subroutine NAME, concatenated !> into a single character string. For example, UPLO = 'U', !> TRANS = 'T', and DIAG = 'N' for a triangular routine would !> be specified as OPTS = 'UTN'. !> \endverbatim !> !> \param[in] N1 !> \verbatim !> N1 is INTEGER !> \endverbatim !> !> \param[in] N2 !> \verbatim !> N2 is INTEGER !> \endverbatim !> !> \param[in] N3 !> \verbatim !> N3 is INTEGER !> \endverbatim !> !> \param[in] N4 !> \verbatim !> N4 is INTEGER !> Problem dimensions for the subroutine NAME; these may not all !> be required. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2015 ! !> \ingroup auxOTHERauxiliary ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> The following conventions have been used when calling ILAENV from the !> LAPACK routines: !> 1) OPTS is a concatenation of all of the character options to !> subroutine NAME, in the same order that they appear in the !> argument list for NAME, even if they are not used in determining !> the value of the parameter specified by ISPEC. !> 2) The problem dimensions N1, N2, N3, N4 are specified in the order !> that they appear in the argument list for NAME. N1 is used !> first, N2 second, and so on, and unused problem dimensions are !> passed a value of -1. !> 3) The parameter value returned by ILAENV is checked for validity in !> the calling subroutine. For example, ILAENV is used to retrieve !> the optimal blocksize for STRTRI as follows: !> !> NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) !> IF( NB.LE.1 ) NB = MAX( 1, N ) !> \endverbatim !> ! ===================================================================== INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) ! ! -- LAPACK auxiliary routine (version 3.6.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2015 ! ! .. Scalar Arguments .. CHARACTER*( * ) NAME, OPTS INTEGER ISPEC, N1, N2, N3, N4 ! .. ! ! ===================================================================== ! ! .. Local Scalars .. INTEGER I, IC, IZ, NB, NBMIN, NX LOGICAL CNAME, SNAME CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6 ! .. ! .. Intrinsic Functions .. INTRINSIC CHAR, ICHAR, INT, MIN, REAL ! .. ! .. External Functions .. ! INTEGER IEEECK, IPARMQ ! EXTERNAL IEEECK, IPARMQ ! .. ! .. Executable Statements .. ! GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, & 130, 140, 150, 160, 160, 160, 160, 160 )ISPEC ! ! Invalid value for ISPEC ! ILAENV = -1 RETURN ! 10 CONTINUE ! ! Convert NAME to upper case if the first character is lower case. ! ILAENV = 1 SUBNAM = NAME IC = ICHAR( SUBNAM( 1: 1 ) ) IZ = ICHAR( 'Z' ) IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN ! ! ASCII character set ! IF( IC.GE.97 .AND. IC.LE.122 ) THEN SUBNAM( 1: 1 ) = CHAR( IC-32 ) DO 20 I = 2, 6 IC = ICHAR( SUBNAM( I: I ) ) IF( IC.GE.97 .AND. IC.LE.122 ) & SUBNAM( I: I ) = CHAR( IC-32 ) 20 CONTINUE END IF ! ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN ! ! EBCDIC character set ! IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. & ( IC.GE.145 .AND. IC.LE.153 ) .OR. & ( IC.GE.162 .AND. IC.LE.169 ) ) THEN SUBNAM( 1: 1 ) = CHAR( IC+64 ) DO 30 I = 2, 6 IC = ICHAR( SUBNAM( I: I ) ) IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. & ( IC.GE.145 .AND. IC.LE.153 ) .OR. & ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: & I ) = CHAR( IC+64 ) 30 CONTINUE END IF ! ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN ! ! Prime machines: ASCII+128 ! IF( IC.GE.225 .AND. IC.LE.250 ) THEN SUBNAM( 1: 1 ) = CHAR( IC-32 ) DO 40 I = 2, 6 IC = ICHAR( SUBNAM( I: I ) ) IF( IC.GE.225 .AND. IC.LE.250 ) & SUBNAM( I: I ) = CHAR( IC-32 ) 40 CONTINUE END IF END IF ! C1 = SUBNAM( 1: 1 ) SNAME = C1.EQ.'S' .OR. C1.EQ.'D' CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' IF( .NOT.( CNAME .OR. SNAME ) ) RETURN C2 = SUBNAM( 2: 3 ) C3 = SUBNAM( 4: 6 ) C4 = C3( 2: 3 ) ! GO TO ( 50, 60, 70 )ISPEC ! 50 CONTINUE ! ! ISPEC = 1: block size ! ! In these examples, separate code is provided for setting NB for ! real and complex. We assume that NB will take the same value in ! single or double precision. ! NB = 1 ! IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. & C3.EQ.'QLF' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF ELSE IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'PO' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN NB = 32 ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN NB = 64 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRF' ) THEN NB = 64 ELSE IF( C3.EQ.'TRD' ) THEN NB = 32 ELSE IF( C3.EQ.'GST' ) THEN NB = 64 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1: 1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. & 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) & THEN NB = 32 END IF ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. & 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) & THEN NB = 32 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1: 1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. & 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) & THEN NB = 32 END IF ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. & 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) & THEN NB = 32 END IF END IF ELSE IF( C2.EQ.'GB' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN IF( N4.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF ELSE IF( N4.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF END IF END IF ELSE IF( C2.EQ.'PB' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN IF( N2.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF ELSE IF( N2.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF END IF END IF ELSE IF( C2.EQ.'TR' ) THEN IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'LA' ) THEN IF( C3.EQ.'UUM' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN IF( C3.EQ.'EBZ' ) THEN NB = 1 END IF ELSE IF( C2.EQ.'GG' ) THEN NB = 32 IF( C3.EQ.'HD3' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF END IF END IF ILAENV = NB RETURN ! 60 CONTINUE ! ! ISPEC = 2: minimum block size ! NBMIN = 2 IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. & 'QLF' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NBMIN = 8 ELSE NBMIN = 8 END IF ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN NBMIN = 2 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRD' ) THEN NBMIN = 2 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1: 1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. & 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) & THEN NBMIN = 2 END IF ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. & 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) & THEN NBMIN = 2 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1: 1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. & 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) & THEN NBMIN = 2 END IF ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. & 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) & THEN NBMIN = 2 END IF END IF ELSE IF( C2.EQ.'GG' ) THEN NBMIN = 2 IF( C3.EQ.'HD3' ) THEN NBMIN = 2 END IF END IF ILAENV = NBMIN RETURN ! 70 CONTINUE ! ! ISPEC = 3: crossover point ! NX = 0 IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. & 'QLF' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( SNAME .AND. C3.EQ.'TRD' ) THEN NX = 32 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRD' ) THEN NX = 32 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1: 1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. & 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) & THEN NX = 128 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1: 1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. & 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) & THEN NX = 128 END IF END IF ELSE IF( C2.EQ.'GG' ) THEN NX = 128 IF( C3.EQ.'HD3' ) THEN NX = 128 END IF END IF ILAENV = NX RETURN ! 80 CONTINUE ! ! ISPEC = 4: number of shifts (used by xHSEQR) ! ILAENV = 6 RETURN ! 90 CONTINUE ! ! ISPEC = 5: minimum column dimension (not used) ! ILAENV = 2 RETURN ! 100 CONTINUE ! ! ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) ! ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) RETURN ! 110 CONTINUE ! ! ISPEC = 7: number of processors (not used) ! ILAENV = 1 RETURN ! 120 CONTINUE ! ! ISPEC = 8: crossover point for multishift (used by xHSEQR) ! ILAENV = 50 RETURN ! 130 CONTINUE ! ! ISPEC = 9: maximum size of the subproblems at the bottom of the ! computation tree in the divide-and-conquer algorithm ! (used by xGELSD and xGESDD) ! ILAENV = 25 RETURN ! 140 CONTINUE ! ! ISPEC = 10: ieee NaN arithmetic can be trusted not to trap ! ! ILAENV = 0 ILAENV = 1 IF( ILAENV.EQ.1 ) THEN ILAENV = IEEECK( 1, 0.0, 1.0 ) END IF RETURN ! 150 CONTINUE ! ! ISPEC = 11: infinity arithmetic can be trusted not to trap ! ! ILAENV = 0 ILAENV = 1 IF( ILAENV.EQ.1 ) THEN ILAENV = IEEECK( 0, 0.0, 1.0 ) END IF RETURN ! 160 CONTINUE ! ! 12 <= ISPEC <= 16: xHSEQR or related subroutines. ! ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) RETURN ! ! End of ILAENV ! END FUNCTION ILAENV !> \brief \b IPARMQ ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download IPARMQ + dependencies !> [TGZ] !> [ZIP] !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) ! ! .. Scalar Arguments .. ! INTEGER IHI, ILO, ISPEC, LWORK, N ! CHARACTER NAME*( * ), OPTS*( * ) ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> This program sets problem and machine dependent parameters !> useful for xHSEQR and related subroutines for eigenvalue !> problems. It is called whenever !> IPARMQ is called with 12 <= ISPEC <= 16 !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] ISPEC !> \verbatim !> ISPEC is integer scalar !> ISPEC specifies which tunable parameter IPARMQ should !> return. !> !> ISPEC=12: (INMIN) Matrices of order nmin or less !> are sent directly to xLAHQR, the implicit !> double shift QR algorithm. NMIN must be !> at least 11. !> !> ISPEC=13: (INWIN) Size of the deflation window. !> This is best set greater than or equal to !> the number of simultaneous shifts NS. !> Larger matrices benefit from larger deflation !> windows. !> !> ISPEC=14: (INIBL) Determines when to stop nibbling and !> invest in an (expensive) multi-shift QR sweep. !> If the aggressive early deflation subroutine !> finds LD converged eigenvalues from an order !> NW deflation window and LD.GT.(NW*NIBBLE)/100, !> then the next QR sweep is skipped and early !> deflation is applied immediately to the !> remaining active diagonal block. Setting !> IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a !> multi-shift QR sweep whenever early deflation !> finds a converged eigenvalue. Setting !> IPARMQ(ISPEC=14) greater than or equal to 100 !> prevents TTQRE from skipping a multi-shift !> QR sweep. !> !> ISPEC=15: (NSHFTS) The number of simultaneous shifts in !> a multi-shift QR iteration. !> !> ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the !> following meanings. !> 0: During the multi-shift QR/QZ sweep, !> blocked eigenvalue reordering, blocked !> Hessenberg-triangular reduction, !> reflections and/or rotations are not !> accumulated when updating the !> far-from-diagonal matrix entries. !> 1: During the multi-shift QR/QZ sweep, !> blocked eigenvalue reordering, blocked !> Hessenberg-triangular reduction, !> reflections and/or rotations are !> accumulated, and matrix-matrix !> multiplication is used to update the !> far-from-diagonal matrix entries. !> 2: During the multi-shift QR/QZ sweep, !> blocked eigenvalue reordering, blocked !> Hessenberg-triangular reduction, !> reflections and/or rotations are !> accumulated, and 2-by-2 block structure !> is exploited during matrix-matrix !> multiplies. !> (If xTRMM is slower than xGEMM, then !> IPARMQ(ISPEC=16)=1 may be more efficient than !> IPARMQ(ISPEC=16)=2 despite the greater level of !> arithmetic work implied by the latter choice.) !> \endverbatim !> !> \param[in] NAME !> \verbatim !> NAME is character string !> Name of the calling subroutine !> \endverbatim !> !> \param[in] OPTS !> \verbatim !> OPTS is character string !> This is a concatenation of the string arguments to !> TTQRE. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is integer scalar !> N is the order of the Hessenberg matrix H. !> \endverbatim !> !> \param[in] ILO !> \verbatim !> ILO is INTEGER !> \endverbatim !> !> \param[in] IHI !> \verbatim !> IHI is INTEGER !> It is assumed that H is already upper triangular !> in rows and columns 1:ILO-1 and IHI+1:N. !> \endverbatim !> !> \param[in] LWORK !> \verbatim !> LWORK is integer scalar !> The amount of workspace available. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2015 ! !> \ingroup auxOTHERauxiliary ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> Little is known about how best to choose these parameters. !> It is possible to use different values of the parameters !> for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. !> !> It is probably best to choose different parameters for !> different matrices and different parameters at different !> times during the iteration, but this has not been !> implemented --- yet. !> !> !> The best choices of most of the parameters depend !> in an ill-understood way on the relative execution !> rate of xLAQR3 and xLAQR5 and on the nature of each !> particular eigenvalue problem. Experiment may be the !> only practical way to determine which choices are most !> effective. !> !> Following is a list of default values supplied by IPARMQ. !> These defaults may be adjusted in order to attain better !> performance in any particular computational environment. !> !> IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. !> Default: 75. (Must be at least 11.) !> !> IPARMQ(ISPEC=13) Recommended deflation window size. !> This depends on ILO, IHI and NS, the !> number of simultaneous shifts returned !> by IPARMQ(ISPEC=15). The default for !> (IHI-ILO+1).LE.500 is NS. The default !> for (IHI-ILO+1).GT.500 is 3*NS/2. !> !> IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. !> !> IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. !> a multi-shift QR iteration. !> !> If IHI-ILO+1 is ... !> !> greater than ...but less ... the !> or equal to ... than default is !> !> 0 30 NS = 2+ !> 30 60 NS = 4+ !> 60 150 NS = 10 !> 150 590 NS = ** !> 590 3000 NS = 64 !> 3000 6000 NS = 128 !> 6000 infinity NS = 256 !> !> (+) By default matrices of this order are !> passed to the implicit double shift routine !> xLAHQR. See IPARMQ(ISPEC=12) above. These !> values of NS are used only in case of a rare !> xLAHQR failure. !> !> (**) The asterisks (**) indicate an ad-hoc !> function increasing from 10 to 64. !> !> IPARMQ(ISPEC=16) Select structured matrix multiply. !> (See ISPEC=16 above for details.) !> Default: 3. !> \endverbatim !> ! ===================================================================== INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) ! ! -- LAPACK auxiliary routine (version 3.6.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2015 ! ! .. Scalar Arguments .. INTEGER IHI, ILO, ISPEC, LWORK, N CHARACTER NAME*( * ), OPTS*( * ) ! ! ================================================================ ! .. Parameters .. INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22 PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14, & ISHFTS = 15, IACC22 = 16 ) INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14, & NIBBLE = 14, KNWSWP = 500 ) REAL TWO PARAMETER ( TWO = 2.0 ) ! .. ! .. Local Scalars .. INTEGER NH, NS INTEGER I, IC, IZ CHARACTER SUBNAM*6 ! .. ! .. Intrinsic Functions .. INTRINSIC LOG, MAX, MOD, NINT, REAL ! .. ! .. Executable Statements .. IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR. & ( ISPEC.EQ.IACC22 ) ) THEN ! ! ==== Set the number simultaneous shifts ==== ! NH = IHI - ILO + 1 NS = 2 IF( NH.GE.30 ) NS = 4 IF( NH.GE.60 ) NS = 10 IF( NH.GE.150 ) & NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) ) IF( NH.GE.590 ) NS = 64 IF( NH.GE.3000 ) NS = 128 IF( NH.GE.6000 ) NS = 256 NS = MAX( 2, NS-MOD( NS, 2 ) ) END IF ! IF( ISPEC.EQ.INMIN ) THEN ! ! ! ===== Matrices of order smaller than NMIN get sent ! . to xLAHQR, the classic double shift algorithm. ! . This must be at least 11. ==== ! IPARMQ = NMIN ! ELSE IF( ISPEC.EQ.INIBL ) THEN ! ! ==== INIBL: skip a multi-shift qr iteration and ! . whenever aggressive early deflation finds ! . at least (NIBBLE*(window size)/100) deflations. ==== ! IPARMQ = NIBBLE ! ELSE IF( ISPEC.EQ.ISHFTS ) THEN ! ! ==== NSHFTS: The number of simultaneous shifts ===== ! IPARMQ = NS ! ELSE IF( ISPEC.EQ.INWIN ) THEN ! ! ==== NW: deflation window size. ==== ! IF( NH.LE.KNWSWP ) THEN IPARMQ = NS ELSE IPARMQ = 3*NS / 2 END IF ! ELSE IF( ISPEC.EQ.IACC22 ) THEN ! ! ==== IACC22: Whether to accumulate reflections ! . before updating the far-from-diagonal elements ! . and whether to use 2-by-2 block structure while ! . doing it. A small amount of work could be saved ! . by making this choice dependent also upon the ! . NH=IHI-ILO+1. ! ! ! Convert NAME to upper case if the first character is lower case. ! IPARMQ = 0 SUBNAM = NAME IC = ICHAR( SUBNAM( 1: 1 ) ) IZ = ICHAR( 'Z' ) IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN ! ! ASCII character set ! IF( IC.GE.97 .AND. IC.LE.122 ) THEN SUBNAM( 1: 1 ) = CHAR( IC-32 ) DO I = 2, 6 IC = ICHAR( SUBNAM( I: I ) ) IF( IC.GE.97 .AND. IC.LE.122 ) & SUBNAM( I: I ) = CHAR( IC-32 ) END DO END IF ! ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN ! ! EBCDIC character set ! IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. & ( IC.GE.145 .AND. IC.LE.153 ) .OR. & ( IC.GE.162 .AND. IC.LE.169 ) ) THEN SUBNAM( 1: 1 ) = CHAR( IC+64 ) DO I = 2, 6 IC = ICHAR( SUBNAM( I: I ) ) IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. & ( IC.GE.145 .AND. IC.LE.153 ) .OR. & ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: & I ) = CHAR( IC+64 ) END DO END IF ! ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN ! ! Prime machines: ASCII+128 ! IF( IC.GE.225 .AND. IC.LE.250 ) THEN SUBNAM( 1: 1 ) = CHAR( IC-32 ) DO I = 2, 6 IC = ICHAR( SUBNAM( I: I ) ) IF( IC.GE.225 .AND. IC.LE.250 ) & SUBNAM( I: I ) = CHAR( IC-32 ) END DO END IF END IF ! IF( SUBNAM( 2:6 ).EQ.'GGHRD' .OR. & SUBNAM( 2:6 ).EQ.'GGHD3' ) THEN IPARMQ = 1 IF( NH.GE.K22MIN ) IPARMQ = 2 ELSE IF ( SUBNAM( 4:6 ).EQ.'EXC' ) THEN IF( NH.GE.KACMIN ) IPARMQ = 1 IF( NH.GE.K22MIN ) IPARMQ = 2 ELSE IF ( SUBNAM( 2:6 ).EQ.'HSEQR' .OR. & SUBNAM( 2:5 ).EQ.'LAQR' ) THEN IF( NS.GE.KACMIN ) IPARMQ = 1 IF( NS.GE.K22MIN ) IPARMQ = 2 END IF ! ELSE ! ===== invalid value of ispec ===== IPARMQ = -1 ! END IF ! ! ==== End of IPARMQ ==== ! END FUNCTION IPARMQ ! !> \brief \b LSAME ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! ! Definition: ! =========== ! ! LOGICAL FUNCTION LSAME(CA,CB) ! ! .. Scalar Arguments .. ! CHARACTER CA,CB ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> LSAME returns .TRUE. if CA is the same letter as CB regardless of !> case. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] CA !> \verbatim !> CA is CHARACTER*1 !> \endverbatim !> !> \param[in] CB !> \verbatim !> CB is CHARACTER*1 !> CA and CB specify the single characters to be compared. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup aux_blas ! ! ===================================================================== LOGICAL FUNCTION LSAME(CA,CB) ! ! -- Reference BLAS level1 routine (version 3.1) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. CHARACTER CA,CB ! .. ! ! ===================================================================== ! ! .. Intrinsic Functions .. INTRINSIC ICHAR ! .. ! .. Local Scalars .. INTEGER INTA,INTB,ZCODE ! .. ! ! Test if the characters are equal ! LSAME = CA .EQ. CB IF (LSAME) RETURN ! ! Now test for equivalence if both characters are alphabetic. ! ZCODE = ICHAR('Z') ! ! Use 'Z' rather than 'A' so that ASCII can be detected on Prime ! machines, on which ICHAR returns a value with bit 8 set. ! ICHAR('A') on Prime machines returns 193 which is the same as ! ICHAR('A') on an EBCDIC machine. ! INTA = ICHAR(CA) INTB = ICHAR(CB) ! IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN ! ! ASCII is assumed - ZCODE is the ASCII code of either lower or ! upper case 'Z'. ! IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32 IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32 ! ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN ! ! EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or ! upper case 'Z'. ! IF (INTA.GE.129 .AND. INTA.LE.137 .OR. & INTA.GE.145 .AND. INTA.LE.153 .OR. & INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64 IF (INTB.GE.129 .AND. INTB.LE.137 .OR. & INTB.GE.145 .AND. INTB.LE.153 .OR. & INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64 ! ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN ! ! ASCII is assumed, on Prime machines - ZCODE is the ASCII code ! plus 128 of either lower or upper case 'Z'. ! IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32 IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32 END IF LSAME = INTA .EQ. INTB ! ! RETURN ! ! End of LSAME ! END FUNCTION LSAME !> \brief \b LSAMEN ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download LSAMEN + dependencies !> [TGZ] !> [ZIP] !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! LOGICAL FUNCTION LSAMEN( N, CA, CB ) ! ! .. Scalar Arguments .. ! CHARACTER*( * ) CA, CB ! INTEGER N ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> LSAMEN tests if the first N letters of CA are the same as the !> first N letters of CB, regardless of case. !> LSAMEN returns .TRUE. if CA and CB are equivalent except for case !> and .FALSE. otherwise. LSAMEN also returns .FALSE. if LEN( CA ) !> or LEN( CB ) is less than N. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] N !> \verbatim !> N is INTEGER !> The number of characters in CA and CB to be compared. !> \endverbatim !> !> \param[in] CA !> \verbatim !> CA is CHARACTER*(*) !> \endverbatim !> !> \param[in] CB !> \verbatim !> CB is CHARACTER*(*) !> CA and CB specify two character strings of length at least N. !> Only the first N characters of each string will be accessed. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup auxOTHERauxiliary ! ! ===================================================================== LOGICAL FUNCTION LSAMEN( N, CA, CB ) ! ! -- LAPACK auxiliary routine (version 3.4.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. CHARACTER*( * ) CA, CB INTEGER N ! .. ! ! ===================================================================== ! ! .. Local Scalars .. INTEGER I ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. Intrinsic Functions .. ! INTRINSIC LEN ! .. ! .. Executable Statements .. ! LSAMEN = .FALSE. IF( LEN( CA ).LT.N .OR. LEN( CB ).LT.N ) GO TO 20 ! ! Do for each character in the two strings. ! DO 10 I = 1, N ! ! Test if the characters are equal using LSAME. ! IF( .NOT.LSAME( CA( I: I ), CB( I: I ) ) ) GO TO 20 ! 10 CONTINUE LSAMEN = .TRUE. ! 20 CONTINUE RETURN ! ! End of LSAMEN ! END FUNCTION LSAMEN !> \brief \b XERBLA ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! ! Definition: ! =========== ! ! SUBROUTINE XERBLA( SRNAME, INFO ) ! ! .. Scalar Arguments .. ! CHARACTER*(*) SRNAME ! INTEGER INFO ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> XERBLA is an error handler for the LAPACK routines. !> It is called by an LAPACK routine if an input parameter has an !> invalid value. A message is printed and execution stops. !> !> Installers may consider modifying the STOP statement in order to !> call system-specific exception-handling facilities. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] SRNAME !> \verbatim !> SRNAME is CHARACTER*(*) !> The name of the routine which called XERBLA. !> \endverbatim !> !> \param[in] INFO !> \verbatim !> INFO is INTEGER !> The position of the invalid parameter in the parameter list !> of the calling routine. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup aux_blas ! ! ===================================================================== SUBROUTINE XERBLA( SRNAME, INFO ) ! ! -- Reference BLAS level1 routine (version 3.4.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. CHARACTER*(*) SRNAME INTEGER INFO ! .. ! ! ===================================================================== ! ! .. Intrinsic Functions .. INTRINSIC LEN_TRIM ! .. ! .. Executable Statements .. ! WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO ! STOP ! 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ', & 'an illegal value' ) ! ! End of XERBLA ! END SUBROUTINE XERBLA ! !> \brief DSPEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DSPEVD + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, ! IWORK, LIWORK, INFO ) ! ! .. Scalar Arguments .. ! CHARACTER JOBZ, UPLO ! INTEGER INFO, LDZ, LIWORK, LWORK, N ! .. ! .. Array Arguments .. ! INTEGER IWORK( * ) ! DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DSPEVD computes all the eigenvalues and, optionally, eigenvectors !> of a real symmetric matrix A in packed storage. If eigenvectors are !> desired, it uses a divide and conquer algorithm. !> !> The divide and conquer algorithm makes very mild assumptions about !> floating point arithmetic. It will work on machines with a guard !> digit in add/subtract, or on those binary machines without guard !> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or !> Cray-2. It could conceivably fail on hexadecimal or decimal machines !> without guard digits, but we know of none. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] JOBZ !> \verbatim !> JOBZ is CHARACTER*1 !> = 'N': Compute eigenvalues only; !> = 'V': Compute eigenvalues and eigenvectors. !> \endverbatim !> !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> = 'U': Upper triangle of A is stored; !> = 'L': Lower triangle of A is stored. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The order of the matrix A. N >= 0. !> \endverbatim !> !> \param[in,out] AP !> \verbatim !> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) !> On entry, the upper or lower triangle of the symmetric matrix !> A, packed columnwise in a linear array. The j-th column of A !> is stored in the array AP as follows: !> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; !> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. !> !> On exit, AP is overwritten by values generated during the !> reduction to tridiagonal form. If UPLO = 'U', the diagonal !> and first superdiagonal of the tridiagonal matrix T overwrite !> the corresponding elements of A, and if UPLO = 'L', the !> diagonal and first subdiagonal of T overwrite the !> corresponding elements of A. !> \endverbatim !> !> \param[out] W !> \verbatim !> W is DOUBLE PRECISION array, dimension (N) !> If INFO = 0, the eigenvalues in ascending order. !> \endverbatim !> !> \param[out] Z !> \verbatim !> Z is DOUBLE PRECISION array, dimension (LDZ, N) !> If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal !> eigenvectors of the matrix A, with the i-th column of Z !> holding the eigenvector associated with W(i). !> If JOBZ = 'N', then Z is not referenced. !> \endverbatim !> !> \param[in] LDZ !> \verbatim !> LDZ is INTEGER !> The leading dimension of the array Z. LDZ >= 1, and if !> JOBZ = 'V', LDZ >= max(1,N). !> \endverbatim !> !> \param[out] WORK !> \verbatim !> WORK is DOUBLE PRECISION array, !> dimension (LWORK) !> On exit, if INFO = 0, WORK(1) returns the required LWORK. !> \endverbatim !> !> \param[in] LWORK !> \verbatim !> LWORK is INTEGER !> The dimension of the array WORK. !> If N <= 1, LWORK must be at least 1. !> If JOBZ = 'N' and N > 1, LWORK must be at least 2*N. !> If JOBZ = 'V' and N > 1, LWORK must be at least !> 1 + 6*N + N**2. !> !> If LWORK = -1, then a workspace query is assumed; the routine !> only calculates the required sizes of the WORK and IWORK !> arrays, returns these values as the first entries of the WORK !> and IWORK arrays, and no error message related to LWORK or !> LIWORK is issued by XERBLA. !> \endverbatim !> !> \param[out] IWORK !> \verbatim !> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) !> On exit, if INFO = 0, IWORK(1) returns the required LIWORK. !> \endverbatim !> !> \param[in] LIWORK !> \verbatim !> LIWORK is INTEGER !> The dimension of the array IWORK. !> If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. !> If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. !> !> If LIWORK = -1, then a workspace query is assumed; the !> routine only calculates the required sizes of the WORK and !> IWORK arrays, returns these values as the first entries of !> the WORK and IWORK arrays, and no error message related to !> LWORK or LIWORK is issued by XERBLA. !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument had an illegal value. !> > 0: if INFO = i, the algorithm failed to converge; i !> off-diagonal elements of an intermediate tridiagonal !> form did not converge to zero. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup doubleOTHEReigen ! ! ===================================================================== SUBROUTINE DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, & IWORK, LIWORK, INFO ) ! ! -- LAPACK driver routine (version 3.4.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. CHARACTER JOBZ, UPLO INTEGER INFO, LDZ, LIWORK, LWORK, N ! .. ! .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) ! .. ! .. Local Scalars .. LOGICAL LQUERY, WANTZ INTEGER IINFO, INDE, INDTAU, INDWRK, ISCALE, LIWMIN,& LLWORK, LWMIN DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,& SMLNUM ! .. ! .. External Functions .. !? LOGICAL LSAME !? DOUBLE PRECISION DLAMCH, DLANSP !? EXTERNAL LSAME, DLAMCH, DLANSP ! .. ! .. External Subroutines .. !? EXTERNAL DOPMTR, DSCAL, DSPTRD, DSTEDC, DSTERF, XERBLA ! EXTERNAL DSTERF ! .. ! .. Intrinsic Functions .. !? INTRINSIC SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! WANTZ = LSAME( JOBZ, 'V' ) LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) ! INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) )& THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -7 END IF ! IF( INFO.EQ.0 ) THEN IF( N.LE.1 ) THEN LIWMIN = 1 LWMIN = 1 ELSE IF( WANTZ ) THEN LIWMIN = 3 + 5*N LWMIN = 1 + 6*N + N**2 ELSE LIWMIN = 1 LWMIN = 2*N END IF END IF IWORK( 1 ) = LIWMIN WORK( 1 ) = LWMIN ! IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -9 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN INFO = -11 END IF END IF ! IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSPEVD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF ! ! Quick return if possible ! IF( N.EQ.0 )& RETURN ! IF( N.EQ.1 ) THEN W( 1 ) = AP( 1 ) IF( WANTZ )& Z( 1, 1 ) = ONE RETURN END IF ! ! Get machine constants. ! SAFMIN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Precision' ) SMLNUM = SAFMIN / EPS BIGNUM = ONE / SMLNUM RMIN = SQRT( SMLNUM ) RMAX = SQRT( BIGNUM ) ! ! Scale matrix to allowable range, if necessary. ! ANRM = DLANSP( 'M', UPLO, N, AP, WORK ) ISCALE = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN ISCALE = 1 SIGMA = RMAX / ANRM END IF IF( ISCALE.EQ.1 ) THEN CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 ) END IF ! ! Call DSPTRD to reduce symmetric packed matrix to tridiagonal form. ! INDE = 1 INDTAU = INDE + N CALL DSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO ) ! ! For eigenvalues only, call DSTERF. For eigenvectors, first call ! DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the ! tridiagonal matrix, then call DOPMTR to multiply it by the ! Householder transformations represented in AP. ! IF( .NOT.WANTZ ) THEN CALL DSTERF( N, W, WORK( INDE ), INFO ) ELSE INDWRK = INDTAU + N LLWORK = LWORK - INDWRK + 1 CALL DSTEDC( 'I', N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ),& LLWORK, IWORK, LIWORK, INFO ) CALL DOPMTR( 'L', UPLO, 'N', N, N, AP, WORK( INDTAU ), Z, LDZ,& WORK( INDWRK ), IINFO ) END IF ! ! If matrix was scaled, then rescale eigenvalues appropriately. ! IF( ISCALE.EQ.1 ) & CALL DSCAL( N, ONE / SIGMA, W, 1 ) ! WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN RETURN ! ! End of DSPEVD ! END SUBROUTINE DSPEVD ! ! !> \brief \b DLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric matrix supplied in packed form. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLANSP + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK ) ! ! .. Scalar Arguments .. ! CHARACTER NORM, UPLO ! INTEGER N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION AP( * ), WORK( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLANSP returns the value of the one norm, or the Frobenius norm, or !> the infinity norm, or the element of largest absolute value of a !> real symmetric matrix A, supplied in packed form. !> \endverbatim !> !> \return DLANSP !> \verbatim !> !> DLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm' !> ( !> ( norm1(A), NORM = '1', 'O' or 'o' !> ( !> ( normI(A), NORM = 'I' or 'i' !> ( !> ( normF(A), NORM = 'F', 'f', 'E' or 'e' !> !> where norm1 denotes the one norm of a matrix (maximum column sum), !> normI denotes the infinity norm of a matrix (maximum row sum) and !> normF denotes the Frobenius norm of a matrix (square root of sum of !> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] NORM !> \verbatim !> NORM is CHARACTER*1 !> Specifies the value to be returned in DLANSP as described !> above. !> \endverbatim !> !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> Specifies whether the upper or lower triangular part of the !> symmetric matrix A is supplied. !> = 'U': Upper triangular part of A is supplied !> = 'L': Lower triangular part of A is supplied !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The order of the matrix A. N >= 0. When N = 0, DLANSP is !> set to zero. !> \endverbatim !> !> \param[in] AP !> \verbatim !> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) !> The upper or lower triangle of the symmetric matrix A, packed !> columnwise in a linear array. The j-th column of A is stored !> in the array AP as follows: !> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; !> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. !> \endverbatim !> !> \param[out] WORK !> \verbatim !> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), !> where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, !> WORK is not referenced. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup doubleOTHERauxiliary ! ! ===================================================================== DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK ) ! ! -- LAPACK auxiliary routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER N ! .. ! .. Array Arguments .. DOUBLE PRECISION AP( * ), WORK( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) ! .. ! .. Local Scalars .. INTEGER I, J, K DOUBLE PRECISION ABSA, SCALE, SUM, VALUE ! .. ! .. External Subroutines .. ! EXTERNAL DLASSQ ! .. ! .. External Functions .. ! LOGICAL LSAME, DISNAN ! EXTERNAL LSAME, DISNAN ! .. ! .. Intrinsic Functions .. ! INTRINSIC ABS, SQRT ! .. ! .. Executable Statements .. ! IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN ! ! Find max(abs(A(i,j))). ! VALUE = ZERO IF( LSAME( UPLO, 'U' ) ) THEN K = 1 DO 20 J = 1, N DO 10 I = K, K + J - 1 SUM = ABS( AP( I ) ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 10 CONTINUE K = K + J 20 CONTINUE ELSE K = 1 DO 40 J = 1, N DO 30 I = K, K + N - J SUM = ABS( AP( I ) ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 30 CONTINUE K = K + N - J + 1 40 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ).OR.& ( NORM.EQ.'1' ) ) THEN ! ! Find normI(A) ( = norm1(A), since A is symmetric). ! VALUE = ZERO K = 1 IF( LSAME( UPLO, 'U' ) ) THEN DO 60 J = 1, N SUM = ZERO DO 50 I = 1, J - 1 ABSA = ABS( AP( K ) ) SUM = SUM + ABSA WORK( I ) = WORK( I ) + ABSA K = K + 1 50 CONTINUE WORK( J ) = SUM + ABS( AP( K ) ) K = K + 1 60 CONTINUE DO 70 I = 1, N SUM = WORK( I ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) & VALUE = SUM 70 CONTINUE ELSE DO 80 I = 1, N WORK( I ) = ZERO 80 CONTINUE DO 100 J = 1, N SUM = WORK( J ) + ABS( AP( K ) ) K = K + 1 DO 90 I = J + 1, N ABSA = ABS( AP( K ) ) SUM = SUM + ABSA WORK( I ) = WORK( I ) + ABSA K = K + 1 90 CONTINUE IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 100 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN ! ! Find normF(A). ! SCALE = ZERO SUM = ONE K = 2 IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N CALL DLASSQ( J-1, AP( K ), 1,& SCALE, SUM ) K = K + J 110 CONTINUE ELSE DO 120 J = 1, N - 1 CALL DLASSQ( N-J, AP( K ), 1, SCALE, SUM ) K = K + N - J + 1 120 CONTINUE END IF SUM = 2*SUM K = 1 DO 130 I = 1, N IF( AP( K ).NE.ZERO ) THEN ABSA = ABS( AP( K ) ) IF( SCALE.LT.ABSA ) THEN SUM = ONE + SUM*( SCALE / ABSA )**2 SCALE = ABSA ELSE SUM = SUM + ( ABSA / SCALE )**2 END IF END IF IF( LSAME( UPLO, 'U' ) ) THEN K = K + I + 1 ELSE K = K + N - I + 1 END IF 130 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF ! DLANSP = VALUE RETURN ! ! End of DLANSP ! END FUNCTION DLANSP ! != ! !> \brief \b DLASSQ updates a sum of squares represented in scaled form. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLASSQ + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) ! ! .. Scalar Arguments .. ! INTEGER INCX, N ! DOUBLE PRECISION SCALE, SUMSQ ! .. ! .. Array Arguments .. ! DOUBLE PRECISION X( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLASSQ returns the values scl and smsq such that !> !> ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, !> !> where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is !> assumed to be non-negative and scl returns the value !> !> scl = max( scale, abs( x( i ) ) ). !> !> scale and sumsq must be supplied in SCALE and SUMSQ and !> scl and smsq are overwritten on SCALE and SUMSQ respectively. !> !> The routine makes only one pass through the vector x. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] N !> \verbatim !> N is INTEGER !> The number of elements to be used from the vector X. !> \endverbatim !> !> \param[in] X !> \verbatim !> X is DOUBLE PRECISION array, dimension (N) !> The vector for which a scaled sum of squares is computed. !> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. !> \endverbatim !> !> \param[in] INCX !> \verbatim !> INCX is INTEGER !> The increment between successive values of the vector X. !> INCX > 0. !> \endverbatim !> !> \param[in,out] SCALE !> \verbatim !> SCALE is DOUBLE PRECISION !> On entry, the value scale in the equation above. !> On exit, SCALE is overwritten with scl , the scaling factor !> for the sum of squares. !> \endverbatim !> !> \param[in,out] SUMSQ !> \verbatim !> SUMSQ is DOUBLE PRECISION !> On entry, the value sumsq in the equation above. !> On exit, SUMSQ is overwritten with smsq , the basic sum of !> squares from which scl has been factored out. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup auxOTHERauxiliary ! ! ===================================================================== SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) ! ! -- LAPACK auxiliary routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. INTEGER INCX, N DOUBLE PRECISION SCALE, SUMSQ ! .. ! .. Array Arguments .. DOUBLE PRECISION X( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) ! .. ! .. Local Scalars .. INTEGER IX DOUBLE PRECISION ABSXI ! .. ! .. External Functions .. ! LOGICAL DISNAN ! EXTERNAL DISNAN ! .. ! .. Intrinsic Functions .. ! INTRINSIC ABS ! .. ! .. Executable Statements .. ! IF( N.GT.0 ) THEN DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX ABSXI = ABS( X( IX ) ) IF( ABSXI.GT.ZERO.OR.DISNAN( ABSXI ) ) THEN IF( SCALE.LT.ABSXI ) THEN SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 SCALE = ABSXI ELSE SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 END IF END IF 10 CONTINUE END IF RETURN ! ! End of DLASSQ ! END SUBROUTINE DLASSQ ! != ! !> \brief \b DSPTRD ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DSPTRD + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO ) ! ! .. Scalar Arguments .. ! CHARACTER UPLO ! INTEGER INFO, N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION AP( * ), D( * ), E( * ), TAU( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DSPTRD reduces a real symmetric matrix A stored in packed form to !> symmetric tridiagonal form T by an orthogonal similarity !> transformation: Q**T * A * Q = T. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> = 'U': Upper triangle of A is stored; !> = 'L': Lower triangle of A is stored. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The order of the matrix A. N >= 0. !> \endverbatim !> !> \param[in,out] AP !> \verbatim !> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) !> On entry, the upper or lower triangle of the symmetric matrix !> A, packed columnwise in a linear array. The j-th column of A !> is stored in the array AP as follows: !> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; !> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. !> On exit, if UPLO = 'U', the diagonal and first superdiagonal !> of A are overwritten by the corresponding elements of the !> tridiagonal matrix T, and the elements above the first !> superdiagonal, with the array TAU, represent the orthogonal !> matrix Q as a product of elementary reflectors; if UPLO !> = 'L', the diagonal and first subdiagonal of A are over- !> written by the corresponding elements of the tridiagonal !> matrix T, and the elements below the first subdiagonal, with !> the array TAU, represent the orthogonal matrix Q as a product !> of elementary reflectors. See Further Details. !> \endverbatim !> !> \param[out] D !> \verbatim !> D is DOUBLE PRECISION array, dimension (N) !> The diagonal elements of the tridiagonal matrix T: !> D(i) = A(i,i). !> \endverbatim !> !> \param[out] E !> \verbatim !> E is DOUBLE PRECISION array, dimension (N-1) !> The off-diagonal elements of the tridiagonal matrix T: !> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. !> \endverbatim !> !> \param[out] TAU !> \verbatim !> TAU is DOUBLE PRECISION array, dimension (N-1) !> The scalar factors of the elementary reflectors (see Further !> Details). !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument had an illegal value !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup doubleOTHERcomputational ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> If UPLO = 'U', the matrix Q is represented as a product of elementary !> reflectors !> !> Q = H(n-1) . . . H(2) H(1). !> !> Each H(i) has the form !> !> H(i) = I - tau * v * v**T !> !> where tau is a real scalar, and v is a real vector with !> v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP, !> overwriting A(1:i-1,i+1), and tau is stored in TAU(i). !> !> If UPLO = 'L', the matrix Q is represented as a product of elementary !> reflectors !> !> Q = H(1) H(2) . . . H(n-1). !> !> Each H(i) has the form !> !> H(i) = I - tau * v * v**T !> !> where tau is a real scalar, and v is a real vector with !> v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP, !> overwriting A(i+2:n,i), and tau is stored in TAU(i). !> \endverbatim !> ! ===================================================================== SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO ) ! ! -- LAPACK computational routine (version 3.4.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, N ! .. ! .. Array Arguments .. DOUBLE PRECISION AP( * ), D( * ), E( * ), TAU( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE, ZERO, HALF PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0,& HALF = 1.0D0 / 2.0D0 ) ! .. ! .. Local Scalars .. LOGICAL UPPER INTEGER I, I1, I1I1, II DOUBLE PRECISION ALPHA, TAUI ! .. ! .. External Subroutines .. !? EXTERNAL DAXPY, DLARFG, DSPMV, DSPR2, XERBLA ! EXTERNAL DAXPY, DSPMV, DSPR2 ! .. ! .. External Functions .. ! LOGICAL LSAME ! DOUBLE PRECISION DDOT ! EXTERNAL LSAME, DDOT ! .. ! .. Executable Statements .. ! ! Test the input parameters ! INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSPTRD', -INFO ) RETURN END IF ! ! Quick return if possible ! IF( N.LE.0 )& RETURN ! IF( UPPER ) THEN ! ! Reduce the upper triangle of A. ! I1 is the index in AP of A(1,I+1). ! I1 = N*( N-1 ) / 2 + 1 DO 10 I = N - 1, 1, -1 ! ! Generate elementary reflector H(i) = I - tau * v * v**T ! to annihilate A(1:i-1,i+1) ! CALL DLARFG( I, AP( I1+I-1 ), AP( I1 ), 1, TAUI ) E( I ) = AP( I1+I-1 ) ! IF( TAUI.NE.ZERO ) THEN ! ! Apply H(i) from both sides to A(1:i,1:i) ! AP( I1+I-1 ) = ONE ! ! Compute y := tau * A * v storing y in TAU(1:i) ! CALL DSPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU, 1) ! ! Compute w := y - 1/2 * tau * (y**T *v) * v ! ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, AP( I1 ), 1 ) CALL DAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 ) ! ! Apply the transformation as a rank-2 update: ! A := A - v * w**T - w * v**T ! CALL DSPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP ) ! AP( I1+I-1 ) = E( I ) END IF D( I+1 ) = AP( I1+I ) TAU( I ) = TAUI I1 = I1 - I 10 CONTINUE D( 1 ) = AP( 1 ) ELSE ! ! Reduce the lower triangle of A. II is the index in AP of ! A(i,i) and I1I1 is the index of A(i+1,i+1). ! II = 1 DO 20 I = 1, N - 1 I1I1 = II + N - I + 1 ! ! Generate elementary reflector H(i) = I - tau * v * v**T ! to annihilate A(i+2:n,i) ! CALL DLARFG( N-I, AP( II+1 ), AP( II+2 ), 1, TAUI ) E( I ) = AP( II+1 ) ! IF( TAUI.NE.ZERO ) THEN ! ! Apply H(i) from both sides to A(i+1:n,i+1:n) ! AP( II+1 ) = ONE ! ! Compute y := tau * A * v storing y in TAU(i:n-1) ! CALL DSPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ), 1,& ZERO, TAU( I ), 1 ) ! ! Compute w := y - 1/2 * tau * (y**T *v) * v ! ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, AP( II+1 ), 1 ) CALL DAXPY( N-I, ALPHA, AP( II+1 ), 1, TAU( I ), 1 ) ! ! Apply the transformation as a rank-2 update: ! A := A - v * w**T - w * v**T ! CALL DSPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ), 1,& AP( I1I1 ) ) ! AP( II+1 ) = E( I ) END IF D( I ) = AP( II ) TAU( I ) = TAUI II = I1I1 20 CONTINUE D( N ) = AP( II ) END IF ! RETURN ! ! End of DSPTRD ! END SUBROUTINE DSPTRD ! != ! !> \brief \b DLARFG generates an elementary reflector (Householder matrix). ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLARFG + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) ! ! .. Scalar Arguments .. ! INTEGER INCX, N ! DOUBLE PRECISION ALPHA, TAU ! .. ! .. Array Arguments .. ! DOUBLE PRECISION X( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLARFG generates a real elementary reflector H of order n, such !> that !> !> H * ( alpha ) = ( beta ), H**T * H = I. !> ( x ) ( 0 ) !> !> where alpha and beta are scalars, and x is an (n-1)-element real !> vector. H is represented in the form !> !> H = I - tau * ( 1 ) * ( 1 v**T ) , !> ( v ) !> !> where tau is a real scalar and v is a real (n-1)-element !> vector. !> !> If the elements of x are all zero, then tau = 0 and H is taken to be !> the unit matrix. !> !> Otherwise 1 <= tau <= 2. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] N !> \verbatim !> N is INTEGER !> The order of the elementary reflector. !> \endverbatim !> !> \param[in,out] ALPHA !> \verbatim !> ALPHA is DOUBLE PRECISION !> On entry, the value alpha. !> On exit, it is overwritten with the value beta. !> \endverbatim !> !> \param[in,out] X !> \verbatim !> X is DOUBLE PRECISION array, dimension !> (1+(N-2)*abs(INCX)) !> On entry, the vector x. !> On exit, it is overwritten with the vector v. !> \endverbatim !> !> \param[in] INCX !> \verbatim !> INCX is INTEGER !> The increment between elements of X. INCX > 0. !> \endverbatim !> !> \param[out] TAU !> \verbatim !> TAU is DOUBLE PRECISION !> The value tau. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup doubleOTHERauxiliary ! ! ===================================================================== SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) ! ! -- LAPACK auxiliary routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. INTEGER INCX, N DOUBLE PRECISION ALPHA, TAU ! .. ! .. Array Arguments .. DOUBLE PRECISION X( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) ! .. ! .. Local Scalars .. INTEGER J, KNT DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM ! .. ! .. External Functions .. !? DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 ! DOUBLE PRECISION DNRM2 ! EXTERNAL DNRM2 ! .. ! .. Intrinsic Functions .. ! INTRINSIC ABS, SIGN ! .. ! .. External Subroutines .. ! EXTERNAL DSCAL ! .. ! .. Executable Statements .. ! IF( N.LE.1 ) THEN TAU = ZERO RETURN END IF ! XNORM = DNRM2( N-1, X, INCX ) ! IF( XNORM.EQ.ZERO ) THEN ! ! H = I ! TAU = ZERO ELSE ! ! general case ! BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) KNT = 0 IF( ABS( BETA ).LT.SAFMIN ) THEN ! ! XNORM, BETA may be inaccurate; scale X and recompute them ! RSAFMN = ONE / SAFMIN 10 CONTINUE KNT = KNT + 1 CALL DSCAL( N-1, RSAFMN, X, INCX ) BETA = BETA*RSAFMN ALPHA = ALPHA*RSAFMN IF( ABS( BETA ).LT.SAFMIN )& GO TO 10 ! ! New BETA is at most 1, at least SAFMIN ! XNORM = DNRM2( N-1, X, INCX ) BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) END IF TAU = ( BETA-ALPHA ) / BETA CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) ! ! If ALPHA is subnormal, it may lose relative accuracy ! DO 20 J = 1, KNT BETA = BETA*SAFMIN 20 CONTINUE ALPHA = BETA END IF ! RETURN ! ! End of DLARFG ! END SUBROUTINE DLARFG ! != ! !> \brief \b DLAPY2 returns sqrt(x2+y2). ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLAPY2 + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) ! ! .. Scalar Arguments .. ! DOUBLE PRECISION X, Y ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary !> overflow. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] X !> \verbatim !> X is DOUBLE PRECISION !> \endverbatim !> !> \param[in] Y !> \verbatim !> Y is DOUBLE PRECISION !> X and Y specify the values x and y. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup auxOTHERauxiliary ! ! ===================================================================== DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) ! ! -- LAPACK auxiliary routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. DOUBLE PRECISION X, Y ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) ! .. ! .. Local Scalars .. DOUBLE PRECISION W, XABS, YABS, Z ! .. ! .. Intrinsic Functions .. ! INTRINSIC ABS, MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! XABS = ABS( X ) YABS = ABS( Y ) W = MAX( XABS, YABS ) Z = MIN( XABS, YABS ) IF( Z.EQ.ZERO ) THEN DLAPY2 = W ELSE DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) END IF RETURN ! ! End of DLAPY2 ! END FUNCTION DLAPY2 ! != ! !> \brief \b DSTERF ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DSTERF + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DSTERF( N, D, E, INFO ) ! ! .. Scalar Arguments .. ! INTEGER INFO, N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION D( * ), E( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DSTERF computes all eigenvalues of a symmetric tridiagonal matrix !> using the Pal-Walker-Kahan variant of the QL or QR algorithm. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] N !> \verbatim !> N is INTEGER !> The order of the matrix. N >= 0. !> \endverbatim !> !> \param[in,out] D !> \verbatim !> D is DOUBLE PRECISION array, dimension (N) !> On entry, the n diagonal elements of the tridiagonal matrix. !> On exit, if INFO = 0, the eigenvalues in ascending order. !> \endverbatim !> !> \param[in,out] E !> \verbatim !> E is DOUBLE PRECISION array, dimension (N-1) !> On entry, the (n-1) subdiagonal elements of the tridiagonal !> matrix. !> On exit, E has been destroyed. !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument had an illegal value !> > 0: the algorithm failed to find all of the eigenvalues in !> a total of 30*N iterations; if INFO = i, then i !> elements of E have not converged to zero. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup auxOTHERcomputational ! ! ===================================================================== SUBROUTINE DSTERF( N, D, E, INFO ) ! ! -- LAPACK computational routine (version 3.4.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. INTEGER INFO, N ! .. ! .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,& THREE = 3.0D0 ) INTEGER MAXIT PARAMETER ( MAXIT = 30 ) ! .. ! .. Local Scalars .. INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M,& NMAXIT DOUBLE PRECISION ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC,& OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN,& SIGMA, SSFMAX, SSFMIN, RMAX ! .. ! .. External Functions .. ! DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 !? EXTERNAL DLAMCH, DLANST, DLAPY2 ! .. ! .. External Subroutines .. !? EXTERNAL DLAE2, DLASCL, DLASRT, XERBLA ! EXTERNAL DLAE2 ! .. ! .. Intrinsic Functions .. ! INTRINSIC ABS, SIGN, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! INFO = 0 ! ! Quick return if possible ! IF( N.LT.0 ) THEN INFO = -1 CALL XERBLA( 'DSTERF', -INFO ) RETURN END IF IF( N.LE.1 ) RETURN ! ! Determine the unit roundoff for this environment. ! EPS = DLAMCH( 'E' ) EPS2 = EPS**2 SAFMIN = DLAMCH( 'S' ) SAFMAX = ONE / SAFMIN SSFMAX = SQRT( SAFMAX ) / THREE SSFMIN = SQRT( SAFMIN ) / EPS2 RMAX = DLAMCH( 'O' ) ! ! Compute the eigenvalues of the tridiagonal matrix. ! NMAXIT = N*MAXIT SIGMA = ZERO JTOT = 0 ! ! Determine where the matrix splits and choose QL or QR iteration ! for each block, according to whether top or bottom diagonal ! element is smaller. ! L1 = 1 ! 10 CONTINUE IF( L1.GT.N ) GO TO 170 IF( L1.GT.1 ) E( L1-1 ) = ZERO DO 20 M = L1, N - 1 IF( ABS( E( M ) ).LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+& 1 ) ) ) )*EPS ) THEN E( M ) = ZERO GO TO 30 END IF 20 CONTINUE M = N ! 30 CONTINUE L = L1 LSV = L LEND = M LENDSV = LEND L1 = M + 1 IF( LEND.EQ.L ) GO TO 10 ! ! Scale submatrix in rows and columns L to LEND ! ANORM = DLANST( 'M', LEND-L+1, D( L ), E( L ) ) ISCALE = 0 IF( ANORM.EQ.ZERO ) GO TO 10 IF( (ANORM.GT.SSFMAX) ) THEN ISCALE = 1 CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, INFO ) CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, INFO) ELSE IF( ANORM.LT.SSFMIN ) THEN ISCALE = 2 CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, INFO) CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, INFO) END IF ! DO 40 I = L, LEND - 1 E( I ) = E( I )**2 40 CONTINUE ! ! Choose between QL and QR iteration ! IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN LEND = LSV L = LENDSV END IF ! IF( LEND.GE.L ) THEN ! ! QL Iteration ! ! Look for small subdiagonal element. ! 50 CONTINUE IF( L.NE.LEND ) THEN DO 60 M = L, LEND - 1 IF( ABS( E( M ) ).LE.EPS2*ABS( D( M )*D( M+1 ) ) ) GO TO 70 60 CONTINUE END IF M = LEND ! 70 CONTINUE IF( M.LT.LEND ) E( M ) = ZERO P = D( L ) IF( M.EQ.L ) GO TO 90 ! ! If remaining matrix is 2 by 2, use DLAE2 to compute its ! eigenvalues. ! IF( M.EQ.L+1 ) THEN RTE = SQRT( E( L ) ) CALL DLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 ) D( L ) = RT1 D( L+1 ) = RT2 E( L ) = ZERO L = L + 2 IF( L.LE.LEND ) GO TO 50 GO TO 150 END IF ! IF( JTOT.EQ.NMAXIT ) GO TO 150 JTOT = JTOT + 1 ! ! Form shift. ! RTE = SQRT( E( L ) ) SIGMA = ( D( L+1 )-P ) / ( TWO*RTE ) R = DLAPY2( SIGMA, ONE ) SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) ! C = ONE S = ZERO GAMMA = D( M ) - SIGMA P = GAMMA*GAMMA ! ! Inner loop ! DO 80 I = M - 1, L, -1 BB = E( I ) R = P + BB IF( I.NE.M-1 ) E( I+1 ) = S*R OLDC = C C = P / R S = BB / R OLDGAM = GAMMA ALPHA = D( I ) GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM D( I+1 ) = OLDGAM + ( ALPHA-GAMMA ) IF( C.NE.ZERO ) THEN P = ( GAMMA*GAMMA ) / C ELSE P = OLDC*BB END IF 80 CONTINUE ! E( L ) = S*P D( L ) = SIGMA + GAMMA GO TO 50 ! ! Eigenvalue found. ! 90 CONTINUE D( L ) = P ! L = L + 1 IF( L.LE.LEND ) GO TO 50 GO TO 150 ! ELSE ! ! QR Iteration ! ! Look for small superdiagonal element. ! 100 CONTINUE DO 110 M = L, LEND + 1, -1 IF( ABS( E( M-1 ) ).LE.EPS2*ABS( D( M )*D( M-1 ) ) ) GO TO 120 110 CONTINUE M = LEND ! 120 CONTINUE IF( M.GT.LEND ) E( M-1 ) = ZERO P = D( L ) IF( M.EQ.L ) GO TO 140 ! ! If remaining matrix is 2 by 2, use DLAE2 to compute its ! eigenvalues. ! IF( M.EQ.L-1 ) THEN RTE = SQRT( E( L-1 ) ) CALL DLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 ) D( L ) = RT1 D( L-1 ) = RT2 E( L-1 ) = ZERO L = L - 2 IF( L.GE.LEND ) GO TO 100 GO TO 150 END IF ! IF( JTOT.EQ.NMAXIT ) GO TO 150 JTOT = JTOT + 1 ! ! Form shift. ! RTE = SQRT( E( L-1 ) ) SIGMA = ( D( L-1 )-P ) / ( TWO*RTE ) R = DLAPY2( SIGMA, ONE ) SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) ! C = ONE S = ZERO GAMMA = D( M ) - SIGMA P = GAMMA*GAMMA ! ! Inner loop ! DO 130 I = M, L - 1 BB = E( I ) R = P + BB IF( I.NE.M ) E( I-1 ) = S*R OLDC = C C = P / R S = BB / R OLDGAM = GAMMA ALPHA = D( I+1 ) GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM D( I ) = OLDGAM + ( ALPHA-GAMMA ) IF( C.NE.ZERO ) THEN P = ( GAMMA*GAMMA ) / C ELSE P = OLDC*BB END IF 130 CONTINUE ! E( L-1 ) = S*P D( L ) = SIGMA + GAMMA GO TO 100 ! ! Eigenvalue found. ! 140 CONTINUE D( L ) = P ! L = L - 1 IF( L.GE.LEND ) GO TO 100 GO TO 150 ! END IF ! ! Undo scaling if necessary ! 150 CONTINUE IF( ISCALE.EQ.1 ) & CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,& D( LSV ), N, INFO ) IF( ISCALE.EQ.2 ) & CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,& D( LSV ), N, INFO ) ! ! Check for no convergence to an eigenvalue after a total ! of N*MAXIT iterations. ! IF( JTOT.LT.NMAXIT ) GO TO 10 DO 160 I = 1, N - 1 IF( E( I ).NE.ZERO ) INFO = INFO + 1 160 CONTINUE GO TO 180 ! ! Sort eigenvalues in increasing order. ! 170 CONTINUE CALL DLASRT( 'I', N, D, INFO ) ! 180 CONTINUE RETURN ! ! End of DSTERF ! END SUBROUTINE DSTERF ! != ! !> \brief \b DOPMTR ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DOPMTR + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, ! INFO ) ! ! .. Scalar Arguments .. ! CHARACTER SIDE, TRANS, UPLO ! INTEGER INFO, LDC, M, N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION AP( * ), C( LDC, * ), TAU( * ), WORK( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DOPMTR overwrites the general real M-by-N matrix C with !> !> SIDE = 'L' SIDE = 'R' !> TRANS = 'N': Q * C C * Q !> TRANS = 'T': Q**T * C C * Q**T !> !> where Q is a real orthogonal matrix of order nq, with nq = m if !> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of !> nq-1 elementary reflectors, as returned by DSPTRD using packed !> storage: !> !> if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); !> !> if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] SIDE !> \verbatim !> SIDE is CHARACTER*1 !> = 'L': apply Q or Q**T from the Left; !> = 'R': apply Q or Q**T from the Right. !> \endverbatim !> !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> = 'U': Upper triangular packed storage used in previous !> call to DSPTRD; !> = 'L': Lower triangular packed storage used in previous !> call to DSPTRD. !> \endverbatim !> !> \param[in] TRANS !> \verbatim !> TRANS is CHARACTER*1 !> = 'N': No transpose, apply Q; !> = 'T': Transpose, apply Q**T. !> \endverbatim !> !> \param[in] M !> \verbatim !> M is INTEGER !> The number of rows of the matrix C. M >= 0. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The number of columns of the matrix C. N >= 0. !> \endverbatim !> !> \param[in] AP !> \verbatim !> AP is DOUBLE PRECISION array, dimension !> (M*(M+1)/2) if SIDE = 'L' !> (N*(N+1)/2) if SIDE = 'R' !> The vectors which define the elementary reflectors, as !> returned by DSPTRD. AP is modified by the routine but !> restored on exit. !> \endverbatim !> !> \param[in] TAU !> \verbatim !> TAU is DOUBLE PRECISION array, dimension (M-1) if SIDE = 'L' !> or (N-1) if SIDE = 'R' !> TAU(i) must contain the scalar factor of the elementary !> reflector H(i), as returned by DSPTRD. !> \endverbatim !> !> \param[in,out] C !> \verbatim !> C is DOUBLE PRECISION array, dimension (LDC,N) !> On entry, the M-by-N matrix C. !> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. !> \endverbatim !> !> \param[in] LDC !> \verbatim !> LDC is INTEGER !> The leading dimension of the array C. LDC >= max(1,M). !> \endverbatim !> !> \param[out] WORK !> \verbatim !> WORK is DOUBLE PRECISION array, dimension !> (N) if SIDE = 'L' !> (M) if SIDE = 'R' !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument had an illegal value !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup doubleOTHERcomputational ! ! ===================================================================== SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,& INFO ) ! ! -- LAPACK computational routine (version 3.4.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. CHARACTER SIDE, TRANS, UPLO INTEGER INFO, LDC, M, N ! .. ! .. Array Arguments .. DOUBLE PRECISION AP( * ), C( LDC, * ), TAU( * ), WORK( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) ! .. ! .. Local Scalars .. LOGICAL FORWRD, LEFT, NOTRAN, UPPER INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ DOUBLE PRECISION AII ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. DLARFG exists ... !? EXTERNAL DLARF, XERBLA ! EXTERNAL DLARF ! .. ! .. Intrinsic Functions .. ! INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input arguments ! INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) UPPER = LSAME( UPLO, 'U' ) ! ! NQ is the order of Q ! IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -2 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DOPMTR', -INFO ) RETURN END IF ! ! Quick return if possible ! IF( M.EQ.0 .OR. N.EQ.0 ) RETURN ! IF( UPPER ) THEN ! ! Q was determined by a call to DSPTRD with UPLO = 'U' ! FORWRD = ( LEFT .AND. NOTRAN ) .OR.& ( .NOT.LEFT .AND. .NOT.NOTRAN ) ! IF( FORWRD ) THEN I1 = 1 I2 = NQ - 1 I3 = 1 II = 2 ELSE I1 = NQ - 1 I2 = 1 I3 = -1 II = NQ*( NQ+1 ) / 2 - 1 END IF ! IF( LEFT ) THEN NI = N ELSE MI = M END IF ! DO 10 I = I1, I2, I3 IF( LEFT ) THEN ! ! H(i) is applied to C(1:i,1:n) ! MI = I ELSE ! ! H(i) is applied to C(1:m,1:i) ! NI = I END IF ! ! Apply H(i) ! AII = AP( II ) AP( II ) = ONE CALL DLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAU( I ), C, LDC, WORK ) AP( II ) = AII ! IF( FORWRD ) THEN II = II + I + 2 ELSE II = II - I - 1 END IF 10 CONTINUE ELSE ! ! Q was determined by a call to DSPTRD with UPLO = 'L'. ! FORWRD = ( LEFT .AND. .NOT.NOTRAN ) .OR.& ( .NOT.LEFT .AND. NOTRAN ) ! IF( FORWRD ) THEN I1 = 1 I2 = NQ - 1 I3 = 1 II = 2 ELSE I1 = NQ - 1 I2 = 1 I3 = -1 II = NQ*( NQ+1 ) / 2 - 1 END IF ! IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF ! DO 20 I = I1, I2, I3 AII = AP( II ) AP( II ) = ONE IF( LEFT ) THEN ! ! H(i) is applied to C(i+1:m,1:n) ! MI = M - I IC = I + 1 ELSE ! ! H(i) is applied to C(1:m,i+1:n) ! NI = N - I JC = I + 1 END IF ! ! Apply H(i) ! CALL DLARF( SIDE, MI, NI, AP( II ), 1, TAU( I ),& C( IC, JC ), LDC, WORK ) AP( II ) = AII ! IF( FORWRD ) THEN II = II + NQ - I + 1 ELSE II = II - NQ + I - 2 END IF 20 CONTINUE END IF RETURN ! ! End of DOPMTR ! END SUBROUTINE DOPMTR ! != ! !> \brief \b DLARF applies an elementary reflector to a general rectangular matrix. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLARF + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) ! ! .. Scalar Arguments .. ! CHARACTER SIDE ! INTEGER INCV, LDC, M, N ! DOUBLE PRECISION TAU ! .. ! .. Array Arguments .. ! DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLARF applies a real elementary reflector H to a real m by n matrix !> C, from either the left or the right. H is represented in the form !> !> H = I - tau * v * v**T !> !> where tau is a real scalar and v is a real vector. !> !> If tau = 0, then H is taken to be the unit matrix. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] SIDE !> \verbatim !> SIDE is CHARACTER*1 !> = 'L': form H * C !> = 'R': form C * H !> \endverbatim !> !> \param[in] M !> \verbatim !> M is INTEGER !> The number of rows of the matrix C. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The number of columns of the matrix C. !> \endverbatim !> !> \param[in] V !> \verbatim !> V is DOUBLE PRECISION array, dimension !> (1 + (M-1)*abs(INCV)) if SIDE = 'L' !> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' !> The vector v in the representation of H. V is not used if !> TAU = 0. !> \endverbatim !> !> \param[in] INCV !> \verbatim !> INCV is INTEGER !> The increment between elements of v. INCV <> 0. !> \endverbatim !> !> \param[in] TAU !> \verbatim !> TAU is DOUBLE PRECISION !> The value tau in the representation of H. !> \endverbatim !> !> \param[in,out] C !> \verbatim !> C is DOUBLE PRECISION array, dimension (LDC,N) !> On entry, the m by n matrix C. !> On exit, C is overwritten by the matrix H * C if SIDE = 'L', !> or C * H if SIDE = 'R'. !> \endverbatim !> !> \param[in] LDC !> \verbatim !> LDC is INTEGER !> The leading dimension of the array C. LDC >= max(1,M). !> \endverbatim !> !> \param[out] WORK !> \verbatim !> WORK is DOUBLE PRECISION array, dimension !> (N) if SIDE = 'L' !> or (M) if SIDE = 'R' !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup doubleOTHERauxiliary ! ! ===================================================================== SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) ! ! -- LAPACK auxiliary routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. CHARACTER SIDE INTEGER INCV, LDC, M, N DOUBLE PRECISION TAU ! .. ! .. Array Arguments .. DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) ! .. ! .. Local Scalars .. LOGICAL APPLYLEFT INTEGER I, LASTV, LASTC ! .. ! .. External Subroutines .. ! EXTERNAL DGEMV, DGER ! EXTERNAL DGER ! .. ! .. External Functions .. ! LOGICAL LSAME ! INTEGER ILADLR, ILADLC ! EXTERNAL LSAME, ILADLR, ILADLC ! EXTERNAL ILADLR, ILADLC ! .. ! .. Executable Statements .. ! APPLYLEFT = LSAME( SIDE, 'L' ) LASTV = 0 LASTC = 0 IF( TAU.NE.ZERO ) THEN ! Set up variables for scanning V. LASTV begins pointing to the end ! of V. IF( APPLYLEFT ) THEN LASTV = M ELSE LASTV = N END IF IF( INCV.GT.0 ) THEN I = 1 + (LASTV-1) * INCV ELSE I = 1 END IF ! Look for the last non-zero row in V. DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) LASTV = LASTV - 1 I = I - INCV END DO IF( APPLYLEFT ) THEN ! Scan for the last non-zero column in C(1:lastv,:). LASTC = ILADLC(LASTV, N, C, LDC) ELSE ! Scan for the last non-zero row in C(:,1:lastv). LASTC = ILADLR(M, LASTV, C, LDC) END IF END IF ! Note that lastc.eq.0 renders the BLAS operations null; no special ! case is needed at this level. IF( APPLYLEFT ) THEN ! ! Form H * C ! IF( LASTV.GT.0 ) THEN ! ! w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) ! CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV,& ZERO, WORK, 1 ) ! ! C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T ! CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) END IF ELSE ! ! Form C * H ! IF( LASTV.GT.0 ) THEN ! ! w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) ! CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,& V, INCV, ZERO, WORK, 1 ) ! ! C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T ! CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) END IF END IF RETURN ! ! End of DLARF ! END SUBROUTINE DLARF ! != ! !> \brief DSPEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DSPEV + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO ) ! ! .. Scalar Arguments .. ! CHARACTER JOBZ, UPLO ! INTEGER INFO, LDZ, N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DSPEV computes all the eigenvalues and, optionally, eigenvectors of a !> real symmetric matrix A in packed storage. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] JOBZ !> \verbatim !> JOBZ is CHARACTER*1 !> = 'N': Compute eigenvalues only; !> = 'V': Compute eigenvalues and eigenvectors. !> \endverbatim !> !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> = 'U': Upper triangle of A is stored; !> = 'L': Lower triangle of A is stored. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The order of the matrix A. N >= 0. !> \endverbatim !> !> \param[in,out] AP !> \verbatim !> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) !> On entry, the upper or lower triangle of the symmetric matrix !> A, packed columnwise in a linear array. The j-th column of A !> is stored in the array AP as follows: !> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; !> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. !> !> On exit, AP is overwritten by values generated during the !> reduction to tridiagonal form. If UPLO = 'U', the diagonal !> and first superdiagonal of the tridiagonal matrix T overwrite !> the corresponding elements of A, and if UPLO = 'L', the !> diagonal and first subdiagonal of T overwrite the !> corresponding elements of A. !> \endverbatim !> !> \param[out] W !> \verbatim !> W is DOUBLE PRECISION array, dimension (N) !> If INFO = 0, the eigenvalues in ascending order. !> \endverbatim !> !> \param[out] Z !> \verbatim !> Z is DOUBLE PRECISION array, dimension (LDZ, N) !> If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal !> eigenvectors of the matrix A, with the i-th column of Z !> holding the eigenvector associated with W(i). !> If JOBZ = 'N', then Z is not referenced. !> \endverbatim !> !> \param[in] LDZ !> \verbatim !> LDZ is INTEGER !> The leading dimension of the array Z. LDZ >= 1, and if !> JOBZ = 'V', LDZ >= max(1,N). !> \endverbatim !> !> \param[out] WORK !> \verbatim !> WORK is DOUBLE PRECISION array, dimension (3*N) !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !> > 0: if INFO = i, the algorithm failed to converge; i !> off-diagonal elements of an intermediate tridiagonal !> form did not converge to zero. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup doubleOTHEReigen ! ! ===================================================================== SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO ) ! ! -- LAPACK driver routine (version 3.4.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. CHARACTER JOBZ, UPLO INTEGER INFO, LDZ, N ! .. ! .. Array Arguments .. DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) ! .. ! .. Local Scalars .. LOGICAL WANTZ INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,& SMLNUM ! .. ! .. External Functions .. ! LOGICAL LSAME ! DOUBLE PRECISION DLAMCH, DLANSP ! EXTERNAL LSAME, DLAMCH, DLANSP ! .. ! .. External Subroutines .. ! EXTERNAL DOPGTR, DSCAL, DSPTRD, DSTEQR, DSTERF, XERBLA ! EXTERNAL DOPGTR, DSTEQR ! .. ! .. Intrinsic Functions .. ! INTRINSIC SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! WANTZ = LSAME( JOBZ, 'V' ) ! INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -7 END IF ! IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSPEV ', -INFO ) RETURN END IF ! ! Quick return if possible ! IF( N.EQ.0 ) RETURN ! IF( N.EQ.1 ) THEN W( 1 ) = AP( 1 ) IF( WANTZ ) Z( 1, 1 ) = ONE RETURN END IF ! ! Get machine constants. ! SAFMIN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Precision' ) SMLNUM = SAFMIN / EPS BIGNUM = ONE / SMLNUM RMIN = SQRT( SMLNUM ) RMAX = SQRT( BIGNUM ) ! ! Scale matrix to allowable range, if necessary. ! ANRM = DLANSP( 'M', UPLO, N, AP, WORK ) ISCALE = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN ISCALE = 1 SIGMA = RMAX / ANRM END IF IF( ISCALE.EQ.1 ) THEN CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 ) END IF ! ! Call DSPTRD to reduce symmetric packed matrix to tridiagonal form. ! INDE = 1 INDTAU = INDE + N CALL DSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO ) ! ! For eigenvalues only, call DSTERF. For eigenvectors, first call ! DOPGTR to generate the orthogonal matrix, then call DSTEQR. ! IF( .NOT.WANTZ ) THEN CALL DSTERF( N, W, WORK( INDE ), INFO ) ELSE INDWRK = INDTAU + N CALL DOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,& WORK( INDWRK ), IINFO ) CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDTAU ),& INFO ) END IF ! ! If matrix was scaled, then rescale eigenvalues appropriately. ! IF( ISCALE.EQ.1 ) THEN IF( INFO.EQ.0 ) THEN IMAX = N ELSE IMAX = INFO - 1 END IF CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) END IF ! RETURN ! ! End of DSPEV ! END SUBROUTINE DSPEV ! != ! !> \brief \b DSTEDC ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DSTEDC + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, ! LIWORK, INFO ) ! ! .. Scalar Arguments .. ! CHARACTER COMPZ ! INTEGER INFO, LDZ, LIWORK, LWORK, N ! .. ! .. Array Arguments .. ! INTEGER IWORK( * ) ! DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DSTEDC computes all eigenvalues and, optionally, eigenvectors of a !> symmetric tridiagonal matrix using the divide and conquer method. !> The eigenvectors of a full or band real symmetric matrix can also be !> found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this !> matrix to tridiagonal form. !> !> This code makes very mild assumptions about floating point !> arithmetic. It will work on machines with a guard digit in !> add/subtract, or on those binary machines without guard digits !> which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. !> It could conceivably fail on hexadecimal or decimal machines !> without guard digits, but we know of none. See DLAED3 for details. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] COMPZ !> \verbatim !> COMPZ is CHARACTER*1 !> = 'N': Compute eigenvalues only. !> = 'I': Compute eigenvectors of tridiagonal matrix also. !> = 'V': Compute eigenvectors of original dense symmetric !> matrix also. On entry, Z contains the orthogonal !> matrix used to reduce the original matrix to !> tridiagonal form. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The dimension of the symmetric tridiagonal matrix. N >= 0. !> \endverbatim !> !> \param[in,out] D !> \verbatim !> D is DOUBLE PRECISION array, dimension (N) !> On entry, the diagonal elements of the tridiagonal matrix. !> On exit, if INFO = 0, the eigenvalues in ascending order. !> \endverbatim !> !> \param[in,out] E !> \verbatim !> E is DOUBLE PRECISION array, dimension (N-1) !> On entry, the subdiagonal elements of the tridiagonal matrix. !> On exit, E has been destroyed. !> \endverbatim !> !> \param[in,out] Z !> \verbatim !> Z is DOUBLE PRECISION array, dimension (LDZ,N) !> On entry, if COMPZ = 'V', then Z contains the orthogonal !> matrix used in the reduction to tridiagonal form. !> On exit, if INFO = 0, then if COMPZ = 'V', Z contains the !> orthonormal eigenvectors of the original symmetric matrix, !> and if COMPZ = 'I', Z contains the orthonormal eigenvectors !> of the symmetric tridiagonal matrix. !> If COMPZ = 'N', then Z is not referenced. !> \endverbatim !> !> \param[in] LDZ !> \verbatim !> LDZ is INTEGER !> The leading dimension of the array Z. LDZ >= 1. !> If eigenvectors are desired, then LDZ >= max(1,N). !> \endverbatim !> !> \param[out] WORK !> \verbatim !> WORK is DOUBLE PRECISION array, !> dimension (LWORK) !> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. !> \endverbatim !> !> \param[in] LWORK !> \verbatim !> LWORK is INTEGER !> The dimension of the array WORK. !> If COMPZ = 'N' or N <= 1 then LWORK must be at least 1. !> If COMPZ = 'V' and N > 1 then LWORK must be at least !> ( 1 + 3*N + 2*N*lg N + 4*N**2 ), !> where lg( N ) = smallest integer k such !> that 2**k >= N. !> If COMPZ = 'I' and N > 1 then LWORK must be at least !> ( 1 + 4*N + N**2 ). !> Note that for COMPZ = 'I' or 'V', then if N is less than or !> equal to the minimum divide size, usually 25, then LWORK need !> only be max(1,2*(N-1)). !> !> If LWORK = -1, then a workspace query is assumed; the routine !> only calculates the optimal size of the WORK array, returns !> this value as the first entry of the WORK array, and no error !> message related to LWORK is issued by XERBLA. !> \endverbatim !> !> \param[out] IWORK !> \verbatim !> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) !> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. !> \endverbatim !> !> \param[in] LIWORK !> \verbatim !> LIWORK is INTEGER !> The dimension of the array IWORK. !> If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1. !> If COMPZ = 'V' and N > 1 then LIWORK must be at least !> ( 6 + 6*N + 5*N*lg N ). !> If COMPZ = 'I' and N > 1 then LIWORK must be at least !> ( 3 + 5*N ). !> Note that for COMPZ = 'I' or 'V', then if N is less than or !> equal to the minimum divide size, usually 25, then LIWORK !> need only be 1. !> !> If LIWORK = -1, then a workspace query is assumed; the !> routine only calculates the optimal size of the IWORK array, !> returns this value as the first entry of the IWORK array, and !> no error message related to LIWORK is issued by XERBLA. !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !> > 0: The algorithm failed to compute an eigenvalue while !> working on the submatrix lying in rows and columns !> INFO/(N+1) through mod(INFO,N+1). !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2015 ! !> \ingroup auxOTHERcomputational ! !> \par Contributors: ! ================== !> !> Jeff Rutter, Computer Science Division, University of California !> at Berkeley, USA \n !> Modified by Francoise Tisseur, University of Tennessee !> ! ===================================================================== SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK,& LIWORK, INFO ) ! ! -- LAPACK computational routine (version 3.6.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2015 ! ! .. Scalar Arguments .. CHARACTER COMPZ INTEGER INFO, LDZ, LIWORK, LWORK, N ! .. ! .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) ! .. ! .. Local Scalars .. LOGICAL LQUERY INTEGER FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN,& LWMIN, M, SMLSIZ, START, STOREZ, STRTRW DOUBLE PRECISION EPS, ORGNRM, P, TINY ! .. ! .. External Functions .. ! LOGICAL LSAME ! INTEGER ILAENV ! DOUBLE PRECISION DLANST ! EXTERNAL LSAME, ILAENV, DLAMCH, DLANST ! EXTERNAL DLANST ! .. ! .. External Subroutines .. ! EXTERNAL DGEMM, DLACPY, DLAED0, DLASCL, DLASET, DLASRT,& ! DSTEQR, DSTERF, DSWAP, XERBLA ! EXTERNAL DSTEQR ! .. ! .. Intrinsic Functions .. ! INTRINSIC ABS, DBLE, INT, LOG, MAX, MOD, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! INFO = 0 LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) ! IF( LSAME( COMPZ, 'N' ) ) THEN ICOMPZ = 0 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ICOMPZ = 2 ELSE ICOMPZ = -1 END IF IF( ICOMPZ.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( ( LDZ.LT.1 ) .OR.& ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, N ) ) ) THEN INFO = -6 END IF ! IF( INFO.EQ.0 ) THEN ! ! Compute the workspace requirements ! SMLSIZ = ILAENV( 9, 'DSTEDC', ' ', 0, 0, 0, 0 ) IF( N.LE.1 .OR. ICOMPZ.EQ.0 ) THEN LIWMIN = 1 LWMIN = 1 ELSE IF( N.LE.SMLSIZ ) THEN LIWMIN = 1 LWMIN = 2*( N - 1 ) ELSE LGN = INT( LOG( DBLE( N ) )/LOG( TWO ) ) IF( 2**LGN.LT.N ) LGN = LGN + 1 IF( 2**LGN.LT.N ) LGN = LGN + 1 IF( ICOMPZ.EQ.1 ) THEN LWMIN = 1 + 3*N + 2*N*LGN + 4*N**2 LIWMIN = 6 + 6*N + 5*N*LGN ELSE IF( ICOMPZ.EQ.2 ) THEN LWMIN = 1 + 4*N + N**2 LIWMIN = 3 + 5*N END IF END IF WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN ! IF( LWORK.LT.LWMIN .AND. .NOT. LQUERY ) THEN INFO = -8 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT. LQUERY ) THEN INFO = -10 END IF END IF ! IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSTEDC', -INFO ) RETURN ELSE IF (LQUERY) THEN RETURN END IF ! ! Quick return if possible ! IF( N.EQ.0 ) RETURN IF( N.EQ.1 ) THEN IF( ICOMPZ.NE.0 ) Z( 1, 1 ) = ONE RETURN END IF ! ! If the following conditional clause is removed, then the routine ! will use the Divide and Conquer routine to compute only the ! eigenvalues, which requires (3N + 3N**2) real workspace and ! (2 + 5N + 2N lg(N)) integer workspace. ! Since on many architectures DSTERF is much faster than any other ! algorithm for finding eigenvalues only, it is used here ! as the default. If the conditional clause is removed, then ! information on the size of workspace needs to be changed. ! ! If COMPZ = 'N', use DSTERF to compute the eigenvalues. ! IF( ICOMPZ.EQ.0 ) THEN CALL DSTERF( N, D, E, INFO ) GO TO 50 END IF ! ! If N is smaller than the minimum divide size (SMLSIZ+1), then ! solve the problem with another solver. ! IF( N.LE.SMLSIZ ) THEN ! CALL DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) ! ELSE ! ! If COMPZ = 'V', the Z matrix must be stored elsewhere for later ! use. ! IF( ICOMPZ.EQ.1 ) THEN STOREZ = 1 + N*N ELSE STOREZ = 1 END IF ! IF( ICOMPZ.EQ.2 ) THEN CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) END IF ! ! Scale. ! ORGNRM = DLANST( 'M', N, D, E ) IF( ORGNRM.EQ.ZERO ) GO TO 50 ! EPS = DLAMCH( 'Epsilon' ) ! START = 1 ! ! while ( START <= N ) ! 10 CONTINUE IF( START.LE.N ) THEN ! ! Let FINISH be the position of the next subdiagonal entry ! such that E( FINISH ) <= TINY or FINISH = N if no such ! subdiagonal exists. The matrix identified by the elements ! between START and FINISH constitutes an independent ! sub-problem. ! FINISH = START 20 CONTINUE IF( FINISH.LT.N ) THEN TINY = EPS*SQRT( ABS( D( FINISH ) ) )*& SQRT( ABS( D( FINISH+1 ) ) ) IF( ABS( E( FINISH ) ).GT.TINY ) THEN FINISH = FINISH + 1 GO TO 20 END IF END IF ! ! (Sub) Problem determined. Compute its size and solve it. ! M = FINISH - START + 1 IF( M.EQ.1 ) THEN START = FINISH + 1 GO TO 10 END IF IF( M.GT.SMLSIZ ) THEN ! ! Scale. ! ORGNRM = DLANST( 'M', M, D( START ), E( START ) ) CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M,INFO) CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ),M-1, INFO ) ! IF( ICOMPZ.EQ.1 ) THEN STRTRW = 1 ELSE STRTRW = START END IF CALL DLAED0( ICOMPZ, N, M, D( START ), E( START ),& Z( STRTRW, START ), LDZ, WORK( 1 ), N,& WORK( STOREZ ), IWORK, INFO ) IF( INFO.NE.0 ) THEN INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) +& MOD( INFO, ( M+1 ) ) + START - 1 GO TO 50 END IF ! ! Scale back. ! CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M,INFO) ! ELSE IF( ICOMPZ.EQ.1 ) THEN ! ! Since QR won't update a Z matrix which is larger than ! the length of D, we must solve the sub-problem in a ! workspace and then multiply back into Z. ! CALL DSTEQR( 'I', M, D( START ), E( START ), WORK, M,& WORK( M*M+1 ), INFO ) CALL DLACPY( 'A', N, M, Z( 1, START ), LDZ,& WORK( STOREZ ), N ) CALL DGEMM( 'N', 'N', N, M, M, ONE,& WORK( STOREZ ), N, WORK, M, ZERO,& Z( 1, START ), LDZ ) ELSE IF( ICOMPZ.EQ.2 ) THEN CALL DSTEQR( 'I', M, D( START ), E( START ),& Z( START, START ), LDZ, WORK, INFO ) ELSE CALL DSTERF( M, D( START ), E( START ), INFO ) END IF IF( INFO.NE.0 ) THEN INFO = START*( N+1 ) + FINISH GO TO 50 END IF END IF ! START = FINISH + 1 GO TO 10 END IF ! ! endwhile ! IF( ICOMPZ.EQ.0 ) THEN ! ! Use Quick Sort ! CALL DLASRT( 'I', N, D, INFO ) ! ELSE ! ! Use Selection Sort to minimize swaps of eigenvectors ! DO 40 II = 2, N I = II - 1 K = I P = D( I ) DO 30 J = II, N IF( D( J ).LT.P ) THEN K = J P = D( J ) END IF 30 CONTINUE IF( K.NE.I ) THEN D( K ) = D( I ) D( I ) = P CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) END IF 40 CONTINUE END IF END IF ! 50 CONTINUE WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN ! RETURN ! ! End of DSTEDC ! END SUBROUTINE DSTEDC ! != ! !> \brief \b DLANST returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric tridiagonal matrix. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLANST + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) ! ! .. Scalar Arguments .. ! CHARACTER NORM ! INTEGER N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION D( * ), E( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLANST returns the value of the one norm, or the Frobenius norm, or !> the infinity norm, or the element of largest absolute value of a !> real symmetric tridiagonal matrix A. !> \endverbatim !> !> \return DLANST !> \verbatim !> !> DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm' !> ( !> ( norm1(A), NORM = '1', 'O' or 'o' !> ( !> ( normI(A), NORM = 'I' or 'i' !> ( !> ( normF(A), NORM = 'F', 'f', 'E' or 'e' !> !> where norm1 denotes the one norm of a matrix (maximum column sum), !> normI denotes the infinity norm of a matrix (maximum row sum) and !> normF denotes the Frobenius norm of a matrix (square root of sum of !> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] NORM !> \verbatim !> NORM is CHARACTER*1 !> Specifies the value to be returned in DLANST as described !> above. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The order of the matrix A. N >= 0. When N = 0, DLANST is !> set to zero. !> \endverbatim !> !> \param[in] D !> \verbatim !> D is DOUBLE PRECISION array, dimension (N) !> The diagonal elements of A. !> \endverbatim !> !> \param[in] E !> \verbatim !> E is DOUBLE PRECISION array, dimension (N-1) !> The (n-1) sub-diagonal or super-diagonal elements of A. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup auxOTHERauxiliary ! ! ===================================================================== DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) ! ! -- LAPACK auxiliary routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. CHARACTER NORM INTEGER N ! .. ! .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) ! .. ! .. Local Scalars .. INTEGER I DOUBLE PRECISION ANORM, SCALE, SUM ! .. ! .. External Functions .. ! LOGICAL LSAME, DISNAN ! EXTERNAL LSAME, DISNAN ! .. ! .. External Subroutines .. ! EXTERNAL DLASSQ ! .. ! .. Intrinsic Functions .. ! INTRINSIC ABS, SQRT ! .. ! .. Executable Statements .. ! IF( N.LE.0 ) THEN ANORM = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN ! ! Find max(abs(A(i,j))). ! ANORM = ABS( D( N ) ) DO 10 I = 1, N - 1 SUM = ABS( D( I ) ) IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM SUM = ABS( E( I ) ) IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM 10 CONTINUE ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR.& LSAME( NORM, 'I' ) ) THEN ! ! Find norm1(A). ! IF( N.EQ.1 ) THEN ANORM = ABS( D( 1 ) ) ELSE ANORM = ABS( D( 1 ) )+ABS( E( 1 ) ) SUM = ABS( E( N-1 ) )+ABS( D( N ) ) IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM DO 20 I = 2, N - 1 SUM = ABS( D( I ) )+ABS( E( I ) )+ABS( E( I-1 ) ) IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM 20 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN ! ! Find normF(A). ! SCALE = ZERO SUM = ONE IF( N.GT.1 ) THEN CALL DLASSQ( N-1, E, 1, SCALE, SUM ) SUM = 2*SUM END IF CALL DLASSQ( N, D, 1, SCALE, SUM ) ANORM = SCALE*SQRT( SUM ) END IF ! DLANST = ANORM RETURN ! ! End of DLANST ! END FUNCTION DLANST ! != ! !> \brief \b DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLASCL + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) ! ! .. Scalar Arguments .. ! CHARACTER TYPE ! INTEGER INFO, KL, KU, LDA, M, N ! DOUBLE PRECISION CFROM, CTO ! .. ! .. Array Arguments .. ! DOUBLE PRECISION A( LDA, * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLASCL multiplies the M by N real matrix A by the real scalar !> CTO/CFROM. This is done without over/underflow as long as the final !> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that !> A may be full, upper triangular, lower triangular, upper Hessenberg, !> or banded. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] TYPE !> \verbatim !> TYPE is CHARACTER*1 !> TYPE indices the storage type of the input matrix. !> = 'G': A is a full matrix. !> = 'L': A is a lower triangular matrix. !> = 'U': A is an upper triangular matrix. !> = 'H': A is an upper Hessenberg matrix. !> = 'B': A is a symmetric band matrix with lower bandwidth KL !> and upper bandwidth KU and with the only the lower !> half stored. !> = 'Q': A is a symmetric band matrix with lower bandwidth KL !> and upper bandwidth KU and with the only the upper !> half stored. !> = 'Z': A is a band matrix with lower bandwidth KL and upper !> bandwidth KU. See DGBTRF for storage details. !> \endverbatim !> !> \param[in] KL !> \verbatim !> KL is INTEGER !> The lower bandwidth of A. Referenced only if TYPE = 'B', !> 'Q' or 'Z'. !> \endverbatim !> !> \param[in] KU !> \verbatim !> KU is INTEGER !> The upper bandwidth of A. Referenced only if TYPE = 'B', !> 'Q' or 'Z'. !> \endverbatim !> !> \param[in] CFROM !> \verbatim !> CFROM is DOUBLE PRECISION !> \endverbatim !> !> \param[in] CTO !> \verbatim !> CTO is DOUBLE PRECISION !> !> The matrix A is multiplied by CTO/CFROM. A(I,J) is computed !> without over/underflow if the final result CTO*A(I,J)/CFROM !> can be represented without over/underflow. CFROM must be !> nonzero. !> \endverbatim !> !> \param[in] M !> \verbatim !> M is INTEGER !> The number of rows of the matrix A. M >= 0. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The number of columns of the matrix A. N >= 0. !> \endverbatim !> !> \param[in,out] A !> \verbatim !> A is DOUBLE PRECISION array, dimension (LDA,N) !> The matrix to be multiplied by CTO/CFROM. See TYPE for the !> storage type. !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,M). !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> 0 - successful exit !> <0 - if INFO = -i, the i-th argument had an illegal value. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup auxOTHERauxiliary ! ! ===================================================================== SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) ! ! -- LAPACK auxiliary routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. CHARACTER TYPE INTEGER INFO, KL, KU, LDA, M, N DOUBLE PRECISION CFROM, CTO ! .. ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) ! .. ! .. Local Scalars .. LOGICAL DONE INTEGER I, ITYPE, J, K1, K2, K3, K4 DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM ! .. ! .. External Functions .. ! LOGICAL LSAME, DISNAN ! DOUBLE PRECISION DLAMCH ! EXTERNAL LSAME, DLAMCH, DISNAN ! .. ! .. Intrinsic Functions .. ! INTRINSIC ABS, MAX, MIN ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Executable Statements .. ! ! Test the input arguments ! INFO = 0 ! IF( LSAME( TYPE, 'G' ) ) THEN ITYPE = 0 ELSE IF( LSAME( TYPE, 'L' ) ) THEN ITYPE = 1 ELSE IF( LSAME( TYPE, 'U' ) ) THEN ITYPE = 2 ELSE IF( LSAME( TYPE, 'H' ) ) THEN ITYPE = 3 ELSE IF( LSAME( TYPE, 'B' ) ) THEN ITYPE = 4 ELSE IF( LSAME( TYPE, 'Q' ) ) THEN ITYPE = 5 ELSE IF( LSAME( TYPE, 'Z' ) ) THEN ITYPE = 6 ELSE ITYPE = -1 END IF ! IF( ITYPE.EQ.-1 ) THEN INFO = -1 ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN INFO = -4 ELSE IF( DISNAN(CTO) ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -6 ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.& ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN INFO = -7 ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN INFO = -9 ELSE IF( ITYPE.GE.4 ) THEN IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN INFO = -2 ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.& ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )& THEN INFO = -3 ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.& ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.& ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN INFO = -9 END IF END IF ! IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLASCL', -INFO ) RETURN END IF ! ! Quick return if possible ! IF( N.EQ.0 .OR. M.EQ.0 ) RETURN ! ! Get machine parameters ! SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM ! CFROMC = CFROM CTOC = CTO ! 10 CONTINUE CFROM1 = CFROMC*SMLNUM IF( CFROM1.EQ.CFROMC ) THEN ! CFROMC is an inf. Multiply by a correctly signed zero for ! finite CTOC, or a NaN if CTOC is infinite. MUL = CTOC / CFROMC DONE = .TRUE. CTO1 = CTOC ELSE CTO1 = CTOC / BIGNUM IF( CTO1.EQ.CTOC ) THEN ! CTOC is either 0 or an inf. In both cases, CTOC itself ! serves as the correct multiplication factor. MUL = CTOC DONE = .TRUE. CFROMC = ONE ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN MUL = SMLNUM DONE = .FALSE. CFROMC = CFROM1 ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN MUL = BIGNUM DONE = .FALSE. CTOC = CTO1 ELSE MUL = CTOC / CFROMC DONE = .TRUE. END IF END IF ! IF( ITYPE.EQ.0 ) THEN ! ! Full matrix ! DO 30 J = 1, N DO 20 I = 1, M A( I, J ) = A( I, J )*MUL 20 CONTINUE 30 CONTINUE ! ELSE IF( ITYPE.EQ.1 ) THEN ! ! Lower triangular matrix ! DO 50 J = 1, N DO 40 I = J, M A( I, J ) = A( I, J )*MUL 40 CONTINUE 50 CONTINUE ! ELSE IF( ITYPE.EQ.2 ) THEN ! ! Upper triangular matrix ! DO 70 J = 1, N DO 60 I = 1, MIN( J, M ) A( I, J ) = A( I, J )*MUL 60 CONTINUE 70 CONTINUE ! ELSE IF( ITYPE.EQ.3 ) THEN ! ! Upper Hessenberg matrix ! DO 90 J = 1, N DO 80 I = 1, MIN( J+1, M ) A( I, J ) = A( I, J )*MUL 80 CONTINUE 90 CONTINUE ! ELSE IF( ITYPE.EQ.4 ) THEN ! ! Lower half of a symmetric band matrix ! K3 = KL + 1 K4 = N + 1 DO 110 J = 1, N DO 100 I = 1, MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 100 CONTINUE 110 CONTINUE ! ELSE IF( ITYPE.EQ.5 ) THEN ! ! Upper half of a symmetric band matrix ! K1 = KU + 2 K3 = KU + 1 DO 130 J = 1, N DO 120 I = MAX( K1-J, 1 ), K3 A( I, J ) = A( I, J )*MUL 120 CONTINUE 130 CONTINUE ! ELSE IF( ITYPE.EQ.6 ) THEN ! ! Band matrix ! K1 = KL + KU + 2 K2 = KL + 1 K3 = 2*KL + KU + 1 K4 = KL + KU + 1 + M DO 150 J = 1, N DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 140 CONTINUE 150 CONTINUE ! END IF ! IF( .NOT.DONE ) GO TO 10 ! RETURN ! ! End of DLASCL ! END SUBROUTINE DLASCL ! != ! !> \brief \b DSTEQR ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DSTEQR + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) ! ! .. Scalar Arguments .. ! CHARACTER COMPZ ! INTEGER INFO, LDZ, N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DSTEQR computes all eigenvalues and, optionally, eigenvectors of a !> symmetric tridiagonal matrix using the implicit QL or QR method. !> The eigenvectors of a full or band symmetric matrix can also be found !> if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to !> tridiagonal form. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] COMPZ !> \verbatim !> COMPZ is CHARACTER*1 !> = 'N': Compute eigenvalues only. !> = 'V': Compute eigenvalues and eigenvectors of the original !> symmetric matrix. On entry, Z must contain the !> orthogonal matrix used to reduce the original matrix !> to tridiagonal form. !> = 'I': Compute eigenvalues and eigenvectors of the !> tridiagonal matrix. Z is initialized to the identity !> matrix. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The order of the matrix. N >= 0. !> \endverbatim !> !> \param[in,out] D !> \verbatim !> D is DOUBLE PRECISION array, dimension (N) !> On entry, the diagonal elements of the tridiagonal matrix. !> On exit, if INFO = 0, the eigenvalues in ascending order. !> \endverbatim !> !> \param[in,out] E !> \verbatim !> E is DOUBLE PRECISION array, dimension (N-1) !> On entry, the (n-1) subdiagonal elements of the tridiagonal !> matrix. !> On exit, E has been destroyed. !> \endverbatim !> !> \param[in,out] Z !> \verbatim !> Z is DOUBLE PRECISION array, dimension (LDZ, N) !> On entry, if COMPZ = 'V', then Z contains the orthogonal !> matrix used in the reduction to tridiagonal form. !> On exit, if INFO = 0, then if COMPZ = 'V', Z contains the !> orthonormal eigenvectors of the original symmetric matrix, !> and if COMPZ = 'I', Z contains the orthonormal eigenvectors !> of the symmetric tridiagonal matrix. !> If COMPZ = 'N', then Z is not referenced. !> \endverbatim !> !> \param[in] LDZ !> \verbatim !> LDZ is INTEGER !> The leading dimension of the array Z. LDZ >= 1, and if !> eigenvectors are desired, then LDZ >= max(1,N). !> \endverbatim !> !> \param[out] WORK !> \verbatim !> WORK is DOUBLE PRECISION array, dimension (max(1,2*N-2)) !> If COMPZ = 'N', then WORK is not referenced. !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument had an illegal value !> > 0: the algorithm has failed to find all the eigenvalues in !> a total of 30*N iterations; if INFO = i, then i !> elements of E have not converged to zero; on exit, D !> and E contain the elements of a symmetric tridiagonal !> matrix which is orthogonally similar to the original !> matrix. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup auxOTHERcomputational ! ! ===================================================================== SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) ! ! -- LAPACK computational routine (version 3.4.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. CHARACTER COMPZ INTEGER INFO, LDZ, N ! .. ! .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,& THREE = 3.0D0 ) INTEGER MAXIT PARAMETER ( MAXIT = 30 ) ! .. ! .. Local Scalars .. INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND,& LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1,& NM1, NMAXIT DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,& S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST ! .. ! .. External Functions .. ! LOGICAL LSAME ! DOUBLE PRECISION DLAPY2 ! EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2 ! .. ! .. External Subroutines .. ! EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASET, DLASR, ! $ DLASRT, DSWAP, XERBLA ! EXTERNAL DLARTG ! .. ! .. Intrinsic Functions .. ! INTRINSIC ABS, MAX, SIGN, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! INFO = 0 ! IF( LSAME( COMPZ, 'N' ) ) THEN ICOMPZ = 0 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ICOMPZ = 2 ELSE ICOMPZ = -1 END IF IF( ICOMPZ.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,& N ) ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSTEQR', -INFO ) RETURN END IF ! ! Quick return if possible ! IF( N.EQ.0 ) RETURN ! IF( N.EQ.1 ) THEN IF( ICOMPZ.EQ.2 ) Z( 1, 1 ) = ONE RETURN END IF ! ! Determine the unit roundoff and over/underflow thresholds. ! EPS = DLAMCH( 'E' ) EPS2 = EPS**2 SAFMIN = DLAMCH( 'S' ) SAFMAX = ONE / SAFMIN SSFMAX = SQRT( SAFMAX ) / THREE SSFMIN = SQRT( SAFMIN ) / EPS2 ! ! Compute the eigenvalues and eigenvectors of the tridiagonal ! matrix. ! IF( ICOMPZ.EQ.2 )& CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) ! NMAXIT = N*MAXIT JTOT = 0 ! ! Determine where the matrix splits and choose QL or QR iteration ! for each block, according to whether top or bottom diagonal ! element is smaller. ! L1 = 1 NM1 = N - 1 ! 10 CONTINUE IF( L1.GT.N ) GO TO 160 IF( L1.GT.1 ) E( L1-1 ) = ZERO IF( L1.LE.NM1 ) THEN DO 20 M = L1, NM1 TST = ABS( E( M ) ) IF( TST.EQ.ZERO ) GO TO 30 IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+& 1 ) ) ) )*EPS ) THEN E( M ) = ZERO GO TO 30 END IF 20 CONTINUE END IF M = N ! 30 CONTINUE L = L1 LSV = L LEND = M LENDSV = LEND L1 = M + 1 IF( LEND.EQ.L ) GO TO 10 ! ! Scale submatrix in rows and columns L to LEND ! ANORM = DLANST( 'M', LEND-L+1, D( L ), E( L ) ) ISCALE = 0 IF( ANORM.EQ.ZERO ) GO TO 10 IF( ANORM.GT.SSFMAX ) THEN ISCALE = 1 CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, INFO ) CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, INFO ) ELSE IF( ANORM.LT.SSFMIN ) THEN ISCALE = 2 CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, INFO ) CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, INFO ) END IF ! ! Choose between QL and QR iteration ! IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN LEND = LSV L = LENDSV END IF ! IF( LEND.GT.L ) THEN ! ! QL Iteration ! ! Look for small subdiagonal element. ! 40 CONTINUE IF( L.NE.LEND ) THEN LENDM1 = LEND - 1 DO 50 M = L, LENDM1 TST = ABS( E( M ) )**2 IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+SAFMIN )GO TO 60 50 CONTINUE END IF ! M = LEND ! 60 CONTINUE IF( M.LT.LEND ) E( M ) = ZERO P = D( L ) IF( M.EQ.L ) GO TO 80 ! ! If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 ! to compute its eigensystem. ! IF( M.EQ.L+1 ) THEN IF( ICOMPZ.GT.0 ) THEN CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) WORK( L ) = C WORK( N-1+L ) = S CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ),& WORK( N-1+L ), Z( 1, L ), LDZ ) ELSE CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) END IF D( L ) = RT1 D( L+1 ) = RT2 E( L ) = ZERO L = L + 2 IF( L.LE.LEND ) GO TO 40 GO TO 140 END IF ! IF( JTOT.EQ.NMAXIT ) GO TO 140 JTOT = JTOT + 1 ! ! Form shift. ! G = ( D( L+1 )-P ) / ( TWO*E( L ) ) R = DLAPY2( G, ONE ) G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) ! S = ONE C = ONE P = ZERO ! ! Inner loop ! MM1 = M - 1 DO 70 I = MM1, L, -1 F = S*E( I ) B = C*E( I ) CALL DLARTG( G, F, C, S, R ) IF( I.NE.M-1 ) E( I+1 ) = R G = D( I+1 ) - P R = ( D( I )-G )*S + TWO*C*B P = S*R D( I+1 ) = G + P G = C*R - B ! ! If eigenvectors are desired, then save rotations. ! IF( ICOMPZ.GT.0 ) THEN WORK( I ) = C WORK( N-1+I ) = -S END IF ! 70 CONTINUE ! ! If eigenvectors are desired, then apply saved rotations. ! IF( ICOMPZ.GT.0 ) THEN MM = M - L + 1 CALL DLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ),& Z( 1, L ), LDZ ) END IF ! D( L ) = D( L ) - P E( L ) = G GO TO 40 ! ! Eigenvalue found. ! 80 CONTINUE D( L ) = P ! L = L + 1 IF( L.LE.LEND ) GO TO 40 GO TO 140 ! ELSE ! ! QR Iteration ! ! Look for small superdiagonal element. ! 90 CONTINUE IF( L.NE.LEND ) THEN LENDP1 = LEND + 1 DO 100 M = L, LENDP1, -1 TST = ABS( E( M-1 ) )**2 IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+& SAFMIN )GO TO 110 100 CONTINUE END IF ! M = LEND ! 110 CONTINUE IF( M.GT.LEND ) E( M-1 ) = ZERO P = D( L ) IF( M.EQ.L ) GO TO 130 ! ! If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 ! to compute its eigensystem. ! IF( M.EQ.L-1 ) THEN IF( ICOMPZ.GT.0 ) THEN CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) WORK( M ) = C WORK( N-1+M ) = S CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ), & WORK( N-1+M ), Z( 1, L-1 ), LDZ ) ELSE CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) END IF D( L-1 ) = RT1 D( L ) = RT2 E( L-1 ) = ZERO L = L - 2 IF( L.GE.LEND ) GO TO 90 GO TO 140 END IF ! IF( JTOT.EQ.NMAXIT ) GO TO 140 JTOT = JTOT + 1 ! ! Form shift. ! G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) R = DLAPY2( G, ONE ) G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) ! S = ONE C = ONE P = ZERO ! ! Inner loop ! LM1 = L - 1 DO 120 I = M, LM1 F = S*E( I ) B = C*E( I ) CALL DLARTG( G, F, C, S, R ) IF( I.NE.M ) E( I-1 ) = R G = D( I ) - P R = ( D( I+1 )-G )*S + TWO*C*B P = S*R D( I ) = G + P G = C*R - B ! ! If eigenvectors are desired, then save rotations. ! IF( ICOMPZ.GT.0 ) THEN WORK( I ) = C WORK( N-1+I ) = S END IF ! 120 CONTINUE ! ! If eigenvectors are desired, then apply saved rotations. ! IF( ICOMPZ.GT.0 ) THEN MM = L - M + 1 CALL DLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ),& Z( 1, M ), LDZ ) END IF ! D( L ) = D( L ) - P E( LM1 ) = G GO TO 90 ! ! Eigenvalue found. ! 130 CONTINUE D( L ) = P ! L = L - 1 IF( L.GE.LEND ) GO TO 90 GO TO 140 ! END IF ! ! Undo scaling if necessary ! 140 CONTINUE IF( ISCALE.EQ.1 ) THEN CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,& D( LSV ), N, INFO ) CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ),& N, INFO ) ELSE IF( ISCALE.EQ.2 ) THEN CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,& D( LSV ), N, INFO ) CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ),& N, INFO ) END IF ! ! Check for no convergence to an eigenvalue after a total ! of N*MAXIT iterations. ! IF( JTOT.LT.NMAXIT ) GO TO 10 DO 150 I = 1, N - 1 IF( E( I ).NE.ZERO ) INFO = INFO + 1 150 CONTINUE GO TO 190 ! ! Order eigenvalues and eigenvectors. ! 160 CONTINUE IF( ICOMPZ.EQ.0 ) THEN ! ! Use Quick Sort ! CALL DLASRT( 'I', N, D, INFO ) ! ELSE ! ! Use Selection Sort to minimize swaps of eigenvectors ! DO 180 II = 2, N I = II - 1 K = I P = D( I ) DO 170 J = II, N IF( D( J ).LT.P ) THEN K = J P = D( J ) END IF 170 CONTINUE IF( K.NE.I ) THEN D( K ) = D( I ) D( I ) = P CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) END IF 180 CONTINUE END IF ! 190 CONTINUE RETURN ! ! End of DSTEQR ! END SUBROUTINE DSTEQR ! != ! !> \brief \b DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLASET + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) ! ! .. Scalar Arguments .. ! CHARACTER UPLO ! INTEGER LDA, M, N ! DOUBLE PRECISION ALPHA, BETA ! .. ! .. Array Arguments .. ! DOUBLE PRECISION A( LDA, * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLASET initializes an m-by-n matrix A to BETA on the diagonal and !> ALPHA on the offdiagonals. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> Specifies the part of the matrix A to be set. !> = 'U': Upper triangular part is set; the strictly lower !> triangular part of A is not changed. !> = 'L': Lower triangular part is set; the strictly upper !> triangular part of A is not changed. !> Otherwise: All of the matrix A is set. !> \endverbatim !> !> \param[in] M !> \verbatim !> M is INTEGER !> The number of rows of the matrix A. M >= 0. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The number of columns of the matrix A. N >= 0. !> \endverbatim !> !> \param[in] ALPHA !> \verbatim !> ALPHA is DOUBLE PRECISION !> The constant to which the offdiagonal elements are to be set. !> \endverbatim !> !> \param[in] BETA !> \verbatim !> BETA is DOUBLE PRECISION !> The constant to which the diagonal elements are to be set. !> \endverbatim !> !> \param[out] A !> \verbatim !> A is DOUBLE PRECISION array, dimension (LDA,N) !> On exit, the leading m-by-n submatrix of A is set as follows: !> !> if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, !> if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, !> otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, !> !> and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,M). !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2015 ! !> \ingroup auxOTHERauxiliary ! ! ===================================================================== SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) ! ! -- LAPACK auxiliary routine (version 3.6.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2015 ! ! .. Scalar Arguments .. CHARACTER UPLO INTEGER LDA, M, N DOUBLE PRECISION ALPHA, BETA ! .. ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. INTEGER I, J ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. Intrinsic Functions .. ! INTRINSIC MIN ! .. ! .. Executable Statements .. ! IF( LSAME( UPLO, 'U' ) ) THEN ! ! Set the strictly upper triangular or trapezoidal part of the ! array to ALPHA. ! DO 20 J = 2, N DO 10 I = 1, MIN( J-1, M ) A( I, J ) = ALPHA 10 CONTINUE 20 CONTINUE ! ELSE IF( LSAME( UPLO, 'L' ) ) THEN ! ! Set the strictly lower triangular or trapezoidal part of the ! array to ALPHA. ! DO 40 J = 1, MIN( M, N ) DO 30 I = J + 1, M A( I, J ) = ALPHA 30 CONTINUE 40 CONTINUE ! ELSE ! ! Set the leading m-by-n submatrix to ALPHA. ! DO 60 J = 1, N DO 50 I = 1, M A( I, J ) = ALPHA 50 CONTINUE 60 CONTINUE END IF ! ! Set the first min(M,N) diagonal elements to BETA. ! DO 70 I = 1, MIN( M, N ) A( I, I ) = BETA 70 CONTINUE ! RETURN ! ! End of DLASET ! END SUBROUTINE DLASET ! != ! !> \brief \b DLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLAEV2 + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) ! ! .. Scalar Arguments .. ! DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix !> [ A B ] !> [ B C ]. !> On return, RT1 is the eigenvalue of larger absolute value, RT2 is the !> eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right !> eigenvector for RT1, giving the decomposition !> !> [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] !> [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] A !> \verbatim !> A is DOUBLE PRECISION !> The (1,1) element of the 2-by-2 matrix. !> \endverbatim !> !> \param[in] B !> \verbatim !> B is DOUBLE PRECISION !> The (1,2) element and the conjugate of the (2,1) element of !> the 2-by-2 matrix. !> \endverbatim !> !> \param[in] C !> \verbatim !> C is DOUBLE PRECISION !> The (2,2) element of the 2-by-2 matrix. !> \endverbatim !> !> \param[out] RT1 !> \verbatim !> RT1 is DOUBLE PRECISION !> The eigenvalue of larger absolute value. !> \endverbatim !> !> \param[out] RT2 !> \verbatim !> RT2 is DOUBLE PRECISION !> The eigenvalue of smaller absolute value. !> \endverbatim !> !> \param[out] CS1 !> \verbatim !> CS1 is DOUBLE PRECISION !> \endverbatim !> !> \param[out] SN1 !> \verbatim !> SN1 is DOUBLE PRECISION !> The vector (CS1, SN1) is a unit right eigenvector for RT1. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup auxOTHERauxiliary ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> RT1 is accurate to a few ulps barring over/underflow. !> !> RT2 may be inaccurate if there is massive cancellation in the !> determinant A*C-B*B; higher precision or correctly rounded or !> correctly truncated arithmetic would be needed to compute RT2 !> accurately in all cases. !> !> CS1 and SN1 are accurate to a few ulps barring over/underflow. !> !> Overflow is possible only if RT1 is within a factor of 5 of overflow. !> Underflow is harmless if the input data is 0 or exceeds !> underflow_threshold / macheps. !> \endverbatim !> ! ===================================================================== SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) ! ! -- LAPACK auxiliary routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION HALF PARAMETER ( HALF = 0.5D0 ) ! .. ! .. Local Scalars .. INTEGER SGN1, SGN2 DOUBLE PRECISION AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM,& TB, TN ! .. ! .. Intrinsic Functions .. ! INTRINSIC ABS, SQRT ! .. ! .. Executable Statements .. ! ! Compute the eigenvalues ! SM = A + C DF = A - C ADF = ABS( DF ) TB = B + B AB = ABS( TB ) IF( ABS( A ).GT.ABS( C ) ) THEN ACMX = A ACMN = C ELSE ACMX = C ACMN = A END IF IF( ADF.GT.AB ) THEN RT = ADF*SQRT( ONE+( AB / ADF )**2 ) ELSE IF( ADF.LT.AB ) THEN RT = AB*SQRT( ONE+( ADF / AB )**2 ) ELSE ! ! Includes case AB=ADF=0 ! RT = AB*SQRT( TWO ) END IF IF( SM.LT.ZERO ) THEN RT1 = HALF*( SM-RT ) SGN1 = -1 ! ! Order of execution important. ! To get fully accurate smaller eigenvalue, ! next line needs to be executed in higher precision. ! RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE IF( SM.GT.ZERO ) THEN RT1 = HALF*( SM+RT ) SGN1 = 1 ! ! Order of execution important. ! To get fully accurate smaller eigenvalue, ! next line needs to be executed in higher precision. ! RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE ! ! Includes case RT1 = RT2 = 0 ! RT1 = HALF*RT RT2 = -HALF*RT SGN1 = 1 END IF ! ! Compute the eigenvector ! IF( DF.GE.ZERO ) THEN CS = DF + RT SGN2 = 1 ELSE CS = DF - RT SGN2 = -1 END IF ACS = ABS( CS ) IF( ACS.GT.AB ) THEN CT = -TB / CS SN1 = ONE / SQRT( ONE+CT*CT ) CS1 = CT*SN1 ELSE IF( AB.EQ.ZERO ) THEN CS1 = ONE SN1 = ZERO ELSE TN = -CS / TB CS1 = ONE / SQRT( ONE+TN*TN ) SN1 = TN*CS1 END IF END IF IF( SGN1.EQ.SGN2 ) THEN TN = CS1 CS1 = -SN1 SN1 = TN END IF RETURN ! ! End of DLAEV2 ! END SUBROUTINE DLAEV2 ! !> \brief \b DLASR applies a sequence of plane rotations to a general rectangular matrix. ! != ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLASR + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) ! ! .. Scalar Arguments .. ! CHARACTER DIRECT, PIVOT, SIDE ! INTEGER LDA, M, N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLASR applies a sequence of plane rotations to a real matrix A, !> from either the left or the right. !> !> When SIDE = 'L', the transformation takes the form !> !> A := P*A !> !> and when SIDE = 'R', the transformation takes the form !> !> A := A*P**T !> !> where P is an orthogonal matrix consisting of a sequence of z plane !> rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', !> and P**T is the transpose of P. !> !> When DIRECT = 'F' (Forward sequence), then !> !> P = P(z-1) * ... * P(2) * P(1) !> !> and when DIRECT = 'B' (Backward sequence), then !> !> P = P(1) * P(2) * ... * P(z-1) !> !> where P(k) is a plane rotation matrix defined by the 2-by-2 rotation !> !> R(k) = ( c(k) s(k) ) !> = ( -s(k) c(k) ). !> !> When PIVOT = 'V' (Variable pivot), the rotation is performed !> for the plane (k,k+1), i.e., P(k) has the form !> !> P(k) = ( 1 ) !> ( ... ) !> ( 1 ) !> ( c(k) s(k) ) !> ( -s(k) c(k) ) !> ( 1 ) !> ( ... ) !> ( 1 ) !> !> where R(k) appears as a rank-2 modification to the identity matrix in !> rows and columns k and k+1. !> !> When PIVOT = 'T' (Top pivot), the rotation is performed for the !> plane (1,k+1), so P(k) has the form !> !> P(k) = ( c(k) s(k) ) !> ( 1 ) !> ( ... ) !> ( 1 ) !> ( -s(k) c(k) ) !> ( 1 ) !> ( ... ) !> ( 1 ) !> !> where R(k) appears in rows and columns 1 and k+1. !> !> Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is !> performed for the plane (k,z), giving P(k) the form !> !> P(k) = ( 1 ) !> ( ... ) !> ( 1 ) !> ( c(k) s(k) ) !> ( 1 ) !> ( ... ) !> ( 1 ) !> ( -s(k) c(k) ) !> !> where R(k) appears in rows and columns k and z. The rotations are !> performed without ever forming P(k) explicitly. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] SIDE !> \verbatim !> SIDE is CHARACTER*1 !> Specifies whether the plane rotation matrix P is applied to !> A on the left or the right. !> = 'L': Left, compute A := P*A !> = 'R': Right, compute A:= A*P**T !> \endverbatim !> !> \param[in] PIVOT !> \verbatim !> PIVOT is CHARACTER*1 !> Specifies the plane for which P(k) is a plane rotation !> matrix. !> = 'V': Variable pivot, the plane (k,k+1) !> = 'T': Top pivot, the plane (1,k+1) !> = 'B': Bottom pivot, the plane (k,z) !> \endverbatim !> !> \param[in] DIRECT !> \verbatim !> DIRECT is CHARACTER*1 !> Specifies whether P is a forward or backward sequence of !> plane rotations. !> = 'F': Forward, P = P(z-1)*...*P(2)*P(1) !> = 'B': Backward, P = P(1)*P(2)*...*P(z-1) !> \endverbatim !> !> \param[in] M !> \verbatim !> M is INTEGER !> The number of rows of the matrix A. If m <= 1, an immediate !> return is effected. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The number of columns of the matrix A. If n <= 1, an !> immediate return is effected. !> \endverbatim !> !> \param[in] C !> \verbatim !> C is DOUBLE PRECISION array, dimension !> (M-1) if SIDE = 'L' !> (N-1) if SIDE = 'R' !> The cosines c(k) of the plane rotations. !> \endverbatim !> !> \param[in] S !> \verbatim !> S is DOUBLE PRECISION array, dimension !> (M-1) if SIDE = 'L' !> (N-1) if SIDE = 'R' !> The sines s(k) of the plane rotations. The 2-by-2 plane !> rotation part of the matrix P(k), R(k), has the form !> R(k) = ( c(k) s(k) ) !> ( -s(k) c(k) ). !> \endverbatim !> !> \param[in,out] A !> \verbatim !> A is DOUBLE PRECISION array, dimension (LDA,N) !> The M-by-N matrix A. On exit, A is overwritten by P*A if !> SIDE = 'R' or by A*P**T if SIDE = 'L'. !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,M). !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup auxOTHERauxiliary ! ! ===================================================================== SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) ! ! -- LAPACK auxiliary routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. CHARACTER DIRECT, PIVOT, SIDE INTEGER LDA, M, N ! .. ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) ! .. ! .. Local Scalars .. INTEGER I, INFO, J DOUBLE PRECISION CTEMP, STEMP, TEMP ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. ! INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters ! INFO = 0 IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN INFO = 1 ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT,& 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN INFO = 2 ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) )& THEN INFO = 3 ELSE IF( M.LT.0 ) THEN INFO = 4 ELSE IF( N.LT.0 ) THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = 9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLASR ', INFO ) RETURN END IF ! ! Quick return if possible ! IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) RETURN IF( LSAME( SIDE, 'L' ) ) THEN ! ! Form P * A ! IF( LSAME( PIVOT, 'V' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 20 J = 1, M - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 10 I = 1, N TEMP = A( J+1, I ) A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 10 CONTINUE END IF 20 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 40 J = M - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 30 I = 1, N TEMP = A( J+1, I ) A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 30 CONTINUE END IF 40 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'T' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 60 J = 2, M CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 50 I = 1, N TEMP = A( J, I ) A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 50 CONTINUE END IF 60 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 80 J = M, 2, -1 CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 70 I = 1, N TEMP = A( J, I ) A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 70 CONTINUE END IF 80 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'B' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 100 J = 1, M - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 90 I = 1, N TEMP = A( J, I ) A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 90 CONTINUE END IF 100 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 120 J = M - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 110 I = 1, N TEMP = A( J, I ) A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 110 CONTINUE END IF 120 CONTINUE END IF END IF ELSE IF( LSAME( SIDE, 'R' ) ) THEN ! ! Form A * P**T ! IF( LSAME( PIVOT, 'V' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 140 J = 1, N - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 130 I = 1, M TEMP = A( I, J+1 ) A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 130 CONTINUE END IF 140 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 160 J = N - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 150 I = 1, M TEMP = A( I, J+1 ) A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 150 CONTINUE END IF 160 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'T' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 180 J = 2, N CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 170 I = 1, M TEMP = A( I, J ) A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 170 CONTINUE END IF 180 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 200 J = N, 2, -1 CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 190 I = 1, M TEMP = A( I, J ) A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 190 CONTINUE END IF 200 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'B' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 220 J = 1, N - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 210 I = 1, M TEMP = A( I, J ) A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 210 CONTINUE END IF 220 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 240 J = N - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 230 I = 1, M TEMP = A( I, J ) A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 230 CONTINUE END IF 240 CONTINUE END IF END IF END IF ! RETURN ! ! End of DLASR ! END SUBROUTINE DLASR ! != ! !> \brief \b DLASRT sorts numbers in increasing or decreasing order. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLASRT + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLASRT( ID, N, D, INFO ) ! ! .. Scalar Arguments .. ! CHARACTER ID ! INTEGER INFO, N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION D( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> Sort the numbers in D in increasing order (if ID = 'I') or !> in decreasing order (if ID = 'D' ). !> !> Use Quick Sort, reverting to Insertion sort on arrays of !> size <= 20. Dimension of STACK limits N to about 2**32. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] ID !> \verbatim !> ID is CHARACTER*1 !> = 'I': sort D in increasing order; !> = 'D': sort D in decreasing order. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The length of the array D. !> \endverbatim !> !> \param[in,out] D !> \verbatim !> D is DOUBLE PRECISION array, dimension (N) !> On entry, the array to be sorted. !> On exit, D has been sorted into increasing order !> (D(1) <= ... <= D(N) ) or into decreasing order !> (D(1) >= ... >= D(N) ), depending on ID. !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument had an illegal value !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup auxOTHERcomputational ! ! ===================================================================== SUBROUTINE DLASRT( ID, N, D, INFO ) ! ! -- LAPACK computational routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. CHARACTER ID INTEGER INFO, N ! .. ! .. Array Arguments .. DOUBLE PRECISION D( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. INTEGER SELECT PARAMETER ( SELECT = 20 ) ! .. ! .. Local Scalars .. INTEGER DIR, ENDD, I, J, START, STKPNT DOUBLE PRECISION D1, D2, D3, DMNMX, TMP ! .. ! .. Local Arrays .. INTEGER STACK( 2, 32 ) ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Executable Statements .. ! ! Test the input paramters. ! INFO = 0 DIR = -1 IF( LSAME( ID, 'D' ) ) THEN DIR = 0 ELSE IF( LSAME( ID, 'I' ) ) THEN DIR = 1 END IF IF( DIR.EQ.-1 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLASRT', -INFO ) RETURN END IF ! ! Quick return if possible ! IF( N.LE.1 ) RETURN ! STKPNT = 1 STACK( 1, 1 ) = 1 STACK( 2, 1 ) = N 10 CONTINUE START = STACK( 1, STKPNT ) ENDD = STACK( 2, STKPNT ) STKPNT = STKPNT - 1 IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN ! ! Do Insertion sort on D( START:ENDD ) ! IF( DIR.EQ.0 ) THEN ! ! Sort into decreasing order ! DO 30 I = START + 1, ENDD DO 20 J = I, START + 1, -1 IF( D( J ).GT.D( J-1 ) ) THEN DMNMX = D( J ) D( J ) = D( J-1 ) D( J-1 ) = DMNMX ELSE GO TO 30 END IF 20 CONTINUE 30 CONTINUE ! ELSE ! ! Sort into increasing order ! DO 50 I = START + 1, ENDD DO 40 J = I, START + 1, -1 IF( D( J ).LT.D( J-1 ) ) THEN DMNMX = D( J ) D( J ) = D( J-1 ) D( J-1 ) = DMNMX ELSE GO TO 50 END IF 40 CONTINUE 50 CONTINUE ! END IF ! ELSE IF( ENDD-START.GT.SELECT ) THEN ! ! Partition D( START:ENDD ) and stack parts, largest one first ! ! Choose partition entry as median of 3 ! D1 = D( START ) D2 = D( ENDD ) I = ( START+ENDD ) / 2 D3 = D( I ) IF( D1.LT.D2 ) THEN IF( D3.LT.D1 ) THEN DMNMX = D1 ELSE IF( D3.LT.D2 ) THEN DMNMX = D3 ELSE DMNMX = D2 END IF ELSE IF( D3.LT.D2 ) THEN DMNMX = D2 ELSE IF( D3.LT.D1 ) THEN DMNMX = D3 ELSE DMNMX = D1 END IF END IF ! IF( DIR.EQ.0 ) THEN ! ! Sort into decreasing order ! I = START - 1 J = ENDD + 1 60 CONTINUE 70 CONTINUE J = J - 1 IF( D( J ).LT.DMNMX ) GO TO 70 80 CONTINUE I = I + 1 IF( D( I ).GT.DMNMX ) GO TO 80 IF( I.LT.J ) THEN TMP = D( I ) D( I ) = D( J ) D( J ) = TMP GO TO 60 END IF IF( J-START.GT.ENDD-J-1 ) THEN STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = START STACK( 2, STKPNT ) = J STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = J + 1 STACK( 2, STKPNT ) = ENDD ELSE STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = J + 1 STACK( 2, STKPNT ) = ENDD STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = START STACK( 2, STKPNT ) = J END IF ELSE ! ! Sort into increasing order ! I = START - 1 J = ENDD + 1 90 CONTINUE 100 CONTINUE J = J - 1 IF( D( J ).GT.DMNMX ) GO TO 100 110 CONTINUE I = I + 1 IF( D( I ).LT.DMNMX ) GO TO 110 IF( I.LT.J ) THEN TMP = D( I ) D( I ) = D( J ) D( J ) = TMP GO TO 90 END IF IF( J-START.GT.ENDD-J-1 ) THEN STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = START STACK( 2, STKPNT ) = J STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = J + 1 STACK( 2, STKPNT ) = ENDD ELSE STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = J + 1 STACK( 2, STKPNT ) = ENDD STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = START STACK( 2, STKPNT ) = J END IF END IF END IF IF( STKPNT.GT.0 ) GO TO 10 RETURN ! ! End of DLASRT ! END SUBROUTINE DLASRT ! != ! !> \brief \b DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLAE2 + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) ! ! .. Scalar Arguments .. ! DOUBLE PRECISION A, B, C, RT1, RT2 ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix !> [ A B ] !> [ B C ]. !> On return, RT1 is the eigenvalue of larger absolute value, and RT2 !> is the eigenvalue of smaller absolute value. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] A !> \verbatim !> A is DOUBLE PRECISION !> The (1,1) element of the 2-by-2 matrix. !> \endverbatim !> !> \param[in] B !> \verbatim !> B is DOUBLE PRECISION !> The (1,2) and (2,1) elements of the 2-by-2 matrix. !> \endverbatim !> !> \param[in] C !> \verbatim !> C is DOUBLE PRECISION !> The (2,2) element of the 2-by-2 matrix. !> \endverbatim !> !> \param[out] RT1 !> \verbatim !> RT1 is DOUBLE PRECISION !> The eigenvalue of larger absolute value. !> \endverbatim !> !> \param[out] RT2 !> \verbatim !> RT2 is DOUBLE PRECISION !> The eigenvalue of smaller absolute value. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup auxOTHERauxiliary ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> RT1 is accurate to a few ulps barring over/underflow. !> !> RT2 may be inaccurate if there is massive cancellation in the !> determinant A*C-B*B; higher precision or correctly rounded or !> correctly truncated arithmetic would be needed to compute RT2 !> accurately in all cases. !> !> Overflow is possible only if RT1 is within a factor of 5 of overflow. !> Underflow is harmless if the input data is 0 or exceeds !> underflow_threshold / macheps. !> \endverbatim !> ! ===================================================================== SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) ! ! -- LAPACK auxiliary routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. DOUBLE PRECISION A, B, C, RT1, RT2 ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION HALF PARAMETER ( HALF = 0.5D0 ) ! .. ! .. Local Scalars .. DOUBLE PRECISION AB, ACMN, ACMX, ADF, DF, RT, SM, TB ! .. ! .. Intrinsic Functions .. ! INTRINSIC ABS, SQRT ! .. ! .. Executable Statements .. ! ! Compute the eigenvalues ! SM = A + C DF = A - C ADF = ABS( DF ) TB = B + B AB = ABS( TB ) IF( ABS( A ).GT.ABS( C ) ) THEN ACMX = A ACMN = C ELSE ACMX = C ACMN = A END IF IF( ADF.GT.AB ) THEN RT = ADF*SQRT( ONE+( AB / ADF )**2 ) ELSE IF( ADF.LT.AB ) THEN RT = AB*SQRT( ONE+( ADF / AB )**2 ) ELSE ! ! Includes case AB=ADF=0 ! RT = AB*SQRT( TWO ) END IF IF( SM.LT.ZERO ) THEN RT1 = HALF*( SM-RT ) ! ! Order of execution important. ! To get fully accurate smaller eigenvalue, ! next line needs to be executed in higher precision. ! RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE IF( SM.GT.ZERO ) THEN RT1 = HALF*( SM+RT ) ! ! Order of execution important. ! To get fully accurate smaller eigenvalue, ! next line needs to be executed in higher precision. ! RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE ! ! Includes case RT1 = RT2 = 0 ! RT1 = HALF*RT RT2 = -HALF*RT END IF RETURN ! ! End of DLAE2 ! END SUBROUTINE DLAE2 ! != ! !> \brief \b DLARTG generates a plane rotation with real cosine and real sine. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLARTG + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLARTG( F, G, CS, SN, R ) ! ! .. Scalar Arguments .. ! DOUBLE PRECISION CS, F, G, R, SN ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLARTG generate a plane rotation so that !> !> [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. !> [ -SN CS ] [ G ] [ 0 ] !> !> This is a slower, more accurate version of the BLAS1 routine DROTG, !> with the following other differences: !> F and G are unchanged on return. !> If G=0, then CS=1 and SN=0. !> If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any !> floating point operations (saves work in DBDSQR when !> there are zeros on the diagonal). !> !> If F exceeds G in magnitude, CS will be positive. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] F !> \verbatim !> F is DOUBLE PRECISION !> The first component of vector to be rotated. !> \endverbatim !> !> \param[in] G !> \verbatim !> G is DOUBLE PRECISION !> The second component of vector to be rotated. !> \endverbatim !> !> \param[out] CS !> \verbatim !> CS is DOUBLE PRECISION !> The cosine of the rotation. !> \endverbatim !> !> \param[out] SN !> \verbatim !> SN is DOUBLE PRECISION !> The sine of the rotation. !> \endverbatim !> !> \param[out] R !> \verbatim !> R is DOUBLE PRECISION !> The nonzero component of the rotated vector. !> !> This version has a few statements commented out for thread safety !> (machine parameters are computed on each entry). 10 feb 03, SJH. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup auxOTHERauxiliary ! ! ===================================================================== SUBROUTINE DLARTG( F, G, CS, SN, R ) ! ! -- LAPACK auxiliary routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. DOUBLE PRECISION CS, F, G, R, SN ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) ! .. ! .. Local Scalars .. ! LOGICAL FIRST INTEGER COUNT, I DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE ! .. ! .. External Functions .. ! DOUBLE PRECISION DLAMCH ! EXTERNAL DLAMCH ! .. ! .. Intrinsic Functions .. ! INTRINSIC ABS, INT, LOG, MAX, SQRT ! .. ! .. Save statement .. ! SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 ! .. ! .. Data statements .. ! DATA FIRST / .TRUE. / ! .. ! .. Executable Statements .. ! ! IF( FIRST ) THEN SAFMIN = DLAMCH( 'S' ) EPS = DLAMCH( 'E' ) SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /& LOG( DLAMCH( 'B' ) ) / TWO ) SAFMX2 = ONE / SAFMN2 ! FIRST = .FALSE. ! END IF IF( G.EQ.ZERO ) THEN CS = ONE SN = ZERO R = F ELSE IF( F.EQ.ZERO ) THEN CS = ZERO SN = ONE R = G ELSE F1 = F G1 = G SCALE = MAX( ABS( F1 ), ABS( G1 ) ) IF( SCALE.GE.SAFMX2 ) THEN COUNT = 0 10 CONTINUE COUNT = COUNT + 1 F1 = F1*SAFMN2 G1 = G1*SAFMN2 SCALE = MAX( ABS( F1 ), ABS( G1 ) ) IF( SCALE.GE.SAFMX2 ) GO TO 10 R = SQRT( F1**2+G1**2 ) CS = F1 / R SN = G1 / R DO 20 I = 1, COUNT R = R*SAFMX2 20 CONTINUE ELSE IF( SCALE.LE.SAFMN2 ) THEN COUNT = 0 30 CONTINUE COUNT = COUNT + 1 F1 = F1*SAFMX2 G1 = G1*SAFMX2 SCALE = MAX( ABS( F1 ), ABS( G1 ) ) IF( SCALE.LE.SAFMN2 ) GO TO 30 R = SQRT( F1**2+G1**2 ) CS = F1 / R SN = G1 / R DO 40 I = 1, COUNT R = R*SAFMN2 40 CONTINUE ELSE R = SQRT( F1**2+G1**2 ) CS = F1 / R SN = G1 / R END IF IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN CS = -CS SN = -SN R = -R END IF END IF RETURN ! ! End of DLARTG ! END SUBROUTINE DLARTG ! != ! !> \brief \b DLACPY copies all or part of one two-dimensional array to another. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLACPY + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) ! ! .. Scalar Arguments .. ! CHARACTER UPLO ! INTEGER LDA, LDB, M, N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION A( LDA, * ), B( LDB, * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLACPY copies all or part of a two-dimensional matrix A to another !> matrix B. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> Specifies the part of the matrix A to be copied to B. !> = 'U': Upper triangular part !> = 'L': Lower triangular part !> Otherwise: All of the matrix A !> \endverbatim !> !> \param[in] M !> \verbatim !> M is INTEGER !> The number of rows of the matrix A. M >= 0. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The number of columns of the matrix A. N >= 0. !> \endverbatim !> !> \param[in] A !> \verbatim !> A is DOUBLE PRECISION array, dimension (LDA,N) !> The m by n matrix A. If UPLO = 'U', only the upper triangle !> or trapezoid is accessed; if UPLO = 'L', only the lower !> triangle or trapezoid is accessed. !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,M). !> \endverbatim !> !> \param[out] B !> \verbatim !> B is DOUBLE PRECISION array, dimension (LDB,N) !> On exit, B = A in the locations specified by UPLO. !> \endverbatim !> !> \param[in] LDB !> \verbatim !> LDB is INTEGER !> The leading dimension of the array B. LDB >= max(1,M). !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup auxOTHERauxiliary ! ! ===================================================================== SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) ! ! -- LAPACK auxiliary routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. CHARACTER UPLO INTEGER LDA, LDB, M, N ! .. ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. INTEGER I, J ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. Intrinsic Functions .. ! INTRINSIC MIN ! .. ! .. Executable Statements .. ! IF( LSAME( UPLO, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = 1, MIN( J, M ) B( I, J ) = A( I, J ) 10 CONTINUE 20 CONTINUE ELSE IF( LSAME( UPLO, 'L' ) ) THEN DO 40 J = 1, N DO 30 I = J, M B( I, J ) = A( I, J ) 30 CONTINUE 40 CONTINUE ELSE DO 60 J = 1, N DO 50 I = 1, M B( I, J ) = A( I, J ) 50 CONTINUE 60 CONTINUE END IF RETURN ! ! End of DLACPY ! END SUBROUTINE DLACPY ! != ! !> \brief \b DLAED0 used by sstedc. Computes all eigenvalues and corresponding eigenvectors of an unreduced symmetric tridiagonal matrix using the divide and conquer method. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLAED0 + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, ! WORK, IWORK, INFO ) ! ! .. Scalar Arguments .. ! INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ ! .. ! .. Array Arguments .. ! INTEGER IWORK( * ) ! DOUBLE PRECISION D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ), ! $ WORK( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLAED0 computes all eigenvalues and corresponding eigenvectors of a !> symmetric tridiagonal matrix using the divide and conquer method. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] ICOMPQ !> \verbatim !> ICOMPQ is INTEGER !> = 0: Compute eigenvalues only. !> = 1: Compute eigenvectors of original dense symmetric matrix !> also. On entry, Q contains the orthogonal matrix used !> to reduce the original matrix to tridiagonal form. !> = 2: Compute eigenvalues and eigenvectors of tridiagonal !> matrix. !> \endverbatim !> !> \param[in] QSIZ !> \verbatim !> QSIZ is INTEGER !> The dimension of the orthogonal matrix used to reduce !> the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The dimension of the symmetric tridiagonal matrix. N >= 0. !> \endverbatim !> !> \param[in,out] D !> \verbatim !> D is DOUBLE PRECISION array, dimension (N) !> On entry, the main diagonal of the tridiagonal matrix. !> On exit, its eigenvalues. !> \endverbatim !> !> \param[in] E !> \verbatim !> E is DOUBLE PRECISION array, dimension (N-1) !> The off-diagonal elements of the tridiagonal matrix. !> On exit, E has been destroyed. !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is DOUBLE PRECISION array, dimension (LDQ, N) !> On entry, Q must contain an N-by-N orthogonal matrix. !> If ICOMPQ = 0 Q is not referenced. !> If ICOMPQ = 1 On entry, Q is a subset of the columns of the !> orthogonal matrix used to reduce the full !> matrix to tridiagonal form corresponding to !> the subset of the full matrix which is being !> decomposed at this time. !> If ICOMPQ = 2 On entry, Q will be the identity matrix. !> On exit, Q contains the eigenvectors of the !> tridiagonal matrix. !> \endverbatim !> !> \param[in] LDQ !> \verbatim !> LDQ is INTEGER !> The leading dimension of the array Q. If eigenvectors are !> desired, then LDQ >= max(1,N). In any case, LDQ >= 1. !> \endverbatim !> !> \param[out] QSTORE !> \verbatim !> QSTORE is DOUBLE PRECISION array, dimension (LDQS, N) !> Referenced only when ICOMPQ = 1. Used to store parts of !> the eigenvector matrix when the updating matrix multiplies !> take place. !> \endverbatim !> !> \param[in] LDQS !> \verbatim !> LDQS is INTEGER !> The leading dimension of the array QSTORE. If ICOMPQ = 1, !> then LDQS >= max(1,N). In any case, LDQS >= 1. !> \endverbatim !> !> \param[out] WORK !> \verbatim !> WORK is DOUBLE PRECISION array, !> If ICOMPQ = 0 or 1, the dimension of WORK must be at least !> 1 + 3*N + 2*N*lg N + 3*N**2 !> ( lg( N ) = smallest integer k !> such that 2^k >= N ) !> If ICOMPQ = 2, the dimension of WORK must be at least !> 4*N + N**2. !> \endverbatim !> !> \param[out] IWORK !> \verbatim !> IWORK is INTEGER array, !> If ICOMPQ = 0 or 1, the dimension of IWORK must be at least !> 6 + 6*N + 5*N*lg N. !> ( lg( N ) = smallest integer k !> such that 2^k >= N ) !> If ICOMPQ = 2, the dimension of IWORK must be at least !> 3 + 5*N. !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !> > 0: The algorithm failed to compute an eigenvalue while !> working on the submatrix lying in rows and columns !> INFO/(N+1) through mod(INFO,N+1). !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup auxOTHERcomputational ! !> \par Contributors: ! ================== !> !> Jeff Rutter, Computer Science Division, University of California !> at Berkeley, USA ! ! ===================================================================== SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS,& WORK, IWORK, INFO ) ! ! -- LAPACK computational routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ ! .. ! .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ),& WORK( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.D0, ONE = 1.D0, TWO = 2.D0 ) ! .. ! .. Local Scalars .. INTEGER CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM,& IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM,& J, K, LGN, MATSIZ, MSD2, SMLSIZ, SMM1, SPM1,& SPM2, SUBMAT, SUBPBS, TLVLS DOUBLE PRECISION TEMP ! .. ! .. External Subroutines .. ! EXTERNAL DCOPY, DGEMM, DLACPY, DLAED1, DLAED7, DSTEQR, ! $ XERBLA ! .. ! .. External Functions .. ! INTEGER ILAENV ! EXTERNAL ILAENV ! .. ! .. Intrinsic Functions .. ! INTRINSIC ABS, DBLE, INT, LOG, MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! INFO = 0 ! IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.2 ) THEN INFO = -1 ELSE IF( ( ICOMPQ.EQ.1 ) .AND. ( QSIZ.LT.MAX( 0, N ) ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN INFO = -9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLAED0', -INFO ) RETURN END IF ! ! Quick return if possible ! IF( N.EQ.0 ) RETURN ! SMLSIZ = ILAENV( 9, 'DLAED0', ' ', 0, 0, 0, 0 ) ! ! Determine the size and placement of the submatrices, and save in ! the leading elements of IWORK. ! IWORK( 1 ) = N SUBPBS = 1 TLVLS = 0 10 CONTINUE IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN DO 20 J = SUBPBS, 1, -1 IWORK( 2*J ) = ( IWORK( J )+1 ) / 2 IWORK( 2*J-1 ) = IWORK( J ) / 2 20 CONTINUE TLVLS = TLVLS + 1 SUBPBS = 2*SUBPBS GO TO 10 END IF DO 30 J = 2, SUBPBS IWORK( J ) = IWORK( J ) + IWORK( J-1 ) 30 CONTINUE ! ! Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1 ! using rank-1 modifications (cuts). ! SPM1 = SUBPBS - 1 DO 40 I = 1, SPM1 SUBMAT = IWORK( I ) + 1 SMM1 = SUBMAT - 1 D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) ) D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) ) 40 CONTINUE ! INDXQ = 4*N + 3 IF( ICOMPQ.NE.2 ) THEN ! ! Set up workspaces for eigenvalues only/accumulate new vectors ! routine ! TEMP = LOG( DBLE( N ) ) / LOG( TWO ) LGN = INT( TEMP ) IF( 2**LGN.LT.N ) LGN = LGN + 1 IF( 2**LGN.LT.N ) LGN = LGN + 1 IPRMPT = INDXQ + N + 1 IPERM = IPRMPT + N*LGN IQPTR = IPERM + N*LGN IGIVPT = IQPTR + N + 2 IGIVCL = IGIVPT + N*LGN ! IGIVNM = 1 IQ = IGIVNM + 2*N*LGN IWREM = IQ + N**2 + 1 ! ! Initialize pointers ! DO 50 I = 0, SUBPBS IWORK( IPRMPT+I ) = 1 IWORK( IGIVPT+I ) = 1 50 CONTINUE IWORK( IQPTR ) = 1 END IF ! ! Solve each submatrix eigenproblem at the bottom of the divide and ! conquer tree. ! CURR = 0 DO 70 I = 0, SPM1 IF( I.EQ.0 ) THEN SUBMAT = 1 MATSIZ = IWORK( 1 ) ELSE SUBMAT = IWORK( I ) + 1 MATSIZ = IWORK( I+1 ) - IWORK( I ) END IF IF( ICOMPQ.EQ.2 ) THEN CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),& Q( SUBMAT, SUBMAT ), LDQ, WORK, INFO ) IF( INFO.NE.0 ) GO TO 130 ELSE CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),& WORK( IQ-1+IWORK( IQPTR+CURR ) ), MATSIZ, WORK, INFO ) IF( INFO.NE.0 ) GO TO 130 IF( ICOMPQ.EQ.1 ) THEN CALL DGEMM( 'N', 'N', QSIZ, MATSIZ, MATSIZ, ONE,& Q( 1, SUBMAT ), LDQ, WORK( IQ-1+IWORK( IQPTR+& CURR ) ), MATSIZ, ZERO, QSTORE( 1, SUBMAT ),& LDQS ) END IF IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2 CURR = CURR + 1 END IF K = 1 DO 60 J = SUBMAT, IWORK( I+1 ) IWORK( INDXQ+J ) = K K = K + 1 60 CONTINUE 70 CONTINUE ! ! Successively merge eigensystems of adjacent submatrices ! into eigensystem for the corresponding larger matrix. ! ! while ( SUBPBS > 1 ) ! CURLVL = 1 80 CONTINUE IF( SUBPBS.GT.1 ) THEN SPM2 = SUBPBS - 2 DO 90 I = 0, SPM2, 2 IF( I.EQ.0 ) THEN SUBMAT = 1 MATSIZ = IWORK( 2 ) MSD2 = IWORK( 1 ) CURPRB = 0 ELSE SUBMAT = IWORK( I ) + 1 MATSIZ = IWORK( I+2 ) - IWORK( I ) MSD2 = MATSIZ / 2 CURPRB = CURPRB + 1 END IF ! ! Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2) ! into an eigensystem of size MATSIZ. ! DLAED1 is used only for the full eigensystem of a tridiagonal ! matrix. ! DLAED7 handles the cases in which eigenvalues only or eigenvalues ! and eigenvectors of a full symmetric matrix (which was reduced to ! tridiagonal form) are desired. ! IF( ICOMPQ.EQ.2 ) THEN CALL DLAED1( MATSIZ, D( SUBMAT ), Q( SUBMAT, SUBMAT ),& LDQ, IWORK( INDXQ+SUBMAT ),& E( SUBMAT+MSD2-1 ), MSD2, WORK,& IWORK( SUBPBS+1 ), INFO ) ELSE CALL DLAED7( ICOMPQ, MATSIZ, QSIZ, TLVLS, CURLVL, CURPRB,& D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS,& IWORK( INDXQ+SUBMAT ), E( SUBMAT+MSD2-1 ),& MSD2, WORK( IQ ), IWORK( IQPTR ),& IWORK( IPRMPT ), IWORK( IPERM ),& IWORK( IGIVPT ), IWORK( IGIVCL ),& WORK( IGIVNM ), WORK( IWREM ),& IWORK( SUBPBS+1 ), INFO ) END IF IF( INFO.NE.0 ) GO TO 130 IWORK( I / 2+1 ) = IWORK( I+2 ) 90 CONTINUE SUBPBS = SUBPBS / 2 CURLVL = CURLVL + 1 GO TO 80 END IF ! ! end while ! ! Re-merge the eigenvalues/vectors which were deflated at the final ! merge step. ! IF( ICOMPQ.EQ.1 ) THEN DO 100 I = 1, N J = IWORK( INDXQ+I ) WORK( I ) = D( J ) CALL DCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 ) 100 CONTINUE CALL DCOPY( N, WORK, 1, D, 1 ) ELSE IF( ICOMPQ.EQ.2 ) THEN DO 110 I = 1, N J = IWORK( INDXQ+I ) WORK( I ) = D( J ) CALL DCOPY( N, Q( 1, J ), 1, WORK( N*I+1 ), 1 ) 110 CONTINUE CALL DCOPY( N, WORK, 1, D, 1 ) CALL DLACPY( 'A', N, N, WORK( N+1 ), N, Q, LDQ ) ELSE DO 120 I = 1, N J = IWORK( INDXQ+I ) WORK( I ) = D( J ) 120 CONTINUE CALL DCOPY( N, WORK, 1, D, 1 ) END IF GO TO 140 ! 130 CONTINUE INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1 ! 140 CONTINUE RETURN ! ! End of DLAED0 ! END SUBROUTINE DLAED0 ! != ! !> \brief \b ILADLC scans a matrix for its last non-zero column. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download ILADLC + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! INTEGER FUNCTION ILADLC( M, N, A, LDA ) ! ! .. Scalar Arguments .. ! INTEGER M, N, LDA ! .. ! .. Array Arguments .. ! DOUBLE PRECISION A( LDA, * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> ILADLC scans A for its last non-zero column. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] M !> \verbatim !> M is INTEGER !> The number of rows of the matrix A. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The number of columns of the matrix A. !> \endverbatim !> !> \param[in] A !> \verbatim !> A is DOUBLE PRECISION array, dimension (LDA,N) !> The m by n matrix A. !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,M). !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup auxOTHERauxiliary ! ! ===================================================================== INTEGER FUNCTION ILADLC( M, N, A, LDA ) ! ! -- LAPACK auxiliary routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. INTEGER M, N, LDA ! .. ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) ! .. ! .. Local Scalars .. INTEGER I ! .. ! .. Executable Statements .. ! ! Quick test for the common case where one corner is non-zero. IF( N.EQ.0 ) THEN ILADLC = N ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN ILADLC = N ELSE ! Now scan each column from the end, returning with the first non-zero. DO ILADLC = N, 1, -1 DO I = 1, M IF( A(I, ILADLC).NE.ZERO ) RETURN END DO END DO END IF RETURN END FUNCTION ILADLC ! != ! !> \brief \b ILADLR scans a matrix for its last non-zero row. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download ILADLR + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! INTEGER FUNCTION ILADLR( M, N, A, LDA ) ! ! .. Scalar Arguments .. ! INTEGER M, N, LDA ! .. ! .. Array Arguments .. ! DOUBLE PRECISION A( LDA, * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> ILADLR scans A for its last non-zero row. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] M !> \verbatim !> M is INTEGER !> The number of rows of the matrix A. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The number of columns of the matrix A. !> \endverbatim !> !> \param[in] A !> \verbatim !> A is DOUBLE PRECISION array, dimension (LDA,N) !> The m by n matrix A. !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,M). !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup auxOTHERauxiliary ! ! ===================================================================== INTEGER FUNCTION ILADLR( M, N, A, LDA ) ! ! -- LAPACK auxiliary routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. INTEGER M, N, LDA ! .. ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) ! .. ! .. Local Scalars .. INTEGER I, J ! .. ! .. Executable Statements .. ! ! Quick test for the common case where one corner is non-zero. IF( M.EQ.0 ) THEN ILADLR = M ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN ILADLR = M ELSE ! Scan up each column tracking the last zero row seen. ILADLR = 0 DO J = 1, N I=M DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1)) I=I-1 ENDDO ILADLR = MAX( ILADLR, I ) END DO END IF RETURN END FUNCTION ILADLR ! != ! !> \brief \b DLAED1 used by sstedc. Computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. Used when the original matrix is tridiagonal. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLAED1 + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, ! INFO ) ! ! .. Scalar Arguments .. ! INTEGER CUTPNT, INFO, LDQ, N ! DOUBLE PRECISION RHO ! .. ! .. Array Arguments .. ! INTEGER INDXQ( * ), IWORK( * ) ! DOUBLE PRECISION D( * ), Q( LDQ, * ), WORK( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLAED1 computes the updated eigensystem of a diagonal !> matrix after modification by a rank-one symmetric matrix. This !> routine is used only for the eigenproblem which requires all !> eigenvalues and eigenvectors of a tridiagonal matrix. DLAED7 handles !> the case in which eigenvalues only or eigenvalues and eigenvectors !> of a full symmetric matrix (which was reduced to tridiagonal form) !> are desired. !> !> T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out) !> !> where Z = Q**T*u, u is a vector of length N with ones in the !> CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. !> !> The eigenvectors of the original matrix are stored in Q, and the !> eigenvalues are in D. The algorithm consists of three stages: !> !> The first stage consists of deflating the size of the problem !> when there are multiple eigenvalues or if there is a zero in !> the Z vector. For each such occurence the dimension of the !> secular equation problem is reduced by one. This stage is !> performed by the routine DLAED2. !> !> The second stage consists of calculating the updated !> eigenvalues. This is done by finding the roots of the secular !> equation via the routine DLAED4 (as called by DLAED3). !> This routine also calculates the eigenvectors of the current !> problem. !> !> The final stage consists of computing the updated eigenvectors !> directly using the updated eigenvalues. The eigenvectors for !> the current problem are multiplied with the eigenvectors from !> the overall problem. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] N !> \verbatim !> N is INTEGER !> The dimension of the symmetric tridiagonal matrix. N >= 0. !> \endverbatim !> !> \param[in,out] D !> \verbatim !> D is DOUBLE PRECISION array, dimension (N) !> On entry, the eigenvalues of the rank-1-perturbed matrix. !> On exit, the eigenvalues of the repaired matrix. !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is DOUBLE PRECISION array, dimension (LDQ,N) !> On entry, the eigenvectors of the rank-1-perturbed matrix. !> On exit, the eigenvectors of the repaired tridiagonal matrix. !> \endverbatim !> !> \param[in] LDQ !> \verbatim !> LDQ is INTEGER !> The leading dimension of the array Q. LDQ >= max(1,N). !> \endverbatim !> !> \param[in,out] INDXQ !> \verbatim !> INDXQ is INTEGER array, dimension (N) !> On entry, the permutation which separately sorts the two !> subproblems in D into ascending order. !> On exit, the permutation which will reintegrate the !> subproblems back into sorted order, !> i.e. D( INDXQ( I = 1, N ) ) will be in ascending order. !> \endverbatim !> !> \param[in] RHO !> \verbatim !> RHO is DOUBLE PRECISION !> The subdiagonal entry used to create the rank-1 modification. !> \endverbatim !> !> \param[in] CUTPNT !> \verbatim !> CUTPNT is INTEGER !> The location of the last eigenvalue in the leading sub-matrix. !> min(1,N) <= CUTPNT <= N/2. !> \endverbatim !> !> \param[out] WORK !> \verbatim !> WORK is DOUBLE PRECISION array, dimension (4*N + N**2) !> \endverbatim !> !> \param[out] IWORK !> \verbatim !> IWORK is INTEGER array, dimension (4*N) !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !> > 0: if INFO = 1, an eigenvalue did not converge !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup auxOTHERcomputational ! !> \par Contributors: ! ================== !> !> Jeff Rutter, Computer Science Division, University of California !> at Berkeley, USA \n !> Modified by Francoise Tisseur, University of Tennessee !> ! ===================================================================== SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, INFO ) ! ! -- LAPACK computational routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. INTEGER CUTPNT, INFO, LDQ, N DOUBLE PRECISION RHO ! .. ! .. Array Arguments .. INTEGER INDXQ( * ), IWORK( * ) DOUBLE PRECISION D( * ), Q( LDQ, * ), WORK( * ) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. INTEGER COLTYP, I, IDLMDA, INDX, INDXC, INDXP, IQ2, IS,& IW, IZ, K, N1, N2, ZPP1 ! .. ! .. External Subroutines .. ! EXTERNAL DCOPY, DLAED2, DLAED3, DLAMRG, XERBLA ! .. ! .. Intrinsic Functions .. ! INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! INFO = 0 ! IF( N.LT.0 ) THEN INFO = -1 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( MIN( 1, N / 2 ).GT.CUTPNT .OR. ( N / 2 ).LT.CUTPNT ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLAED1', -INFO ) RETURN END IF ! ! Quick return if possible ! IF( N.EQ.0 ) RETURN ! ! The following values are integer pointers which indicate ! the portion of the workspace ! used by a particular array in DLAED2 and DLAED3. ! IZ = 1 IDLMDA = IZ + N IW = IDLMDA + N IQ2 = IW + N ! INDX = 1 INDXC = INDX + N COLTYP = INDXC + N INDXP = COLTYP + N ! ! ! Form the z-vector which consists of the last row of Q_1 and the ! first row of Q_2. ! CALL DCOPY( CUTPNT, Q( CUTPNT, 1 ), LDQ, WORK( IZ ), 1 ) ZPP1 = CUTPNT + 1 CALL DCOPY( N-CUTPNT, Q( ZPP1, ZPP1 ), LDQ, WORK( IZ+CUTPNT ), 1 ) ! ! Deflate eigenvalues. ! CALL DLAED2( K, N, CUTPNT, D, Q, LDQ, INDXQ, RHO, WORK( IZ ),& WORK( IDLMDA ), WORK( IW ), WORK( IQ2 ),& IWORK( INDX ), IWORK( INDXC ), IWORK( INDXP ),& IWORK( COLTYP ), INFO ) ! IF( INFO.NE.0 ) GO TO 20 ! ! Solve Secular Equation. ! IF( K.NE.0 ) THEN IS = ( IWORK( COLTYP )+IWORK( COLTYP+1 ) )*CUTPNT +& ( IWORK( COLTYP+1 )+IWORK( COLTYP+2 ) )*( N-CUTPNT ) + IQ2 CALL DLAED3( K, N, CUTPNT, D, Q, LDQ, RHO, WORK( IDLMDA ),& WORK( IQ2 ), IWORK( INDXC ), IWORK( COLTYP ),& WORK( IW ), WORK( IS ), INFO ) IF( INFO.NE.0 ) GO TO 20 ! ! Prepare the INDXQ sorting permutation. ! N1 = K N2 = N - K CALL DLAMRG( N1, N2, D, 1, -1, INDXQ ) ELSE DO 10 I = 1, N INDXQ( I ) = I 10 CONTINUE END IF ! 20 CONTINUE RETURN ! ! End of DLAED1 ! END SUBROUTINE DLAED1 ! != ! !> \brief \b DLAED7 used by sstedc. Computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. Used when the original matrix is dense. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLAED7 + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, ! LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR, ! PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, ! INFO ) ! ! .. Scalar Arguments .. ! INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N, ! $ QSIZ, TLVLS ! DOUBLE PRECISION RHO ! .. ! .. Array Arguments .. ! INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ), ! $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * ) ! DOUBLE PRECISION D( * ), GIVNUM( 2, * ), Q( LDQ, * ), ! $ QSTORE( * ), WORK( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLAED7 computes the updated eigensystem of a diagonal !> matrix after modification by a rank-one symmetric matrix. This !> routine is used only for the eigenproblem which requires all !> eigenvalues and optionally eigenvectors of a dense symmetric matrix !> that has been reduced to tridiagonal form. DLAED1 handles !> the case in which all eigenvalues and eigenvectors of a symmetric !> tridiagonal matrix are desired. !> !> T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out) !> !> where Z = Q**Tu, u is a vector of length N with ones in the !> CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. !> !> The eigenvectors of the original matrix are stored in Q, and the !> eigenvalues are in D. The algorithm consists of three stages: !> !> The first stage consists of deflating the size of the problem !> when there are multiple eigenvalues or if there is a zero in !> the Z vector. For each such occurence the dimension of the !> secular equation problem is reduced by one. This stage is !> performed by the routine DLAED8. !> !> The second stage consists of calculating the updated !> eigenvalues. This is done by finding the roots of the secular !> equation via the routine DLAED4 (as called by DLAED9). !> This routine also calculates the eigenvectors of the current !> problem. !> !> The final stage consists of computing the updated eigenvectors !> directly using the updated eigenvalues. The eigenvectors for !> the current problem are multiplied with the eigenvectors from !> the overall problem. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] ICOMPQ !> \verbatim !> ICOMPQ is INTEGER !> = 0: Compute eigenvalues only. !> = 1: Compute eigenvectors of original dense symmetric matrix !> also. On entry, Q contains the orthogonal matrix used !> to reduce the original matrix to tridiagonal form. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The dimension of the symmetric tridiagonal matrix. N >= 0. !> \endverbatim !> !> \param[in] QSIZ !> \verbatim !> QSIZ is INTEGER !> The dimension of the orthogonal matrix used to reduce !> the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. !> \endverbatim !> !> \param[in] TLVLS !> \verbatim !> TLVLS is INTEGER !> The total number of merging levels in the overall divide and !> conquer tree. !> \endverbatim !> !> \param[in] CURLVL !> \verbatim !> CURLVL is INTEGER !> The current level in the overall merge routine, !> 0 <= CURLVL <= TLVLS. !> \endverbatim !> !> \param[in] CURPBM !> \verbatim !> CURPBM is INTEGER !> The current problem in the current level in the overall !> merge routine (counting from upper left to lower right). !> \endverbatim !> !> \param[in,out] D !> \verbatim !> D is DOUBLE PRECISION array, dimension (N) !> On entry, the eigenvalues of the rank-1-perturbed matrix. !> On exit, the eigenvalues of the repaired matrix. !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is DOUBLE PRECISION array, dimension (LDQ, N) !> On entry, the eigenvectors of the rank-1-perturbed matrix. !> On exit, the eigenvectors of the repaired tridiagonal matrix. !> \endverbatim !> !> \param[in] LDQ !> \verbatim !> LDQ is INTEGER !> The leading dimension of the array Q. LDQ >= max(1,N). !> \endverbatim !> !> \param[out] INDXQ !> \verbatim !> INDXQ is INTEGER array, dimension (N) !> The permutation which will reintegrate the subproblem just !> solved back into sorted order, i.e., D( INDXQ( I = 1, N ) ) !> will be in ascending order. !> \endverbatim !> !> \param[in] RHO !> \verbatim !> RHO is DOUBLE PRECISION !> The subdiagonal element used to create the rank-1 !> modification. !> \endverbatim !> !> \param[in] CUTPNT !> \verbatim !> CUTPNT is INTEGER !> Contains the location of the last eigenvalue in the leading !> sub-matrix. min(1,N) <= CUTPNT <= N. !> \endverbatim !> !> \param[in,out] QSTORE !> \verbatim !> QSTORE is DOUBLE PRECISION array, dimension (N**2+1) !> Stores eigenvectors of submatrices encountered during !> divide and conquer, packed together. QPTR points to !> beginning of the submatrices. !> \endverbatim !> !> \param[in,out] QPTR !> \verbatim !> QPTR is INTEGER array, dimension (N+2) !> List of indices pointing to beginning of submatrices stored !> in QSTORE. The submatrices are numbered starting at the !> bottom left of the divide and conquer tree, from left to !> right and bottom to top. !> \endverbatim !> !> \param[in] PRMPTR !> \verbatim !> PRMPTR is INTEGER array, dimension (N lg N) !> Contains a list of pointers which indicate where in PERM a !> level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) !> indicates the size of the permutation and also the size of !> the full, non-deflated problem. !> \endverbatim !> !> \param[in] PERM !> \verbatim !> PERM is INTEGER array, dimension (N lg N) !> Contains the permutations (from deflation and sorting) to be !> applied to each eigenblock. !> \endverbatim !> !> \param[in] GIVPTR !> \verbatim !> GIVPTR is INTEGER array, dimension (N lg N) !> Contains a list of pointers which indicate where in GIVCOL a !> level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) !> indicates the number of Givens rotations. !> \endverbatim !> !> \param[in] GIVCOL !> \verbatim !> GIVCOL is INTEGER array, dimension (2, N lg N) !> Each pair of numbers indicates a pair of columns to take place !> in a Givens rotation. !> \endverbatim !> !> \param[in] GIVNUM !> \verbatim !> GIVNUM is DOUBLE PRECISION array, dimension (2, N lg N) !> Each number indicates the S value to be used in the !> corresponding Givens rotation. !> \endverbatim !> !> \param[out] WORK !> \verbatim !> WORK is DOUBLE PRECISION array, dimension (3*N+2*QSIZ*N) !> \endverbatim !> !> \param[out] IWORK !> \verbatim !> IWORK is INTEGER array, dimension (4*N) !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !> > 0: if INFO = 1, an eigenvalue did not converge !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2015 ! !> \ingroup auxOTHERcomputational ! !> \par Contributors: ! ================== !> !> Jeff Rutter, Computer Science Division, University of California !> at Berkeley, USA ! ! ===================================================================== SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q,& LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR,& PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK,& INFO ) ! ! -- LAPACK computational routine (version 3.6.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2015 ! ! .. Scalar Arguments .. INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N,& QSIZ, TLVLS DOUBLE PRECISION RHO ! .. ! .. Array Arguments .. INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),& IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * ) DOUBLE PRECISION D( * ), GIVNUM( 2, * ), Q( LDQ, * ),& QSTORE( * ), WORK( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) ! .. ! .. Local Scalars .. INTEGER COLTYP, CURR, I, IDLMDA, INDX, INDXC, INDXP,& IQ2, IS, IW, IZ, K, LDQ2, N1, N2, PTR ! .. ! .. External Subroutines .. ! EXTERNAL DGEMM, DLAED8, DLAED9, DLAEDA, DLAMRG, XERBLA ! .. ! .. Intrinsic Functions .. ! INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! INFO = 0 ! IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN INFO = -3 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN INFO = -12 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLAED7', -INFO ) RETURN END IF ! ! Quick return if possible ! IF( N.EQ.0 ) RETURN ! ! The following values are for bookkeeping purposes only. They are ! integer pointers which indicate the portion of the workspace ! used by a particular array in DLAED8 and DLAED9. ! IF( ICOMPQ.EQ.1 ) THEN LDQ2 = QSIZ ELSE LDQ2 = N END IF ! IZ = 1 IDLMDA = IZ + N IW = IDLMDA + N IQ2 = IW + N IS = IQ2 + N*LDQ2 ! INDX = 1 INDXC = INDX + N COLTYP = INDXC + N INDXP = COLTYP + N ! ! Form the z-vector which consists of the last row of Q_1 and the ! first row of Q_2. ! PTR = 1 + 2**TLVLS DO 10 I = 1, CURLVL - 1 PTR = PTR + 2**( TLVLS-I ) 10 CONTINUE CURR = PTR + CURPBM CALL DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,& GIVCOL, GIVNUM, QSTORE, QPTR, WORK( IZ ),& WORK( IZ+N ), INFO ) ! ! When solving the final problem, we no longer need the stored data, ! so we will overwrite the data from this level onto the previously ! used storage space. ! IF( CURLVL.EQ.TLVLS ) THEN QPTR( CURR ) = 1 PRMPTR( CURR ) = 1 GIVPTR( CURR ) = 1 END IF ! ! Sort and Deflate eigenvalues. ! CALL DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT,& WORK( IZ ), WORK( IDLMDA ), WORK( IQ2 ), LDQ2,& WORK( IW ), PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ),& GIVCOL( 1, GIVPTR( CURR ) ),& GIVNUM( 1, GIVPTR( CURR ) ), IWORK( INDXP ),& IWORK( INDX ), INFO ) PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR ) ! ! Solve Secular Equation. ! IF( K.NE.0 ) THEN CALL DLAED9( K, 1, K, N, D, WORK( IS ), K, RHO, WORK( IDLMDA ),& WORK( IW ), QSTORE( QPTR( CURR ) ), K, INFO ) IF( INFO.NE.0 ) GO TO 30 IF( ICOMPQ.EQ.1 ) THEN CALL DGEMM( 'N', 'N', QSIZ, K, K, ONE, WORK( IQ2 ), LDQ2,& QSTORE( QPTR( CURR ) ), K, ZERO, Q, LDQ ) END IF QPTR( CURR+1 ) = QPTR( CURR ) + K**2 ! ! Prepare the INDXQ sorting permutation. ! N1 = K N2 = N - K CALL DLAMRG( N1, N2, D, 1, -1, INDXQ ) ELSE QPTR( CURR+1 ) = QPTR( CURR ) DO 20 I = 1, N INDXQ( I ) = I 20 CONTINUE END IF ! 30 CONTINUE RETURN ! ! End of DLAED7 ! END SUBROUTINE DLAED7 ! != ! !> \brief \b DLAED8 used by sstedc. Merges eigenvalues and deflates secular equation. Used when the original matrix is dense. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLAED8 + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, ! CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, ! GIVCOL, GIVNUM, INDXP, INDX, INFO ) ! ! .. Scalar Arguments .. ! INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N, ! $ QSIZ ! DOUBLE PRECISION RHO ! .. ! .. Array Arguments .. ! INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ), ! $ INDXQ( * ), PERM( * ) ! DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ), ! $ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLAED8 merges the two sets of eigenvalues together into a single !> sorted set. Then it tries to deflate the size of the problem. !> There are two ways in which deflation can occur: when two or more !> eigenvalues are close together or if there is a tiny element in the !> Z vector. For each such occurrence the order of the related secular !> equation problem is reduced by one. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] ICOMPQ !> \verbatim !> ICOMPQ is INTEGER !> = 0: Compute eigenvalues only. !> = 1: Compute eigenvectors of original dense symmetric matrix !> also. On entry, Q contains the orthogonal matrix used !> to reduce the original matrix to tridiagonal form. !> \endverbatim !> !> \param[out] K !> \verbatim !> K is INTEGER !> The number of non-deflated eigenvalues, and the order of the !> related secular equation. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The dimension of the symmetric tridiagonal matrix. N >= 0. !> \endverbatim !> !> \param[in] QSIZ !> \verbatim !> QSIZ is INTEGER !> The dimension of the orthogonal matrix used to reduce !> the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. !> \endverbatim !> !> \param[in,out] D !> \verbatim !> D is DOUBLE PRECISION array, dimension (N) !> On entry, the eigenvalues of the two submatrices to be !> combined. On exit, the trailing (N-K) updated eigenvalues !> (those which were deflated) sorted into increasing order. !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is DOUBLE PRECISION array, dimension (LDQ,N) !> If ICOMPQ = 0, Q is not referenced. Otherwise, !> on entry, Q contains the eigenvectors of the partially solved !> system which has been previously updated in matrix !> multiplies with other partially solved eigensystems. !> On exit, Q contains the trailing (N-K) updated eigenvectors !> (those which were deflated) in its last N-K columns. !> \endverbatim !> !> \param[in] LDQ !> \verbatim !> LDQ is INTEGER !> The leading dimension of the array Q. LDQ >= max(1,N). !> \endverbatim !> !> \param[in] INDXQ !> \verbatim !> INDXQ is INTEGER array, dimension (N) !> The permutation which separately sorts the two sub-problems !> in D into ascending order. Note that elements in the second !> half of this permutation must first have CUTPNT added to !> their values in order to be accurate. !> \endverbatim !> !> \param[in,out] RHO !> \verbatim !> RHO is DOUBLE PRECISION !> On entry, the off-diagonal element associated with the rank-1 !> cut which originally split the two submatrices which are now !> being recombined. !> On exit, RHO has been modified to the value required by !> DLAED3. !> \endverbatim !> !> \param[in] CUTPNT !> \verbatim !> CUTPNT is INTEGER !> The location of the last eigenvalue in the leading !> sub-matrix. min(1,N) <= CUTPNT <= N. !> \endverbatim !> !> \param[in] Z !> \verbatim !> Z is DOUBLE PRECISION array, dimension (N) !> On entry, Z contains the updating vector (the last row of !> the first sub-eigenvector matrix and the first row of the !> second sub-eigenvector matrix). !> On exit, the contents of Z are destroyed by the updating !> process. !> \endverbatim !> !> \param[out] DLAMDA !> \verbatim !> DLAMDA is DOUBLE PRECISION array, dimension (N) !> A copy of the first K eigenvalues which will be used by !> DLAED3 to form the secular equation. !> \endverbatim !> !> \param[out] Q2 !> \verbatim !> Q2 is DOUBLE PRECISION array, dimension (LDQ2,N) !> If ICOMPQ = 0, Q2 is not referenced. Otherwise, !> a copy of the first K eigenvectors which will be used by !> DLAED7 in a matrix multiply (DGEMM) to update the new !> eigenvectors. !> \endverbatim !> !> \param[in] LDQ2 !> \verbatim !> LDQ2 is INTEGER !> The leading dimension of the array Q2. LDQ2 >= max(1,N). !> \endverbatim !> !> \param[out] W !> \verbatim !> W is DOUBLE PRECISION array, dimension (N) !> The first k values of the final deflation-altered z-vector and !> will be passed to DLAED3. !> \endverbatim !> !> \param[out] PERM !> \verbatim !> PERM is INTEGER array, dimension (N) !> The permutations (from deflation and sorting) to be applied !> to each eigenblock. !> \endverbatim !> !> \param[out] GIVPTR !> \verbatim !> GIVPTR is INTEGER !> The number of Givens rotations which took place in this !> subproblem. !> \endverbatim !> !> \param[out] GIVCOL !> \verbatim !> GIVCOL is INTEGER array, dimension (2, N) !> Each pair of numbers indicates a pair of columns to take place !> in a Givens rotation. !> \endverbatim !> !> \param[out] GIVNUM !> \verbatim !> GIVNUM is DOUBLE PRECISION array, dimension (2, N) !> Each number indicates the S value to be used in the !> corresponding Givens rotation. !> \endverbatim !> !> \param[out] INDXP !> \verbatim !> INDXP is INTEGER array, dimension (N) !> The permutation used to place deflated values of D at the end !> of the array. INDXP(1:K) points to the nondeflated D-values !> and INDXP(K+1:N) points to the deflated eigenvalues. !> \endverbatim !> !> \param[out] INDX !> \verbatim !> INDX is INTEGER array, dimension (N) !> The permutation used to sort the contents of D into ascending !> order. !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup auxOTHERcomputational ! !> \par Contributors: ! ================== !> !> Jeff Rutter, Computer Science Division, University of California !> at Berkeley, USA ! ! ===================================================================== SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO,& CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR,& GIVCOL, GIVNUM, INDXP, INDX, INFO ) ! ! -- LAPACK computational routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N,& QSIZ DOUBLE PRECISION RHO ! .. ! .. Array Arguments .. INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ),& INDXQ( * ), PERM( * ) DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ),& Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0,& TWO = 2.0D0, EIGHT = 8.0D0 ) ! .. ! .. Local Scalars .. ! INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2 DOUBLE PRECISION C, EPS, S, T, TAU, TOL ! .. ! .. External Functions .. ! INTEGER IDAMAX ! DOUBLE PRECISION DLAMCH, DLAPY2 ! EXTERNAL IDAMAX, DLAMCH, DLAPY2 ! .. ! .. External Subroutines .. ! EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA ! .. ! .. Intrinsic Functions .. ! INTRINSIC ABS, MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! INFO = 0 ! IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN INFO = -4 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN INFO = -10 ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN INFO = -14 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLAED8', -INFO ) RETURN END IF ! ! Need to initialize GIVPTR to O here in case of quick exit ! to prevent an unspecified code behavior (usually sigfault) ! when IWORK array on entry to *stedc is not zeroed ! (or at least some IWORK entries which used in *laed7 for GIVPTR). ! GIVPTR = 0 ! ! Quick return if possible ! IF( N.EQ.0 ) RETURN ! N1 = CUTPNT N2 = N - N1 N1P1 = N1 + 1 ! IF( RHO.LT.ZERO ) THEN CALL DSCAL( N2, MONE, Z( N1P1 ), 1 ) END IF ! ! Normalize z so that norm(z) = 1 ! T = ONE / SQRT( TWO ) DO 10 J = 1, N INDX( J ) = J 10 CONTINUE CALL DSCAL( N, T, Z, 1 ) RHO = ABS( TWO*RHO ) ! ! Sort the eigenvalues into increasing order ! DO 20 I = CUTPNT + 1, N INDXQ( I ) = INDXQ( I ) + CUTPNT 20 CONTINUE DO 30 I = 1, N DLAMDA( I ) = D( INDXQ( I ) ) W( I ) = Z( INDXQ( I ) ) 30 CONTINUE I = 1 J = CUTPNT + 1 CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDX ) DO 40 I = 1, N D( I ) = DLAMDA( INDX( I ) ) Z( I ) = W( INDX( I ) ) 40 CONTINUE ! ! Calculate the allowable deflation tolerence ! IMAX = IDAMAX( N, Z, 1 ) JMAX = IDAMAX( N, D, 1 ) EPS = DLAMCH( 'Epsilon' ) TOL = EIGHT*EPS*ABS( D( JMAX ) ) ! ! If the rank-1 modifier is small enough, no more needs to be done ! except to reorganize Q so that its columns correspond with the ! elements in D. ! IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN K = 0 IF( ICOMPQ.EQ.0 ) THEN DO 50 J = 1, N PERM( J ) = INDXQ( INDX( J ) ) 50 CONTINUE ELSE DO 60 J = 1, N PERM( J ) = INDXQ( INDX( J ) ) CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 ) 60 CONTINUE CALL DLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ), LDQ ) END IF RETURN END IF ! ! If there are multiple eigenvalues then the problem deflates. Here ! the number of equal eigenvalues are found. As each equal ! eigenvalue is found, an elementary reflector is computed to rotate ! the corresponding eigensubspace so that the corresponding ! components of Z are zero in this new basis. ! K = 0 K2 = N + 1 DO 70 J = 1, N IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN ! ! Deflate due to small z component. ! K2 = K2 - 1 INDXP( K2 ) = J IF( J.EQ.N ) GO TO 110 ELSE JLAM = J GO TO 80 END IF 70 CONTINUE 80 CONTINUE J = J + 1 IF( J.GT.N ) GO TO 100 IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN ! ! Deflate due to small z component. ! K2 = K2 - 1 INDXP( K2 ) = J ELSE ! ! Check if eigenvalues are close enough to allow deflation. ! S = Z( JLAM ) C = Z( J ) ! ! Find sqrt(a**2+b**2) without overflow or ! destructive underflow. ! TAU = DLAPY2( C, S ) T = D( J ) - D( JLAM ) C = C / TAU S = -S / TAU IF( ABS( T*C*S ).LE.TOL ) THEN ! ! Deflation is possible. ! Z( J ) = TAU Z( JLAM ) = ZERO ! ! Record the appropriate Givens rotation ! GIVPTR = GIVPTR + 1 GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) ) GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) ) GIVNUM( 1, GIVPTR ) = C GIVNUM( 2, GIVPTR ) = S IF( ICOMPQ.EQ.1 ) THEN CALL DROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1,& Q( 1, INDXQ( INDX( J ) ) ), 1, C, S ) END IF T = D( JLAM )*C*C + D( J )*S*S D( J ) = D( JLAM )*S*S + D( J )*C*C D( JLAM ) = T K2 = K2 - 1 I = 1 90 CONTINUE IF( K2+I.LE.N ) THEN IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN INDXP( K2+I-1 ) = INDXP( K2+I ) INDXP( K2+I ) = JLAM I = I + 1 GO TO 90 ELSE INDXP( K2+I-1 ) = JLAM END IF ELSE INDXP( K2+I-1 ) = JLAM END IF JLAM = J ELSE K = K + 1 W( K ) = Z( JLAM ) DLAMDA( K ) = D( JLAM ) INDXP( K ) = JLAM JLAM = J END IF END IF GO TO 80 100 CONTINUE ! ! Record the last eigenvalue. ! K = K + 1 W( K ) = Z( JLAM ) DLAMDA( K ) = D( JLAM ) INDXP( K ) = JLAM ! 110 CONTINUE ! ! Sort the eigenvalues and corresponding eigenvectors into DLAMDA ! and Q2 respectively. The eigenvalues/vectors which were not ! deflated go into the first K slots of DLAMDA and Q2 respectively, ! while those which were deflated go into the last N - K slots. ! IF( ICOMPQ.EQ.0 ) THEN DO 120 J = 1, N JP = INDXP( J ) DLAMDA( J ) = D( JP ) PERM( J ) = INDXQ( INDX( JP ) ) 120 CONTINUE ELSE DO 130 J = 1, N JP = INDXP( J ) DLAMDA( J ) = D( JP ) PERM( J ) = INDXQ( INDX( JP ) ) CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 ) 130 CONTINUE END IF ! ! The deflated eigenvalues and their corresponding vectors go back ! into the last N - K slots of D and Q respectively. ! IF( K.LT.N ) THEN IF( ICOMPQ.EQ.0 ) THEN CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 ) ELSE CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 ) CALL DLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2,& Q( 1, K+1 ), LDQ ) END IF END IF ! RETURN ! ! End of DLAED8 ! END SUBROUTINE DLAED8 ! != ! !> \brief \b DLAED9 used by sstedc. Finds the roots of the secular equation and updates the eigenvectors. Used when the original matrix is dense. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLAED9 + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, ! S, LDS, INFO ) ! ! .. Scalar Arguments .. ! INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N ! DOUBLE PRECISION RHO ! .. ! .. Array Arguments .. ! DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ), ! $ W( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLAED9 finds the roots of the secular equation, as defined by the !> values in D, Z, and RHO, between KSTART and KSTOP. It makes the !> appropriate calls to DLAED4 and then stores the new matrix of !> eigenvectors for use in calculating the next level of Z vectors. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] K !> \verbatim !> K is INTEGER !> The number of terms in the rational function to be solved by !> DLAED4. K >= 0. !> \endverbatim !> !> \param[in] KSTART !> \verbatim !> KSTART is INTEGER !> \endverbatim !> !> \param[in] KSTOP !> \verbatim !> KSTOP is INTEGER !> The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP !> are to be computed. 1 <= KSTART <= KSTOP <= K. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The number of rows and columns in the Q matrix. !> N >= K (delation may result in N > K). !> \endverbatim !> !> \param[out] D !> \verbatim !> D is DOUBLE PRECISION array, dimension (N) !> D(I) contains the updated eigenvalues !> for KSTART <= I <= KSTOP. !> \endverbatim !> !> \param[out] Q !> \verbatim !> Q is DOUBLE PRECISION array, dimension (LDQ,N) !> \endverbatim !> !> \param[in] LDQ !> \verbatim !> LDQ is INTEGER !> The leading dimension of the array Q. LDQ >= max( 1, N ). !> \endverbatim !> !> \param[in] RHO !> \verbatim !> RHO is DOUBLE PRECISION !> The value of the parameter in the rank one update equation. !> RHO >= 0 required. !> \endverbatim !> !> \param[in] DLAMDA !> \verbatim !> DLAMDA is DOUBLE PRECISION array, dimension (K) !> The first K elements of this array contain the old roots !> of the deflated updating problem. These are the poles !> of the secular equation. !> \endverbatim !> !> \param[in] W !> \verbatim !> W is DOUBLE PRECISION array, dimension (K) !> The first K elements of this array contain the components !> of the deflation-adjusted updating vector. !> \endverbatim !> !> \param[out] S !> \verbatim !> S is DOUBLE PRECISION array, dimension (LDS, K) !> Will contain the eigenvectors of the repaired matrix which !> will be stored for subsequent Z vector calculation and !> multiplied by the previously accumulated eigenvectors !> to update the system. !> \endverbatim !> !> \param[in] LDS !> \verbatim !> LDS is INTEGER !> The leading dimension of S. LDS >= max( 1, K ). !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !> > 0: if INFO = 1, an eigenvalue did not converge !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup auxOTHERcomputational ! !> \par Contributors: ! ================== !> !> Jeff Rutter, Computer Science Division, University of California !> at Berkeley, USA ! ! ===================================================================== SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W,& S, LDS, INFO ) ! ! -- LAPACK computational routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N DOUBLE PRECISION RHO ! .. ! .. Array Arguments .. DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ),& W( * ) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. INTEGER I, J DOUBLE PRECISION TEMP ! .. ! .. External Functions .. ! DOUBLE PRECISION DLAMC3, DNRM2 ! EXTERNAL DLAMC3, DNRM2 ! .. ! .. External Subroutines .. ! EXTERNAL DCOPY, DLAED4, XERBLA ! .. ! .. Intrinsic Functions .. ! INTRINSIC MAX, SIGN, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! INFO = 0 ! IF( K.LT.0 ) THEN INFO = -1 ELSE IF( KSTART.LT.1 .OR. KSTART.GT.MAX( 1, K ) ) THEN INFO = -2 ELSE IF( MAX( 1, KSTOP ).LT.KSTART .OR. KSTOP.GT.MAX( 1, K ) ) THEN INFO = -3 ELSE IF( N.LT.K ) THEN INFO = -4 ELSE IF( LDQ.LT.MAX( 1, K ) ) THEN INFO = -7 ELSE IF( LDS.LT.MAX( 1, K ) ) THEN INFO = -12 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLAED9', -INFO ) RETURN END IF ! ! Quick return if possible ! IF( K.EQ.0 ) RETURN ! ! Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can ! be computed with high relative accuracy (barring over/underflow). ! This is a problem on machines without a guard digit in ! add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). ! The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), ! which on any of these machines zeros out the bottommost ! bit of DLAMDA(I) if it is 1; this makes the subsequent ! subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation ! occurs. On binary machines with a guard digit (almost all ! machines) it does not change DLAMDA(I) at all. On hexadecimal ! and decimal machines with a guard digit, it slightly ! changes the bottommost bits of DLAMDA(I). It does not account ! for hexadecimal or decimal machines without guard digits ! (we know of none). We use a subroutine call to compute ! 2*DLAMBDA(I) to prevent optimizing compilers from eliminating ! this code. ! DO 10 I = 1, N DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I ) 10 CONTINUE ! DO 20 J = KSTART, KSTOP CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO ) ! ! If the zero finder fails, the computation is terminated. ! IF( INFO.NE.0 ) GO TO 120 20 CONTINUE ! IF( K.EQ.1 .OR. K.EQ.2 ) THEN DO 40 I = 1, K DO 30 J = 1, K S( J, I ) = Q( J, I ) 30 CONTINUE 40 CONTINUE GO TO 120 END IF ! ! Compute updated W. ! CALL DCOPY( K, W, 1, S, 1 ) ! ! Initialize W(I) = Q(I,I) ! CALL DCOPY( K, Q, LDQ+1, W, 1 ) DO 70 J = 1, K DO 50 I = 1, J - 1 W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) ) 50 CONTINUE DO 60 I = J + 1, K W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) ) 60 CONTINUE 70 CONTINUE DO 80 I = 1, K W( I ) = SIGN( SQRT( -W( I ) ), S( I, 1 ) ) 80 CONTINUE ! ! Compute eigenvectors of the modified rank-1 modification. ! DO 110 J = 1, K DO 90 I = 1, K Q( I, J ) = W( I ) / Q( I, J ) 90 CONTINUE TEMP = DNRM2( K, Q( 1, J ), 1 ) DO 100 I = 1, K S( I, J ) = Q( I, J ) / TEMP 100 CONTINUE 110 CONTINUE ! 120 CONTINUE RETURN ! ! End of DLAED9 ! END SUBROUTINE DLAED9 ! != ! !> \brief \b DLAED2 used by sstedc. Merges eigenvalues and deflates secular equation. Used when the original matrix is tridiagonal. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLAED2 + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, ! Q2, INDX, INDXC, INDXP, COLTYP, INFO ) ! ! .. Scalar Arguments .. ! INTEGER INFO, K, LDQ, N, N1 ! DOUBLE PRECISION RHO ! .. ! .. Array Arguments .. ! INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ), ! $ INDXQ( * ) ! DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), ! $ W( * ), Z( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLAED2 merges the two sets of eigenvalues together into a single !> sorted set. Then it tries to deflate the size of the problem. !> There are two ways in which deflation can occur: when two or more !> eigenvalues are close together or if there is a tiny entry in the !> Z vector. For each such occurrence the order of the related secular !> equation problem is reduced by one. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[out] K !> \verbatim !> K is INTEGER !> The number of non-deflated eigenvalues, and the order of the !> related secular equation. 0 <= K <=N. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The dimension of the symmetric tridiagonal matrix. N >= 0. !> \endverbatim !> !> \param[in] N1 !> \verbatim !> N1 is INTEGER !> The location of the last eigenvalue in the leading sub-matrix. !> min(1,N) <= N1 <= N/2. !> \endverbatim !> !> \param[in,out] D !> \verbatim !> D is DOUBLE PRECISION array, dimension (N) !> On entry, D contains the eigenvalues of the two submatrices to !> be combined. !> On exit, D contains the trailing (N-K) updated eigenvalues !> (those which were deflated) sorted into increasing order. !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is DOUBLE PRECISION array, dimension (LDQ, N) !> On entry, Q contains the eigenvectors of two submatrices in !> the two square blocks with corners at (1,1), (N1,N1) !> and (N1+1, N1+1), (N,N). !> On exit, Q contains the trailing (N-K) updated eigenvectors !> (those which were deflated) in its last N-K columns. !> \endverbatim !> !> \param[in] LDQ !> \verbatim !> LDQ is INTEGER !> The leading dimension of the array Q. LDQ >= max(1,N). !> \endverbatim !> !> \param[in,out] INDXQ !> \verbatim !> INDXQ is INTEGER array, dimension (N) !> The permutation which separately sorts the two sub-problems !> in D into ascending order. Note that elements in the second !> half of this permutation must first have N1 added to their !> values. Destroyed on exit. !> \endverbatim !> !> \param[in,out] RHO !> \verbatim !> RHO is DOUBLE PRECISION !> On entry, the off-diagonal element associated with the rank-1 !> cut which originally split the two submatrices which are now !> being recombined. !> On exit, RHO has been modified to the value required by !> DLAED3. !> \endverbatim !> !> \param[in] Z !> \verbatim !> Z is DOUBLE PRECISION array, dimension (N) !> On entry, Z contains the updating vector (the last !> row of the first sub-eigenvector matrix and the first row of !> the second sub-eigenvector matrix). !> On exit, the contents of Z have been destroyed by the updating !> process. !> \endverbatim !> !> \param[out] DLAMDA !> \verbatim !> DLAMDA is DOUBLE PRECISION array, dimension (N) !> A copy of the first K eigenvalues which will be used by !> DLAED3 to form the secular equation. !> \endverbatim !> !> \param[out] W !> \verbatim !> W is DOUBLE PRECISION array, dimension (N) !> The first k values of the final deflation-altered z-vector !> which will be passed to DLAED3. !> \endverbatim !> !> \param[out] Q2 !> \verbatim !> Q2 is DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2) !> A copy of the first K eigenvectors which will be used by !> DLAED3 in a matrix multiply (DGEMM) to solve for the new !> eigenvectors. !> \endverbatim !> !> \param[out] INDX !> \verbatim !> INDX is INTEGER array, dimension (N) !> The permutation used to sort the contents of DLAMDA into !> ascending order. !> \endverbatim !> !> \param[out] INDXC !> \verbatim !> INDXC is INTEGER array, dimension (N) !> The permutation used to arrange the columns of the deflated !> Q matrix into three groups: the first group contains non-zero !> elements only at and above N1, the second contains !> non-zero elements only below N1, and the third is dense. !> \endverbatim !> !> \param[out] INDXP !> \verbatim !> INDXP is INTEGER array, dimension (N) !> The permutation used to place deflated values of D at the end !> of the array. INDXP(1:K) points to the nondeflated D-values !> and INDXP(K+1:N) points to the deflated eigenvalues. !> \endverbatim !> !> \param[out] COLTYP !> \verbatim !> COLTYP is INTEGER array, dimension (N) !> During execution, a label which will indicate which of the !> following types a column in the Q2 matrix is: !> 1 : non-zero in the upper half only; !> 2 : dense; !> 3 : non-zero in the lower half only; !> 4 : deflated. !> On exit, COLTYP(i) is the number of columns of type i, !> for i=1 to 4 only. !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup auxOTHERcomputational ! !> \par Contributors: ! ================== !> !> Jeff Rutter, Computer Science Division, University of California !> at Berkeley, USA \n !> Modified by Francoise Tisseur, University of Tennessee !> ! ===================================================================== SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W,& Q2, INDX, INDXC, INDXP, COLTYP, INFO ) ! ! -- LAPACK computational routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. INTEGER INFO, K, LDQ, N, N1 DOUBLE PRECISION RHO ! .. ! .. Array Arguments .. INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ),& INDXQ( * ) DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),& W( * ), Z( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0,& TWO = 2.0D0, EIGHT = 8.0D0 ) ! .. ! .. Local Arrays .. INTEGER CTOT( 4 ), PSM( 4 ) ! .. ! .. Local Scalars .. INTEGER CT, I, IMAX, IQ1, IQ2, J, JMAX, JS, K2, N1P1,& N2, NJ, PJ DOUBLE PRECISION C, EPS, S, T, TAU, TOL ! .. ! .. External Functions .. ! INTEGER IDAMAX ! DOUBLE PRECISION DLAMCH, DLAPY2 ! EXTERNAL IDAMAX, DLAMCH, DLAPY2 ! .. ! .. External Subroutines .. ! EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA ! .. ! .. Intrinsic Functions .. ! INTRINSIC ABS, MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! INFO = 0 ! IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( MIN( 1, ( N / 2 ) ).GT.N1 .OR. ( N / 2 ).LT.N1 ) THEN INFO = -3 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLAED2', -INFO ) RETURN END IF ! ! Quick return if possible ! IF( N.EQ.0 ) RETURN ! N2 = N - N1 N1P1 = N1 + 1 ! IF( RHO.LT.ZERO ) THEN CALL DSCAL( N2, MONE, Z( N1P1 ), 1 ) END IF ! ! Normalize z so that norm(z) = 1. Since z is the concatenation of ! two normalized vectors, norm2(z) = sqrt(2). ! T = ONE / SQRT( TWO ) CALL DSCAL( N, T, Z, 1 ) ! ! RHO = ABS( norm(z)**2 * RHO ) ! RHO = ABS( TWO*RHO ) ! ! Sort the eigenvalues into increasing order ! DO 10 I = N1P1, N INDXQ( I ) = INDXQ( I ) + N1 10 CONTINUE ! ! re-integrate the deflated parts from the last pass ! DO 20 I = 1, N DLAMDA( I ) = D( INDXQ( I ) ) 20 CONTINUE CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDXC ) DO 30 I = 1, N INDX( I ) = INDXQ( INDXC( I ) ) 30 CONTINUE ! ! Calculate the allowable deflation tolerance ! IMAX = IDAMAX( N, Z, 1 ) JMAX = IDAMAX( N, D, 1 ) EPS = DLAMCH( 'Epsilon' ) TOL = EIGHT*EPS*MAX( ABS( D( JMAX ) ), ABS( Z( IMAX ) ) ) ! ! If the rank-1 modifier is small enough, no more needs to be done ! except to reorganize Q so that its columns correspond with the ! elements in D. ! IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN K = 0 IQ2 = 1 DO 40 J = 1, N I = INDX( J ) CALL DCOPY( N, Q( 1, I ), 1, Q2( IQ2 ), 1 ) DLAMDA( J ) = D( I ) IQ2 = IQ2 + N 40 CONTINUE CALL DLACPY( 'A', N, N, Q2, N, Q, LDQ ) CALL DCOPY( N, DLAMDA, 1, D, 1 ) GO TO 190 END IF ! ! If there are multiple eigenvalues then the problem deflates. Here ! the number of equal eigenvalues are found. As each equal ! eigenvalue is found, an elementary reflector is computed to rotate ! the corresponding eigensubspace so that the corresponding ! components of Z are zero in this new basis. ! DO 50 I = 1, N1 COLTYP( I ) = 1 50 CONTINUE DO 60 I = N1P1, N COLTYP( I ) = 3 60 CONTINUE ! ! K = 0 K2 = N + 1 DO 70 J = 1, N NJ = INDX( J ) IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN ! ! Deflate due to small z component. ! K2 = K2 - 1 COLTYP( NJ ) = 4 INDXP( K2 ) = NJ IF( J.EQ.N ) GO TO 100 ELSE PJ = NJ GO TO 80 END IF 70 CONTINUE 80 CONTINUE J = J + 1 NJ = INDX( J ) IF( J.GT.N ) GO TO 100 IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN ! ! Deflate due to small z component. ! K2 = K2 - 1 COLTYP( NJ ) = 4 INDXP( K2 ) = NJ ELSE ! ! Check if eigenvalues are close enough to allow deflation. ! S = Z( PJ ) C = Z( NJ ) ! ! Find sqrt(a**2+b**2) without overflow or ! destructive underflow. ! TAU = DLAPY2( C, S ) T = D( NJ ) - D( PJ ) C = C / TAU S = -S / TAU IF( ABS( T*C*S ).LE.TOL ) THEN ! ! Deflation is possible. ! Z( NJ ) = TAU Z( PJ ) = ZERO IF( COLTYP( NJ ).NE.COLTYP( PJ ) ) COLTYP( NJ ) = 2 COLTYP( PJ ) = 4 CALL DROT( N, Q( 1, PJ ), 1, Q( 1, NJ ), 1, C, S ) T = D( PJ )*C**2 + D( NJ )*S**2 D( NJ ) = D( PJ )*S**2 + D( NJ )*C**2 D( PJ ) = T K2 = K2 - 1 I = 1 90 CONTINUE IF( K2+I.LE.N ) THEN IF( D( PJ ).LT.D( INDXP( K2+I ) ) ) THEN INDXP( K2+I-1 ) = INDXP( K2+I ) INDXP( K2+I ) = PJ I = I + 1 GO TO 90 ELSE INDXP( K2+I-1 ) = PJ END IF ELSE INDXP( K2+I-1 ) = PJ END IF PJ = NJ ELSE K = K + 1 DLAMDA( K ) = D( PJ ) W( K ) = Z( PJ ) INDXP( K ) = PJ PJ = NJ END IF END IF GO TO 80 100 CONTINUE ! ! Record the last eigenvalue. ! K = K + 1 DLAMDA( K ) = D( PJ ) W( K ) = Z( PJ ) INDXP( K ) = PJ ! ! Count up the total number of the various types of columns, then ! form a permutation which positions the four column types into ! four uniform groups (although one or more of these groups may be ! empty). ! DO 110 J = 1, 4 CTOT( J ) = 0 110 CONTINUE DO 120 J = 1, N CT = COLTYP( J ) CTOT( CT ) = CTOT( CT ) + 1 120 CONTINUE ! ! PSM(*) = Position in SubMatrix (of types 1 through 4) ! PSM( 1 ) = 1 PSM( 2 ) = 1 + CTOT( 1 ) PSM( 3 ) = PSM( 2 ) + CTOT( 2 ) PSM( 4 ) = PSM( 3 ) + CTOT( 3 ) K = N - CTOT( 4 ) ! ! Fill out the INDXC array so that the permutation which it induces ! will place all type-1 columns first, all type-2 columns next, ! then all type-3's, and finally all type-4's. ! DO 130 J = 1, N JS = INDXP( J ) CT = COLTYP( JS ) INDX( PSM( CT ) ) = JS INDXC( PSM( CT ) ) = J PSM( CT ) = PSM( CT ) + 1 130 CONTINUE ! ! Sort the eigenvalues and corresponding eigenvectors into DLAMDA ! and Q2 respectively. The eigenvalues/vectors which were not ! deflated go into the first K slots of DLAMDA and Q2 respectively, ! while those which were deflated go into the last N - K slots. ! I = 1 IQ1 = 1 IQ2 = 1 + ( CTOT( 1 )+CTOT( 2 ) )*N1 DO 140 J = 1, CTOT( 1 ) JS = INDX( I ) CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 ) Z( I ) = D( JS ) I = I + 1 IQ1 = IQ1 + N1 140 CONTINUE ! DO 150 J = 1, CTOT( 2 ) JS = INDX( I ) CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 ) CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 ) Z( I ) = D( JS ) I = I + 1 IQ1 = IQ1 + N1 IQ2 = IQ2 + N2 150 CONTINUE ! DO 160 J = 1, CTOT( 3 ) JS = INDX( I ) CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 ) Z( I ) = D( JS ) I = I + 1 IQ2 = IQ2 + N2 160 CONTINUE ! IQ1 = IQ2 DO 170 J = 1, CTOT( 4 ) JS = INDX( I ) CALL DCOPY( N, Q( 1, JS ), 1, Q2( IQ2 ), 1 ) IQ2 = IQ2 + N Z( I ) = D( JS ) I = I + 1 170 CONTINUE ! ! The deflated eigenvalues and their corresponding vectors go back ! into the last N - K slots of D and Q respectively. ! IF( K.LT.N ) THEN CALL DLACPY( 'A', N, CTOT( 4 ), Q2( IQ1 ), N, & Q( 1, K+1 ), LDQ ) CALL DCOPY( N-K, Z( K+1 ), 1, D( K+1 ), 1 ) END IF ! ! Copy CTOT into COLTYP for referencing in DLAED3. ! DO 180 J = 1, 4 COLTYP( J ) = CTOT( J ) 180 CONTINUE ! 190 CONTINUE RETURN ! ! End of DLAED2 ! END SUBROUTINE DLAED2 ! != ! !> \brief \b DLAED3 used by sstedc. Finds the roots of the secular equation and updates the eigenvectors. Used when the original matrix is tridiagonal. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLAED3 + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, ! CTOT, W, S, INFO ) ! ! .. Scalar Arguments .. ! INTEGER INFO, K, LDQ, N, N1 ! DOUBLE PRECISION RHO ! .. ! .. Array Arguments .. ! INTEGER CTOT( * ), INDX( * ) ! DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), ! $ S( * ), W( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLAED3 finds the roots of the secular equation, as defined by the !> values in D, W, and RHO, between 1 and K. It makes the !> appropriate calls to DLAED4 and then updates the eigenvectors by !> multiplying the matrix of eigenvectors of the pair of eigensystems !> being combined by the matrix of eigenvectors of the K-by-K system !> which is solved here. !> !> This code makes very mild assumptions about floating point !> arithmetic. It will work on machines with a guard digit in !> add/subtract, or on those binary machines without guard digits !> which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. !> It could conceivably fail on hexadecimal or decimal machines !> without guard digits, but we know of none. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] K !> \verbatim !> K is INTEGER !> The number of terms in the rational function to be solved by !> DLAED4. K >= 0. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The number of rows and columns in the Q matrix. !> N >= K (deflation may result in N>K). !> \endverbatim !> !> \param[in] N1 !> \verbatim !> N1 is INTEGER !> The location of the last eigenvalue in the leading submatrix. !> min(1,N) <= N1 <= N/2. !> \endverbatim !> !> \param[out] D !> \verbatim !> D is DOUBLE PRECISION array, dimension (N) !> D(I) contains the updated eigenvalues for !> 1 <= I <= K. !> \endverbatim !> !> \param[out] Q !> \verbatim !> Q is DOUBLE PRECISION array, dimension (LDQ,N) !> Initially the first K columns are used as workspace. !> On output the columns 1 to K contain !> the updated eigenvectors. !> \endverbatim !> !> \param[in] LDQ !> \verbatim !> LDQ is INTEGER !> The leading dimension of the array Q. LDQ >= max(1,N). !> \endverbatim !> !> \param[in] RHO !> \verbatim !> RHO is DOUBLE PRECISION !> The value of the parameter in the rank one update equation. !> RHO >= 0 required. !> \endverbatim !> !> \param[in,out] DLAMDA !> \verbatim !> DLAMDA is DOUBLE PRECISION array, dimension (K) !> The first K elements of this array contain the old roots !> of the deflated updating problem. These are the poles !> of the secular equation. May be changed on output by !> having lowest order bit set to zero on Cray X-MP, Cray Y-MP, !> Cray-2, or Cray C-90, as described above. !> \endverbatim !> !> \param[in] Q2 !> \verbatim !> Q2 is DOUBLE PRECISION array, dimension (LDQ2, N) !> The first K columns of this matrix contain the non-deflated !> eigenvectors for the split problem. !> \endverbatim !> !> \param[in] INDX !> \verbatim !> INDX is INTEGER array, dimension (N) !> The permutation used to arrange the columns of the deflated !> Q matrix into three groups (see DLAED2). !> The rows of the eigenvectors found by DLAED4 must be likewise !> permuted before the matrix multiply can take place. !> \endverbatim !> !> \param[in] CTOT !> \verbatim !> CTOT is INTEGER array, dimension (4) !> A count of the total number of the various types of columns !> in Q, as described in INDX. The fourth column type is any !> column which has been deflated. !> \endverbatim !> !> \param[in,out] W !> \verbatim !> W is DOUBLE PRECISION array, dimension (K) !> The first K elements of this array contain the components !> of the deflation-adjusted updating vector. Destroyed on !> output. !> \endverbatim !> !> \param[out] S !> \verbatim !> S is DOUBLE PRECISION array, dimension (N1 + 1)*K !> Will contain the eigenvectors of the repaired matrix which !> will be multiplied by the previously accumulated eigenvectors !> to update the system. !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !> > 0: if INFO = 1, an eigenvalue did not converge !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup auxOTHERcomputational ! !> \par Contributors: ! ================== !> !> Jeff Rutter, Computer Science Division, University of California !> at Berkeley, USA \n !> Modified by Francoise Tisseur, University of Tennessee !> ! ===================================================================== SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX,& CTOT, W, S, INFO ) ! ! -- LAPACK computational routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. INTEGER INFO, K, LDQ, N, N1 DOUBLE PRECISION RHO ! .. ! .. Array Arguments .. INTEGER CTOT( * ), INDX( * ) DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),& S( * ), W( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) ! .. ! .. Local Scalars .. INTEGER I, II, IQ2, J, N12, N2, N23 DOUBLE PRECISION TEMP ! .. ! .. External Functions .. ! DOUBLE PRECISION DLAMC3, DNRM2 ! EXTERNAL DLAMC3, DNRM2 ! .. ! .. External Subroutines .. ! EXTERNAL DCOPY, DGEMM, DLACPY, DLAED4, DLASET, XERBLA ! .. ! .. Intrinsic Functions .. ! INTRINSIC MAX, SIGN, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! INFO = 0 ! IF( K.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.K ) THEN INFO = -2 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLAED3', -INFO ) RETURN END IF ! ! Quick return if possible ! IF( K.EQ.0 ) RETURN ! ! Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can ! be computed with high relative accuracy (barring over/underflow). ! This is a problem on machines without a guard digit in ! add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). ! The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), ! which on any of these machines zeros out the bottommost ! bit of DLAMDA(I) if it is 1; this makes the subsequent ! subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation ! occurs. On binary machines with a guard digit (almost all ! machines) it does not change DLAMDA(I) at all. On hexadecimal ! and decimal machines with a guard digit, it slightly ! changes the bottommost bits of DLAMDA(I). It does not account ! for hexadecimal or decimal machines without guard digits ! (we know of none). We use a subroutine call to compute ! 2*DLAMBDA(I) to prevent optimizing compilers from eliminating ! this code. ! DO 10 I = 1, K DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I ) 10 CONTINUE ! DO 20 J = 1, K CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO ) ! ! If the zero finder fails, the computation is terminated. ! IF( INFO.NE.0 ) GO TO 120 20 CONTINUE ! IF( K.EQ.1 ) GO TO 110 IF( K.EQ.2 ) THEN DO 30 J = 1, K W( 1 ) = Q( 1, J ) W( 2 ) = Q( 2, J ) II = INDX( 1 ) Q( 1, J ) = W( II ) II = INDX( 2 ) Q( 2, J ) = W( II ) 30 CONTINUE GO TO 110 END IF ! ! Compute updated W. ! CALL DCOPY( K, W, 1, S, 1 ) ! ! Initialize W(I) = Q(I,I) ! CALL DCOPY( K, Q, LDQ+1, W, 1 ) DO 60 J = 1, K DO 40 I = 1, J - 1 W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) ) 40 CONTINUE DO 50 I = J + 1, K W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) ) 50 CONTINUE 60 CONTINUE DO 70 I = 1, K W( I ) = SIGN( SQRT( -W( I ) ), S( I ) ) 70 CONTINUE ! ! Compute eigenvectors of the modified rank-1 modification. ! DO 100 J = 1, K DO 80 I = 1, K S( I ) = W( I ) / Q( I, J ) 80 CONTINUE TEMP = DNRM2( K, S, 1 ) DO 90 I = 1, K II = INDX( I ) Q( I, J ) = S( II ) / TEMP 90 CONTINUE 100 CONTINUE ! ! Compute the updated eigenvectors. ! 110 CONTINUE ! N2 = N - N1 N12 = CTOT( 1 ) + CTOT( 2 ) N23 = CTOT( 2 ) + CTOT( 3 ) ! CALL DLACPY( 'A', N23, K, Q( CTOT( 1 )+1, 1 ), LDQ, S, N23 ) IQ2 = N1*N12 + 1 IF( N23.NE.0 ) THEN CALL DGEMM( 'N', 'N', N2, K, N23, ONE, Q2( IQ2 ), N2, S, N23,& ZERO, Q( N1+1, 1 ), LDQ ) ELSE CALL DLASET( 'A', N2, K, ZERO, ZERO, Q( N1+1, 1 ), LDQ ) END IF ! CALL DLACPY( 'A', N12, K, Q, LDQ, S, N12 ) IF( N12.NE.0 ) THEN CALL DGEMM( 'N', 'N', N1, K, N12, ONE, Q2, N1, S, N12, ZERO, Q,& LDQ ) ELSE CALL DLASET( 'A', N1, K, ZERO, ZERO, Q( 1, 1 ), LDQ ) END IF ! ! 120 CONTINUE RETURN ! ! End of DLAED3 ! END SUBROUTINE DLAED3 ! != ! !> \brief \b DLAED4 used by sstedc. Finds a single root of the secular equation. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLAED4 + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO ) ! ! .. Scalar Arguments .. ! INTEGER I, INFO, N ! DOUBLE PRECISION DLAM, RHO ! .. ! .. Array Arguments .. ! DOUBLE PRECISION D( * ), DELTA( * ), Z( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> This subroutine computes the I-th updated eigenvalue of a symmetric !> rank-one modification to a diagonal matrix whose elements are !> given in the array d, and that !> !> D(i) < D(j) for i < j !> !> and that RHO > 0. This is arranged by the calling routine, and is !> no loss in generality. The rank-one modified system is thus !> !> diag( D ) + RHO * Z * Z_transpose. !> !> where we assume the Euclidean norm of Z is 1. !> !> The method consists of approximating the rational functions in the !> secular equation by simpler interpolating rational functions. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] N !> \verbatim !> N is INTEGER !> The length of all arrays. !> \endverbatim !> !> \param[in] I !> \verbatim !> I is INTEGER !> The index of the eigenvalue to be computed. 1 <= I <= N. !> \endverbatim !> !> \param[in] D !> \verbatim !> D is DOUBLE PRECISION array, dimension (N) !> The original eigenvalues. It is assumed that they are in !> order, D(I) < D(J) for I < J. !> \endverbatim !> !> \param[in] Z !> \verbatim !> Z is DOUBLE PRECISION array, dimension (N) !> The components of the updating vector. !> \endverbatim !> !> \param[out] DELTA !> \verbatim !> DELTA is DOUBLE PRECISION array, dimension (N) !> If N .GT. 2, DELTA contains (D(j) - lambda_I) in its j-th !> component. If N = 1, then DELTA(1) = 1. If N = 2, see DLAED5 !> for detail. The vector DELTA contains the information necessary !> to construct the eigenvectors by DLAED3 and DLAED9. !> \endverbatim !> !> \param[in] RHO !> \verbatim !> RHO is DOUBLE PRECISION !> The scalar in the symmetric updating formula. !> \endverbatim !> !> \param[out] DLAM !> \verbatim !> DLAM is DOUBLE PRECISION !> The computed lambda_I, the I-th updated eigenvalue. !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit !> > 0: if INFO = 1, the updating process failed. !> \endverbatim ! !> \par Internal Parameters: ! ========================= !> !> \verbatim !> Logical variable ORGATI (origin-at-i?) is used for distinguishing !> whether D(i) or D(i+1) is treated as the origin. !> !> ORGATI = .true. origin at i !> ORGATI = .false. origin at i+1 !> !> Logical variable SWTCH3 (switch-for-3-poles?) is for noting !> if we are working with THREE poles! !> !> MAXIT is the maximum number of iterations allowed for each !> eigenvalue. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup auxOTHERcomputational ! !> \par Contributors: ! ================== !> !> Ren-Cang Li, Computer Science Division, University of California !> at Berkeley, USA !> ! ===================================================================== SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO ) ! ! -- LAPACK computational routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. INTEGER I, INFO, N DOUBLE PRECISION DLAM, RHO ! .. ! .. Array Arguments .. DOUBLE PRECISION D( * ), DELTA( * ), Z( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. INTEGER MAXIT PARAMETER ( MAXIT = 30 ) DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,& THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0,& TEN = 10.0D0 ) ! .. ! .. Local Scalars .. LOGICAL ORGATI, SWTCH, SWTCH3 INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER DOUBLE PRECISION A, B, C, DEL, DLTLB, DLTUB, DPHI, DPSI, DW,& EPS, ERRETM, ETA, MIDPT, PHI, PREW, PSI,& RHOINV, TAU, TEMP, TEMP1, W ! .. ! .. Local Arrays .. DOUBLE PRECISION ZZ( 3 ) ! .. ! .. External Functions .. ! DOUBLE PRECISION DLAMCH ! EXTERNAL DLAMCH ! .. ! .. External Subroutines .. ! EXTERNAL DLAED5, DLAED6 ! .. ! .. Intrinsic Functions .. ! INTRINSIC ABS, MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! ! Since this routine is called in an inner loop, we do no argument ! checking. ! ! Quick return for N=1 and 2. ! INFO = 0 IF( N.EQ.1 ) THEN ! ! Presumably, I=1 upon entry ! DLAM = D( 1 ) + RHO*Z( 1 )*Z( 1 ) DELTA( 1 ) = ONE RETURN END IF IF( N.EQ.2 ) THEN CALL DLAED5( I, D, Z, DELTA, RHO, DLAM ) RETURN END IF ! ! Compute machine epsilon ! EPS = DLAMCH( 'Epsilon' ) RHOINV = ONE / RHO ! ! The case I = N ! IF( I.EQ.N ) THEN ! ! Initialize some basic variables ! II = N - 1 NITER = 1 ! ! Calculate initial guess ! MIDPT = RHO / TWO ! ! If ||Z||_2 is not one, then TEMP should be set to ! RHO * ||Z||_2^2 / TWO ! DO 10 J = 1, N DELTA( J ) = ( D( J )-D( I ) ) - MIDPT 10 CONTINUE ! PSI = ZERO DO 20 J = 1, N - 2 PSI = PSI + Z( J )*Z( J ) / DELTA( J ) 20 CONTINUE ! C = RHOINV + PSI W = C + Z( II )*Z( II ) / DELTA( II ) +& Z( N )*Z( N ) / DELTA( N ) ! IF( W.LE.ZERO ) THEN TEMP = Z( N-1 )*Z( N-1 ) / ( D( N )-D( N-1 )+RHO ) +& Z( N )*Z( N ) / RHO IF( C.LE.TEMP ) THEN TAU = RHO ELSE DEL = D( N ) - D( N-1 ) A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N ) B = Z( N )*Z( N )*DEL IF( A.LT.ZERO ) THEN TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A ) ELSE TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C ) END IF END IF ! ! It can be proved that ! D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO ! DLTLB = MIDPT DLTUB = RHO ELSE DEL = D( N ) - D( N-1 ) A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N ) B = Z( N )*Z( N )*DEL IF( A.LT.ZERO ) THEN TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A ) ELSE TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C ) END IF ! ! It can be proved that ! D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2 ! DLTLB = ZERO DLTUB = MIDPT END IF ! DO 30 J = 1, N DELTA( J ) = ( D( J )-D( I ) ) - TAU 30 CONTINUE ! ! Evaluate PSI and the derivative DPSI ! DPSI = ZERO PSI = ZERO ERRETM = ZERO DO 40 J = 1, II TEMP = Z( J ) / DELTA( J ) PSI = PSI + Z( J )*TEMP DPSI = DPSI + TEMP*TEMP ERRETM = ERRETM + PSI 40 CONTINUE ERRETM = ABS( ERRETM ) ! ! Evaluate PHI and the derivative DPHI ! TEMP = Z( N ) / DELTA( N ) PHI = Z( N )*TEMP DPHI = TEMP*TEMP ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +& ABS( TAU )*( DPSI+DPHI ) ! W = RHOINV + PHI + PSI ! ! Test for convergence ! IF( ABS( W ).LE.EPS*ERRETM ) THEN DLAM = D( I ) + TAU GO TO 250 END IF ! IF( W.LE.ZERO ) THEN DLTLB = MAX( DLTLB, TAU ) ELSE DLTUB = MIN( DLTUB, TAU ) END IF ! ! Calculate the new step ! NITER = NITER + 1 C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI A = ( DELTA( N-1 )+DELTA( N ) )*W -& DELTA( N-1 )*DELTA( N )*( DPSI+DPHI ) B = DELTA( N-1 )*DELTA( N )*W IF( C.LT.ZERO ) C = ABS( C ) IF( C.EQ.ZERO ) THEN ! ETA = B/A ! ETA = RHO - TAU ETA = DLTUB - TAU ELSE IF( A.GE.ZERO ) THEN ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) ELSE ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) END IF ! ! Note, eta should be positive if w is negative, and ! eta should be negative otherwise. However, ! if for some reason caused by roundoff, eta*w > 0, ! we simply use one Newton step instead. This way ! will guarantee eta*w < 0. ! IF( W*ETA.GT.ZERO ) ETA = -W / ( DPSI+DPHI ) TEMP = TAU + ETA IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN IF( W.LT.ZERO ) THEN ETA = ( DLTUB-TAU ) / TWO ELSE ETA = ( DLTLB-TAU ) / TWO END IF END IF DO 50 J = 1, N DELTA( J ) = DELTA( J ) - ETA 50 CONTINUE ! TAU = TAU + ETA ! ! Evaluate PSI and the derivative DPSI ! DPSI = ZERO PSI = ZERO ERRETM = ZERO DO 60 J = 1, II TEMP = Z( J ) / DELTA( J ) PSI = PSI + Z( J )*TEMP DPSI = DPSI + TEMP*TEMP ERRETM = ERRETM + PSI 60 CONTINUE ERRETM = ABS( ERRETM ) ! ! Evaluate PHI and the derivative DPHI ! TEMP = Z( N ) / DELTA( N ) PHI = Z( N )*TEMP DPHI = TEMP*TEMP ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +& ABS( TAU )*( DPSI+DPHI ) ! W = RHOINV + PHI + PSI ! ! Main loop to update the values of the array DELTA ! ITER = NITER + 1 ! DO 90 NITER = ITER, MAXIT ! ! Test for convergence ! IF( ABS( W ).LE.EPS*ERRETM ) THEN DLAM = D( I ) + TAU GO TO 250 END IF ! IF( W.LE.ZERO ) THEN DLTLB = MAX( DLTLB, TAU ) ELSE DLTUB = MIN( DLTUB, TAU ) END IF ! ! Calculate the new step ! C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI A = ( DELTA( N-1 )+DELTA( N ) )*W -& DELTA( N-1 )*DELTA( N )*( DPSI+DPHI ) B = DELTA( N-1 )*DELTA( N )*W IF( A.GE.ZERO ) THEN ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) ELSE ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) END IF ! ! Note, eta should be positive if w is negative, and ! eta should be negative otherwise. However, ! if for some reason caused by roundoff, eta*w > 0, ! we simply use one Newton step instead. This way ! will guarantee eta*w < 0. ! IF( W*ETA.GT.ZERO )& ETA = -W / ( DPSI+DPHI ) TEMP = TAU + ETA IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN IF( W.LT.ZERO ) THEN ETA = ( DLTUB-TAU ) / TWO ELSE ETA = ( DLTLB-TAU ) / TWO END IF END IF DO 70 J = 1, N DELTA( J ) = DELTA( J ) - ETA 70 CONTINUE ! TAU = TAU + ETA ! ! Evaluate PSI and the derivative DPSI ! DPSI = ZERO PSI = ZERO ERRETM = ZERO DO 80 J = 1, II TEMP = Z( J ) / DELTA( J ) PSI = PSI + Z( J )*TEMP DPSI = DPSI + TEMP*TEMP ERRETM = ERRETM + PSI 80 CONTINUE ERRETM = ABS( ERRETM ) ! ! Evaluate PHI and the derivative DPHI ! TEMP = Z( N ) / DELTA( N ) PHI = Z( N )*TEMP DPHI = TEMP*TEMP ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +& ABS( TAU )*( DPSI+DPHI ) ! W = RHOINV + PHI + PSI 90 CONTINUE ! ! Return with INFO = 1, NITER = MAXIT and not converged ! INFO = 1 DLAM = D( I ) + TAU GO TO 250 ! ! End for the case I = N ! ELSE ! ! The case for I < N ! NITER = 1 IP1 = I + 1 ! ! Calculate initial guess ! DEL = D( IP1 ) - D( I ) MIDPT = DEL / TWO DO 100 J = 1, N DELTA( J ) = ( D( J )-D( I ) ) - MIDPT 100 CONTINUE ! PSI = ZERO DO 110 J = 1, I - 1 PSI = PSI + Z( J )*Z( J ) / DELTA( J ) 110 CONTINUE ! PHI = ZERO DO 120 J = N, I + 2, -1 PHI = PHI + Z( J )*Z( J ) / DELTA( J ) 120 CONTINUE C = RHOINV + PSI + PHI W = C + Z( I )*Z( I ) / DELTA( I ) +& Z( IP1 )*Z( IP1 ) / DELTA( IP1 ) ! IF( W.GT.ZERO ) THEN ! ! d(i)< the ith eigenvalue < (d(i)+d(i+1))/2 ! ! We choose d(i) as origin. ! ORGATI = .TRUE. A = C*DEL + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 ) B = Z( I )*Z( I )*DEL IF( A.GT.ZERO ) THEN TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) ELSE TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) END IF DLTLB = ZERO DLTUB = MIDPT ELSE ! ! (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1) ! ! We choose d(i+1) as origin. ! ORGATI = .FALSE. A = C*DEL - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 ) B = Z( IP1 )*Z( IP1 )*DEL IF( A.LT.ZERO ) THEN TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) ) ELSE TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C ) END IF DLTLB = -MIDPT DLTUB = ZERO END IF ! IF( ORGATI ) THEN DO 130 J = 1, N DELTA( J ) = ( D( J )-D( I ) ) - TAU 130 CONTINUE ELSE DO 140 J = 1, N DELTA( J ) = ( D( J )-D( IP1 ) ) - TAU 140 CONTINUE END IF IF( ORGATI ) THEN II = I ELSE II = I + 1 END IF IIM1 = II - 1 IIP1 = II + 1 ! ! Evaluate PSI and the derivative DPSI ! DPSI = ZERO PSI = ZERO ERRETM = ZERO DO 150 J = 1, IIM1 TEMP = Z( J ) / DELTA( J ) PSI = PSI + Z( J )*TEMP DPSI = DPSI + TEMP*TEMP ERRETM = ERRETM + PSI 150 CONTINUE ERRETM = ABS( ERRETM ) ! ! Evaluate PHI and the derivative DPHI ! DPHI = ZERO PHI = ZERO DO 160 J = N, IIP1, -1 TEMP = Z( J ) / DELTA( J ) PHI = PHI + Z( J )*TEMP DPHI = DPHI + TEMP*TEMP ERRETM = ERRETM + PHI 160 CONTINUE ! W = RHOINV + PHI + PSI ! ! W is the value of the secular function with ! its ii-th element removed. ! SWTCH3 = .FALSE. IF( ORGATI ) THEN IF( W.LT.ZERO ) SWTCH3 = .TRUE. ELSE IF( W.GT.ZERO ) SWTCH3 = .TRUE. END IF IF( II.EQ.1 .OR. II.EQ.N ) SWTCH3 = .FALSE. ! TEMP = Z( II ) / DELTA( II ) DW = DPSI + DPHI + TEMP*TEMP TEMP = Z( II )*TEMP W = W + TEMP ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +& THREE*ABS( TEMP ) + ABS( TAU )*DW ! ! Test for convergence ! IF( ABS( W ).LE.EPS*ERRETM ) THEN IF( ORGATI ) THEN DLAM = D( I ) + TAU ELSE DLAM = D( IP1 ) + TAU END IF GO TO 250 END IF ! IF( W.LE.ZERO ) THEN DLTLB = MAX( DLTLB, TAU ) ELSE DLTUB = MIN( DLTUB, TAU ) END IF ! ! Calculate the new step ! NITER = NITER + 1 IF( .NOT.SWTCH3 ) THEN IF( ORGATI ) THEN C = W - DELTA( IP1 )*DW - ( D( I )-D( IP1 ) )*& ( Z( I ) / DELTA( I ) )**2 ELSE C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*& ( Z( IP1 ) / DELTA( IP1 ) )**2 END IF A = ( DELTA( I )+DELTA( IP1 ) )*W -& DELTA( I )*DELTA( IP1 )*DW B = DELTA( I )*DELTA( IP1 )*W IF( C.EQ.ZERO ) THEN IF( A.EQ.ZERO ) THEN IF( ORGATI ) THEN A = Z( I )*Z( I ) + DELTA( IP1 )*DELTA( IP1 )*& ( DPSI+DPHI ) ELSE A = Z( IP1 )*Z( IP1 ) + DELTA( I )*DELTA( I )*& ( DPSI+DPHI ) END IF END IF ETA = B / A ELSE IF( A.LE.ZERO ) THEN ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) ELSE ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) END IF ELSE ! ! Interpolation using THREE most relevant poles ! TEMP = RHOINV + PSI + PHI IF( ORGATI ) THEN TEMP1 = Z( IIM1 ) / DELTA( IIM1 ) TEMP1 = TEMP1*TEMP1 C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -& ( D( IIM1 )-D( IIP1 ) )*TEMP1 ZZ( 1 ) = Z( IIM1 )*Z( IIM1 ) ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*& ( ( DPSI-TEMP1 )+DPHI ) ELSE TEMP1 = Z( IIP1 ) / DELTA( IIP1 ) TEMP1 = TEMP1*TEMP1 C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -& ( D( IIP1 )-D( IIM1 ) )*TEMP1 ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*& ( DPSI+( DPHI-TEMP1 ) ) ZZ( 3 ) = Z( IIP1 )*Z( IIP1 ) END IF ZZ( 2 ) = Z( II )*Z( II ) CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,& INFO ) IF( INFO.NE.0 ) GO TO 250 END IF ! ! Note, eta should be positive if w is negative, and ! eta should be negative otherwise. However, ! if for some reason caused by roundoff, eta*w > 0, ! we simply use one Newton step instead. This way ! will guarantee eta*w < 0. ! IF( W*ETA.GE.ZERO ) ETA = -W / DW TEMP = TAU + ETA IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN IF( W.LT.ZERO ) THEN ETA = ( DLTUB-TAU ) / TWO ELSE ETA = ( DLTLB-TAU ) / TWO END IF END IF ! PREW = W ! DO 180 J = 1, N DELTA( J ) = DELTA( J ) - ETA 180 CONTINUE ! ! Evaluate PSI and the derivative DPSI ! DPSI = ZERO PSI = ZERO ERRETM = ZERO DO 190 J = 1, IIM1 TEMP = Z( J ) / DELTA( J ) PSI = PSI + Z( J )*TEMP DPSI = DPSI + TEMP*TEMP ERRETM = ERRETM + PSI 190 CONTINUE ERRETM = ABS( ERRETM ) ! ! Evaluate PHI and the derivative DPHI ! DPHI = ZERO PHI = ZERO DO 200 J = N, IIP1, -1 TEMP = Z( J ) / DELTA( J ) PHI = PHI + Z( J )*TEMP DPHI = DPHI + TEMP*TEMP ERRETM = ERRETM + PHI 200 CONTINUE ! TEMP = Z( II ) / DELTA( II ) DW = DPSI + DPHI + TEMP*TEMP TEMP = Z( II )*TEMP W = RHOINV + PHI + PSI + TEMP ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +& THREE*ABS( TEMP ) + ABS( TAU+ETA )*DW ! SWTCH = .FALSE. IF( ORGATI ) THEN IF( -W.GT.ABS( PREW ) / TEN ) SWTCH = .TRUE. ELSE IF( W.GT.ABS( PREW ) / TEN ) SWTCH = .TRUE. END IF ! TAU = TAU + ETA ! ! Main loop to update the values of the array DELTA ! ITER = NITER + 1 ! DO 240 NITER = ITER, MAXIT ! ! Test for convergence ! IF( ABS( W ).LE.EPS*ERRETM ) THEN IF( ORGATI ) THEN DLAM = D( I ) + TAU ELSE DLAM = D( IP1 ) + TAU END IF GO TO 250 END IF ! IF( W.LE.ZERO ) THEN DLTLB = MAX( DLTLB, TAU ) ELSE DLTUB = MIN( DLTUB, TAU ) END IF ! ! Calculate the new step ! IF( .NOT.SWTCH3 ) THEN IF( .NOT.SWTCH ) THEN IF( ORGATI ) THEN C = W - DELTA( IP1 )*DW -& ( D( I )-D( IP1 ) )*( Z( I ) / DELTA( I ) )**2 ELSE C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*& ( Z( IP1 ) / DELTA( IP1 ) )**2 END IF ELSE TEMP = Z( II ) / DELTA( II ) IF( ORGATI ) THEN DPSI = DPSI + TEMP*TEMP ELSE DPHI = DPHI + TEMP*TEMP END IF C = W - DELTA( I )*DPSI - DELTA( IP1 )*DPHI END IF A = ( DELTA( I )+DELTA( IP1 ) )*W -& DELTA( I )*DELTA( IP1 )*DW B = DELTA( I )*DELTA( IP1 )*W IF( C.EQ.ZERO ) THEN IF( A.EQ.ZERO ) THEN IF( .NOT.SWTCH ) THEN IF( ORGATI ) THEN A = Z( I )*Z( I ) + DELTA( IP1 )*& DELTA( IP1 )*( DPSI+DPHI ) ELSE A = Z( IP1 )*Z( IP1 ) +& DELTA( I )*DELTA( I )*( DPSI+DPHI ) END IF ELSE A = DELTA( I )*DELTA( I )*DPSI +& DELTA( IP1 )*DELTA( IP1 )*DPHI END IF END IF ETA = B / A ELSE IF( A.LE.ZERO ) THEN ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) ELSE ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) END IF ELSE ! ! Interpolation using THREE most relevant poles ! TEMP = RHOINV + PSI + PHI IF( SWTCH ) THEN C = TEMP - DELTA( IIM1 )*DPSI - DELTA( IIP1 )*DPHI ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*DPSI ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*DPHI ELSE IF( ORGATI ) THEN TEMP1 = Z( IIM1 ) / DELTA( IIM1 ) TEMP1 = TEMP1*TEMP1 C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -& ( D( IIM1 )-D( IIP1 ) )*TEMP1 ZZ( 1 ) = Z( IIM1 )*Z( IIM1 ) ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*& ( ( DPSI-TEMP1 )+DPHI ) ELSE TEMP1 = Z( IIP1 ) / DELTA( IIP1 ) TEMP1 = TEMP1*TEMP1 C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -& ( D( IIP1 )-D( IIM1 ) )*TEMP1 ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*& ( DPSI+( DPHI-TEMP1 ) ) ZZ( 3 ) = Z( IIP1 )*Z( IIP1 ) END IF END IF CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,& INFO ) IF( INFO.NE.0 ) GO TO 250 END IF ! ! Note, eta should be positive if w is negative, and ! eta should be negative otherwise. However, ! if for some reason caused by roundoff, eta*w > 0, ! we simply use one Newton step instead. This way ! will guarantee eta*w < 0. ! IF( W*ETA.GE.ZERO ) ETA = -W / DW TEMP = TAU + ETA IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN IF( W.LT.ZERO ) THEN ETA = ( DLTUB-TAU ) / TWO ELSE ETA = ( DLTLB-TAU ) / TWO END IF END IF ! DO 210 J = 1, N DELTA( J ) = DELTA( J ) - ETA 210 CONTINUE ! TAU = TAU + ETA PREW = W ! ! Evaluate PSI and the derivative DPSI ! DPSI = ZERO PSI = ZERO ERRETM = ZERO DO 220 J = 1, IIM1 TEMP = Z( J ) / DELTA( J ) PSI = PSI + Z( J )*TEMP DPSI = DPSI + TEMP*TEMP ERRETM = ERRETM + PSI 220 CONTINUE ERRETM = ABS( ERRETM ) ! ! Evaluate PHI and the derivative DPHI ! DPHI = ZERO PHI = ZERO DO 230 J = N, IIP1, -1 TEMP = Z( J ) / DELTA( J ) PHI = PHI + Z( J )*TEMP DPHI = DPHI + TEMP*TEMP ERRETM = ERRETM + PHI 230 CONTINUE ! TEMP = Z( II ) / DELTA( II ) DW = DPSI + DPHI + TEMP*TEMP TEMP = Z( II )*TEMP W = RHOINV + PHI + PSI + TEMP ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +& THREE*ABS( TEMP ) + ABS( TAU )*DW IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN ) & SWTCH = .NOT.SWTCH ! 240 CONTINUE ! ! Return with INFO = 1, NITER = MAXIT and not converged ! INFO = 1 IF( ORGATI ) THEN DLAM = D( I ) + TAU ELSE DLAM = D( IP1 ) + TAU END IF ! END IF ! 250 CONTINUE ! RETURN ! ! End of DLAED4 ! END SUBROUTINE DLAED4 ! != ! !> \brief \b DLAED5 used by sstedc. Solves the 2-by-2 secular equation. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLAED5 + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM ) ! ! .. Scalar Arguments .. ! INTEGER I ! DOUBLE PRECISION DLAM, RHO ! .. ! .. Array Arguments .. ! DOUBLE PRECISION D( 2 ), DELTA( 2 ), Z( 2 ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> This subroutine computes the I-th eigenvalue of a symmetric rank-one !> modification of a 2-by-2 diagonal matrix !> !> diag( D ) + RHO * Z * transpose(Z) . !> !> The diagonal elements in the array D are assumed to satisfy !> !> D(i) < D(j) for i < j . !> !> We also assume RHO > 0 and that the Euclidean norm of the vector !> Z is one. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] I !> \verbatim !> I is INTEGER !> The index of the eigenvalue to be computed. I = 1 or I = 2. !> \endverbatim !> !> \param[in] D !> \verbatim !> D is DOUBLE PRECISION array, dimension (2) !> The original eigenvalues. We assume D(1) < D(2). !> \endverbatim !> !> \param[in] Z !> \verbatim !> Z is DOUBLE PRECISION array, dimension (2) !> The components of the updating vector. !> \endverbatim !> !> \param[out] DELTA !> \verbatim !> DELTA is DOUBLE PRECISION array, dimension (2) !> The vector DELTA contains the information necessary !> to construct the eigenvectors. !> \endverbatim !> !> \param[in] RHO !> \verbatim !> RHO is DOUBLE PRECISION !> The scalar in the symmetric updating formula. !> \endverbatim !> !> \param[out] DLAM !> \verbatim !> DLAM is DOUBLE PRECISION !> The computed lambda_I, the I-th updated eigenvalue. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup auxOTHERcomputational ! !> \par Contributors: ! ================== !> !> Ren-Cang Li, Computer Science Division, University of California !> at Berkeley, USA !> ! ===================================================================== SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM ) ! ! -- LAPACK computational routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. INTEGER I DOUBLE PRECISION DLAM, RHO ! .. ! .. Array Arguments .. DOUBLE PRECISION D( 2 ), DELTA( 2 ), Z( 2 ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, FOUR PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,& FOUR = 4.0D0 ) ! .. ! .. Local Scalars .. DOUBLE PRECISION B, C, DEL, TAU, TEMP, W ! .. ! .. Intrinsic Functions .. ! INTRINSIC ABS, SQRT ! .. ! .. Executable Statements .. ! DEL = D( 2 ) - D( 1 ) IF( I.EQ.1 ) THEN W = ONE + TWO*RHO*( Z( 2 )*Z( 2 )-Z( 1 )*Z( 1 ) ) / DEL IF( W.GT.ZERO ) THEN B = DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) C = RHO*Z( 1 )*Z( 1 )*DEL ! ! B > ZERO, always ! TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) ) DLAM = D( 1 ) + TAU DELTA( 1 ) = -Z( 1 ) / TAU DELTA( 2 ) = Z( 2 ) / ( DEL-TAU ) ELSE B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) C = RHO*Z( 2 )*Z( 2 )*DEL IF( B.GT.ZERO ) THEN TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) ) ELSE TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO END IF DLAM = D( 2 ) + TAU DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) DELTA( 2 ) = -Z( 2 ) / TAU END IF TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) DELTA( 1 ) = DELTA( 1 ) / TEMP DELTA( 2 ) = DELTA( 2 ) / TEMP ELSE ! ! Now I=2 ! B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) C = RHO*Z( 2 )*Z( 2 )*DEL IF( B.GT.ZERO ) THEN TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO ELSE TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) ) END IF DLAM = D( 2 ) + TAU DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) DELTA( 2 ) = -Z( 2 ) / TAU TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) DELTA( 1 ) = DELTA( 1 ) / TEMP DELTA( 2 ) = DELTA( 2 ) / TEMP END IF RETURN ! ! End OF DLAED5 ! END SUBROUTINE DLAED5 != !> \brief \b DLAED6 used by sstedc. Computes one Newton step in solution of the secular equation. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLAED6 + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) ! ! .. Scalar Arguments .. ! LOGICAL ORGATI ! INTEGER INFO, KNITER ! DOUBLE PRECISION FINIT, RHO, TAU ! .. ! .. Array Arguments .. ! DOUBLE PRECISION D( 3 ), Z( 3 ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLAED6 computes the positive or negative root (closest to the origin) !> of !> z(1) z(2) z(3) !> f(x) = rho + --------- + ---------- + --------- !> d(1)-x d(2)-x d(3)-x !> !> It is assumed that !> !> if ORGATI = .true. the root is between d(2) and d(3); !> otherwise it is between d(1) and d(2) !> !> This routine will be called by DLAED4 when necessary. In most cases, !> the root sought is the smallest in magnitude, though it might not be !> in some extremely rare situations. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] KNITER !> \verbatim !> KNITER is INTEGER !> Refer to DLAED4 for its significance. !> \endverbatim !> !> \param[in] ORGATI !> \verbatim !> ORGATI is LOGICAL !> If ORGATI is true, the needed root is between d(2) and !> d(3); otherwise it is between d(1) and d(2). See !> DLAED4 for further details. !> \endverbatim !> !> \param[in] RHO !> \verbatim !> RHO is DOUBLE PRECISION !> Refer to the equation f(x) above. !> \endverbatim !> !> \param[in] D !> \verbatim !> D is DOUBLE PRECISION array, dimension (3) !> D satisfies d(1) < d(2) < d(3). !> \endverbatim !> !> \param[in] Z !> \verbatim !> Z is DOUBLE PRECISION array, dimension (3) !> Each of the elements in z must be positive. !> \endverbatim !> !> \param[in] FINIT !> \verbatim !> FINIT is DOUBLE PRECISION !> The value of f at 0. It is more accurate than the one !> evaluated inside this routine (if someone wants to do !> so). !> \endverbatim !> !> \param[out] TAU !> \verbatim !> TAU is DOUBLE PRECISION !> The root of the equation f(x). !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit !> > 0: if INFO = 1, failure to converge !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2015 ! !> \ingroup auxOTHERcomputational ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> 10/02/03: This version has a few statements commented out for thread !> safety (machine parameters are computed on each entry). SJH. !> !> 05/10/06: Modified from a new version of Ren-Cang Li, use !> Gragg-Thornton-Warner cubic convergent scheme for better stability. !> \endverbatim ! !> \par Contributors: ! ================== !> !> Ren-Cang Li, Computer Science Division, University of California !> at Berkeley, USA !> ! ===================================================================== SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) ! ! -- LAPACK computational routine (version 3.6.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2015 ! ! .. Scalar Arguments .. LOGICAL ORGATI INTEGER INFO, KNITER DOUBLE PRECISION FINIT, RHO, TAU ! .. ! .. Array Arguments .. DOUBLE PRECISION D( 3 ), Z( 3 ) ! .. ! ! ===================================================================== ! ! .. Parameters .. INTEGER MAXIT PARAMETER ( MAXIT = 40 ) DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,& THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0 ) ! .. ! .. External Functions .. ! DOUBLE PRECISION DLAMCH ! EXTERNAL DLAMCH ! .. ! .. Local Arrays .. DOUBLE PRECISION DSCALE( 3 ), ZSCALE( 3 ) ! .. ! .. Local Scalars .. LOGICAL SCALE INTEGER I, ITER, NITER DOUBLE PRECISION A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F,& FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1,& SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4, & LBD, UBD ! .. ! .. Intrinsic Functions .. ! INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! INFO = 0 ! IF( ORGATI ) THEN LBD = D(2) UBD = D(3) ELSE LBD = D(1) UBD = D(2) END IF IF( FINIT .LT. ZERO )THEN LBD = ZERO ELSE UBD = ZERO END IF ! NITER = 1 TAU = ZERO IF( KNITER.EQ.2 ) THEN IF( ORGATI ) THEN TEMP = ( D( 3 )-D( 2 ) ) / TWO C = RHO + Z( 1 ) / ( ( D( 1 )-D( 2 ) )-TEMP ) A = C*( D( 2 )+D( 3 ) ) + Z( 2 ) + Z( 3 ) B = C*D( 2 )*D( 3 ) + Z( 2 )*D( 3 ) + Z( 3 )*D( 2 ) ELSE TEMP = ( D( 1 )-D( 2 ) ) / TWO C = RHO + Z( 3 ) / ( ( D( 3 )-D( 2 ) )-TEMP ) A = C*( D( 1 )+D( 2 ) ) + Z( 1 ) + Z( 2 ) B = C*D( 1 )*D( 2 ) + Z( 1 )*D( 2 ) + Z( 2 )*D( 1 ) END IF TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) ) A = A / TEMP B = B / TEMP C = C / TEMP IF( C.EQ.ZERO ) THEN TAU = B / A ELSE IF( A.LE.ZERO ) THEN TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) ELSE TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) END IF IF( TAU .LT. LBD .OR. TAU .GT. UBD ) TAU = ( LBD+UBD )/TWO IF( D(1).EQ.TAU .OR. D(2).EQ.TAU .OR. D(3).EQ.TAU ) THEN TAU = ZERO ELSE TEMP = FINIT + TAU*Z(1)/( D(1)*( D( 1 )-TAU ) ) +& TAU*Z(2)/( D(2)*( D( 2 )-TAU ) ) +& TAU*Z(3)/( D(3)*( D( 3 )-TAU ) ) IF( TEMP .LE. ZERO )THEN LBD = TAU ELSE UBD = TAU END IF IF( ABS( FINIT ).LE.ABS( TEMP ) ) TAU = ZERO END IF END IF ! ! get machine parameters for possible scaling to avoid overflow ! ! modified by Sven: parameters SMALL1, SMINV1, SMALL2, ! SMINV2, EPS are not SAVEd anymore between one call to the ! others but recomputed at each call ! EPS = DLAMCH( 'Epsilon' ) BASE = DLAMCH( 'Base' ) SMALL1 = BASE**( INT( LOG( DLAMCH( 'SafMin' ) ) / LOG( BASE ) /& THREE ) ) SMINV1 = ONE / SMALL1 SMALL2 = SMALL1*SMALL1 SMINV2 = SMINV1*SMINV1 ! ! Determine if scaling of inputs necessary to avoid overflow ! when computing 1/TEMP**3 ! IF( ORGATI ) THEN TEMP = MIN( ABS( D( 2 )-TAU ), ABS( D( 3 )-TAU ) ) ELSE TEMP = MIN( ABS( D( 1 )-TAU ), ABS( D( 2 )-TAU ) ) END IF SCALE = .FALSE. IF( TEMP.LE.SMALL1 ) THEN SCALE = .TRUE. IF( TEMP.LE.SMALL2 ) THEN ! ! Scale up by power of radix nearest 1/SAFMIN**(2/3) ! SCLFAC = SMINV2 SCLINV = SMALL2 ELSE ! ! Scale up by power of radix nearest 1/SAFMIN**(1/3) ! SCLFAC = SMINV1 SCLINV = SMALL1 END IF ! ! Scaling up safe because D, Z, TAU scaled elsewhere to be O(1) ! DO 10 I = 1, 3 DSCALE( I ) = D( I )*SCLFAC ZSCALE( I ) = Z( I )*SCLFAC 10 CONTINUE TAU = TAU*SCLFAC LBD = LBD*SCLFAC UBD = UBD*SCLFAC ELSE ! ! Copy D and Z to DSCALE and ZSCALE ! DO 20 I = 1, 3 DSCALE( I ) = D( I ) ZSCALE( I ) = Z( I ) 20 CONTINUE END IF ! FC = ZERO DF = ZERO DDF = ZERO DO 30 I = 1, 3 TEMP = ONE / ( DSCALE( I )-TAU ) TEMP1 = ZSCALE( I )*TEMP TEMP2 = TEMP1*TEMP TEMP3 = TEMP2*TEMP FC = FC + TEMP1 / DSCALE( I ) DF = DF + TEMP2 DDF = DDF + TEMP3 30 CONTINUE F = FINIT + TAU*FC ! IF( ABS( F ).LE.ZERO ) GO TO 60 IF( F .LE. ZERO )THEN LBD = TAU ELSE UBD = TAU END IF ! ! Iteration begins -- Use Gragg-Thornton-Warner cubic convergent ! scheme ! ! It is not hard to see that ! ! 1) Iterations will go up monotonically ! if FINIT < 0; ! ! 2) Iterations will go down monotonically ! if FINIT > 0. ! ITER = NITER + 1 ! DO 50 NITER = ITER, MAXIT ! IF( ORGATI ) THEN TEMP1 = DSCALE( 2 ) - TAU TEMP2 = DSCALE( 3 ) - TAU ELSE TEMP1 = DSCALE( 1 ) - TAU TEMP2 = DSCALE( 2 ) - TAU END IF A = ( TEMP1+TEMP2 )*F - TEMP1*TEMP2*DF B = TEMP1*TEMP2*F C = F - ( TEMP1+TEMP2 )*DF + TEMP1*TEMP2*DDF TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) ) A = A / TEMP B = B / TEMP C = C / TEMP IF( C.EQ.ZERO ) THEN ETA = B / A ELSE IF( A.LE.ZERO ) THEN ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) ELSE ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) END IF IF( F*ETA.GE.ZERO ) THEN ETA = -F / DF END IF ! TAU = TAU + ETA IF( TAU .LT. LBD .OR. TAU .GT. UBD ) TAU = ( LBD + UBD )/TWO ! FC = ZERO ERRETM = ZERO DF = ZERO DDF = ZERO DO 40 I = 1, 3 IF ( ( DSCALE( I )-TAU ).NE.ZERO ) THEN TEMP = ONE / ( DSCALE( I )-TAU ) TEMP1 = ZSCALE( I )*TEMP TEMP2 = TEMP1*TEMP TEMP3 = TEMP2*TEMP TEMP4 = TEMP1 / DSCALE( I ) FC = FC + TEMP4 ERRETM = ERRETM + ABS( TEMP4 ) DF = DF + TEMP2 DDF = DDF + TEMP3 ELSE GO TO 60 END IF 40 CONTINUE F = FINIT + TAU*FC ERRETM = EIGHT*( ABS( FINIT )+ABS( TAU )*ERRETM ) + ABS( TAU )*DF IF( ( ABS( F ).LE.FOUR*EPS*ERRETM ) .OR. & ( (UBD-LBD).LE.FOUR*EPS*ABS(TAU) ) )& GO TO 60 IF( F .LE. ZERO )THEN LBD = TAU ELSE UBD = TAU END IF 50 CONTINUE INFO = 1 60 CONTINUE ! ! Undo scaling ! IF( SCALE ) TAU = TAU*SCLINV RETURN ! ! End of DLAED6 ! END SUBROUTINE DLAED6 ! != ! !> \brief \b DLAEDA used by sstedc. Computes the Z vector determining the rank-one modification of the diagonal matrix. Used when the original matrix is dense. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLAEDA + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, ! GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO ) ! ! .. Scalar Arguments .. ! INTEGER CURLVL, CURPBM, INFO, N, TLVLS ! .. ! .. Array Arguments .. ! INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ), ! $ PRMPTR( * ), QPTR( * ) ! DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLAEDA computes the Z vector corresponding to the merge step in the !> CURLVLth step of the merge process with TLVLS steps for the CURPBMth !> problem. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] N !> \verbatim !> N is INTEGER !> The dimension of the symmetric tridiagonal matrix. N >= 0. !> \endverbatim !> !> \param[in] TLVLS !> \verbatim !> TLVLS is INTEGER !> The total number of merging levels in the overall divide and !> conquer tree. !> \endverbatim !> !> \param[in] CURLVL !> \verbatim !> CURLVL is INTEGER !> The current level in the overall merge routine, !> 0 <= curlvl <= tlvls. !> \endverbatim !> !> \param[in] CURPBM !> \verbatim !> CURPBM is INTEGER !> The current problem in the current level in the overall !> merge routine (counting from upper left to lower right). !> \endverbatim !> !> \param[in] PRMPTR !> \verbatim !> PRMPTR is INTEGER array, dimension (N lg N) !> Contains a list of pointers which indicate where in PERM a !> level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) !> indicates the size of the permutation and incidentally the !> size of the full, non-deflated problem. !> \endverbatim !> !> \param[in] PERM !> \verbatim !> PERM is INTEGER array, dimension (N lg N) !> Contains the permutations (from deflation and sorting) to be !> applied to each eigenblock. !> \endverbatim !> !> \param[in] GIVPTR !> \verbatim !> GIVPTR is INTEGER array, dimension (N lg N) !> Contains a list of pointers which indicate where in GIVCOL a !> level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) !> indicates the number of Givens rotations. !> \endverbatim !> !> \param[in] GIVCOL !> \verbatim !> GIVCOL is INTEGER array, dimension (2, N lg N) !> Each pair of numbers indicates a pair of columns to take place !> in a Givens rotation. !> \endverbatim !> !> \param[in] GIVNUM !> \verbatim !> GIVNUM is DOUBLE PRECISION array, dimension (2, N lg N) !> Each number indicates the S value to be used in the !> corresponding Givens rotation. !> \endverbatim !> !> \param[in] Q !> \verbatim !> Q is DOUBLE PRECISION array, dimension (N**2) !> Contains the square eigenblocks from previous levels, the !> starting positions for blocks are given by QPTR. !> \endverbatim !> !> \param[in] QPTR !> \verbatim !> QPTR is INTEGER array, dimension (N+2) !> Contains a list of pointers which indicate where in Q an !> eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates !> the size of the block. !> \endverbatim !> !> \param[out] Z !> \verbatim !> Z is DOUBLE PRECISION array, dimension (N) !> On output this vector contains the updating vector (the last !> row of the first sub-eigenvector matrix and the first row of !> the second sub-eigenvector matrix). !> \endverbatim !> !> \param[out] ZTEMP !> \verbatim !> ZTEMP is DOUBLE PRECISION array, dimension (N) !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup auxOTHERcomputational ! !> \par Contributors: ! ================== !> !> Jeff Rutter, Computer Science Division, University of California !> at Berkeley, USA ! ! ===================================================================== SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,& GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO ) ! ! -- LAPACK computational routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. INTEGER CURLVL, CURPBM, INFO, N, TLVLS ! .. ! .. Array Arguments .. INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ),& PRMPTR( * ), QPTR( * ) DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) ! .. ! .. Local Scalars .. INTEGER BSIZ1, BSIZ2, CURR, I, K, MID, PSIZ1, PSIZ2,& PTR, ZPTR1 ! .. ! .. External Subroutines .. ! EXTERNAL DCOPY, DGEMV, DROT, XERBLA ! .. ! .. Intrinsic Functions .. ! INTRINSIC DBLE, INT, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! INFO = 0 ! IF( N.LT.0 ) THEN INFO = -1 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLAEDA', -INFO ) RETURN END IF ! ! Quick return if possible ! IF( N.EQ.0 ) RETURN ! ! Determine location of first number in second half. ! MID = N / 2 + 1 ! ! Gather last/first rows of appropriate eigenblocks into center of Z ! PTR = 1 ! ! Determine location of lowest level subproblem in the full storage ! scheme ! CURR = PTR + CURPBM*2**CURLVL + 2**( CURLVL-1 ) - 1 ! ! Determine size of these matrices. We add HALF to the value of ! the SQRT in case the machine underestimates one of these square ! roots. ! BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) ) BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+1 ) ) ) ) DO 10 K = 1, MID - BSIZ1 - 1 Z( K ) = ZERO 10 CONTINUE CALL DCOPY( BSIZ1, Q( QPTR( CURR )+BSIZ1-1 ), BSIZ1,& Z( MID-BSIZ1 ), 1 ) CALL DCOPY( BSIZ2, Q( QPTR( CURR+1 ) ), BSIZ2, Z( MID ), 1 ) DO 20 K = MID + BSIZ2, N Z( K ) = ZERO 20 CONTINUE ! ! Loop through remaining levels 1 -> CURLVL applying the Givens ! rotations and permutation and then multiplying the center matrices ! against the current Z. ! PTR = 2**TLVLS + 1 DO 70 K = 1, CURLVL - 1 CURR = PTR + CURPBM*2**( CURLVL-K ) + 2**( CURLVL-K-1 ) - 1 PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR ) PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 ) ZPTR1 = MID - PSIZ1 ! ! Apply Givens at CURR and CURR+1 ! DO 30 I = GIVPTR( CURR ), GIVPTR( CURR+1 ) - 1 CALL DROT( 1, Z( ZPTR1+GIVCOL( 1, I )-1 ), 1,& Z( ZPTR1+GIVCOL( 2, I )-1 ), 1, GIVNUM( 1, I ),& GIVNUM( 2, I ) ) 30 CONTINUE DO 40 I = GIVPTR( CURR+1 ), GIVPTR( CURR+2 ) - 1 CALL DROT( 1, Z( MID-1+GIVCOL( 1, I ) ), 1,& Z( MID-1+GIVCOL( 2, I ) ), 1, GIVNUM( 1, I ),& GIVNUM( 2, I ) ) 40 CONTINUE PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR ) PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 ) DO 50 I = 0, PSIZ1 - 1 ZTEMP( I+1 ) = Z( ZPTR1+PERM( PRMPTR( CURR )+I )-1 ) 50 CONTINUE DO 60 I = 0, PSIZ2 - 1 ZTEMP( PSIZ1+I+1 ) = Z( MID+PERM( PRMPTR( CURR+1 )+I )-1 ) 60 CONTINUE ! ! Multiply Blocks at CURR and CURR+1 ! ! Determine size of these matrices. We add HALF to the value of ! the SQRT in case the machine underestimates one of these ! square roots. ! BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) ) BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+& 1 ) ) ) ) IF( BSIZ1.GT.0 ) THEN CALL DGEMV( 'T', BSIZ1, BSIZ1, ONE, Q( QPTR( CURR ) ),& BSIZ1, ZTEMP( 1 ), 1, ZERO, Z( ZPTR1 ), 1 ) END IF CALL DCOPY( PSIZ1-BSIZ1, ZTEMP( BSIZ1+1 ), 1, Z( ZPTR1+BSIZ1 ), 1 ) IF( BSIZ2.GT.0 ) THEN CALL DGEMV( 'T', BSIZ2, BSIZ2, ONE, Q( QPTR( CURR+1 ) ),& BSIZ2, ZTEMP( PSIZ1+1 ), 1, ZERO, Z( MID ), 1 ) END IF CALL DCOPY( PSIZ2-BSIZ2, ZTEMP( PSIZ1+BSIZ2+1 ), 1,& Z( MID+BSIZ2 ), 1 ) ! PTR = PTR + 2**( TLVLS-K ) 70 CONTINUE ! RETURN ! ! End of DLAEDA ! END SUBROUTINE DLAEDA ! != ! !> \brief \b DOPGTR ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DOPGTR + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) ! ! .. Scalar Arguments .. ! CHARACTER UPLO ! INTEGER INFO, LDQ, N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION AP( * ), Q( LDQ, * ), TAU( * ), WORK( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DOPGTR generates a real orthogonal matrix Q which is defined as the !> product of n-1 elementary reflectors H(i) of order n, as returned by !> DSPTRD using packed storage: !> !> if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), !> !> if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> = 'U': Upper triangular packed storage used in previous !> call to DSPTRD; !> = 'L': Lower triangular packed storage used in previous !> call to DSPTRD. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The order of the matrix Q. N >= 0. !> \endverbatim !> !> \param[in] AP !> \verbatim !> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) !> The vectors which define the elementary reflectors, as !> returned by DSPTRD. !> \endverbatim !> !> \param[in] TAU !> \verbatim !> TAU is DOUBLE PRECISION array, dimension (N-1) !> TAU(i) must contain the scalar factor of the elementary !> reflector H(i), as returned by DSPTRD. !> \endverbatim !> !> \param[out] Q !> \verbatim !> Q is DOUBLE PRECISION array, dimension (LDQ,N) !> The N-by-N orthogonal matrix Q. !> \endverbatim !> !> \param[in] LDQ !> \verbatim !> LDQ is INTEGER !> The leading dimension of the array Q. LDQ >= max(1,N). !> \endverbatim !> !> \param[out] WORK !> \verbatim !> WORK is DOUBLE PRECISION array, dimension (N-1) !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument had an illegal value !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup doubleOTHERcomputational ! ! ===================================================================== SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) ! ! -- LAPACK computational routine (version 3.4.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDQ, N ! .. ! .. Array Arguments .. DOUBLE PRECISION AP( * ), Q( LDQ, * ), TAU( * ), WORK( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) ! .. ! .. Local Scalars .. LOGICAL UPPER INTEGER I, IINFO, IJ, J ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL DORG2L, DORG2R, XERBLA ! .. ! .. Intrinsic Functions .. ! INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input arguments ! INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DOPGTR', -INFO ) RETURN END IF ! ! Quick return if possible ! IF( N.EQ.0 ) RETURN ! IF( UPPER ) THEN ! ! Q was determined by a call to DSPTRD with UPLO = 'U' ! ! Unpack the vectors which define the elementary reflectors and ! set the last row and column of Q equal to those of the unit ! matrix ! IJ = 2 DO 20 J = 1, N - 1 DO 10 I = 1, J - 1 Q( I, J ) = AP( IJ ) IJ = IJ + 1 10 CONTINUE IJ = IJ + 2 Q( N, J ) = ZERO 20 CONTINUE DO 30 I = 1, N - 1 Q( I, N ) = ZERO 30 CONTINUE Q( N, N ) = ONE ! ! Generate Q(1:n-1,1:n-1) ! CALL DORG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO ) ! ELSE ! ! Q was determined by a call to DSPTRD with UPLO = 'L'. ! ! Unpack the vectors which define the elementary reflectors and ! set the first row and column of Q equal to those of the unit ! matrix ! Q( 1, 1 ) = ONE DO 40 I = 2, N Q( I, 1 ) = ZERO 40 CONTINUE IJ = 3 DO 60 J = 2, N Q( 1, J ) = ZERO DO 50 I = J + 1, N Q( I, J ) = AP( IJ ) IJ = IJ + 1 50 CONTINUE IJ = IJ + 2 60 CONTINUE IF( N.GT.1 ) THEN ! ! Generate Q(2:n,2:n) ! CALL DORG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK, IINFO ) END IF END IF RETURN ! ! End of DOPGTR ! END SUBROUTINE DOPGTR ! != ! !> \brief \b DORG2L generates all or part of the orthogonal matrix Q from a QL factorization determined by sgeqlf (unblocked algorithm). ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DORG2L + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) ! ! .. Scalar Arguments .. ! INTEGER INFO, K, LDA, M, N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) ! .. ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DORG2L generates an m by n real matrix Q with orthonormal columns, !> which is defined as the last n columns of a product of k elementary !> reflectors of order m !> !> Q = H(k) . . . H(2) H(1) !> !> as returned by DGEQLF. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] M !> \verbatim !> M is INTEGER !> The number of rows of the matrix Q. M >= 0. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The number of columns of the matrix Q. M >= N >= 0. !> \endverbatim !> !> \param[in] K !> \verbatim !> K is INTEGER !> The number of elementary reflectors whose product defines the !> matrix Q. N >= K >= 0. !> \endverbatim !> !> \param[in,out] A !> \verbatim !> A is DOUBLE PRECISION array, dimension (LDA,N) !> On entry, the (n-k+i)-th column must contain the vector which !> defines the elementary reflector H(i), for i = 1,2,...,k, as !> returned by DGEQLF in the last k columns of its array !> argument A. !> On exit, the m by n matrix Q. !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> The first dimension of the array A. LDA >= max(1,M). !> \endverbatim !> !> \param[in] TAU !> \verbatim !> TAU is DOUBLE PRECISION array, dimension (K) !> TAU(i) must contain the scalar factor of the elementary !> reflector H(i), as returned by DGEQLF. !> \endverbatim !> !> \param[out] WORK !> \verbatim !> WORK is DOUBLE PRECISION array, dimension (N) !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument has an illegal value !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup doubleOTHERcomputational ! ! ===================================================================== SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) ! ! -- LAPACK computational routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N ! .. ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) ! .. ! .. Local Scalars .. INTEGER I, II, J, L ! .. ! .. External Subroutines .. ! EXTERNAL DLARF, DSCAL, XERBLA ! .. ! .. Intrinsic Functions .. ! INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input arguments ! INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORG2L', -INFO ) RETURN END IF ! ! Quick return if possible ! IF( N.LE.0 ) RETURN ! ! Initialise columns 1:n-k to columns of the unit matrix ! DO 20 J = 1, N - K DO 10 L = 1, M A( L, J ) = ZERO 10 CONTINUE A( M-N+J, J ) = ONE 20 CONTINUE ! DO 40 I = 1, K II = N - K + I ! ! Apply H(i) to A(1:m-k+i,1:n-k+i) from the left ! A( M-N+II, II ) = ONE CALL DLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A,& LDA, WORK ) CALL DSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) A( M-N+II, II ) = ONE - TAU( I ) ! ! Set A(m-k+i+1:m,n-k+i) to zero ! DO 30 L = M - N + II + 1, M A( L, II ) = ZERO 30 CONTINUE 40 CONTINUE RETURN ! ! End of DORG2L ! END SUBROUTINE DORG2L ! != ! !> \brief \b DORG2R generates all or part of the orthogonal matrix Q from a QR factorization determined by sgeqrf (unblocked algorithm). ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DORG2R + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) ! ! .. Scalar Arguments .. ! INTEGER INFO, K, LDA, M, N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DORG2R generates an m by n real matrix Q with orthonormal columns, !> which is defined as the first n columns of a product of k elementary !> reflectors of order m !> !> Q = H(1) H(2) . . . H(k) !> !> as returned by DGEQRF. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] M !> \verbatim !> M is INTEGER !> The number of rows of the matrix Q. M >= 0. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The number of columns of the matrix Q. M >= N >= 0. !> \endverbatim !> !> \param[in] K !> \verbatim !> K is INTEGER !> The number of elementary reflectors whose product defines the !> matrix Q. N >= K >= 0. !> \endverbatim !> !> \param[in,out] A !> \verbatim !> A is DOUBLE PRECISION array, dimension (LDA,N) !> On entry, the i-th column must contain the vector which !> defines the elementary reflector H(i), for i = 1,2,...,k, as !> returned by DGEQRF in the first k columns of its array !> argument A. !> On exit, the m-by-n matrix Q. !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> The first dimension of the array A. LDA >= max(1,M). !> \endverbatim !> !> \param[in] TAU !> \verbatim !> TAU is DOUBLE PRECISION array, dimension (K) !> TAU(i) must contain the scalar factor of the elementary !> reflector H(i), as returned by DGEQRF. !> \endverbatim !> !> \param[out] WORK !> \verbatim !> WORK is DOUBLE PRECISION array, dimension (N) !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument has an illegal value !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup doubleOTHERcomputational ! ! ===================================================================== SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) ! ! -- LAPACK computational routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N ! .. ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) ! .. ! .. Local Scalars .. INTEGER I, J, L ! .. ! .. External Subroutines .. ! EXTERNAL DLARF, DSCAL, XERBLA ! .. ! .. Intrinsic Functions .. ! INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input arguments ! INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORG2R', -INFO ) RETURN END IF ! ! Quick return if possible ! IF( N.LE.0 ) RETURN ! ! Initialise columns k+1:n to columns of the unit matrix ! DO 20 J = K + 1, N DO 10 L = 1, M A( L, J ) = ZERO 10 CONTINUE A( J, J ) = ONE 20 CONTINUE ! DO 40 I = K, 1, -1 ! ! Apply H(i) to A(i:m,i:n) from the left ! IF( I.LT.N ) THEN A( I, I ) = ONE CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),& A( I, I+1 ), LDA, WORK ) END IF IF( I.LT.M ) CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) A( I, I ) = ONE - TAU( I ) ! ! Set A(1:i-1,i) to zero ! DO 30 L = 1, I - 1 A( L, I ) = ZERO 30 CONTINUE 40 CONTINUE RETURN ! ! End of DORG2R ! END SUBROUTINE DORG2R ! !======================================================================== ! ! BLAS ! !> \brief \b DROT ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! ! Definition: ! =========== ! ! SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S) ! ! .. Scalar Arguments .. ! DOUBLE PRECISION C,S ! INTEGER INCX,INCY,N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION DX(*),DY(*) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DROT applies a plane rotation. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup double_blas_level1 ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> jack dongarra, linpack, 3/11/78. !> modified 12/3/93, array(1) declarations changed to array(*) !> \endverbatim !> ! ===================================================================== SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S) ! ! -- Reference BLAS level1 routine (version 3.4.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. DOUBLE PRECISION C,S INTEGER INCX,INCY,N ! .. ! .. Array Arguments .. DOUBLE PRECISION DX(*),DY(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. DOUBLE PRECISION DTEMP INTEGER I,IX,IY ! .. IF (N.LE.0) RETURN IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN ! ! code for both increments equal to 1 ! DO I = 1,N DTEMP = C*DX(I) + S*DY(I) DY(I) = C*DY(I) - S*DX(I) DX(I) = DTEMP END DO ELSE ! ! code for unequal increments or equal increments not equal ! to 1 ! IX = 1 IY = 1 IF (INCX.LT.0) IX = (-N+1)*INCX + 1 IF (INCY.LT.0) IY = (-N+1)*INCY + 1 DO I = 1,N DTEMP = C*DX(IX) + S*DY(IY) DY(IY) = C*DY(IY) - S*DX(IX) DX(IX) = DTEMP IX = IX + INCX IY = IY + INCY END DO END IF RETURN END SUBROUTINE DROT ! != ! !> \brief \b DNRM2 ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! ! Definition: ! =========== ! ! DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX) ! ! .. Scalar Arguments .. ! INTEGER INCX,N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION X(*) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DNRM2 returns the euclidean norm of a vector via the function !> name, so that !> !> DNRM2 := sqrt( x'*x ) !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup double_blas_level1 ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> -- This version written on 25-October-1982. !> Modified on 14-October-1993 to inline the call to DLASSQ. !> Sven Hammarling, Nag Ltd. !> \endverbatim !> ! ===================================================================== DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX) ! ! -- Reference BLAS level1 routine (version 3.4.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. INTEGER INCX,N ! .. ! .. Array Arguments .. DOUBLE PRECISION X(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE,ZERO PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) ! .. ! .. Local Scalars .. DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ INTEGER IX ! .. ! .. Intrinsic Functions .. INTRINSIC ABS,SQRT ! .. IF (N.LT.1 .OR. INCX.LT.1) THEN NORM = ZERO ELSE IF (N.EQ.1) THEN NORM = ABS(X(1)) ELSE SCALE = ZERO SSQ = ONE ! The following loop is equivalent to this call to the LAPACK ! auxiliary routine: ! CALL DLASSQ( N, X, INCX, SCALE, SSQ ) ! DO 10 IX = 1,1 + (N-1)*INCX,INCX IF (X(IX).NE.ZERO) THEN ABSXI = ABS(X(IX)) IF (SCALE.LT.ABSXI) THEN SSQ = ONE + SSQ* (SCALE/ABSXI)**2 SCALE = ABSXI ELSE SSQ = SSQ + (ABSXI/SCALE)**2 END IF END IF 10 CONTINUE NORM = SCALE*SQRT(SSQ) END IF ! DNRM2 = NORM RETURN ! ! End of DNRM2. ! END FUNCTION DNRM2 ! != ! !> \brief \b DGER ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! ! Definition: ! =========== ! ! SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) ! ! .. Scalar Arguments .. ! DOUBLE PRECISION ALPHA ! INTEGER INCX,INCY,LDA,M,N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION A(LDA,*),X(*),Y(*) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DGER performs the rank 1 operation !> !> A := alpha*x*y**T + A, !> !> where alpha is a scalar, x is an m element vector, y is an n element !> vector and A is an m by n matrix. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] M !> \verbatim !> M is INTEGER !> On entry, M specifies the number of rows of the matrix A. !> M must be at least zero. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> On entry, N specifies the number of columns of the matrix A. !> N must be at least zero. !> \endverbatim !> !> \param[in] ALPHA !> \verbatim !> ALPHA is DOUBLE PRECISION. !> On entry, ALPHA specifies the scalar alpha. !> \endverbatim !> !> \param[in] X !> \verbatim !> X is DOUBLE PRECISION array of dimension at least !> ( 1 + ( m - 1 )*abs( INCX ) ). !> Before entry, the incremented array X must contain the m !> element vector x. !> \endverbatim !> !> \param[in] INCX !> \verbatim !> INCX is INTEGER !> On entry, INCX specifies the increment for the elements of !> X. INCX must not be zero. !> \endverbatim !> !> \param[in] Y !> \verbatim !> Y is DOUBLE PRECISION array of dimension at least !> ( 1 + ( n - 1 )*abs( INCY ) ). !> Before entry, the incremented array Y must contain the n !> element vector y. !> \endverbatim !> !> \param[in] INCY !> \verbatim !> INCY is INTEGER !> On entry, INCY specifies the increment for the elements of !> Y. INCY must not be zero. !> \endverbatim !> !> \param[in,out] A !> \verbatim !> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ). !> Before entry, the leading m by n part of the array A must !> contain the matrix of coefficients. On exit, A is !> overwritten by the updated matrix. !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> On entry, LDA specifies the first dimension of A as declared !> in the calling (sub) program. LDA must be at least !> max( 1, m ). !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup double_blas_level2 ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> Level 2 Blas routine. !> !> -- Written on 22-October-1986. !> Jack Dongarra, Argonne National Lab. !> Jeremy Du Croz, Nag Central Office. !> Sven Hammarling, Nag Central Office. !> Richard Hanson, Sandia National Labs. !> \endverbatim !> ! ===================================================================== SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) ! ! -- Reference BLAS level2 routine (version 3.4.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. DOUBLE PRECISION ALPHA INTEGER INCX,INCY,LDA,M,N ! .. ! .. Array Arguments .. DOUBLE PRECISION A(LDA,*),X(*),Y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ZERO PARAMETER (ZERO=0.0D+0) ! .. ! .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I,INFO,IX,J,JY,KX ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. ! INTRINSIC MAX ! .. ! ! Test the input parameters. ! INFO = 0 IF (M.LT.0) THEN INFO = 1 ELSE IF (N.LT.0) THEN INFO = 2 ELSE IF (INCX.EQ.0) THEN INFO = 5 ELSE IF (INCY.EQ.0) THEN INFO = 7 ELSE IF (LDA.LT.MAX(1,M)) THEN INFO = 9 END IF IF (INFO.NE.0) THEN CALL XERBLA('DGER ',INFO) RETURN END IF ! ! Quick return if possible. ! IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! IF (INCY.GT.0) THEN JY = 1 ELSE JY = 1 - (N-1)*INCY END IF IF (INCX.EQ.1) THEN DO 20 J = 1,N IF (Y(JY).NE.ZERO) THEN TEMP = ALPHA*Y(JY) DO 10 I = 1,M A(I,J) = A(I,J) + X(I)*TEMP 10 CONTINUE END IF JY = JY + INCY 20 CONTINUE ELSE IF (INCX.GT.0) THEN KX = 1 ELSE KX = 1 - (M-1)*INCX END IF DO 40 J = 1,N IF (Y(JY).NE.ZERO) THEN TEMP = ALPHA*Y(JY) IX = KX DO 30 I = 1,M A(I,J) = A(I,J) + X(IX)*TEMP IX = IX + INCX 30 CONTINUE END IF JY = JY + INCY 40 CONTINUE END IF ! RETURN ! ! End of DGER . ! END SUBROUTINE DGER ! != ! !> \brief \b DSPMV ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! ! Definition: ! =========== ! ! SUBROUTINE DSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) ! ! .. Scalar Arguments .. ! DOUBLE PRECISION ALPHA,BETA ! INTEGER INCX,INCY,N ! CHARACTER UPLO ! .. ! .. Array Arguments .. ! DOUBLE PRECISION AP(*),X(*),Y(*) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DSPMV performs the matrix-vector operation !> !> y := alpha*A*x + beta*y, !> !> where alpha and beta are scalars, x and y are n element vectors and !> A is an n by n symmetric matrix, supplied in packed form. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> On entry, UPLO specifies whether the upper or lower !> triangular part of the matrix A is supplied in the packed !> array AP as follows: !> !> UPLO = 'U' or 'u' The upper triangular part of A is !> supplied in AP. !> !> UPLO = 'L' or 'l' The lower triangular part of A is !> supplied in AP. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> On entry, N specifies the order of the matrix A. !> N must be at least zero. !> \endverbatim !> !> \param[in] ALPHA !> \verbatim !> ALPHA is DOUBLE PRECISION. !> On entry, ALPHA specifies the scalar alpha. !> \endverbatim !> !> \param[in] AP !> \verbatim !> AP is DOUBLE PRECISION array of DIMENSION at least !> ( ( n*( n + 1 ) )/2 ). !> Before entry with UPLO = 'U' or 'u', the array AP must !> contain the upper triangular part of the symmetric matrix !> packed sequentially, column by column, so that AP( 1 ) !> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) !> and a( 2, 2 ) respectively, and so on. !> Before entry with UPLO = 'L' or 'l', the array AP must !> contain the lower triangular part of the symmetric matrix !> packed sequentially, column by column, so that AP( 1 ) !> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) !> and a( 3, 1 ) respectively, and so on. !> \endverbatim !> !> \param[in] X !> \verbatim !> X is DOUBLE PRECISION array of dimension at least !> ( 1 + ( n - 1 )*abs( INCX ) ). !> Before entry, the incremented array X must contain the n !> element vector x. !> \endverbatim !> !> \param[in] INCX !> \verbatim !> INCX is INTEGER !> On entry, INCX specifies the increment for the elements of !> X. INCX must not be zero. !> \endverbatim !> !> \param[in] BETA !> \verbatim !> BETA is DOUBLE PRECISION. !> On entry, BETA specifies the scalar beta. When BETA is !> supplied as zero then Y need not be set on input. !> \endverbatim !> !> \param[in,out] Y !> \verbatim !> Y is DOUBLE PRECISION array of dimension at least !> ( 1 + ( n - 1 )*abs( INCY ) ). !> Before entry, the incremented array Y must contain the n !> element vector y. On exit, Y is overwritten by the updated !> vector y. !> \endverbatim !> !> \param[in] INCY !> \verbatim !> INCY is INTEGER !> On entry, INCY specifies the increment for the elements of !> Y. INCY must not be zero. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup double_blas_level2 ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> Level 2 Blas routine. !> The vector and matrix arguments are not referenced when N = 0, or M = 0 !> !> -- Written on 22-October-1986. !> Jack Dongarra, Argonne National Lab. !> Jeremy Du Croz, Nag Central Office. !> Sven Hammarling, Nag Central Office. !> Richard Hanson, Sandia National Labs. !> \endverbatim !> ! ===================================================================== SUBROUTINE DSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) ! ! -- Reference BLAS level2 routine (version 3.4.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. DOUBLE PRECISION ALPHA,BETA INTEGER INCX,INCY,N CHARACTER UPLO ! .. ! .. Array Arguments .. DOUBLE PRECISION AP(*),X(*),Y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE,ZERO PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) ! .. ! .. Local Scalars .. DOUBLE PRECISION TEMP1,TEMP2 INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! ! Test the input parameters. ! INFO = 0 IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN INFO = 1 ELSE IF (N.LT.0) THEN INFO = 2 ELSE IF (INCX.EQ.0) THEN INFO = 6 ELSE IF (INCY.EQ.0) THEN INFO = 9 END IF IF (INFO.NE.0) THEN CALL XERBLA('DSPMV ',INFO) RETURN END IF ! ! Quick return if possible. ! IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN ! ! Set up the start points in X and Y. ! IF (INCX.GT.0) THEN KX = 1 ELSE KX = 1 - (N-1)*INCX END IF IF (INCY.GT.0) THEN KY = 1 ELSE KY = 1 - (N-1)*INCY END IF ! ! Start the operations. In this version the elements of the array AP ! are accessed sequentially with one pass through AP. ! ! First form y := beta*y. ! IF (BETA.NE.ONE) THEN IF (INCY.EQ.1) THEN IF (BETA.EQ.ZERO) THEN DO 10 I = 1,N Y(I) = ZERO 10 CONTINUE ELSE DO 20 I = 1,N Y(I) = BETA*Y(I) 20 CONTINUE END IF ELSE IY = KY IF (BETA.EQ.ZERO) THEN DO 30 I = 1,N Y(IY) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40 I = 1,N Y(IY) = BETA*Y(IY) IY = IY + INCY 40 CONTINUE END IF END IF END IF IF (ALPHA.EQ.ZERO) RETURN KK = 1 IF (LSAME(UPLO,'U')) THEN ! ! Form y when AP contains the upper triangle. ! IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN DO 60 J = 1,N TEMP1 = ALPHA*X(J) TEMP2 = ZERO K = KK DO 50 I = 1,J - 1 Y(I) = Y(I) + TEMP1*AP(K) TEMP2 = TEMP2 + AP(K)*X(I) K = K + 1 50 CONTINUE Y(J) = Y(J) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2 KK = KK + J 60 CONTINUE ELSE JX = KX JY = KY DO 80 J = 1,N TEMP1 = ALPHA*X(JX) TEMP2 = ZERO IX = KX IY = KY DO 70 K = KK,KK + J - 2 Y(IY) = Y(IY) + TEMP1*AP(K) TEMP2 = TEMP2 + AP(K)*X(IX) IX = IX + INCX IY = IY + INCY 70 CONTINUE Y(JY) = Y(JY) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY KK = KK + J 80 CONTINUE END IF ELSE ! ! Form y when AP contains the lower triangle. ! IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN DO 100 J = 1,N TEMP1 = ALPHA*X(J) TEMP2 = ZERO Y(J) = Y(J) + TEMP1*AP(KK) K = KK + 1 DO 90 I = J + 1,N Y(I) = Y(I) + TEMP1*AP(K) TEMP2 = TEMP2 + AP(K)*X(I) K = K + 1 90 CONTINUE Y(J) = Y(J) + ALPHA*TEMP2 KK = KK + (N-J+1) 100 CONTINUE ELSE JX = KX JY = KY DO 120 J = 1,N TEMP1 = ALPHA*X(JX) TEMP2 = ZERO Y(JY) = Y(JY) + TEMP1*AP(KK) IX = JX IY = JY DO 110 K = KK + 1,KK + N - J IX = IX + INCX IY = IY + INCY Y(IY) = Y(IY) + TEMP1*AP(K) TEMP2 = TEMP2 + AP(K)*X(IX) 110 CONTINUE Y(JY) = Y(JY) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY KK = KK + (N-J+1) 120 CONTINUE END IF END IF ! RETURN ! ! End of DSPMV . ! END SUBROUTINE DSPMV ! != ! !> \brief \b DAXPY ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! ! Definition: ! =========== ! ! SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) ! ! .. Scalar Arguments .. ! DOUBLE PRECISION DA ! INTEGER INCX,INCY,N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION DX(*),DY(*) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DAXPY constant times a vector plus a vector. !> uses unrolled loops for increments equal to one. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup double_blas_level1 ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> jack dongarra, linpack, 3/11/78. !> modified 12/3/93, array(1) declarations changed to array(*) !> \endverbatim !> ! ===================================================================== SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) ! ! -- Reference BLAS level1 routine (version 3.4.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. DOUBLE PRECISION DA INTEGER INCX,INCY,N ! .. ! .. Array Arguments .. DOUBLE PRECISION DX(*),DY(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. INTEGER I,IX,IY,M,MP1 ! .. ! .. Intrinsic Functions .. ! INTRINSIC MOD ! .. IF (N.LE.0) RETURN IF (DA.EQ.0.0d0) RETURN IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN ! ! code for both increments equal to 1 ! ! ! clean-up loop ! M = MOD(N,4) IF (M.NE.0) THEN DO I = 1,M DY(I) = DY(I) + DA*DX(I) END DO END IF IF (N.LT.4) RETURN MP1 = M + 1 DO I = MP1,N,4 DY(I) = DY(I) + DA*DX(I) DY(I+1) = DY(I+1) + DA*DX(I+1) DY(I+2) = DY(I+2) + DA*DX(I+2) DY(I+3) = DY(I+3) + DA*DX(I+3) END DO ELSE ! ! code for unequal increments or equal increments ! not equal to 1 ! IX = 1 IY = 1 IF (INCX.LT.0) IX = (-N+1)*INCX + 1 IF (INCY.LT.0) IY = (-N+1)*INCY + 1 DO I = 1,N DY(IY) = DY(IY) + DA*DX(IX) IX = IX + INCX IY = IY + INCY END DO END IF RETURN END SUBROUTINE DAXPY ! != ! !> \brief \b DSPR2 ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! ! Definition: ! =========== ! ! SUBROUTINE DSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) ! ! .. Scalar Arguments .. ! DOUBLE PRECISION ALPHA ! INTEGER INCX,INCY,N ! CHARACTER UPLO ! .. ! .. Array Arguments .. ! DOUBLE PRECISION AP(*),X(*),Y(*) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DSPR2 performs the symmetric rank 2 operation !> !> A := alpha*x*y**T + alpha*y*x**T + A, !> !> where alpha is a scalar, x and y are n element vectors and A is an !> n by n symmetric matrix, supplied in packed form. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> On entry, UPLO specifies whether the upper or lower !> triangular part of the matrix A is supplied in the packed !> array AP as follows: !> !> UPLO = 'U' or 'u' The upper triangular part of A is !> supplied in AP. !> !> UPLO = 'L' or 'l' The lower triangular part of A is !> supplied in AP. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> On entry, N specifies the order of the matrix A. !> N must be at least zero. !> \endverbatim !> !> \param[in] ALPHA !> \verbatim !> ALPHA is DOUBLE PRECISION. !> On entry, ALPHA specifies the scalar alpha. !> \endverbatim !> !> \param[in] X !> \verbatim !> X is DOUBLE PRECISION array of dimension at least !> ( 1 + ( n - 1 )*abs( INCX ) ). !> Before entry, the incremented array X must contain the n !> element vector x. !> \endverbatim !> !> \param[in] INCX !> \verbatim !> INCX is INTEGER !> On entry, INCX specifies the increment for the elements of !> X. INCX must not be zero. !> \endverbatim !> !> \param[in] Y !> \verbatim !> Y is DOUBLE PRECISION array of dimension at least !> ( 1 + ( n - 1 )*abs( INCY ) ). !> Before entry, the incremented array Y must contain the n !> element vector y. !> \endverbatim !> !> \param[in] INCY !> \verbatim !> INCY is INTEGER !> On entry, INCY specifies the increment for the elements of !> Y. INCY must not be zero. !> \endverbatim !> !> \param[in,out] AP !> \verbatim !> AP is DOUBLE PRECISION array of DIMENSION at least !> ( ( n*( n + 1 ) )/2 ). !> Before entry with UPLO = 'U' or 'u', the array AP must !> contain the upper triangular part of the symmetric matrix !> packed sequentially, column by column, so that AP( 1 ) !> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) !> and a( 2, 2 ) respectively, and so on. On exit, the array !> AP is overwritten by the upper triangular part of the !> updated matrix. !> Before entry with UPLO = 'L' or 'l', the array AP must !> contain the lower triangular part of the symmetric matrix !> packed sequentially, column by column, so that AP( 1 ) !> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) !> and a( 3, 1 ) respectively, and so on. On exit, the array !> AP is overwritten by the lower triangular part of the !> updated matrix. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup double_blas_level2 ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> Level 2 Blas routine. !> !> -- Written on 22-October-1986. !> Jack Dongarra, Argonne National Lab. !> Jeremy Du Croz, Nag Central Office. !> Sven Hammarling, Nag Central Office. !> Richard Hanson, Sandia National Labs. !> \endverbatim !> ! ===================================================================== SUBROUTINE DSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) ! ! -- Reference BLAS level2 routine (version 3.4.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. DOUBLE PRECISION ALPHA INTEGER INCX,INCY,N CHARACTER UPLO ! .. ! .. Array Arguments .. DOUBLE PRECISION AP(*),X(*),Y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ZERO PARAMETER (ZERO=0.0D+0) ! .. ! .. Local Scalars .. DOUBLE PRECISION TEMP1,TEMP2 INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! ! Test the input parameters. ! INFO = 0 IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN INFO = 1 ELSE IF (N.LT.0) THEN INFO = 2 ELSE IF (INCX.EQ.0) THEN INFO = 5 ELSE IF (INCY.EQ.0) THEN INFO = 7 END IF IF (INFO.NE.0) THEN CALL XERBLA('DSPR2 ',INFO) RETURN END IF ! ! Quick return if possible. ! IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN ! ! Set up the start points in X and Y if the increments are not both ! unity. ! IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN IF (INCX.GT.0) THEN KX = 1 ELSE KX = 1 - (N-1)*INCX END IF IF (INCY.GT.0) THEN KY = 1 ELSE KY = 1 - (N-1)*INCY END IF JX = KX JY = KY END IF ! ! Start the operations. In this version the elements of the array AP ! are accessed sequentially with one pass through AP. ! KK = 1 IF (LSAME(UPLO,'U')) THEN ! ! Form A when upper triangle is stored in AP. ! IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN DO 20 J = 1,N IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN TEMP1 = ALPHA*Y(J) TEMP2 = ALPHA*X(J) K = KK DO 10 I = 1,J AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2 K = K + 1 10 CONTINUE END IF KK = KK + J 20 CONTINUE ELSE DO 40 J = 1,N IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN TEMP1 = ALPHA*Y(JY) TEMP2 = ALPHA*X(JX) IX = KX IY = KY DO 30 K = KK,KK + J - 1 AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2 IX = IX + INCX IY = IY + INCY 30 CONTINUE END IF JX = JX + INCX JY = JY + INCY KK = KK + J 40 CONTINUE END IF ELSE ! ! Form A when lower triangle is stored in AP. ! IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN DO 60 J = 1,N IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN TEMP1 = ALPHA*Y(J) TEMP2 = ALPHA*X(J) K = KK DO 50 I = J,N AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2 K = K + 1 50 CONTINUE END IF KK = KK + N - J + 1 60 CONTINUE ELSE DO 80 J = 1,N IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN TEMP1 = ALPHA*Y(JY) TEMP2 = ALPHA*X(JX) IX = JX IY = JY DO 70 K = KK,KK + N - J AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2 IX = IX + INCX IY = IY + INCY 70 CONTINUE END IF JX = JX + INCX JY = JY + INCY KK = KK + N - J + 1 80 CONTINUE END IF END IF ! RETURN ! ! End of DSPR2 . ! END SUBROUTINE DSPR2 ! != ! !> \brief \b DTRMV ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! ! Definition: ! =========== ! ! SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) ! ! .. Scalar Arguments .. ! INTEGER INCX,LDA,N ! CHARACTER DIAG,TRANS,UPLO ! .. ! .. Array Arguments .. ! DOUBLE PRECISION A(LDA,*),X(*) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DTRMV performs one of the matrix-vector operations !> !> x := A*x, or x := A**T*x, !> !> where x is an n element vector and A is an n by n unit, or non-unit, !> upper or lower triangular matrix. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> On entry, UPLO specifies whether the matrix is an upper or !> lower triangular matrix as follows: !> !> UPLO = 'U' or 'u' A is an upper triangular matrix. !> !> UPLO = 'L' or 'l' A is a lower triangular matrix. !> \endverbatim !> !> \param[in] TRANS !> \verbatim !> TRANS is CHARACTER*1 !> On entry, TRANS specifies the operation to be performed as !> follows: !> !> TRANS = 'N' or 'n' x := A*x. !> !> TRANS = 'T' or 't' x := A**T*x. !> !> TRANS = 'C' or 'c' x := A**T*x. !> \endverbatim !> !> \param[in] DIAG !> \verbatim !> DIAG is CHARACTER*1 !> On entry, DIAG specifies whether or not A is unit !> triangular as follows: !> !> DIAG = 'U' or 'u' A is assumed to be unit triangular. !> !> DIAG = 'N' or 'n' A is not assumed to be unit !> triangular. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> On entry, N specifies the order of the matrix A. !> N must be at least zero. !> \endverbatim !> !> \param[in] A !> \verbatim !> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ). !> Before entry with UPLO = 'U' or 'u', the leading n by n !> upper triangular part of the array A must contain the upper !> triangular matrix and the strictly lower triangular part of !> A is not referenced. !> Before entry with UPLO = 'L' or 'l', the leading n by n !> lower triangular part of the array A must contain the lower !> triangular matrix and the strictly upper triangular part of !> A is not referenced. !> Note that when DIAG = 'U' or 'u', the diagonal elements of !> A are not referenced either, but are assumed to be unity. !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> On entry, LDA specifies the first dimension of A as declared !> in the calling (sub) program. LDA must be at least !> max( 1, n ). !> \endverbatim !> !> \param[in,out] X !> \verbatim !> X is DOUBLE PRECISION array of dimension at least !> ( 1 + ( n - 1 )*abs( INCX ) ). !> Before entry, the incremented array X must contain the n !> element vector x. On exit, X is overwritten with the !> tranformed vector x. !> \endverbatim !> !> \param[in] INCX !> \verbatim !> INCX is INTEGER !> On entry, INCX specifies the increment for the elements of !> X. INCX must not be zero. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup double_blas_level2 ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> Level 2 Blas routine. !> The vector and matrix arguments are not referenced when N = 0, or M = 0 !> !> -- Written on 22-October-1986. !> Jack Dongarra, Argonne National Lab. !> Jeremy Du Croz, Nag Central Office. !> Sven Hammarling, Nag Central Office. !> Richard Hanson, Sandia National Labs. !> \endverbatim !> ! ===================================================================== SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) ! ! -- Reference BLAS level2 routine (version 3.4.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. INTEGER INCX,LDA,N CHARACTER DIAG,TRANS,UPLO ! .. ! .. Array Arguments .. DOUBLE PRECISION A(LDA,*),X(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ZERO PARAMETER (ZERO=0.0D+0) ! .. ! .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I,INFO,IX,J,JX,KX LOGICAL NOUNIT ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. ! INTRINSIC MAX ! .. ! ! Test the input parameters. ! INFO = 0 IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN INFO = 1 ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.& .NOT.LSAME(TRANS,'C')) THEN INFO = 2 ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN INFO = 3 ELSE IF (N.LT.0) THEN INFO = 4 ELSE IF (LDA.LT.MAX(1,N)) THEN INFO = 6 ELSE IF (INCX.EQ.0) THEN INFO = 8 END IF IF (INFO.NE.0) THEN CALL XERBLA('DTRMV ',INFO) RETURN END IF ! ! Quick return if possible. ! IF (N.EQ.0) RETURN ! NOUNIT = LSAME(DIAG,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! IF (INCX.LE.0) THEN KX = 1 - (N-1)*INCX ELSE IF (INCX.NE.1) THEN KX = 1 END IF ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! IF (LSAME(TRANS,'N')) THEN ! ! Form x := A*x. ! IF (LSAME(UPLO,'U')) THEN IF (INCX.EQ.1) THEN DO 20 J = 1,N IF (X(J).NE.ZERO) THEN TEMP = X(J) DO 10 I = 1,J - 1 X(I) = X(I) + TEMP*A(I,J) 10 CONTINUE IF (NOUNIT) X(J) = X(J)*A(J,J) END IF 20 CONTINUE ELSE JX = KX DO 40 J = 1,N IF (X(JX).NE.ZERO) THEN TEMP = X(JX) IX = KX DO 30 I = 1,J - 1 X(IX) = X(IX) + TEMP*A(I,J) IX = IX + INCX 30 CONTINUE IF (NOUNIT) X(JX) = X(JX)*A(J,J) END IF JX = JX + INCX 40 CONTINUE END IF ELSE IF (INCX.EQ.1) THEN DO 60 J = N,1,-1 IF (X(J).NE.ZERO) THEN TEMP = X(J) DO 50 I = N,J + 1,-1 X(I) = X(I) + TEMP*A(I,J) 50 CONTINUE IF (NOUNIT) X(J) = X(J)*A(J,J) END IF 60 CONTINUE ELSE KX = KX + (N-1)*INCX JX = KX DO 80 J = N,1,-1 IF (X(JX).NE.ZERO) THEN TEMP = X(JX) IX = KX DO 70 I = N,J + 1,-1 X(IX) = X(IX) + TEMP*A(I,J) IX = IX - INCX 70 CONTINUE IF (NOUNIT) X(JX) = X(JX)*A(J,J) END IF JX = JX - INCX 80 CONTINUE END IF END IF ELSE ! ! Form x := A**T*x. ! IF (LSAME(UPLO,'U')) THEN IF (INCX.EQ.1) THEN DO 100 J = N,1,-1 TEMP = X(J) IF (NOUNIT) TEMP = TEMP*A(J,J) DO 90 I = J - 1,1,-1 TEMP = TEMP + A(I,J)*X(I) 90 CONTINUE X(J) = TEMP 100 CONTINUE ELSE JX = KX + (N-1)*INCX DO 120 J = N,1,-1 TEMP = X(JX) IX = JX IF (NOUNIT) TEMP = TEMP*A(J,J) DO 110 I = J - 1,1,-1 IX = IX - INCX TEMP = TEMP + A(I,J)*X(IX) 110 CONTINUE X(JX) = TEMP JX = JX - INCX 120 CONTINUE END IF ELSE IF (INCX.EQ.1) THEN DO 140 J = 1,N TEMP = X(J) IF (NOUNIT) TEMP = TEMP*A(J,J) DO 130 I = J + 1,N TEMP = TEMP + A(I,J)*X(I) 130 CONTINUE X(J) = TEMP 140 CONTINUE ELSE JX = KX DO 160 J = 1,N TEMP = X(JX) IX = JX IF (NOUNIT) TEMP = TEMP*A(J,J) DO 150 I = J + 1,N IX = IX + INCX TEMP = TEMP + A(I,J)*X(IX) 150 CONTINUE X(JX) = TEMP JX = JX + INCX 160 CONTINUE END IF END IF END IF ! RETURN ! ! End of DTRMV . ! END SUBROUTINE DTRMV !> \brief \b DTRMM ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! ! Definition: ! =========== ! ! SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) ! ! .. Scalar Arguments .. ! DOUBLE PRECISION ALPHA ! INTEGER LDA,LDB,M,N ! CHARACTER DIAG,SIDE,TRANSA,UPLO ! .. ! .. Array Arguments .. ! DOUBLE PRECISION A(LDA,*),B(LDB,*) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DTRMM performs one of the matrix-matrix operations !> !> B := alpha*op( A )*B, or B := alpha*B*op( A ), !> !> where alpha is a scalar, B is an m by n matrix, A is a unit, or !> non-unit, upper or lower triangular matrix and op( A ) is one of !> !> op( A ) = A or op( A ) = A**T. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] SIDE !> \verbatim !> SIDE is CHARACTER*1 !> On entry, SIDE specifies whether op( A ) multiplies B from !> the left or right as follows: !> !> SIDE = 'L' or 'l' B := alpha*op( A )*B. !> !> SIDE = 'R' or 'r' B := alpha*B*op( A ). !> \endverbatim !> !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> On entry, UPLO specifies whether the matrix A is an upper or !> lower triangular matrix as follows: !> !> UPLO = 'U' or 'u' A is an upper triangular matrix. !> !> UPLO = 'L' or 'l' A is a lower triangular matrix. !> \endverbatim !> !> \param[in] TRANSA !> \verbatim !> TRANSA is CHARACTER*1 !> On entry, TRANSA specifies the form of op( A ) to be used in !> the matrix multiplication as follows: !> !> TRANSA = 'N' or 'n' op( A ) = A. !> !> TRANSA = 'T' or 't' op( A ) = A**T. !> !> TRANSA = 'C' or 'c' op( A ) = A**T. !> \endverbatim !> !> \param[in] DIAG !> \verbatim !> DIAG is CHARACTER*1 !> On entry, DIAG specifies whether or not A is unit triangular !> as follows: !> !> DIAG = 'U' or 'u' A is assumed to be unit triangular. !> !> DIAG = 'N' or 'n' A is not assumed to be unit !> triangular. !> \endverbatim !> !> \param[in] M !> \verbatim !> M is INTEGER !> On entry, M specifies the number of rows of B. M must be at !> least zero. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> On entry, N specifies the number of columns of B. N must be !> at least zero. !> \endverbatim !> !> \param[in] ALPHA !> \verbatim !> ALPHA is DOUBLE PRECISION. !> On entry, ALPHA specifies the scalar alpha. When alpha is !> zero then A is not referenced and B need not be set before !> entry. !> \endverbatim !> !> \param[in] A !> \verbatim !> A is DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m !> when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. !> Before entry with UPLO = 'U' or 'u', the leading k by k !> upper triangular part of the array A must contain the upper !> triangular matrix and the strictly lower triangular part of !> A is not referenced. !> Before entry with UPLO = 'L' or 'l', the leading k by k !> lower triangular part of the array A must contain the lower !> triangular matrix and the strictly upper triangular part of !> A is not referenced. !> Note that when DIAG = 'U' or 'u', the diagonal elements of !> A are not referenced either, but are assumed to be unity. !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> On entry, LDA specifies the first dimension of A as declared !> in the calling (sub) program. When SIDE = 'L' or 'l' then !> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' !> then LDA must be at least max( 1, n ). !> \endverbatim !> !> \param[in,out] B !> \verbatim !> B is DOUBLE PRECISION array of DIMENSION ( LDB, n ). !> Before entry, the leading m by n part of the array B must !> contain the matrix B, and on exit is overwritten by the !> transformed matrix. !> \endverbatim !> !> \param[in] LDB !> \verbatim !> LDB is INTEGER !> On entry, LDB specifies the first dimension of B as declared !> in the calling (sub) program. LDB must be at least !> max( 1, m ). !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup double_blas_level3 ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> Level 3 Blas routine. !> !> -- Written on 8-February-1989. !> Jack Dongarra, Argonne National Laboratory. !> Iain Duff, AERE Harwell. !> Jeremy Du Croz, Numerical Algorithms Group Ltd. !> Sven Hammarling, Numerical Algorithms Group Ltd. !> \endverbatim !> ! ===================================================================== SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) ! ! -- Reference BLAS level3 routine (version 3.4.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. DOUBLE PRECISION ALPHA INTEGER LDA,LDB,M,N CHARACTER DIAG,SIDE,TRANSA,UPLO ! .. ! .. Array Arguments .. DOUBLE PRECISION A(LDA,*),B(LDB,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. ! INTRINSIC MAX ! .. ! .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I,INFO,J,K,NROWA LOGICAL LSIDE,NOUNIT,UPPER ! .. ! .. Parameters .. DOUBLE PRECISION ONE,ZERO PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) ! .. ! ! Test the input parameters. ! LSIDE = LSAME(SIDE,'L') IF (LSIDE) THEN NROWA = M ELSE NROWA = N END IF NOUNIT = LSAME(DIAG,'N') UPPER = LSAME(UPLO,'U') ! INFO = 0 IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN INFO = 1 ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN INFO = 2 ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. & (.NOT.LSAME(TRANSA,'T')) .AND.& (.NOT.LSAME(TRANSA,'C'))) THEN INFO = 3 ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN INFO = 4 ELSE IF (M.LT.0) THEN INFO = 5 ELSE IF (N.LT.0) THEN INFO = 6 ELSE IF (LDA.LT.MAX(1,NROWA)) THEN INFO = 9 ELSE IF (LDB.LT.MAX(1,M)) THEN INFO = 11 END IF IF (INFO.NE.0) THEN CALL XERBLA('DTRMM ',INFO) RETURN END IF ! ! Quick return if possible. ! IF (M.EQ.0 .OR. N.EQ.0) RETURN ! ! And when alpha.eq.zero. ! IF (ALPHA.EQ.ZERO) THEN DO 20 J = 1,N DO 10 I = 1,M B(I,J) = ZERO 10 CONTINUE 20 CONTINUE RETURN END IF ! ! Start the operations. ! IF (LSIDE) THEN IF (LSAME(TRANSA,'N')) THEN ! ! Form B := alpha*A*B. ! IF (UPPER) THEN DO 50 J = 1,N DO 40 K = 1,M IF (B(K,J).NE.ZERO) THEN TEMP = ALPHA*B(K,J) DO 30 I = 1,K - 1 B(I,J) = B(I,J) + TEMP*A(I,K) 30 CONTINUE IF (NOUNIT) TEMP = TEMP*A(K,K) B(K,J) = TEMP END IF 40 CONTINUE 50 CONTINUE ELSE DO 80 J = 1,N DO 70 K = M,1,-1 IF (B(K,J).NE.ZERO) THEN TEMP = ALPHA*B(K,J) B(K,J) = TEMP IF (NOUNIT) B(K,J) = B(K,J)*A(K,K) DO 60 I = K + 1,M B(I,J) = B(I,J) + TEMP*A(I,K) 60 CONTINUE END IF 70 CONTINUE 80 CONTINUE END IF ELSE ! ! Form B := alpha*A**T*B. ! IF (UPPER) THEN DO 110 J = 1,N DO 100 I = M,1,-1 TEMP = B(I,J) IF (NOUNIT) TEMP = TEMP*A(I,I) DO 90 K = 1,I - 1 TEMP = TEMP + A(K,I)*B(K,J) 90 CONTINUE B(I,J) = ALPHA*TEMP 100 CONTINUE 110 CONTINUE ELSE DO 140 J = 1,N DO 130 I = 1,M TEMP = B(I,J) IF (NOUNIT) TEMP = TEMP*A(I,I) DO 120 K = I + 1,M TEMP = TEMP + A(K,I)*B(K,J) 120 CONTINUE B(I,J) = ALPHA*TEMP 130 CONTINUE 140 CONTINUE END IF END IF ELSE IF (LSAME(TRANSA,'N')) THEN ! ! Form B := alpha*B*A. ! IF (UPPER) THEN DO 180 J = N,1,-1 TEMP = ALPHA IF (NOUNIT) TEMP = TEMP*A(J,J) DO 150 I = 1,M B(I,J) = TEMP*B(I,J) 150 CONTINUE DO 170 K = 1,J - 1 IF (A(K,J).NE.ZERO) THEN TEMP = ALPHA*A(K,J) DO 160 I = 1,M B(I,J) = B(I,J) + TEMP*B(I,K) 160 CONTINUE END IF 170 CONTINUE 180 CONTINUE ELSE DO 220 J = 1,N TEMP = ALPHA IF (NOUNIT) TEMP = TEMP*A(J,J) DO 190 I = 1,M B(I,J) = TEMP*B(I,J) 190 CONTINUE DO 210 K = J + 1,N IF (A(K,J).NE.ZERO) THEN TEMP = ALPHA*A(K,J) DO 200 I = 1,M B(I,J) = B(I,J) + TEMP*B(I,K) 200 CONTINUE END IF 210 CONTINUE 220 CONTINUE END IF ELSE ! ! Form B := alpha*B*A**T. ! IF (UPPER) THEN DO 260 K = 1,N DO 240 J = 1,K - 1 IF (A(J,K).NE.ZERO) THEN TEMP = ALPHA*A(J,K) DO 230 I = 1,M B(I,J) = B(I,J) + TEMP*B(I,K) 230 CONTINUE END IF 240 CONTINUE TEMP = ALPHA IF (NOUNIT) TEMP = TEMP*A(K,K) IF (TEMP.NE.ONE) THEN DO 250 I = 1,M B(I,K) = TEMP*B(I,K) 250 CONTINUE END IF 260 CONTINUE ELSE DO 300 K = N,1,-1 DO 280 J = K + 1,N IF (A(J,K).NE.ZERO) THEN TEMP = ALPHA*A(J,K) DO 270 I = 1,M B(I,J) = B(I,J) + TEMP*B(I,K) 270 CONTINUE END IF 280 CONTINUE TEMP = ALPHA IF (NOUNIT) TEMP = TEMP*A(K,K) IF (TEMP.NE.ONE) THEN DO 290 I = 1,M B(I,K) = TEMP*B(I,K) 290 CONTINUE END IF 300 CONTINUE END IF END IF END IF ! RETURN ! ! End of DTRMM . ! END SUBROUTINE DTRMM ! !> \brief \b DPPTRI ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DPPTRI + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DPPTRI( UPLO, N, AP, INFO ) ! ! .. Scalar Arguments .. ! CHARACTER UPLO ! INTEGER INFO, N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION AP( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DPPTRI computes the inverse of a real symmetric positive definite !> matrix A using the Cholesky factorization A = U**T*U or A = L*L**T !> computed by DPPTRF. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> = 'U': Upper triangular factor is stored in AP; !> = 'L': Lower triangular factor is stored in AP. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The order of the matrix A. N >= 0. !> \endverbatim !> !> \param[in,out] AP !> \verbatim !> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) !> On entry, the triangular factor U or L from the Cholesky !> factorization A = U**T*U or A = L*L**T, packed columnwise as !> a linear array. The j-th column of U or L is stored in the !> array AP as follows: !> if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; !> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. !> !> On exit, the upper or lower triangle of the (symmetric) !> inverse of A, overwriting the input factor U or L. !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument had an illegal value !> > 0: if INFO = i, the (i,i) element of the factor U or L is !> zero, and the inverse could not be computed. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup doubleOTHERcomputational ! ! ===================================================================== SUBROUTINE DPPTRI( UPLO, N, AP, INFO ) ! ! -- LAPACK computational routine (version 3.4.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, N ! .. ! .. Array Arguments .. DOUBLE PRECISION AP( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) ! .. ! .. Local Scalars .. LOGICAL UPPER INTEGER J, JC, JJ, JJN DOUBLE PRECISION AJJ ! .. ! .. External Functions .. ! LOGICAL LSAME ! DOUBLE PRECISION DDOT ! EXTERNAL LSAME, DDOT ! .. ! .. External Subroutines .. ! EXTERNAL DSCAL, DSPR, DTPMV, DTPTRI, XERBLA ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPPTRI', -INFO ) RETURN END IF ! ! Quick return if possible ! IF( N.EQ.0 ) RETURN ! ! Invert the triangular Cholesky factor U or L. ! CALL DTPTRI( UPLO, 'Non-unit', N, AP, INFO ) IF( INFO.GT.0 ) RETURN ! IF( UPPER ) THEN ! ! Compute the product inv(U) * inv(U)**T. ! JJ = 0 ! DO 10 J = 1, N DO J = 1, N JC = JJ + 1 JJ = JJ + J IF( J.GT.1 ) & CALL DSPR( 'Upper', J-1, ONE, AP( JC ), 1, AP ) AJJ = AP( JJ ) CALL DSCAL( J, AJJ, AP( JC ), 1 ) enddo !10 CONTINUE ! ELSE ! ! Compute the product inv(L)**T * inv(L). ! JJ = 1 ! DO 20 J = 1, N DO J = 1, N JJN = JJ + N - J + 1 AP( JJ ) = DDOT( N-J+1, AP( JJ ), 1, AP( JJ ), 1 ) IF( J.LT.N ) & CALL DTPMV( 'Lower', 'Transpose', 'Non-unit', N-J, & AP( JJN ), AP( JJ+1 ), 1 ) JJ = JJN enddo !20 CONTINUE END IF ! RETURN ! ! End of DPPTRI ! END SUBROUTINE DPPTRI !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> \brief \b DSPR ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! ! Definition: ! =========== ! ! SUBROUTINE DSPR(UPLO,N,ALPHA,X,INCX,AP) ! ! .. Scalar Arguments .. ! DOUBLE PRECISION ALPHA ! INTEGER INCX,N ! CHARACTER UPLO ! .. ! .. Array Arguments .. ! DOUBLE PRECISION AP(*),X(*) ! .. ! ! !> \par Purpose: ! ! ============= ! !> ! !> \verbatim !> !> DSPR performs the symmetric rank 1 operation !> !> A := alpha*x*x**T + A,! !> !> where alpha is a real scalar, x is an n element vector and A is an ! !> n by n symmetric matrix, supplied in packed form. ! !> \endverbatim ! ! ! ! Arguments: ! ! ==========! ! ! !> \param[in] UPLO ! !> \verbatim ! !> UPLO is CHARACTER*1 ! !> On entry, UPLO specifies whether the upper or lower ! !> triangular part of the matrix A is supplied in the packed ! !> array AP as follows: ! !> ! !> UPLO = 'U' or 'u' The upper triangular part of A is ! !> supplied in AP. ! !> ! !> UPLO = 'L' or 'l' The lower triangular part of A is ! !> supplied in AP. ! !> \endverbatim ! !> ! !> \param[in] N ! !> \verbatim ! !> N is INTEGER ! !> On entry, N specifies the order of the matrix A. ! !> N must be at least zero. ! !> \endverbatim ! !> ! !> \param[in] ALPHA ! !> \verbatim ! !> ALPHA is DOUBLE PRECISION. ! !> On entry, ALPHA specifies the scalar alpha. ! !> \endverbatim ! !> ! !> \param[in] X ! !> \verbatim ! !> X is DOUBLE PRECISION array of dimension at least ! !> ( 1 + ( n - 1 )*abs( INCX ) ). ! !> Before entry, the incremented array X must contain the n ! !> element vector x. ! !> \endverbatim ! !> ! !> \param[in] INCX ! !> \verbatim ! !> INCX is INTEGER ! !> On entry, INCX specifies the increment for the elements of ! !> X. INCX must not be zero. ! !> \endverbatim ! !> ! !> \param[in,out] AP ! !> \verbatim ! !> AP is DOUBLE PRECISION array of DIMENSION at least ! !> ( ( n*( n + 1 ) )/2 ). ! !> Before entry with UPLO = 'U' or 'u', the array AP must ! !> contain the upper triangular part of the symmetric matrix ! !> packed sequentially, column by column, so that AP( 1 ) ! !> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) ! !> and a( 2, 2 ) respectively, and so on. On exit, the array ! !> AP is overwritten by the upper triangular part of the ! !> updated matrix. ! !> Before entry with UPLO = 'L' or 'l', the array AP must ! !> contain the lower triangular part of the symmetric matrix ! !> packed sequentially, column by column, so that AP( 1 ) ! !> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) ! !> and a( 3, 1 ) respectively, and so on. On exit, the array ! !> AP is overwritten by the lower triangular part of the ! !> updated matrix. ! !> \endverbatim ! ! ! ! Authors: ! ! ======== ! ! ! !> \author Univ. of Tennessee ! !> \author Univ. of California Berkeley ! !> \author Univ. of Colorado Denver ! !> \author NAG Ltd. ! ! ! !> \date November 2011 ! ! ! !> \ingroup double_blas_level2 ! ! ! !> \par Further Details: ! ! ===================== ! !> ! !> \verbatim ! !> ! !> Level 2 Blas routine. ! !> ! !> -- Written on 22-October-1986. ! !> Jack Dongarra, Argonne National Lab. ! !> Jeremy Du Croz, Nag Central Office. ! !> Sven Hammarling, Nag Central Office. ! !> Richard Hanson, Sandia National Labs. ! !> \endverbatim ! !> ! ! ===================================================================== SUBROUTINE DSPR(UPLO,N,ALPHA,X,INCX,AP) ! ! ! ! -- Reference BLAS level2 routine (version 3.4.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! ! .. Scalar Arguments .. DOUBLE PRECISION ALPHA INTEGER INCX,N CHARACTER UPLO ! ! .. ! ! .. Array Arguments .. DOUBLE PRECISION AP(*),X(*) ! ! .. ! ! ! ! ===================================================================== ! ! ! ! .. Parameters .. DOUBLE PRECISION ZERO PARAMETER (ZERO=0.0D+0) ! ! .. ! ! .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I,INFO,IX,J,JX,K,KK,KX ! ! .. ! ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! ! .. ! ! .. External Subroutines .. ! EXTERNAL XERBLA ! ! .. ! ! ! ! Test the input parameters. ! ! INFO = 0 IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN INFO = 1 ELSE IF (N.LT.0) THEN INFO = 2 ELSE IF (INCX.EQ.0) THEN INFO = 5 END IF IF (INFO.NE.0) THEN CALL XERBLA('DSPR ',INFO) RETURN END IF ! ! ! ! Quick return if possible. ! ! IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN ! ! ! ! Set the start point in X if the increment is not unity. ! IF (INCX.LE.0) THEN KX = 1 - (N-1)*INCX ELSE IF (INCX.NE.1) THEN KX = 1 END IF ! ! ! ! Start the operations. In this version the elements of the array AP ! ! are accessed sequentially with one pass through AP. ! KK = 1 IF (LSAME(UPLO,'U')) THEN ! ! ! ! Form A when upper triangle is stored in AP. ! IF (INCX.EQ.1) THEN ! DO 20 J = 1,N DO J = 1,N IF (X(J).NE.ZERO) THEN TEMP = ALPHA*X(J) K = KK ! DO 10 I = 1,J DO I = 1,J AP(K) = AP(K) + X(I)*TEMP K = K + 1 ENDDO ! 10 CONTINUE END IF KK = KK + J enddo ! 20 CONTINUE ELSE JX = KX ! DO 40 J = 1,N DO J = 1,N IF (X(JX).NE.ZERO) THEN TEMP = ALPHA*X(JX) IX = KX ! DO 30 K = KK,KK + J - 1 DO K = KK,KK + J - 1 AP(K) = AP(K) + X(IX)*TEMP IX = IX + INCX enddo ! 30 CONTINUE END IF JX = JX + INCX KK = KK + J enddo ! 40 CONTINUE END IF ELSE ! ! ! ! Form A when lower triangle is stored in AP. ! IF (INCX.EQ.1) THEN ! DO 60 J = 1,N DO J = 1,N IF (X(J).NE.ZERO) THEN TEMP = ALPHA*X(J) K = KK ! DO 50 I = J,N DO I = J,N AP(K) = AP(K) + X(I)*TEMP K = K + 1 enddo !50 CONTINUE END IF KK = KK + N - J + 1 enddo ! 60 CONTINUE ELSE JX = KX ! DO 80 J = 1,N DO J = 1,N IF (X(JX).NE.ZERO) THEN TEMP = ALPHA*X(JX) IX = JX ! DO 70 K = KK,KK + N - J DO K = KK,KK + N - J AP(K) = AP(K) + X(IX)*TEMP IX = IX + INCX enddo !70 CONTINUE END IF JX = JX + INCX KK = KK + N - J + 1 enddo ! 80 CONTINUE END IF END IF ! RETURN ! ! End of DSPR . ! END SUBROUTINE DSPR ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !> \brief \b DTPTRI ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DTPTRI + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DTPTRI( UPLO, DIAG, N, AP, INFO ) ! ! .. Scalar Arguments .. ! CHARACTER DIAG, UPLO ! INTEGER INFO, N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION AP( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DTPTRI computes the inverse of a real upper or lower triangular !> matrix A stored in packed format. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> = 'U': A is upper triangular; !> = 'L': A is lower triangular. !> \endverbatim !> !> \param[in] DIAG !> \verbatim !> DIAG is CHARACTER*1 !> = 'N': A is non-unit triangular; !> = 'U': A is unit triangular. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The order of the matrix A. N >= 0. !> \endverbatim !> !> \param[in,out] AP !> \verbatim !> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) !> On entry, the upper or lower triangular matrix A, stored !> columnwise in a linear array. The j-th column of A is stored !> in the array AP as follows: !> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; !> if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n. !> See below for further details. !> On exit, the (triangular) inverse of the original matrix, in !> the same packed storage format. !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument had an illegal value !> > 0: if INFO = i, A(i,i) is exactly zero. The triangular !> matrix is singular and its inverse can not be computed. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup doubleOTHERcomputational ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> A triangular matrix A can be transferred to packed storage using one !> of the following program segments: !> !> UPLO = 'U': UPLO = 'L': !> !> JC = 1 JC = 1 !> DO 2 J = 1, N DO 2 J = 1, N !> DO 1 I = 1, J DO 1 I = J, N !> AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J) !> 1 CONTINUE 1 CONTINUE !> JC = JC + J JC = JC + N - J + 1 !> 2 CONTINUE 2 CONTINUE !> \endverbatim !> ! ===================================================================== SUBROUTINE DTPTRI( UPLO, DIAG, N, AP, INFO ) ! ! -- LAPACK computational routine (version 3.4.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. CHARACTER DIAG, UPLO INTEGER INFO, N ! .. ! .. Array Arguments .. DOUBLE PRECISION AP( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) ! .. ! .. Local Scalars .. LOGICAL NOUNIT, UPPER INTEGER J, JC, JCLAST, JJ DOUBLE PRECISION AJJ ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL DSCAL, DTPMV, XERBLA ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOUNIT = LSAME( DIAG, 'N' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTPTRI', -INFO ) RETURN END IF ! ! Check for singularity if non-unit. ! IF( NOUNIT ) THEN IF( UPPER ) THEN JJ = 0 ! DO 10 INFO = 1, N DO INFO = 1, N JJ = JJ + INFO IF( AP( JJ ).EQ.ZERO ) RETURN enddo !10 CONTINUE ELSE JJ = 1 ! DO 20 INFO = 1, N DO INFO = 1, N IF( AP( JJ ).EQ.ZERO ) RETURN JJ = JJ + N - INFO + 1 enddo !20 CONTINUE END IF INFO = 0 END IF ! IF( UPPER ) THEN ! ! Compute inverse of upper triangular matrix. ! JC = 1 ! DO 30 J = 1, N DO J = 1, N IF( NOUNIT ) THEN AP( JC+J-1 ) = ONE / AP( JC+J-1 ) AJJ = -AP( JC+J-1 ) ELSE AJJ = -ONE END IF ! ! Compute elements 1:j-1 of j-th column. ! CALL DTPMV( 'Upper', 'No transpose', DIAG, J-1, AP, AP( JC ), 1 ) CALL DSCAL( J-1, AJJ, AP( JC ), 1 ) JC = JC + J enddo ! 30 CONTINUE ! ELSE ! ! Compute inverse of lower triangular matrix. ! JC = N*( N+1 ) / 2 ! DO 40 J = N, 1, -1 DO J = N, 1, -1 IF( NOUNIT ) THEN AP( JC ) = ONE / AP( JC ) AJJ = -AP( JC ) ELSE AJJ = -ONE END IF IF( J.LT.N ) THEN ! ! Compute elements j+1:n of j-th column. ! CALL DTPMV( 'Lower', 'No transpose', DIAG, N-J,& AP( JCLAST ), AP( JC+1 ), 1 ) CALL DSCAL( N-J, AJJ, AP( JC+1 ), 1 ) END IF JCLAST = JC JC = JC - N + J - 2 enddo ! 40 CONTINUE END IF ! RETURN ! ! End of DTPTRI ! END SUBROUTINE DTPTRI ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !> \brief \b DTPMV ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! ! Definition: ! =========== ! ! SUBROUTINE DTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) ! ! .. Scalar Arguments .. ! INTEGER INCX,N ! CHARACTER DIAG,TRANS,UPLO ! .. ! .. Array Arguments .. ! DOUBLE PRECISION AP(*),X(*) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DTPMV performs one of the matrix-vector operations !> !> x := A*x, or x := A**T*x, !> !> where x is an n element vector and A is an n by n unit, or non-unit, !> upper or lower triangular matrix, supplied in packed form. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> On entry, UPLO specifies whether the matrix is an upper or !> lower triangular matrix as follows: !> !> UPLO = 'U' or 'u' A is an upper triangular matrix. !> !> UPLO = 'L' or 'l' A is a lower triangular matrix. !> \endverbatim !> !> \param[in] TRANS !> \verbatim !> TRANS is CHARACTER*1 !> On entry, TRANS specifies the operation to be performed as !> follows: !> !> TRANS = 'N' or 'n' x := A*x. !> !> TRANS = 'T' or 't' x := A**T*x. !> !> TRANS = 'C' or 'c' x := A**T*x. !> \endverbatim !> !> \param[in] DIAG !> \verbatim !> DIAG is CHARACTER*1 !> On entry, DIAG specifies whether or not A is unit !> triangular as follows: !> !> DIAG = 'U' or 'u' A is assumed to be unit triangular. !> !> DIAG = 'N' or 'n' A is not assumed to be unit !> triangular. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> On entry, N specifies the order of the matrix A. !> N must be at least zero. !> \endverbatim !> !> \param[in] AP !> \verbatim !> AP is DOUBLE PRECISION array of DIMENSION at least !> ( ( n*( n + 1 ) )/2 ). !> Before entry with UPLO = 'U' or 'u', the array AP must !> contain the upper triangular matrix packed sequentially, !> column by column, so that AP( 1 ) contains a( 1, 1 ), !> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) !> respectively, and so on. !> Before entry with UPLO = 'L' or 'l', the array AP must !> contain the lower triangular matrix packed sequentially, !> column by column, so that AP( 1 ) contains a( 1, 1 ), !> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) !> respectively, and so on. !> Note that when DIAG = 'U' or 'u', the diagonal elements of !> A are not referenced, but are assumed to be unity. !> \endverbatim !> !> \param[in,out] X !> \verbatim !> X is DOUBLE PRECISION array of dimension at least !> ( 1 + ( n - 1 )*abs( INCX ) ). !> Before entry, the incremented array X must contain the n !> element vector x. On exit, X is overwritten with the !> tranformed vector x. !> \endverbatim !> !> \param[in] INCX !> \verbatim !> INCX is INTEGER !> On entry, INCX specifies the increment for the elements of !> X. INCX must not be zero. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup double_blas_level2 ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> Level 2 Blas routine. !> The vector and matrix arguments are not referenced when N = 0, or M = 0 !> !> -- Written on 22-October-1986. !> Jack Dongarra, Argonne National Lab. !> Jeremy Du Croz, Nag Central Office. !> Sven Hammarling, Nag Central Office. !> Richard Hanson, Sandia National Labs. !> \endverbatim !> ! ===================================================================== SUBROUTINE DTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) ! ! -- Reference BLAS level2 routine (version 3.4.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. INTEGER INCX,N CHARACTER DIAG,TRANS,UPLO ! .. ! .. Array Arguments .. DOUBLE PRECISION AP(*),X(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ZERO PARAMETER (ZERO=0.0D+0) ! .. ! .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I,INFO,IX,J,JX,K,KK,KX LOGICAL NOUNIT ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! ! Test the input parameters. ! INFO = 0 IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN INFO = 1 ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.& .NOT.LSAME(TRANS,'C')) THEN INFO = 2 ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN INFO = 3 ELSE IF (N.LT.0) THEN INFO = 4 ELSE IF (INCX.EQ.0) THEN INFO = 7 END IF IF (INFO.NE.0) THEN CALL XERBLA('DTPMV ',INFO) RETURN END IF ! ! Quick return if possible. ! IF (N.EQ.0) RETURN ! NOUNIT = LSAME(DIAG,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! IF (INCX.LE.0) THEN KX = 1 - (N-1)*INCX ELSE IF (INCX.NE.1) THEN KX = 1 END IF ! ! Start the operations. In this version the elements of AP are ! accessed sequentially with one pass through AP. ! IF (LSAME(TRANS,'N')) THEN ! ! Form x:= A*x. ! IF (LSAME(UPLO,'U')) THEN KK = 1 IF (INCX.EQ.1) THEN ! DO 20 J = 1,N DO J = 1,N IF (X(J).NE.ZERO) THEN TEMP = X(J) K = KK ! DO 10 I = 1,J - 1 DO I = 1,J - 1 X(I) = X(I) + TEMP*AP(K) K = K + 1 enddo !10 CONTINUE IF (NOUNIT) X(J) = X(J)*AP(KK+J-1) END IF KK = KK + J enddo !20 CONTINUE ELSE JX = KX ! DO 40 J = 1,N DO J = 1,N IF (X(JX).NE.ZERO) THEN TEMP = X(JX) IX = KX ! DO 30 K = KK,KK + J - 2 DO K = KK,KK + J - 2 X(IX) = X(IX) + TEMP*AP(K) IX = IX + INCX enddo !30 CONTINUE IF (NOUNIT) X(JX) = X(JX)*AP(KK+J-1) END IF JX = JX + INCX KK = KK + J enddo !40 CONTINUE END IF ELSE KK = (N* (N+1))/2 IF (INCX.EQ.1) THEN ! DO 60 J = N,1,-1 DO J = N,1,-1 IF (X(J).NE.ZERO) THEN TEMP = X(J) K = KK ! DO 50 I = N,J + 1,-1 DO I = N,J + 1,-1 X(I) = X(I) + TEMP*AP(K) K = K - 1 enddo !50 CONTINUE IF (NOUNIT) X(J) = X(J)*AP(KK-N+J) END IF KK = KK - (N-J+1) enddo !60 CONTINUE ELSE KX = KX + (N-1)*INCX JX = KX ! DO 80 J = N,1,-1 DO J = N,1,-1 IF (X(JX).NE.ZERO) THEN TEMP = X(JX) IX = KX ! DO 70 K = KK,KK - (N- (J+1)),-1 DO K = KK,KK - (N- (J+1)),-1 X(IX) = X(IX) + TEMP*AP(K) IX = IX - INCX enddo !70 CONTINUE IF (NOUNIT) X(JX) = X(JX)*AP(KK-N+J) END IF JX = JX - INCX KK = KK - (N-J+1) enddo !80 CONTINUE END IF END IF ELSE ! ! Form x := A**T*x. ! IF (LSAME(UPLO,'U')) THEN KK = (N* (N+1))/2 IF (INCX.EQ.1) THEN ! DO 100 J = N,1,-1 DO J = N,1,-1 TEMP = X(J) IF (NOUNIT) TEMP = TEMP*AP(KK) K = KK - 1 ! DO 90 I = J - 1,1,-1 DO I = J - 1,1,-1 TEMP = TEMP + AP(K)*X(I) K = K - 1 enddo !90 CONTINUE X(J) = TEMP KK = KK - J enddo !100 CONTINUE ELSE JX = KX + (N-1)*INCX ! DO 120 J = N,1,-1 DO J = N,1,-1 TEMP = X(JX) IX = JX IF (NOUNIT) TEMP = TEMP*AP(KK) ! DO 110 K = KK - 1,KK - J + 1,-1 DO K = KK - 1,KK - J + 1,-1 IX = IX - INCX TEMP = TEMP + AP(K)*X(IX) !110 CONTINUE enddo X(JX) = TEMP JX = JX - INCX KK = KK - J !120 CONTINUE enddo END IF ELSE KK = 1 IF (INCX.EQ.1) THEN ! DO 140 J = 1,N DO J = 1,N TEMP = X(J) IF (NOUNIT) TEMP = TEMP*AP(KK) K = KK + 1 ! DO 130 I = J + 1,N DO I = J + 1,N TEMP = TEMP + AP(K)*X(I) K = K + 1 !130 CONTINUE enddo X(J) = TEMP KK = KK + (N-J+1) !140 CONTINUE enddo ELSE JX = KX ! DO 160 J = 1,N DO J = 1,N TEMP = X(JX) IX = JX IF (NOUNIT) TEMP = TEMP*AP(KK) ! DO 150 K = KK + 1,KK + N - J DO K = KK + 1,KK + N - J IX = IX + INCX TEMP = TEMP + AP(K)*X(IX) !150 CONTINUE enddo X(JX) = TEMP JX = JX + INCX KK = KK + (N-J+1) !160 CONTINUE enddo END IF END IF END IF ! RETURN ! ! End of DTPMV . ! END SUBROUTINE DTPMV ! !> \brief \b DPPTRF ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DPPTRF + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DPPTRF( UPLO, N, AP, INFO ) ! ! .. Scalar Arguments .. ! CHARACTER UPLO ! INTEGER INFO, N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION AP( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DPPTRF computes the Cholesky factorization of a real symmetric !> positive definite matrix A stored in packed format. !> !> The factorization has the form !> A = U**T * U, if UPLO = 'U', or !> A = L * L**T, if UPLO = 'L', !> where U is an upper triangular matrix and L is lower triangular. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> = 'U': Upper triangle of A is stored; !> = 'L': Lower triangle of A is stored. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The order of the matrix A. N >= 0. !> \endverbatim !> !> \param[in,out] AP !> \verbatim !> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) !> On entry, the upper or lower triangle of the symmetric matrix !> A, packed columnwise in a linear array. The j-th column of A !> is stored in the array AP as follows: !> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; !> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. !> See below for further details. !> !> On exit, if INFO = 0, the triangular factor U or L from the !> Cholesky factorization A = U**T*U or A = L*L**T, in the same !> storage format as A. !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument had an illegal value !> > 0: if INFO = i, the leading minor of order i is not !> positive definite, and the factorization could not be !> completed. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup doubleOTHERcomputational ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> The packed storage scheme is illustrated by the following example !> when N = 4, UPLO = 'U': !> !> Two-dimensional storage of the symmetric matrix A: !> !> a11 a12 a13 a14 !> a22 a23 a24 !> a33 a34 (aij = aji) !> a44 !> !> Packed storage of the upper triangle of A: !> !> AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] !> \endverbatim !> ! ===================================================================== SUBROUTINE DPPTRF( UPLO, N, AP, INFO ) ! ! -- LAPACK computational routine (version 3.4.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, N ! .. ! .. Array Arguments .. DOUBLE PRECISION AP( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) ! .. ! .. Local Scalars .. LOGICAL UPPER INTEGER J, JC, JJ DOUBLE PRECISION AJJ ! .. ! .. External Functions .. ! LOGICAL LSAME ! DOUBLE PRECISION DDOT ! EXTERNAL LSAME, DDOT ! .. ! .. External Subroutines .. ! EXTERNAL DSCAL, DSPR, DTPSV, XERBLA ! .. ! .. Intrinsic Functions .. ! INTRINSIC SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPPTRF', -INFO ) RETURN END IF ! ! Quick return if possible ! IF( N.EQ.0 ) RETURN ! IF( UPPER ) THEN ! ! Compute the Cholesky factorization A = U**T*U. ! JJ = 0 ! DO 10 J = 1, N DO J = 1, N JC = JJ + 1 JJ = JJ + J ! ! Compute elements 1:J-1 of column J. ! IF( J.GT.1 ) & CALL DTPSV( 'Upper', 'Transpose', 'Non-unit', J-1, AP,AP( JC ),1 ) ! ! Compute U(J,J) and test for non-positive-definiteness. ! AJJ = AP( JJ ) - DDOT( J-1, AP( JC ), 1, AP( JC ), 1 ) IF( AJJ.LE.ZERO ) THEN AP( JJ ) = AJJ GO TO 30 END IF AP( JJ ) = SQRT( AJJ ) !10 CONTINUE enddo ELSE ! ! Compute the Cholesky factorization A = L*L**T. ! JJ = 1 ! DO 20 J = 1, N DO J = 1, N ! ! Compute L(J,J) and test for non-positive-definiteness. ! AJJ = AP( JJ ) IF( AJJ.LE.ZERO ) THEN AP( JJ ) = AJJ GO TO 30 END IF AJJ = SQRT( AJJ ) AP( JJ ) = AJJ ! ! Compute elements J+1:N of column J and update the trailing ! submatrix. ! IF( J.LT.N ) THEN CALL DSCAL( N-J, ONE / AJJ, AP( JJ+1 ), 1 ) CALL DSPR( 'Lower', N-J, -ONE, AP( JJ+1 ), 1, AP( JJ+N-J+1 ) ) JJ = JJ + N - J + 1 END IF !20 CONTINUE enddo END IF GO TO 40 ! 30 CONTINUE INFO = J ! 40 CONTINUE RETURN ! ! End of DPPTRF ! END SUBROUTINE DPPTRF ! !> \brief \b DTPSV ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! ! Definition: ! =========== ! ! SUBROUTINE DTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) ! ! .. Scalar Arguments .. ! INTEGER INCX,N ! CHARACTER DIAG,TRANS,UPLO ! .. ! .. Array Arguments .. ! DOUBLE PRECISION AP(*),X(*) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DTPSV solves one of the systems of equations !> !> A*x = b, or A**T*x = b, !> !> where b and x are n element vectors and A is an n by n unit, or !> non-unit, upper or lower triangular matrix, supplied in packed form. !> !> No test for singularity or near-singularity is included in this !> routine. Such tests must be performed before calling this routine. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] UPLO !> \verbatim !> UPLO is CHARACTER*1 !> On entry, UPLO specifies whether the matrix is an upper or !> lower triangular matrix as follows: !> !> UPLO = 'U' or 'u' A is an upper triangular matrix. !> !> UPLO = 'L' or 'l' A is a lower triangular matrix. !> \endverbatim !> !> \param[in] TRANS !> \verbatim !> TRANS is CHARACTER*1 !> On entry, TRANS specifies the equations to be solved as !> follows: !> !> TRANS = 'N' or 'n' A*x = b. !> !> TRANS = 'T' or 't' A**T*x = b. !> !> TRANS = 'C' or 'c' A**T*x = b. !> \endverbatim !> !> \param[in] DIAG !> \verbatim !> DIAG is CHARACTER*1 !> On entry, DIAG specifies whether or not A is unit !> triangular as follows: !> !> DIAG = 'U' or 'u' A is assumed to be unit triangular. !> !> DIAG = 'N' or 'n' A is not assumed to be unit !> triangular. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> On entry, N specifies the order of the matrix A. !> N must be at least zero. !> \endverbatim !> !> \param[in] AP !> \verbatim !> AP is DOUBLE PRECISION array of DIMENSION at least !> ( ( n*( n + 1 ) )/2 ). !> Before entry with UPLO = 'U' or 'u', the array AP must !> contain the upper triangular matrix packed sequentially, !> column by column, so that AP( 1 ) contains a( 1, 1 ), !> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) !> respectively, and so on. !> Before entry with UPLO = 'L' or 'l', the array AP must !> contain the lower triangular matrix packed sequentially, !> column by column, so that AP( 1 ) contains a( 1, 1 ), !> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) !> respectively, and so on. !> Note that when DIAG = 'U' or 'u', the diagonal elements of !> A are not referenced, but are assumed to be unity. !> \endverbatim !> !> \param[in,out] X !> \verbatim !> X is DOUBLE PRECISION array of dimension at least !> ( 1 + ( n - 1 )*abs( INCX ) ). !> Before entry, the incremented array X must contain the n !> element right-hand side vector b. On exit, X is overwritten !> with the solution vector x. !> \endverbatim !> !> \param[in] INCX !> \verbatim !> INCX is INTEGER !> On entry, INCX specifies the increment for the elements of !> X. INCX must not be zero. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup double_blas_level2 ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> Level 2 Blas routine. !> !> -- Written on 22-October-1986. !> Jack Dongarra, Argonne National Lab. !> Jeremy Du Croz, Nag Central Office. !> Sven Hammarling, Nag Central Office. !> Richard Hanson, Sandia National Labs. !> \endverbatim !> ! ===================================================================== SUBROUTINE DTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) ! ! -- Reference BLAS level2 routine (version 3.4.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. INTEGER INCX,N CHARACTER DIAG,TRANS,UPLO ! .. ! .. Array Arguments .. DOUBLE PRECISION AP(*),X(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ZERO PARAMETER (ZERO=0.0D+0) ! .. ! .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I,INFO,IX,J,JX,K,KK,KX LOGICAL NOUNIT ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! ! Test the input parameters. ! INFO = 0 IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN INFO = 1 ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. & .NOT.LSAME(TRANS,'C')) THEN INFO = 2 ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN INFO = 3 ELSE IF (N.LT.0) THEN INFO = 4 ELSE IF (INCX.EQ.0) THEN INFO = 7 END IF IF (INFO.NE.0) THEN CALL XERBLA('DTPSV ',INFO) RETURN END IF ! ! Quick return if possible. ! IF (N.EQ.0) RETURN ! NOUNIT = LSAME(DIAG,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! IF (INCX.LE.0) THEN KX = 1 - (N-1)*INCX ELSE IF (INCX.NE.1) THEN KX = 1 END IF ! ! Start the operations. In this version the elements of AP are ! accessed sequentially with one pass through AP. ! IF (LSAME(TRANS,'N')) THEN ! ! Form x := inv( A )*x. ! IF (LSAME(UPLO,'U')) THEN KK = (N* (N+1))/2 IF (INCX.EQ.1) THEN ! DO 20 J = N,1,-1 DO J = N,1,-1 IF (X(J).NE.ZERO) THEN IF (NOUNIT) X(J) = X(J)/AP(KK) TEMP = X(J) K = KK - 1 ! DO 10 I = J - 1,1,-1 DO I = J - 1,1,-1 X(I) = X(I) - TEMP*AP(K) K = K - 1 !10 CONTINUE enddo END IF KK = KK - J !20 CONTINUE enddo ELSE JX = KX + (N-1)*INCX ! DO 40 J = N,1,-1 DO J = N,1,-1 IF (X(JX).NE.ZERO) THEN IF (NOUNIT) X(JX) = X(JX)/AP(KK) TEMP = X(JX) IX = JX ! DO 30 K = KK - 1,KK - J + 1,-1 DO K = KK - 1,KK - J + 1,-1 IX = IX - INCX X(IX) = X(IX) - TEMP*AP(K) !30 CONTINUE enddo END IF JX = JX - INCX KK = KK - J !40 CONTINUE enddo END IF ELSE KK = 1 IF (INCX.EQ.1) THEN ! DO 60 J = 1,N DO J = 1,N IF (X(J).NE.ZERO) THEN IF (NOUNIT) X(J) = X(J)/AP(KK) TEMP = X(J) K = KK + 1 ! DO 50 I = J + 1,N DO I = J + 1,N X(I) = X(I) - TEMP*AP(K) K = K + 1 !50 CONTINUE enddo END IF KK = KK + (N-J+1) !60 CONTINUE enddo ELSE JX = KX ! DO 80 J = 1,N DO J = 1,N IF (X(JX).NE.ZERO) THEN IF (NOUNIT) X(JX) = X(JX)/AP(KK) TEMP = X(JX) IX = JX ! DO 70 K = KK + 1,KK + N - J DO K = KK + 1,KK + N - J IX = IX + INCX X(IX) = X(IX) - TEMP*AP(K) !70 CONTINUE enddo END IF JX = JX + INCX KK = KK + (N-J+1) !80 CONTINUE enddo END IF END IF ELSE ! ! Form x := inv( A**T )*x. ! IF (LSAME(UPLO,'U')) THEN KK = 1 IF (INCX.EQ.1) THEN ! DO 100 J = 1,N DO J = 1,N TEMP = X(J) K = KK ! DO 90 I = 1,J - 1 DO I = 1,J - 1 TEMP = TEMP - AP(K)*X(I) K = K + 1 !90 CONTINUE enddo IF (NOUNIT) TEMP = TEMP/AP(KK+J-1) X(J) = TEMP KK = KK + J !100 CONTINUE enddo ELSE JX = KX ! DO 120 J = 1,N DO J = 1,N TEMP = X(JX) IX = KX ! DO 110 K = KK,KK + J - 2 DO K = KK,KK + J - 2 TEMP = TEMP - AP(K)*X(IX) IX = IX + INCX !110 CONTINUE enddo IF (NOUNIT) TEMP = TEMP/AP(KK+J-1) X(JX) = TEMP JX = JX + INCX KK = KK + J !120 CONTINUE enddo END IF ELSE KK = (N* (N+1))/2 IF (INCX.EQ.1) THEN ! DO 140 J = N,1,-1 DO J = N,1,-1 TEMP = X(J) K = KK ! DO 130 I = N,J + 1,-1 DO I = N,J + 1,-1 TEMP = TEMP - AP(K)*X(I) K = K - 1 !130 CONTINUE enddo IF (NOUNIT) TEMP = TEMP/AP(KK-N+J) X(J) = TEMP KK = KK - (N-J+1) !140 CONTINUE enddo ELSE KX = KX + (N-1)*INCX JX = KX ! DO 160 J = N,1,-1 DO J = N,1,-1 TEMP = X(JX) IX = KX ! DO 150 K = KK,KK - (N- (J+1)),-1 DO K = KK,KK - (N- (J+1)),-1 TEMP = TEMP - AP(K)*X(IX) IX = IX - INCX !150 CONTINUE enddo IF (NOUNIT) TEMP = TEMP/AP(KK-N+J) X(JX) = TEMP JX = JX - INCX KK = KK - (N-J+1) !160 CONTINUE enddo END IF END IF END IF ! RETURN ! ! End of DTPSV . ! END SUBROUTINE DTPSV ! ! =================================================================== ! !> \brief \b DGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm. ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DGEQR2 + dependencies !> !> [TGZ] !> !> [ZIP] !> !> [TXT] !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) ! ! .. Scalar Arguments .. ! INTEGER INFO, LDA, M, N ! .. ! .. Array Arguments .. ! DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DGEQR2 computes a QR factorization of a real m by n matrix A: !> A = Q * R. !> \endverbatim ! ! Arguments: ! ========== ! !> \param[in] M !> \verbatim !> M is INTEGER !> The number of rows of the matrix A. M >= 0. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> The number of columns of the matrix A. N >= 0. !> \endverbatim !> !> \param[in,out] A !> \verbatim !> A is DOUBLE PRECISION array, dimension (LDA,N) !> On entry, the m by n matrix A. !> On exit, the elements on and above the diagonal of the array !> contain the min(m,n) by n upper trapezoidal matrix R (R is !> upper triangular if m >= n); the elements below the diagonal, !> with the array TAU, represent the orthogonal matrix Q as a !> product of elementary reflectors (see Further Details). !> \endverbatim !> !> \param[in] LDA !> \verbatim !> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,M). !> \endverbatim !> !> \param[out] TAU !> \verbatim !> TAU is DOUBLE PRECISION array, dimension (min(M,N)) !> The scalar factors of the elementary reflectors (see Further !> Details). !> \endverbatim !> !> \param[out] WORK !> \verbatim !> WORK is DOUBLE PRECISION array, dimension (N) !> \endverbatim !> !> \param[out] INFO !> \verbatim !> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument had an illegal value !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date September 2012 ! !> \ingroup doubleGEcomputational ! !> \par Further Details: ! ===================== !> !> \verbatim !> !> The matrix Q is represented as a product of elementary reflectors !> !> Q = H(1) H(2) . . . H(k), where k = min(m,n). !> !> Each H(i) has the form !> !> H(i) = I - tau * v * v**T !> !> where tau is a real scalar, and v is a real vector with !> v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), !> and tau in TAU(i). !> \endverbatim !> ! ===================================================================== SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) ! ! -- LAPACK computational routine (version 3.4.2) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! September 2012 ! ! .. Scalar Arguments .. INTEGER INFO, LDA, M, N ! .. ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) ! .. ! ! ===================================================================== ! ! .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) ! .. ! .. Local Scalars .. INTEGER I, K DOUBLE PRECISION AII ! .. ! .. External Subroutines .. ! EXTERNAL DLARF, DLARFG, XERBLA ! .. ! .. Intrinsic Functions .. ! INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input arguments ! INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEQR2', -INFO ) RETURN END IF ! K = MIN( M, N ) ! DO I = 1, K ! ! Generate elementary reflector H(i) to annihilate A(i+1:m,i) ! CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, TAU( I ) ) IF( I.LT.N ) THEN ! ! Apply H(i) to A(i:m,i+1:n) from the left ! AII = A( I, I ) A( I, I ) = ONE CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), & A( I, I+1 ), LDA, WORK ) A( I, I ) = AII END IF enddo RETURN ! ! End of DGEQR2 ! END SUBROUTINE DGEQR2 ! !====================================== list of all subroutines/functions ! ! SUBROUTINES included complete 2019.11.12 ! DGETRI ! DTRTRI ! DTRTI2 ! DCOPY ! DGEMM ! DGEMV ! DGETRF ! DGETRF2 ! DGETRS ! DLAMRG ! DLASWP ! DLASYF ! DSCAL ! DSWAP ! DSYMV ! DSYR ! DSYTF2 ! DSYTRF ! DSYTRI ! DTRSM ! XERBLA ! DSPEVD ! DLASSQ ! DSPTRD ! DLARFG ! DSTERF ! DOPMTR ! DLARF ! DSPEV ! DSTEDC ! DLASCL ! DSTEQR ! DLASET ! DLAEV2 ! DLASR ! DLASRT ! DLAE2 ! DLARTG ! DLACPY ! DLAED0 ! DLAED1 ! DLAED7 ! DLAED8 ! DLAED9 ! DLAED2 ! DLAED3 ! DLAED4 ! DLAED5 ! DLAED6 ! DLAEDA ! DOPGTR ! DORG2L ! DORG2R ! DROT ! DGER ! DSPMV ! DAXPY ! DSPR2 ! DTRMV ! DTRMM ! DPPTRI ! DSPR ! DTPTRI ! DTPMV ! DPPTRF ! DTPSV ! DGEQR2 ! ! Functions: ! DDOT ! DISNAN ! DLAISNAN ! DLAMCH ! DLAMC3 ! IDAMAX ! IEEECK ! ILAENV ! IPARMQ ! LSAME ! LSAMEN ! DLANSP ! DLAPY2 ! DLANST ! ILADLC ! ILADLR ! DNRM2 ! ! end module oclablas ================================================ FILE: src/numlib/ocnum.F90 ================================================ ! ! MODULE LUKASNUM MODULE OCNUM ! ! This is free software using LAPACK and BLAS ! ! This program is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 2 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this program; if not, write to the Free Software ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! !------------------- ! ! double precision, private, parameter :: DSMIN=1.0D-18,DSMAX=1.0D+18,& ! DMAX=1.0D+36,DMIN=1.0D-36,epsx=1.0D-10,r=8.31451D0,& ! unity=1.0D0,zero=0.0D0 ! COMPILER WARNING ABOUT UNINITIALIZED ZERO, DSMIN, DSMAX, DMAX, DMIN, UNITY ! double precision, private, parameter :: DSMIN=1.0D-18,DSMAX=1.0D+18,& ! DMAX=1.0D+36,DMIN=1.0D-36,unity=1.0D0,zero=0.0D0 ! modified to handle gas phases with fractions 1.0D-30 ! double precision, private, parameter :: DSMIN=1.0D-33,DSMAX=1.0D+33,& ! DMAX=1.0D+60,DMIN=1.0D-60,& ! epsx=1.0D-10,r=8.31451D0,unity=1.0D0,zero=0.0D0 ! ! The orignal routines LINGLD and MDINV written by H L Lukas ! has been replaced by using LAPACK and BLAS ! ! MDINV was split in two to handle symmetric and general matrices. ! ! oclablas is a small subset of lapack and blas needed for OC ! it is not optimized for any hardware. If you have a full LAPACK+BLAS ! library for your hardware you should use that. ! #ifdef NOLAPACK use oclablas ! compile with -DLAPACK if LAPCK not extermal #endif ! ! COMPILER WARNING ABOUT UNINITIALIZED ZERO, DSMIN, DSMAX, DMAX, DMIN, UNITY double precision, private, parameter :: DSMIN=1.0D-18,DSMAX=1.0D+18,& DMAX=1.0D+36,DMIN=1.0D-36,unity=1.0D0,zero=0.0D0 ! declaration above must follow after USE ! CONTAINS ! !CCI !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Development based on the work of Joao Pedro Carvalho Teuber 12/2020 ! Linear system solved by splitting approch for conditions giving square ! mass matrix. Otherwise lingld is used SUBROUTINE lingldSplit(ND1,ND2,RMAT,X,N,M,NCONST,NPH) !----------------------------------------------------------------------- ! Solving a system of n linear equations with n unknowns ! | Masse 0 | |X| = | Gibbs | ! | Ca MasseT | | | | Cig | !----------------------------------------------------------------------- implicit none integer M,N,ND1,ND2, NPH, NCONST double precision RMAT(ND1,ND2),X(ND1) !----------------------------------------------------------------------- character trans*1 integer i,j,k,nrhs,lda,ldb,info integer ipiv1(n), ipiv2(n), ipiv(n) double precision, allocatable :: a(:,:),Masse(:, :), Gibbs(:),& MasseT(:, :), Cig(:) ! allocate(a(n,n)) allocate(Cig(NCONST)) allocate(Masse(NPH, NCONST)) allocate(Gibbs(NPH)) allocate(MasseT(NCONST, NPH)) ! ipiv=0 ipiv1=0 ipiv2=0 nrhs=1 trans='N' lda=n ldb=n ! do j=1,N do k=1,N a(j,k)=rmat(j,k) enddo x(j)=rmat(j,n+1) enddo do j=1,NPH do k=1, NCONST Masse(j,k) = a(j,k) Gibbs(j) = x(j) enddo enddo MasseT = transpose(Masse) ! Solve first part of the system call DGETRF(NPH, NCONST,Masse, NPH,IPIV1,INFO) if(info.ne.0) then write(*,*)'lingldSplit: Error return from dgetrf',info goto 900 endif call DGETRS(TRANS,NPH,NRHS,Masse,NPH,IPIV1,Gibbs,NPH,INFO) ! Solve second part of the system ! Ca = a(j+NPH,1:NCONST) !***********************************/BoS ! for MQMQA calculations with fix gas phase error here ! index of j larger than dimension of x !*********************************** do j=1, NCONST Cig(j) = x(j+NPH) - DOT_PRODUCT(a(j+NPH,1:NCONST), Gibbs) enddo call DGETRF(NCONST, NPH, MasseT, NCONST,IPIV2,INFO) if(info.ne.0) then write(*,*)'lingldSplit: Error return from dgetrf',info goto 900 endif call DGETRS(TRANS,NCONST,NRHS,MasseT,NCONST,IPIV2,Cig,NCONST,INFO) ! get solution do j=1, N if(j.LE.NCONST) then x(j) = Gibbs(j) else x(j) = Cig(j-NPH) endif enddo 900 continue deallocate(a,Masse, Gibbs,MasseT, Cig) return END SUBROUTINE lingldSplit !CCI !----------------------------------------------------------------------- SUBROUTINE LINGLDY (ND1,ND2,RMAT,X,N,M) !----------------------------------------------------------------------- ! System of n linear equations with n unknowns, ! algorithm after Gauss with line exchange ! ND1, ND2 = Dimensioning of RMAT and X (ND2 = ND1 + 1) ! RMAT = matrix with right hand side as additional column, changed ! X = result vector ! N = number of equations and unknowns ! M = Test for singularity (= n - rank) !----------------------------------------------------------------------- !---- COMMON VARIABLES ! COMMON /ALLG/ DMAX,DMIN,DSMAX,DSMIN,EPSX,R,UNITY,ZERO ! DOUBLE PRECISION DMAX,DMIN,DSMAX,DSMIN,EPSX,R,UNITY,ZERO !----------------------------------------------------------------------- !---- VARIABLES OF THE ARGUMENT LIST INTEGER M,N,ND1,ND2 DOUBLE PRECISION RMAT(ND1,ND2),X(ND1) !----------------------------------------------------------------------- !---- LOCAL VARIABLES DOUBLE PRECISION A,B,C INTEGER I,I1,J,K,L,N1,NN1 !----------------------------------------------------------------------- ! double precision, parameter :: DSMIN=1.0D-18,DSMAX=1.0D+18,& ! DMAX=1.0D+36,DMIN=1.0D-36,epsx=1.0D-10,r=8.31451D0,& ! unity=1.0D0,zero=0.0D0 ! DSMIN=1.0D-18 ! DSMAX=1.0D+18 ! DMAX=1.0D+36 ! DMIN=1.0D-36 ! epsx=1.0D-10 ! r=8.31451d0 ! unity=1.0D0 ! zero=0.0D0 !----------------------------------------------------------------------- ! write(*,*)'enter lingld' N1=N+1 NN1=N-1 M=0 !----------------------------------------------------------------------- L490: DO I=1,NN1 I1=I+1 A=ZERO L=I !----------------------------------------------------------------------- ! search of pivot line L290: DO J=I,N B=ZERO L220: DO K=I,N IF(DABS(RMAT(J,K)).LT.DSMIN) GOTO 210 IF(DABS(RMAT(J,K)).GT.DSMAX) GOTO 200 B=B+RMAT(J,K)**2 GOTO 220 200 B=B+DMAX GOTO 220 210 B=B+DMIN 220 CONTINUE enddo L220 IF (B.GE.DMAX) GOTO 290 IF (DABS(RMAT(J,I))*DSMAX.LT.B) GOTO 290 IF (DABS(RMAT(J,I)).LT.DSMIN) GOTO 290 C=RMAT(J,I)/B*RMAT(J,I) IF (C.LE.A) GOTO 290 A=C L=J 290 CONTINUE enddo L290 !----------------------------------------------------------------------- ! line exchange IF (L.EQ.I) GOTO 400 L300: DO J=I,N1 C=RMAT(I,J) RMAT(I,J)=RMAT(L,J) RMAT(L,J)=C enddo L300 !----------------------------------------------------------------------- ! diagonalisation of the matrix 400 CONTINUE L470: DO J=I1,N IF (DABS(RMAT(J,I)).LT.DSMIN.AND.DABS(RMAT(I,I)).GE.UNITY) & GOTO 470 IF (DABS(RMAT(J,I)).LE.UNITY.AND.DABS(RMAT(I,I)).GT.DSMAX) & GOTO 470 IF (DABS(RMAT(J,I)).LT.DMIN) GOTO 470 IF (DABS(RMAT(J,I)).GT.DSMAX.AND.DABS(RMAT(I,I)).LE.UNITY) & GOTO 460 IF (DABS(RMAT(J,I)).GE.UNITY.AND.DABS(RMAT(I,I)).LT.DSMIN) & GOTO 460 IF (DABS(RMAT(I,I)).LT.DMIN) GOTO 470 C=RMAT(J,I)/RMAT(I,I) L440: DO K=I1,N1 IF (DABS(RMAT(I,K)).LT.DSMIN.AND.DABS(C).LE.UNITY) GOTO 440 IF (DABS(RMAT(I,K)).LE.UNITY.AND.DABS(C).LT.DSMIN) GOTO 440 IF (DABS(RMAT(I,K)).LT.DMIN.OR.DABS(C).LT.DMIN) GOTO 440 IF (DABS(RMAT(I,K)).GT.DSMAX.AND.DABS(C).GE.UNITY) GOTO 430 IF (DABS(RMAT(I,K)).GE.UNITY.AND.DABS(C).GT.DSMAX) GOTO 430 RMAT(J,K)=RMAT(J,K)-RMAT(I,K)*C GOTO 440 430 CALL WARNGB (3,A,B,J,K) 440 CONTINUE enddo L440 GOTO 470 460 CALL WARNGB(3,A,B,J,I) 470 CONTINUE enddo L470 490 CONTINUE enddo L490 !----------------------------------------------------------------------- L700: DO L=1,N I=N1-L I1=I-1 IF (DABS(RMAT(I,N1)).LT.DSMIN.AND.DABS(RMAT(I,I)).GE.UNITY) & GOTO 660 IF (DABS(RMAT(I,N1)).LE.UNITY.AND.DABS(RMAT(I,I)).GT.DSMAX) & GOTO 660 IF (DABS(RMAT(I,N1)).LT.DMIN) GOTO 660 IF (DABS(RMAT(I,N1)).GT.DSMAX.AND.DABS(RMAT(I,I)).LE.UNITY) & GOTO 650 IF (DABS(RMAT(I,N1)).GE.UNITY.AND.DABS(RMAT(I,I)).LT.DSMIN) & GOTO 650 IF (DABS(RMAT(I,I)).LT.DMIN) GOTO 650 C=RMAT(I,N1)/RMAT(I,I) X(I)=C IF (I.EQ.1) GOTO 700 L600: DO J=1,I1 IF (DABS(RMAT(J,I)).LT.DSMIN.AND.DABS(C).LE.UNITY) GOTO 600 IF (DABS(RMAT(J,I)).LE.UNITY.AND.DABS(C).LT.DSMIN) GOTO 600 IF (DABS(RMAT(J,I)).LT.DMIN.OR.DABS(C).LT.DMIN) GOTO 600 IF (DABS(RMAT(J,I)).GT.DSMAX.AND.DABS(C).GE.UNITY) GOTO 550 IF (DABS(RMAT(J,I)).GE.UNITY.AND.DABS(C).GT.DSMAX) GOTO 550 RMAT(J,N1)=RMAT(J,N1)-RMAT(J,I)*C GOTO 600 550 CALL WARNGB (3,A,B,J,I) 600 CONTINUE enddo L600 GOTO 700 !----------------------------------------------------------------------- ! matrix singular, cutting of line and column to continue 650 M=M+1 660 X(I)=ZERO !----------------------------------------------------------------------- 700 CONTINUE enddo L700 ! write(*,701)DSMIN,DSMAX,UNITY,DMAX,DMIN !701 format('LINGLD: ',5(1PE12.4)) RETURN END SUBROUTINE LINGLDY !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ SUBROUTINE WARNGB (NR,A1,A2,I1,I2) !---- Printing of warnings, counting and stop printing after 5 times !----------------------------------------------------------------------- !---- VARIABLES OF THE ARGUMENT LIST INTEGER I1,I2,NR REAL*8 A1,A2 !----------------------------------------------------------------------- !---- LOCAL VARIABLES INTEGER K(4) SAVE K DATA K/0,0,0,0/ !----------------------------------------------------------------------- 10 FORMAT (a,': Following message appears last time') 20 FORMAT (a,': Temperature',F8.2,' above maximum Temp.:',F8.2, & ' IPHEXC(*,1-2) =',2I3) 30 FORMAT (a,': Phase stability of component',I3,' of phase',I3/5X, & 'is not defined for T =',F8.2,', range from',F8.2,' taken') 40 FORMAT (a,': Error in LINGLD, place(',I2,',',I2,')') 50 FORMAT (a,': d2G/dx2 suffers from rounding, phase',I3,' type',I3, & ' x =',E10.3,' test',E9.2) 90 FORMAT (a,': Subroutine WARNGB called with NR =',I3) !----------------------------------------------------------------------- ! write(*,*)'enter WARNGB' return IF (NR.LT.1.OR.NR.GT.4) GOTO 900 K(NR)=K(NR)+1 IF (K(NR).GT.5) RETURN IF (K(NR).EQ.5) WRITE (*,10)'WARNGB' GOTO (200,300,400,500),NR 200 WRITE (*,20)'WARNGB', A1,A2,I1,I2 RETURN 300 WRITE (*,30)'WARNGB', I1,I2,A1,A2 RETURN 400 WRITE (*,40)'WARNGB', I1,I2 RETURN 500 WRITE (*,50)'WARNGB', I1,I2,A1,A2 RETURN 900 WRITE (*,90)'WARNGB', NR STOP END SUBROUTINE WARNGB !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ SUBROUTINE PRECOND (ND1,ND2,RMAT,BADMAT) ! This is called from matsmin, code added by Clement/Joao from CEA implicit none INTEGER ND1,ND2, J DOUBLE PRECISION RMAT(ND1,ND2), INVERSIBLE LOGICAL BADMAT BADMAT=.FALSE. INVERSIBLE = 1.D20 DO J=1,ND1 INVERSIBLE = min(INVERSIBLE,DABS(RMAT(J,J))) ENDDO IF ((INVERSIBLE.GT.0.D0).AND.(ND1.EQ.ND2-1)) THEN DO J=1,ND1 RMAT(J,ND2) = RMAT(J,ND2)/RMAT(J,J) RMAT(J,J) = 1.0D0 ENDDO ELSE ! Added due to problems in parallel2 running all macros /2022.02.20 BOS ! probably because NEW Y does not reinitiate ! write(*,*)'PRECOND: Matrix illconditioned',INVERSIBLE BADMAT=.TRUE. ! ignoring this message .... it does not seem to matter 2020.02.19/BoS ! IF (ND1.NE.ND2-1) THEN ! WRITE(*,*) 'PRECOND: No Square Matrix - no preconditiong applied' ! ELSE ! WRITE(*,77)ND1,ND2,INVERSIBLE !77 format('PRECOND: Matrix not inversible - no preconditiong applied',& ! 2i4,1pe12.4) ! ENDIF ENDIF RETURN END SUBROUTINE PRECOND SUBROUTINE LINGLD (ND1,ND2,RMAT,X,N,M) !----------------------------------------------------------------------- ! Solving a system of n linear equations with n unknowns ! USING LAPACK+BLAS ! ND1, ND2 = Dimensioning of RMAT and X (ND2 = ND1 + 1) ! RMAT = matrix with right hand side as additional column, changed ! X = result vector ! N = number of equations and unknowns ! M = Test for singularity (= n - rank) !----------------------------------------------------------------------- implicit none INTEGER M,N,ND1,ND2 DOUBLE PRECISION RMAT(ND1,ND2),X(ND1) !----------------------------------------------------------------------- character trans*1 integer j,k,nrhs,lda,ldb,info integer, allocatable :: ipiv(:) double precision, allocatable :: a(:,:) ! allocate(a(n,n)) allocate(ipiv(n)) ipiv=0 ! there is just one right hand side nrhs=1 ! right hand side is in rmat(n+1,j),j=1,n), move it to x do j=1,n do k=1,n a(j,k)=rmat(j,k) enddo x(j)=rmat(j,n+1) enddo ! write(*,*)'Solving: ',nd1,nd2,n ! do j=1,n ! write(*,11)j,(rmat(j,k),k=1,n+1) ! enddo ! do j=1,n ! write(*,11)j,x(j),(a(j,k),k=1,n) ! enddo 11 format(i3,6(1pe12.4)) ! trans='N' means no transpose trans='N' lda=n ldb=n ! ! we must first L*U factorize RMAT, the original values destroyed ! CALL DGETRF(N,N,RMAT,LDA,IPIV,INFO) CALL DGETRF(N,N,A,LDA,IPIV,INFO) if(info.ne.0) then ! write(*,*)'Error return dgetrf',info goto 900 endif ! right hand side in X is overwritten by solution CALL DGETRS(TRANS,N,NRHS,A,LDA,IPIV,X,LDB,INFO) ! if(info.ne.0) then ! write(*,*)'Error return dgetrs',info ! endif 900 continue ! info=0 meaks OK, returning m=0 means error m=info ! No warnings here, using gridminimizer may generate errors that can be ignored ! if(info.gt.0) then ! write(*,*)'Error solving equilibrium matrix with DGETRS' ! else ! write(*,*)'Solving equilibrium matrix with DGETRS',m ! endif 1000 continue !CCI deallocate (a, ipiv) !CCI return END SUBROUTINE LINGLD !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ SUBROUTINE MDINV (ND1,RMAT,RINV,N,IS) ! ND2 not used and removed to eliminate confusions ! SUBROUTINE MDINV (ND1,ND2,RMAT,RINV,N,IS) ! SUBROUTINE MSINV (ND1,RMAT,RINV,IS) !----------------------------------------------------------------------- ! Matrix inversion, symmetric matrix, DOUBLE PRECISION ! using LAPACK (phase matrix) ! ND1, ND2 = Dimensioning of RMAT and RINV (ND2 = ND1 + 1) ! RINV = invers of matrix RMAT (without last column of RMAT) ! RMAT = matrix with additional column ! N = number of lines and columns ! IS = Test for singularity (0 = singular, 1 = not singular) !----------------------------------------------------------------------- ! implicit none integer nd1,nd2,n,is double precision rmat(nd1,nd1),rinv(nd1,nd1) ! integer, dimension(:), allocatable :: ipiv double precision, dimension(:), allocatable :: work integer i,j,info,lda,m,lwork character uplo*1 ! if(nd1.ne.n) ! write(*,*)'in mdinv: ',nd1,n ! do not destroy RMAT ! do i=1,nd1 ! write(*,17)nd1,(rmat(j,i),j=1,nd1) ! enddo !17 format(i3,6(1pe12.4)/(3x,6e12.4)) RINV=RMAT ! lda=n allocate(ipiv(n)) ! nonzero ipiv(i) will signalis the original row of row i ipiv=0 ! upper triangular symmetric matrix uplo='U' ! if called with lwork=-1 the optimal dimension of work is returned m=-1 ! write(*,*)'Calling dsytrf',lda,m,n allocate(work(800)) CALL DSYTRF(UPLO,N,RMAT,LDA,IPIV,WORK,m,INFO) if(info.ne.0) then write(*,*)'MDINV: Error from DSYTRF: ',info IS=0 goto 1000 endif ! lwork=int(work(1)) ! write(*,*)'lwork: ',nd1,n,lwork if(lwork.gt.700) then deallocate(work) allocate(work(lwork)) endif ! factorize a symmetric unpacked indefinite matrix CALL DSYTRF(UPLO,N,RINV,LDA,IPIV,WORK,LWORK,INFO) if(info.ne.0) then ! write(*,*)'Error return from DSYTRF:',info is=0; goto 1000 endif ! invert using the factorization CALL DSYTRI(UPLO,N,RINV,LDA,IPIV,WORK,INFO) ! write(*,*)'Info: ',info,n,lda,lwork if(info.ne.0) then ! write(*,*)'Error return from DSYTRI: ',info is=0; goto 1000 endif ! copy solution to RINV triangle to lower do i=2,n do j=1,i-1 RINV(i,j)=RINV(j,i) enddo enddo ! all OK ! write(*,*)'Matrix inverted using DSYTRI' is=1 ! 1000 continue RETURN END SUBROUTINE MDINV !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ SUBROUTINE MDINVOLD(ND1,RMAT,RINV,N,IS) ! ND2 not used and removed to eliminate confusion ! SUBROUTINE MDINVOLD(ND1,ND2,RMAT,RINV,N,IS) ! SUBROUTINE MGINV(ND1,RMAT,RINV,IS) !----------------------------------------------------------------------- ! Matrix inversion, general matrix, DOUBLE PRECISION ! using LAPACK for general matrix (component matrix) ! ND1, ND2 = Dimensioning of RMAT and RINV (ND2 = ND1 + 1) ! RINV = invers of matrix RMAT (without last column of RMAT) ! RMAT = matrix with additional column ! N = number of lines and columns ! IS = Test for singularity (0 = singular, 1 = not singular) !----------------------------------------------------------------------- ! implicit none integer nd1,nd2,n,is double precision rmat(nd1,nd1),rinv(nd1,nd1) integer, dimension(:), allocatable :: ipiv double precision, dimension(:), allocatable :: work integer i,j,info,lda,m,lwork ! if(nd1.ne.n) ! write(*,*)'in mdinv: ',nd1,n ! do not destroy RMAT ! do i=1,nd1 ! write(*,17)nd1,(rmat(j,i),j=1,nd1) ! enddo !17 format(i3,6(1pe12.4)/(3x,6e12.4)) ! copy input matrix to solution not to destroy RMAT RINV=RMAT ! lda=n allocate(ipiv(n)) ! nonzero ipiv(i) will signal the original row of row i ipiv=0 ! if called with lwork=-1 the optimal dimension of work is returned m=-1 ! write(*,*)'Calling dsytrf',lda,m,n allocate(work(800)) ! replaced DSY with DGE for general matrix inversion .... ???? CALL DGETRI(N,RINV,LDA,IPIV,WORK,m,INFO) if(info.ne.0) then ! write(*,*)'Error from DGETRI at 1: ',info IS=0 goto 1000 endif ! lwork=int(work(1)) ! write(*,*)'lwork: ',nd1,n,lwork if(lwork.gt.700) then deallocate(work) allocate(work(lwork)) endif ! factorize an general matrix CALL DGETRF(N,N,RINV,LDA,IPIV,INFO) if(info.ne.0) then ! write(*,*)'Error return from DGETRF:',info is=0; goto 1000 endif ! invert a general matrix using the factorization CALL DGETRI(N,RINV,LDA,IPIV,WORK,LWORK,INFO) ! write(*,*)'Info: ',info,n,lda,lwork if(info.ne.0) then ! write(*,*)'Error return from DGETRI: ',info is=0; goto 1000 endif ! write(*,*)'Matrix inverted using DGETRI' ! All OK, the solution is in RINV is=1 ! 1000 continue return end SUBROUTINE MDINVOLD !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ END MODULE OCNUM ================================================ FILE: src/pmain1.F90 ================================================ PROGRAM pmain1 !************************************ ! main program for the free Open Calphad software !************************************ ! use cmon1oc ! ! For parallel processing !$ use omp_lib ! implicit none ! character linkdate*12 ! version moved to models/gtp3.F90 ! character linkdate*12,version*8 TYPE(gtp_equilibrium_data), pointer :: ceq ! these will be used later for dimensioning things and efaul integer i,narg,intvar(10) double precision dblvar(10) character arginline(4)*256,arg*64,date*16 ! ! save the data of linking the program ! call date_and_time(date) ! write(*,*)'Stored linking date: ',date ! This line replaced by linkocdate to the date when compilin linkdate='2026-04-23' ! for example: linkdate='2026-04-23' ! the overall version identifier is now in gtp3.F90 ! intvar and dblvar will eventually be used for allocations intvar(1)=30 call init_gtp(intvar,dblvar) if(gx%bmperr.ne.0) then stop 'Error initiating GTP data structures' endif ! extract arguments from the line of invocation ! at present just a macro file name narg=iargc() if(narg.gt.4) then write(*,*)'OC accepts max 4 inline arguments' narg=4 ! else ! write(*,*)'Inline arguments: ',narg endif do i=1,narg call getarg(i,arginline(i)) ! write(*,*)trim(arginline(i)) enddo ! call oc_command_monitor(version,linkdate,narg,arginline) ! ! we come back here with the "back" command in the user i/f ! The data structure for the default equilibrium is in eqlis ceq=>eqlista(1) ! additional code can be added below for some particular app ! write(*,*)'A bientot' call deallocate_gtp(intvar,dblvar) ! end PROGRAM pmain1 ================================================ FILE: src/stepmapplot/smp2.F90 ================================================ ! Data structures and routines for step/map/plot (using gnuplot) ! MODULE ocsmp ! ! Copyright 2012-2021, Bo Sundman, France ! ! This program is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 2 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this program; if not, write to the Free Software ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! !------------------------------ ! use liboceqplus ! this to implement sleep use, intrinsic:: iso_c_binding, only: c_int ! implicit none character*8, parameter :: smpversion='SMP-2.30' ! ! this interface added to sleep after GNUPLOT command interface subroutine usleep(us) bind (C) import c_int integer(c_int), value :: us end subroutine usleep end interface ! ! note the type map_fixph declared in matsmin.F90 (in liboceq) ! ! Thought for smp3. A new method to calculate diagrams with tie-line in plane ! No fix phase but instead a fixed compostion in the middle of the tie-line ! That means no problems changing fix phase! ! ! MAP_NODE records are created whenever the set of stable phases changes. ! It can have links to two or more MAP_LINE records with calculated equilibra. ! Initially at least one of these map_line records are empty with just ! information of the axis to vary and direction. ! There is a FIRST map_node record and subsequent are linked by a double linked ! list, next and previous. All map_node records have a pointer to the first. ! There are a special use of map_node records when the node has as many stable ! phases as the line and it has only two lines connected: ! - when starting following a line from a start point ! - when the array of calculated equilibria must be saved on a file a map_node ! record is created for each unifinished line. The map_node and map_line ! records must be saved on the random file also and initiated for the next. ! All map_node records must be kept for the next block. It is possible that ! a line is being calculated leading to a node with no exits. If that node ! is removed it will be created again and all already calculated lines exiting ! will be calculated again ... ! ! MAP_LINE records are created for each line followed during the step/map. It ! contains links to stored gtp_equilibrium_data records and some ! additional info. ! The stored gtp_equilibrium_data records belong to an array that can be saved ! on a random file and the links are the index to reords in this array. The ! gtp_equilibrium_data records are linked internallw with these indices also. ! The map_line record has links to two map_node records representing the ! two ends of the line. A map_line that terminates at the end of an axis will ! have a zero link for that end of the line. ! !\begin{verbatim} ! These are bits in the map_line status word ! if EXCLUDEDLINE set the whole line is inactived ! TWOSTOICH set if there are tie-lines inplane and line ends with stoich phases ! with same composition (see for example U-O) integer, parameter :: EXCLUDEDLINE=0, TWOSTOICH=1 ! Bit in the MAP_NODE record integer, parameter :: MAPINVARIANT=0,STEPINVARIANT=1 !\end{verbatim} ! ! !\begin{verbatim} TYPE map_line ! This is record contains a list of calculated equilibria along a line ! These are pointers to map_node records at start and end of line. type(map_node), pointer :: start,end ! For threading this record must be separate from other threads ! This record is created by calling calceq7 the first equilibrium of line type(meq_setup) :: meqrec ! the active ceq record must be stored together with all others in order to be ! copied from the ceq record saved with the node record when line starts type(gtp_equilibrium_data), pointer :: lineceq ! this is the number of calculated equilibria for this line and the index ! of the first and last one stored. ! The stored equilibria has an internal next link. ! lineid is a sequential index of the lines. done is negative if done ! nfixphases are the number of fixed phases replacing axis conditions ! status kan be used to delete a line integer number_of_equilibria,first,last,lineid,done,nfixphases,status ! This is used during mapping to identify lines that have the same fixed phases ! if we have 3 or more axis there can be 2 or more fix phases along the line?? ! With 2 axis there can only be one fix phase! type(gtp_phasetuple), dimension(:), allocatable :: linefixph ! also save index to phr!! (do not trust ...) integer, dimension(:), allocatable :: linefix_phr ! Save the phase tuplet representing the phase fix at start node here ! If it wants to be stable at first step along a line change axis direction ! type(gtp_phasetuple) :: nodfixph <<<< not used ! This is the phase index in the phr array (phr has both phase and compset) integer nodfixph ! We must also save the number and set of stable phases and theit amounts ! as we will have different stable phases for different lines integer nstabph type(gtp_phasetuple), dimension(:), allocatable :: stableph double precision, dimension(:), allocatable :: stablepham ! added also index to phr as that seems useful integer, dimension(:), allocatable :: stable_phr ! axandir is set when linenode is created to the axis and direction for first ! step from the node. It can be changed to another axis and direction ! during map and indicate the current axis with active condition ! axchange remember the equilibrum number for an axis change integer axandir,axchange ! more is 1 while following the line, 0 for last equilbrium, -1 when finished ! termerr is zero unless line terminated with error, -1 means exit not used ! problem is nonzero if map_problems has been called ! lasterr is the last error occured calculating this line integer more,termerr,problems,lasterr ! firstinc is a value to add the the axis variable for the first equilibrium ! to avoid finding the node point again. Evenvalue is the next value ! to calculate during a step calculation. Both set when creating the node. ! At start nodes they are zero double precision firstinc,evenvalue ! During map the last axis values for ALL axis are stored here double precision, dimension(:), allocatable :: axvals ! If tie-lines in the plane we must also check the axis values for ! the other line as we may have to change the fix phase double precision, dimension(:), allocatable :: axvals2 ! save previous values of axvals to handle axis changes ... double precision, dimension(:), allocatable :: axvalx ! save previous changes in axis values, for tie-line in plane ! dxval(phase,axis) double precision, dimension(:,:), allocatable :: dxval ! factor to control length of step in axis with axtive condition double precision :: axfact ! data particular to a step calculation, for example scheil ! character*24, allocatable, dimension(:) :: stepresultid end TYPE map_line !\end{verbatim} ! !------------------------------------------------------------------- ! !\begin{verbatim} TYPE map_node ! this record organizes the step/map results. Whenever there is a ! change of the set of stable phases a node record is created and it ! can have links to several map_line records. The map node record has a ! link to a gtp_equilibrium_data record (ceq) for the equilibrium at the node. ! This is copied to the map_line record when this is activated. ! In the map_line record an axis and direction to start is stored. ! NOTE all gtp_equilibrium_data (ceq) records are pointers to the global ! array as new composition sets may be created along any line. ! The node record is identified by the set of stable phases and the ! chemical potentials of the components. One must be able to identify the ! node as one may find the same node following different lines. ! locally stored linerecords for lines exiting the node type(map_line), dimension(:), allocatable :: linehead ! links to other nodes ! plotlink is used to overlay two or more map or step commands type(map_node), pointer :: first,next,previous,plotlink ! saved copy of the meqrec record used to calculate the node type(meq_setup) :: meqrec ! link to saved copy of the equilibrium record type(gtp_equilibrium_data), pointer :: nodeceq ! link to array of saved equilibrium record. (only maptop?) type(map_ceqresults), pointer :: saveceq ! copy of nodeceq in saveceq (composition sets not updated but needed for plot) integer savednodeceq ! type_of_node not used?? Proposal ! =1 step normal; =2 step_separate; =3 Scheil; =4 Tzero; =5 Paraeq; =6 NPLE ! =10 map_tieline_inplane; =11 map_isotherm; ! =20 map_isopleth ! lines are number of line records ! noofstph is number of stable phases (copied from meqrec) ! tieline_inplane is 1 if so, 0 if step, -1 if no tie-lines (only maptop) ! number_ofaxis is the number of axis, 1=step; (only maptop) ! artxe (extra) to indicate that the node has two stoichiom phases ! status for some bits maybe ! globalcheckinterval set when created from integer mapglobalcheck integer type_of_node,lines,noofstph,tieline_inplane,number_ofaxis,artxe integer status,globalcheckinterval ! seqx is unique identifier for a map node ! seqy unique identifier for maplines, incremented for each line (only maptop) integer seqx,seqy ! nodefix is the phase held fix when calculating node type(gtp_phasetuple) :: nodefix ! Value of T and P, copied from meqrec double precision, dimension(2) :: tpval ! chemical potentials, copied from meqrec double precision, dimension(:), allocatable :: chempots ! stable phase+compset, copied from meqrec (not used?) type(gtp_phasetuple), dimension(:), allocatable :: stable_phases end TYPE map_node !\end{verbatim} ! !------------------------------------------------------------------- ! !\begin{verbatim} TYPE map_axis ! description of the axis variables used for step/map ! The axis condition in bits and pieces integer nterm,istv,iref,iunit integer, dimension(:,:), allocatable :: indices type(gtp_state_variable), dimension(:), allocatable :: axcond double precision, dimension(:), allocatable :: coeffs ! the min, max and increment along the axis double precision axmin,axmax,axinc ! more must be initiated to 0, if nonzero replaced by a fixed phase ! seqz is the sequential index of the condition in the list (this is not ! changed if conditions are added (at the end) or deleted (active=1) ! we cannot use a pointer as that depend on the current equilibrium. integer more,seqz ! This is the last succesfully calculated axis value double precision lastaxval end TYPE map_axis !\end{verbatim} ! decrlared as an array with each axis as one element of the array ! !------------------------------------------------------------------- ! !\begin{verbatim} TYPE map_ceqresults ! stores calculated equilibrium records integer size,free,index TYPE(gtp_equilibrium_data), dimension(:), allocatable :: savedceq end TYPE map_ceqresults !\end{verbatim} ! !-------------------------------------------------------------- ! !\begin{verbatim} TYPE graphics_textlabel ! To put labels on a graph we must store these in a list TYPE(graphics_textlabel), pointer :: nexttextlabel double precision xpos,ypos,textfontscale integer angle character*80 textline end type graphics_textlabel ! !\end{verbatim} ! !------------------------------------------------------------------------ ! !\begin{verbatim} TYPE plot_line ! here various information about a line to be plotted should be stored ! for the moment it is under construction in parallel with old structures ! the "plot_line" records form a linked list starting at plotline1 type(plot_line), pointer :: nextline ! linetype 1=normal; 2=binary invariant; 3=ternary monovariant; 4=tieline ! linetype -1=end of plotlines integer type integer active end type plot_line !\end{verbatim} ! !------------------------------------------------------------------------ ! !\begin{verbatim} TYPE starteqlista ! links to equilibria that are used as start points for step or map type(gtp_equilibrium_data), pointer :: p1 end type starteqlista !\end{verbatim} type (starteqlista), dimension(20) :: starteqs integer noofstarteq ! !------------------------------------------------------------------------ ! !\begin{verbatim} TYPE graphics_options ! setting options for the plotting, this replaces most arguments in the call ! to ocplot2(ndx,pltax,filename,maptop,axarr,form) ! ndx is mumber of plot axis, pltax is text with plotaxis variables ! filename is intermediary file (maybe not needed) ! maptop is map_node record with all results ! form is type of output (screen/postscript/pdf(acrobat)/gif) !------------------------------------------------------------------ ! status contain bits, BITS defined below (GRKEEP etc) ! rangedefaults(i) nonzero if min/max for axis i set by user ! axistype(i) is 1 if axis i is logscale ! plotmin/max are user definied min/max ! defltmin/max are default min/max (generated by the plotting software) integer :: status=0,rangedefaults(3)=0,axistype(2)=0,setgrid=0 double precision, dimension(3) :: plotmin,plotmax double precision, dimension(3) :: dfltmin,dfltmax ! number of axis used for calculation (STEP=1 MAP=2 or more) integer noofcalcax ! scalefact is by defailt 1.0 and can be used to scale ais value, fore ! example to plot kJ rather than J for reasonable axis double precision, dimension(3) :: scalefact=one ! these define realative plot size for X and Y, normally 1.0 or less double precision :: xsize=1.0D0,ysize=1.0D0 ! labeldefaults(i) for axis i 0 means default text, 1 text in plotlabels ! tielines>0 means plot a tieline every tielines calculated equilibrium integer :: labeldefaults(3),linett=1,tielines=0 ! plotlabel(1) is heading, 2 is x-axis text, 3 is y-axis text character*64, dimension(3) :: plotlabels ! linetype is 0 for dashed lines, 1 for full lines ! integer linestyle integer linetype ! if linepoints >0 plot a symbol at each linewp point integer :: linewp=0 ! if true plot a triangular diagram (isothermal section) logical gibbstriangle ! the set key command in GNUPLOT specifies where the line id is written ! it can be on/off, placed inside/outside, left/right/center, top/bottom/center, ! and some more options that may be implemented later ... character labelkey*48, font*32 ! filename is file to write the GNUPLOT command and data file ! appendfile is a file name that will be appended unless empty character filename*256,appendfile*256 ! gnuplot terminals and keys, gnuselterm is selected terminal type (1..8) integer gnutermsel,gnutermax character*80 gnuterminal(8) character*8 filext(8) character*8 gnutermid(8) ! firstextlabel is a pointer to a list of text label(s) ! to be written at a given position TYPE(graphics_textlabel), pointer :: firsttextlabel ! pltax are the state variables to be plotted ! NOT USED: pform is the graphics format replaced by gnutermsel character pltax(2)*24,pform*32 ! The default and current ending of a plot character*12 :: plotenddefault='pause mouse ' character plotend*36 ! added 18.09.24 text at lower left corner character (len=6) :: lowerleftcorner=' ' ! added to have larger axis texts and line titles integer:: textonaxis=0 ! nothing special 0, other as stepspecial: 1=separate; 2=Scheil; 3=Tzero; ! 4=paraequil; 5=NPLE ! but stepseparate, Tzero and paraequil works without using this. ! For Schiel I am trying to change line color for different parts of the line integer :: specialdiagram=0 #ifdef notwin ! Garamond and Baskerville not available in GNUPLOT ! character (len=8) :: logofont='Arial,20' character (len=14) :: logofont='Baskerville,20' #else ! On windows system the Garamond is nicer character (len=16) :: logofont='Garamond Bold,20' #endif ! many more options can easily be added when desired, linetypes etc end TYPE graphics_options !\end{verbatim} ! ! fix status during mapping, normally 2 means fix (not used) integer, parameter :: MAPPHASEFIX=3 ! OS dependent values NOT BITS #ifdef notwin integer, parameter :: PLOTONWIN=0 #else integer, parameter :: PLOTONWIN=1 #endif !------------------------------------------------- ! BITS for graphopt status word, do not use bit 0 and 1 ... ! these bits are very confused ... ! GRKEEP is set if graphics windows kept (does not really matter) ! GRNOTITLE is set if no title plotted ! GRISOPLETH if plot is an isopleth (no tielines) ! GRTABLE list results in a CSV table integer, parameter :: GRKEEP=2, GRNOTITLE=3, GRISOPLETH=4, GRCSVTABLE=5 !-------------------------------------------------- ! default for some colors character (len=6) :: monovariant='7CFF40' ! this is light green character (len=6) :: tielinecolor='7CFF40' ! for trace logical :: plottrace=.FALSE. ! Using memory for stored equilibria to avoid memory crash ! Totalsaved includes all equilibria saved during multiple map integer totalsavedceq integer, parameter :: maxsavedceq=1999 ! To warn that some calculated lines are excluded from plot integer :: lines_excluded=0 ! !------------------------------------------------- ! type(plot_line), pointer :: lastplotline,plotline1 ! set by user for globalcheck during STEP/MAP integer :: mapglobalcheck=0 ! repeated errors integer :: repeatederr=0 ! !------------------------------------------------- ! equlibrium record used to handle fast diffusiion in calc_allslices ! Should be initiated at each step/map command TYPE(gtp_equilibrium_data), target :: sliceq !------------------------------------------------- ! CONTAINS ! routines to calculate the diagrams include "smp2A.F90" ! routines to plot the diagrams include "smp2B.F90" END MODULE ocsmp ================================================ FILE: src/stepmapplot/smp2A.F90 ================================================ ! These soubroutine calculate the diagram, smp2B plot it !\addtotable subroutine map_setup !\begin{verbatim} subroutine map_setup(maptop,nax,axarr,seqxyz,starteqs) ! main map/step routine ! THIS HAS BEEN SPLIT IN TWO PARTS ! This first part tranforms all user provided or automatic start points ! to start equilibria ! The second goes through the list of start equiliria until it is ! empty ! ! maptop is the main map_node record which will return all calculated lines. ! nax is the number of axis (can be just one for STEP) ! axarr is an array of records specifying the axis for the step/map ! seqxyz are intial values for number of nodes and lines ! starteqs is an array with equilibrium data record ! they are linked using the ceq%next index implicit none integer nax,seqxyz(*) type(map_axis), dimension(nax) :: axarr ! TYPE(gtp_equilibrium_data), pointer :: starteq TYPE(starteqlista), dimension(*) :: starteqs TYPE(map_node), pointer :: maptop !\end{verbatim} TYPE(gtp_equilibrium_data), pointer :: ceq,starteq type(gtp_condition), pointer :: pcond TYPE(map_node), pointer :: tmp type(map_line), pointer :: mapline ! should this meqrec be a pointer or not?? type(meq_setup), pointer :: meqrec type(map_fixph), allocatable :: mapfix ! type(map_fixph), pointer :: mapfix double precision starting,finish2,axvalok,dgm,tsave,xxx,yyy,zzz integer starttid,endoftime,bytdir,seqz,nrestore,termerr,lastimethiserror type(gtp_state_variable), pointer :: svrrec,svr2 type(gtp_state_variable), target :: svrtarget ! save current conditions character savedconditions*1024 ! for saving a copy of constitutions double precision, allocatable, dimension(:) :: copyofconst ! inactive are indices of axis conditions inactivated by phases set fixed ! inactive not used ... integer iadd,irem,isp,seqx,seqy,mode,halfstep,jj,ij,inactive(4),bytaxis integer ceqlista ! inmap=1 turns off converge control of T integer, parameter :: inmap=1 character ch1*1 logical firststep,onetime ! ! write(*,*)'in map_setup' ! save all conditions ! call get_all_conditions(savedconditions,-1,starteqs(1)%p1) ij=1 savedconditions=' ' savecond: do jj=1,nax ! write(*,*)'SMP2A get_one: ',ij,axarr(jj)%seqz call get_one_condition(ij,savedconditions,& axarr(jj)%seqz,starteqs(1)%p1) if(gx%bmperr.ne.0) then gx%bmperr=0; savedconditions=' '; exit savecond endif ij=len_trim(savedconditions)+2 enddo savecond ! initiate sliceq for Scheilsimilation of fast diffusion sliceq%nexteq=-1 ! write(kou,*)'SMP2A saved: ',trim(savedconditions) nrestore=0 lastimethiserror=0 ! first transform start points to start equilibria on zero phase lines ! All axis conditions except one are converted to fix phase conditions ! (if there is just one axis skip this) ! One or more map_node records are created with mapline records each call cpu_time(starting) call system_clock(count=starttid) inactive=0 ! if(ocv()) write(*,*)'Entering map_setup',nax ! if automatic statpoints requested they are generatet here ! call auto_startpoints(maptop,nax,axarr,seqxyz,starteq) ! ceq=>starteq ceq=>starteqs(1)%p1 iadd=1 ! ceqlista=1 21 continue ! write(*,'(a,a,3i4)')'SMP2A Start equilibrium: ',trim(ceq%eqname),& ! ceq%eqno,ceq%nexteq,ceq%multiuse ! if(ceq%nexteq.gt.0) then ! ceq=>eqlista(ceq%nexteq) ! iadd=iadd+1 ! goto 21 ! endif ! noofstarteq is a global variable in SMP, set by calling routine if(noofstarteq.gt.0) write(*,*)'There are ',noofstarteq,' start equilibria' ! loop to change all start equilibria to start points ! Store the start points in map_node records started from maptop do ceqlista=1,noofstarteq ceq=>starteqs(ceqlista)%p1 ! write(*,*)'SMP2A calling map_startpoint: ',trim(ceq%eqname),ceq%eqno ! read(*,106)ch1 106 format(a) ! convert all axis conditions except one to fix phase call map_startpoint(maptop,nax,axarr,seqxyz,inactive,ceq) if(gx%bmperr.ne.0) then write(*,101)ceq%nexteq,gx%bmperr 101 format('Failed calculate a start point: ',i4,i7) ! ceq=>eqlista(ceq%nexteq) gx%bmperr=0 goto 900 endif ! I have not really implemented several startpoint, I am not sure ! if each does each have separate maptop and savesec .... ! error if no startpoints if(.not.associated(maptop)) then write(*,*)'Cound not find a single start equilibria for',ceqlista ! gx%bmperr=4224; goto 1100 goto 900 endif ! write(*,*)'There is a MAPTOP record ...' ! create array of equilibrium records for saving results seqy=maxsavedceq call create_saveceq(maptop%saveceq,seqy) if(gx%bmperr.ne.0) goto 1000 ! initiate node counter done, line counter will be incremented if(maptop%seqx.gt.1) write(*,85)maptop%seqx,maptop%seqy+1 85 format('Previous step/map results saved'/& 'New mapnode/line equilibria indices will start from: ',i3,i5) ! maptop%seqy=0 ! write(*,*)'savesize: ',size(maptop%saveceq%savedceq) ! if there are more startpoints try to convert these to start equilibria 900 continue ! write(*,*)'At label 900: ',gx%bmperr enddo ! write(*,*)'SMP Finished loop',associated(maptop) if(associated(maptop)) then if(allocated(maptop%linehead)) then ! Clear any error code if we have linhead allocated if(gx%bmperr.ne.0) gx%bmperr=0 else write(*,*)'Failed to find any lines to calculate' goto 1000 endif else ! no maptop record write(*,*)'Failed finding startpoints for step/map' goto 1100 endif !----------------------------------------------------- ! now we should calculate all lines stored as start equilibria ! but maybe there are no start equilibria?? ! starteq is a ceq record, mapping will use maptop record .... write(*,*)'SMP2A call map_doallines' call map_doallines(maptop,nax,axarr,seqxyz,starteq) ! write(*,*)'SMP2A back from map_doallines' !----------------------------------------------------- 1000 continue !-------------------------------------------------- ! Here we have now finished the step/map. ! Set back inactive axis conditions How?? ! do ij=2,inactive(1) ! call locate_condition(inactive(ij),pcond,ceq) ! pcond%active=0 ! enddo call system_clock(count=endoftime) call cpu_time(finish2) if(gx%bmperr.ne.0) then write(*,1005)gx%bmperr 1005 format('STEP/MAP terminated with error code: ',i5) gx%bmperr=0 else write(*,1010)maptop%saveceq%free-1,finish2-starting,endoftime-starttid 1010 format(/'Finished step/map with ',i5,' equilibria in ',& 1pe12.4,' CPU s and ',i7,' cc') endif if(len_trim(savedconditions).gt.0) then ! write(*,*)'SMP2A restore: ',trim(savedconditions) ! if(index(savedconditions,'>=').gt.0) then ! conditions including a fix phase, do not try to restore ! write(*,*)'SMP2A cannot restore original conditions' ! goto 1100 ! endif ! write(*,*)'Restoring all initial conditions: ' ! write(*,*)trim(savedconditions) ! ij is incremented by 1 inside set_condition ij=0 ! SUCK, I fixed that conditions with 2 terms was not entered again but ! after other changes to handle condition with species such as O-2 ! the same problem! Just remove all conditions and set those saved!! ! write(*,*)'SMP2A conditions at end of step/map' ! It may create loss of memory but ... what the heck ... buy more! ! call list_conditions(kou,ceq) ! write(*,*)'SMP2A remove all conditions' ! if(nax.eq.1) then ! write(*,*)'SMP2 Conditions can be changed by some STEP commands' ! endif ! goto 1100 !----------------------------------------------------- ! I am not sure it is critical to restore conditions ... ! it could be some cases when conditions are modified in STEP TZERO/SCHEIL/PARA !----------------------------------------------------- ! this does not work because axis and maybe other things refer to ! conditions by index. If I remove all conditions to restore them ! these indices become invalid ! call set_condition('*:=none ',ij,starteqs(1)%p1) ! call list_conditions(kou,ceq) ij=0 ! write(*,*)'SMP2A restore axis cond: ',trim(savedconditions) call set_condition(savedconditions,ij,starteqs(1)%p1) if(gx%bmperr.ne.0) write(*,*)'Error restoring axis conditions',gx%bmperr ! write(*,*)'SMP2A restored conditions:' ! call list_conditions(kou,ceq) else write(*,*)'SMP2A axis conditions could not be restored' endif 1100 continue return end subroutine map_setup !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine map_doallines !\begin{verbatim} subroutine map_doallines(maptop,nax,axarr,seqxyz,starteq) ! main map/step routine ! maptop is the main map_node record which will return all calculated lines. ! nax is the number of axis (can be just one for STEP) ! axarr is an array of records specifying the axis for the step/map ! seqxyz are intial values for number of nodes and lines ! starteq is an equilibrium data record, if there are more start equilibria ! they are linked using the ceq%next index implicit none integer nax,seqxyz(*) type(map_axis), dimension(nax) :: axarr TYPE(gtp_equilibrium_data), pointer :: starteq TYPE(map_node), pointer :: maptop !\end{verbatim} TYPE(gtp_equilibrium_data), pointer :: ceq type(gtp_condition), pointer :: pcond TYPE(map_node), pointer :: tmp type(map_line), pointer :: mapline ! should this meqrec be a pointer or not?? type(meq_setup), pointer :: meqrec type(map_fixph), allocatable :: mapfix ! type(map_fixph), pointer :: mapfix double precision starting,finish2,axvalok,dgm,tsave,xxx,yyy,zzz,axval integer starttid,endoftime,bytdir,seqz,nrestore,termerr,lastimethiserror type(gtp_state_variable), pointer :: svrrec,svr2 type(gtp_state_variable), target :: svrtarget ! save current conditions character savedconditions*1024 ! for saving a copy of constitutions double precision, allocatable, dimension(:) :: copyofconst ! inactive are indices of axis conditions inactivated by phases set fixed ! inactive not used ... integer iadd,irem,isp,seqx,seqy,mode,halfstep,jj,ij,inactive(4),bytaxis integer ceqlista,phfix,haha,lastax,mapx,lokph,lokcs,bypass integer trynewphase,jrem,addcheck ! inmap=1 turns off converge control of T integer, parameter :: inmap=1 character ch1*1,phasename*28 logical firststep,onetime,noderrmess ! ! write(*,*)'in map_doallines' !------------------------------- ! return here for each new line to be calculated ! NOTE we can start a new thread for each line, when a node is found ! all threads stop. ! If the node already exists the exit corresponing to the new line removed ! and the thread ends ! initiate phfix, looking for crash it seems to be used before set ... phfix=0 ! If the node is new it is created and exits added and the thread ends. inactive=0 nrestore=0 lastimethiserror=0 300 continue ! this is to write a warning message once for each line onetime=.true. bytaxis=0 firststep=.TRUE. ! THREADPROTECTED CALL the map_findline will copy the ceq from mapnode if(ocv()) write(*,*)'Looking for a line to calculate' call map_findline(maptop,axarr,mapfix,mapline) if(gx%bmperr.ne.0) goto 1000 ! if no line we are finished! ! write(*,*)'Back from map_findline 1: ',associated(mapline),allocated(mapfix) ! segmentation fault crash later ... if(.not.associated(mapline)) goto 900 ! write(*,*)'We will start calculate line: ',mapline%lineid,mapline%axandir if(maptop%tieline_inplane.ne.0) then ! for mapping we need to check how all axis varies allocate(mapline%axvals(nax)) allocate(mapline%axvalx(nax)) if(maptop%tieline_inplane.gt.0) then ! with tie-lines in plane we must check axis variable for stable phase also allocate(mapline%axvals2(nax)) ! else ! any special to do?? endif endif ! Each thread must have separate meqrec and ceq records !vvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ceq=>mapline%lineceq ! ?? We may have incompatibility between ceq and meqrec if new compsets added ! maybe meqrec should not be a pointer? meqrec=>mapline%meqrec noderrmess=.true. ! No grid minimization and the phr is not deallocated with mode<0 ! It is necessary to generate new meqrec for each line as there may be new ! composition sets created in other threads. But we must also specify ! phases set fix due to the mapping to replace axis conditions. ! We must provide an array of phase tuples with fix phases. ! write(*,*)'Calling calceq7 for new line: ',mapline%lineid if(ocv()) write(*,*)'Calling calceq7 for new line: ',mapline%lineid ! mode=-1 means no gridminimization and do not deallocate phr mapline%problems=0 mapline%lasterr=0 mode=-1 if(ocv()) write(*,*)'This call generates mapline%meqrec for this line' bytdir=0 ! the save constitutions may be useful if problems ... ??? if(allocated(copyofconst)) deallocate(copyofconst) ! segmentation fault in this subroutine ... ! because I checked only size(..) and not if it was allocated ... call save_constitutions(ceq,copyofconst) ! segmentation fault before this output ... ! write(*,*)'called save_constitutions: ',size(copyofconst) 305 continue ! to be able to handle problems copy the constitutions!! ! if(mapline%problems.gt.0) then ! write(*,*)'problems',mapline%problems,ceq%tpval(1) ! endif ! STEP/MAP with an MQMQA phase present require restoring csumx at each step ! if(allocated(mqmqa_data%csumx)) then ! write(*,*)'SMP reset csumx for MQMQA phase' ! mqmqa_data%csumx=.FALSE. ! endif ! write(*,*)'Calling calceq7 with T=',ceq%tpval(1),mapline%axandir ! write(*,*)'Calling calceq7 with meqrec%status:',meqrec%status call calceq7(mode,meqrec,mapfix,ceq) ! write(*,*)'SMP2A Back from calceq7 ',gx%bmperr,meqrec%status if(gx%bmperr.ne.0) then ! error 4187 is to set T or P to less than 0.1 if(gx%bmperr.eq.4187) then goto 306 endif if(mapline%number_of_equilibria.eq.0) then ! We can add/subtract a small amount of axis condition if error at first step ! write(*,*)'Error at first equilibrium: ',gx%bmperr,mapline%axandir mapline%lasterr=gx%bmperr mapline%problems=mapline%problems+1 ! if(bytdir.eq.1) then ! we have tried adding a small step in axandir direction, now change direction ! mapline%axandir=-mapline%axandir ! elseif(bytdir.gt.1) then ! give up ! goto 306 ! endif ! Extract the current value of the axis state variable items using pcond jj=abs(mapline%axandir) ! write(*,*)'SMP: axandir: ',jj,gx%bmperr gx%bmperr=0 if(jj.le.0 .or. jj.gt.2) then write(*,*)'SMP error: no axis direction! Set to 1' mapline%axandir=1 jj=1 ! call list_conditions(kou,ceq) endif seqz=axarr(jj)%seqz call locate_condition(seqz,pcond,ceq) if(gx%bmperr.ne.0) goto 1000 call condition_value(1,pcond,zzz,ceq) if(gx%bmperr.ne.0) goto 1000 if(ocv())write(*,765)bytdir,jj,zzz,mapline%axvals(jj),axarr(jj)%axinc 765 format('Attempt to step 1: ',i2,i3,3(1pe16.8)) ! first time bytdir=1, second time bytdir=2, compensate for first step ... ! yyy=1.0D-2*bytdir*axarr(jj)%axinc ! yyy=1.0D-3*bytdir*axarr(jj)%axinc ! xxx=zzz+mapline%axandir*yyy xxx=zzz !>>>>>>>>>>>>>>>>>>>>>>>>>>>> ! restore constitutions, not a good idea ?? ... ! write(*,*)'Restore constitutions 1' call restore_constitutions(ceq,copyofconst) ! call map_problems(maptop,mapline,axarr,xxx,1) if(gx%bmperr.ne.0) goto 306 if(ocv()) write(*,737)'Error at first step: ',mapline%axandir,& mapline%nodfixph,zzz,xxx 737 format(a,2i3,6(1pe14.6)) ! read(*,738)ch1 738 format(a) ! set the condition value ... ??? if(nax.gt.1) then ! run time error that axvals has dimension 0 ... when step mapline%axvals(abs(jj))=xxx endif call condition_value(0,pcond,xxx,ceq) if(gx%bmperr.ne.0) goto 1000 if(ocv()) write(*,765)0,mapline%axandir,zzz,xxx,yyy ! call calceq7 again, we must deallocate meqrec%phr deallocate(meqrec%phr) goto 305 endif 306 continue ! write(*,*)'SMP2 Generating mapline%meqrec failed 2: ',gx%bmperr call map_lineend(mapline,axarr(abs(mapline%axandir))%lastaxval,ceq) ! look for a new line to follow goto 300 endif ! write(*,*)'back from calceq7B' ! if all has gone well deallocate mapfix if(allocated(mapfix)) deallocate(mapfix) ! write(*,*)'SMP successfully deallocated mapfix' !-------------------------------- ! limit the maximum change in T and P, should be small during step/map meqrec%tpmaxdelta(1)=2.0D1 meqrec%tpmaxdelta(2)=1.0D1 bypass=0 !-------------------------------- ! return to label 310 after each new equilibrium calculated along the same line ! Follow the equilibria along a line. For each equilibria calculated ! store the data. If the phase set want to change (irem or iadd>0) calculate ! exactly the phase change, generate a node and terminate the line and then ! look for a new line to follow. 310 continue halfstep=0 ! save current value of T if trouble later ... tsave=ceq%tpval(1) ! try saving constitutions ... if(allocated(copyofconst)) deallocate(copyofconst) call save_constitutions(ceq,copyofconst) ! emergency return when two phases want to change status 320 continue iadd=0 ! Note setting iadd=-1 turn on verbose inside meq_sameset 321 continue irem=0 mapline%meqrec%noofits=0 ! write(*,*)'Calling meq_sameset 7: ',mapline%number_of_equilibria,& ! ceq%tpval(1),gx%bmperr ! ! call list_conditions(kou,ceq) ! ! write(*,*)'Calling meq_sameset ',mapline%more,mapline%number_of_equilibria ! write(*,884)1,mapline%linefixph(1)%ixphase,& ! mapline%linefixph(1)%compset,iadd,meqrec%nphase,abs(phfix) !884 format('SMP fix phase ',i1,':',i3,i2,', new fix phase: ',i3,& ! ', number of phases: ',i3,' abs(phfix): ',i3) !-------------------------------------------------------------------------- ! This is where most equilibrium calculations are made !-------------------------------------------------------------------------- ! ! write(*,*)'smp2A calling meq_sameset from map_doallines',ceq%tpval(1) call meq_sameset(irem,iadd,mapx,mapline%meqrec,mapline%meqrec%phr,inmap,ceq) ! !-------------------------------------------------------------------------- ! write(*,331)'SMP Back from meq_sameset ',mapline%number_of_equilibria,& ! irem,iadd,gx%bmperr,phfix,ceq%tpval(1),ceq%phase_varres(4)%dgm 331 format(a,5i5,2(F10.2)) ! write(*,884)2,mapline%linefixph(1)%ixphase,& ! mapline%linefixph(1)%compset,iadd,meqrec%nphase,abs(phfix) !------------------------------------------------------------------ ! write(*,*)'SMP2A axis: ',maptop%number_ofaxis ! goto 3000 ! suck if(maptop%number_ofaxis.eq.2) goto 3000 !================================================================== ! The code between ==== is added to avoid STEP termination because unstable ! phases tries to be stable. It is very fragile and should not ! be used for MAP calculations if(gx%bmperr.ne.0) then ! step1 2ndtime error bug: write(*,'(a,F7.2,i7)')'Failed calculate equilibrium, along line, T=',& ceq%tpval(1),gx%bmperr call map_lineend(mapline,axvalok,ceq) axvalok=zero ! step1 2ndtime error bug: try to find out the error, maybe atoms/formula unit ! gx%bmperr=4500; goto 1000 goto 300 endif gx%bmperr=0; trynewphase=0; addcheck=0; jrem=0 ! We may have to extract the axis condition ?? jj=abs(mapline%axandir) ! write(*,*)'SMP2A axandir: ',jj if(jj.le.0 .or. jj.gt.2) then write(*,*)'SMP error: no axis direction! Set to 1' mapline%axandir=1 jj=1 ! call list_conditions(kou,ceq) endif seqz=axarr(jj)%seqz call locate_condition(seqz,pcond,ceq) if(gx%bmperr.ne.0) goto 1000 ! end extracting axis condition ! write(*,'(a,F10.2,4i4)')'SMP2A new phase and T axis?',ceq%tpval(1),& ! maptop%number_ofaxis,iadd,pcond%statev ! Return here if map_calcnode return with error code 4223 716 continue baddata: if(iadd.gt.0 .and. pcond%statev.eq.1 .and. & maptop%number_ofaxis.eq.1) then ! If a new phase is stable and axis is T and we have only one axis then ! make a second call with same conditions to check if really stable 717 continue if(trynewphase.gt.4) then ! we have tried 4 times with different new phases trying to be stable write(*,*)'SMP2A cannot find which phase to set stable',trynewphase gx%bmperr=4399; exit baddata ! elseif(trynewphase.eq.3) then ! restore original phase constitutions .... does not help ! call restore_constitutions(ceq,copyofconst) endif trynewphase=trynewphase+1 addcheck=iadd; iadd=0 call meq_sameset(jrem,iadd,mapx,mapline%meqrec,mapline%meqrec%phr,& inmap,ceq) if(gx%bmperr.ne.0) then write(*,*)'SMP2A reset error in meq_sameset',gx%bmperr gx%bmperr=0 endif ! call get_phasetup_name(meqrec%phr(iadd)%phtupix,phasename) ! write(*,'(a,F10.2,a,a)')'SMP2A test at T=',& ! ceq%tpval(1),' for stablility of ',trim(phasename) ! exit if no phase wants to be stable, loop if a different one if(iadd.gt.0 .and. iadd.ne.addcheck) then ! cycle baddata this would have been elegant .... if allowed call get_phasetup_name(meqrec%phr(addcheck)%phtupix,phasename) write(*,'(a,a,a,F10.2,2i5)')'SMP2A test if ',phasename(1:16),& ' is stable at T=',ceq%tpval(1),& meqrec%phr(addcheck)%phtupix,meqrec%phr(iadd)%phtupix goto 717 endif ! exit if iadd=0 or same twice to calculate node endif baddata !================================================================== !------------------------------------------------------------------ ! we come back here if iadd was 0 but removed as 3000 continue ! new global check for stable and metastable phases ! write(*,*)'SMP error 6A:',mapline%number_of_equilibria,& ! maptop%globalcheckinterval phasecheck: if(gx%bmperr.eq.0 .and. iadd.eq.0 .and. irem.eq.0) then ! write(*,*)'SMP error 6B:',mapline%number_of_equilibria,& ! maptop%globalcheckinterval ! if(maptop%globalcheckinterval.le.0) then ! write(*,*)'SMP maptop%globalcheckinterval:',maptop%globalcheckinterval ! maptop%globalcheckinterval=10 ! endif checkinterval: if(maptop%globalcheckinterval.gt.0) then if(mod(mapline%number_of_equilibria,maptop%globalcheckinterval).eq.0)& then ! this may set error code if equilibrium should be recalculated ! and it may change constitutions of metastable phases ! write(*,'(a,i5)')'SMP check_all_phases at equilibrium: ',& ! mapline%number_of_equilibria jj=0 call check_all_phases(jj,ceq) if(gx%bmperr.ne.0) then ! if(associated(mapline%lineceq,ceq)) then ! This is true and dangerous but I will be careful programming ... ! write(*,*)'SMP ceq is same as mapline%lineceq' ! else ! write(*,*)'SMP ceq is NOT same as mapline%lineceq' ! endif ! call get_phase_compset(iph,ics,lokph,lokres) if(gx%bmperr.eq.4366) then ! terminate line and call gridminimizer ! write(*,*)'SMP check_all_phases require gridminimizer',jj gx%bmperr=0 call map_halfstep(halfstep,0,axvalok,mapline,axarr,ceq) if(gx%bmperr.eq.0) goto 321 elseif(gx%bmperr.eq.4365) then ! write(*,*)'SMP check_all_phases error, call map_halfstep:',jj gx%bmperr=0 ! we have to convert jj=iph*10+ics to index in mapline%meqrec%phr ! Check if constitution is the one se in check_all_phases ! write(*,95)(yarr(ii),ii=1,jj) !95 format('3Y gridy: ',10(F7.4)) call map_halfstep(halfstep,0,axvalok,mapline,axarr,ceq) if(gx%bmperr.eq.0) goto 321 endif ! otherwise ignore any errors gx%bmperr=0 endif endif endif checkinterval endif phasecheck !------------------------------------------------------------------ ! write(*,*)'SMP looking for error 7:' sameseterror: if(gx%bmperr.ne.0) then ! write(*,*)'Error in meq_sameset called from smp',gx%bmperr ! if error 4359 (slow convergence), 4204 (too many its) take smaller step ... ! error 4195 means negative phase amounts 491 continue if(gx%bmperr.eq.4195 .or. gx%bmperr.eq.4359 & .or. gx%bmperr.eq.4204) then ! I am not sure there is really any change for the equilibrium calculated ... ! write(*,317)'Trying half step: ',halfstep,mapline%axandir,& ! mapline%number_of_equilibria,lastimethiserror,ceq%tpval(1) 317 format(a,2i3,2i4,f9.2) if(mapline%number_of_equilibria-lastimethiserror.gt.10) then lastimethiserror=mapline%number_of_equilibria ! if(mapline%meqrec%noofits-lastimethiserror.gt.10) then ! lastimethiserror=mapline%meqrec%noofits gx%bmperr=0 mapline%axfact=1.0D-2 call map_halfstep(halfstep,0,axvalok,mapline,axarr,ceq) ! write(*,*)'Back from halfstep 1',halfstep,gx%bmperr if(gx%bmperr.eq.0) goto 321 endif elseif(gx%bmperr.eq.4364) then ! Two stoichiometric phases with same composition stable, we have ! to calculated an invariant equilibrium T in a different way. ! if tielines in plane create nodepoint otherwise I do not know what to do if(maptop%tieline_inplane.gt.0) then ! dummy values (for the moment) axval=ceq%tpval(1) haha=mapx phfix=iadd lastax=abs(mapline%axandir) ! maybe save last calculated equilibrium as endpoint of current line? ! Collecting values needed fot map_newnode ! irem is last fix phase, haha is entered phase, phfix is new stable phase ! write(*,219)'SMP call map_newnode: ',lastax,axval,& ! ceq%tpval(1),meqrec%nstph,irem,haha,phfix !219 format(a,i2,2F12.4,5i5) ! list current settings: is content of mapline%meqrec same as meqrec?? ! write(*,885)mapline%nfixphases,& ! mapline%linefixph(1)%ixphase,mapline%linefixph(1)%compset,& ! mapline%meqrec%nv,mapline%meqrec%iphl(1),& ! mapline%meqrec%iphl(2) !885 format('SMP Fixed phase:',i2,': ',i3,i2,', entered: ',i2,': ',5i3) mapline%status=ibset(mapline%status,TWOSTOICH) call map_newnode(mapline,meqrec,maptop,axval,lastax,axarr,& phfix,haha,ceq) if(gx%bmperr.ne.0) then ! give up on this line, map_lineend set error code to zero write(*,*)'Failed create node point, terminate and take next',& gx%bmperr call map_lineend(mapline,axvalok,ceq) axvalok=zero endif endif endif ! give up this line, reset error code and check if there are more lines gx%bmperr=0 goto 805 endif sameseterror ! write(*,323)'Calc line: ',gx%bmperr,irem,iadd,mapline%axandir,& ! mapline%meqrec%noofits,mapline%meqrec%nstph,ceq%tpval(1) if(ocv())write(*,323)'Calc line: ',gx%bmperr,irem,iadd,mapline%axandir,& mapline%meqrec%noofits,mapline%meqrec%nstph,ceq%tpval(1) 323 format(a,i5,2i3,2i4,i3,f10.2) if(iadd.gt.0) then ! check if it is a closing miscibility gap or loss of ordering ! remove iadd if it is a phase with same composition as an already stable one if(same_composition(iadd,mapline%meqrec%phr,mapline%meqrec,ceq,dgm)) & iadd=0 endif ! write(*,*)'Check if same phase: ',iadd 330 continue if(gx%bmperr.eq.0 .and. irem.eq.0 .and. iadd.eq.0) then ! no error and no change of phase set, just store the calculated equilibrium. ! and calculate another point along the line ! write(*,*)'hms: Storing equilibrium',& ! mapline%number_of_equilibria,maptop%globalcheckinterval if(mapline%number_of_equilibria.gt.10 .and. mapline%nodfixph.gt.0) then ! we have managed 3 steps, set phase at start node as entered (if dormant) if(meqrec%phr(mapline%nodfixph)%phasestatus.eq.PHDORM) then ! write(*,*)'Phase set entered ',mapline%nodfixph meqrec%phr(mapline%nodfixph)%phasestatus=PHENTUNST endif endif ! mapline%problems=0 ! nrestore=0 call map_store(mapline,axarr,nax,maptop%saveceq) if(gx%bmperr.ne.0 .or. mapline%more.eq.0) then ! Test if we are running out of memory if(gx%bmperr.eq.4219) goto 1000 if(gx%bmperr.eq.4360) then ! too big difference in some axis, take halfstep ! write(*,*)'Take a half step',halfstep gx%bmperr=0; halfstep=halfstep+1 call map_halfstep(halfstep,0,axvalok,mapline,axarr,ceq) if(gx%bmperr.eq.0) goto 321 endif ! terminate line any error code will be cleared inside map_lineend. ! write(*,*)'Calling map_lineend 1' call map_lineend(mapline,axarr(abs(mapline%axandir))%lastaxval,ceq) goto 300 endif ! stored last calculated equilibrium mapline%problems=0 nrestore=0 ! check which axis variable changes most rapidly, maybe change step axis ! (for tie-lines in plane check axis values for all phases) ! and take a step in this axis variable making sure it inside the limits ! and continue, else terminate and take another start equilibrium ! Normally do not change the phase kept fix. ! write(*,*)'hms: taking a step' call map_step(maptop,mapline,mapline%meqrec,mapline%meqrec%phr,& axvalok,nax,axarr,ceq) ! write(*,*)'Back from map_step 1',mapline%more,& ! mapline%number_of_equilibria,gx%bmperr if(gx%bmperr.ne.0) then ! write(*,*)'SMP2A error return from map_step 1: ',gx%bmperr gx%bmperr=0 if(meqrec%tpindep(1)) then ! write(*,*)'SMP2A restore T 1: ',tsave,axvalok ceq%tpval(1)=tsave endif call map_halfstep(halfstep,0,axvalok,mapline,axarr,ceq) if(gx%bmperr.eq.0) then ! jump back without setting halfstep=0, setting iadd=-1 turn on debug output ! iadd=-1 goto 321 endif endif ! if mapline%more>0 continue, otherwise line has terminated at axis limit ! check if there are other nodes with lines to calculate ! write(*,*)'Back from step:',gx%bmperr,mapline%more,ceq%tpval(1) ! if mapline%more>=0 there is no error and a new equilibrium to calculate ! if mapline%more<0 the line has ended at axis limit or there is an error if(mapline%more.ge.0) goto 310 if(gx%bmperr.ne.0) then ! write(*,*)'SMP2A Error stepping to next equilibria, ',gx%bmperr endif ! any error code will be cleared inside map_lineend. ! write(*,*)'Calling map_lineend 1' call map_lineend(mapline,axarr(abs(mapline%axandir))%lastaxval,ceq) ! look for a new line to follow goto 300 ! finish thread started at label 300 ?? !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ elseif(gx%bmperr.ne.0) then ! write(*,*)'Error return from meq_sameset: ',gx%bmperr,mapline%lasterr,& ! ceq%tpval(1) termerr=gx%bmperr gx%bmperr=0 if(meqrec%tpindep(1)) then if(ocv()) write(*,*)'Restoring T 2: ',tsave,axvalok ceq%tpval(1)=tsave endif ! also restore constitutions nrestore=nrestore+1 if(nrestore.lt.3) then ! write(*,*)'Restore constitutions 2',nrestore call restore_constitutions(ceq,copyofconst) ! ! take smaller steps! mapline%axfact=1.0D-2 ! write(*,552)'Call halfstep: ',bytaxis,nrestore,& ! mapline%number_of_equilibria,axvalok 552 format(a,3i3,2(1pe12.4)) call map_halfstep(halfstep,0,axvalok,mapline,axarr,ceq) if(gx%bmperr.eq.0) then ! jump back without setting halfstep=0, setting iadd=-1 turns on debug output ! iadd=-1 goto 321 endif elseif(nax.gt.1 .and. bytaxis.eq.0) then ! write(*,*)'Restore last OK: ',mapline%number_of_equilibria,nrestore,& ! axvalok call restore_constitutions(ceq,copyofconst) if(meqrec%tpindep(1)) then if(ocv()) write(*,*)'Restoring T 3: ',tsave,axvalok ceq%tpval(1)=tsave endif if(ocv()) write(*,555)'Repeated error 7, try to change axis',& gx%bmperr,ceq%tpval(1),axvalok,tsave 555 format(a,i5,3F8.2) gx%bmperr=0 bytaxis=1 ! Make sure that the current axis has the last successfully calculated value ! as prescribed value call locate_condition(axarr(abs(mapline%axandir))%seqz,pcond,ceq) if(gx%bmperr.ne.0) goto 1000 ! first argument 1 means to extract the value, 0 means to set the value call condition_value(1,pcond,xxx,ceq) if(gx%bmperr.ne.0) goto 1000 call condition_value(0,pcond,axvalok,ceq) if(gx%bmperr.ne.0) goto 1000 write(*,19)'Force changeaxis: ',mapline%axandir,gx%bmperr,axvalok,xxx 19 format(a,i3,i5,2(1pe14.6)) ! call map_force_changeaxis(maptop,mapline,mapline%meqrec,& nax,axarr,axvalok,ceq) ! write(*,*)'new changeaxis: ',mapline%axandir,gx%bmperr,axvalok ! call list_conditions(kou,ceq) if(gx%bmperr.eq.0) goto 320 endif ! Giv up, terminate the line and check if there are other lines to calculate ! macro map1 ends at composition axis end still with T axis as variable !! ! write(*,*)'Calling map_lineend 3',nrestore,termerr gx%bmperr=termerr call map_lineend(mapline,axarr(abs(mapline%axandir))%lastaxval,ceq) ! find a new line goto 300 endif !------------------------------------------------------------ 379 continue phasechange: if(irem.gt.0 .and. iadd.gt.0) then ! We can also have a stoichiometic phase with ALLOTROPIC transformation ! which will change form one to another at a fix T if(allotropes(irem,iadd,meqrec%noofits,ceq)) then irem=0 goto 379 endif ! if there is phase which wants to appear and another disappear then ! first check if they are the composition sets of the same phase ! calculate with half the step 5 times. If axvalok=0 no previous axis value ! BUG: Problems here for map5.OCM, when matsmin compiled with -O2 ! two extra composition sets of BCC and LIQUID wanted to appear. ! Will lok at that later ... if(onetime) then ! write(*,22)'SMP: phases appear and disappear at same time: ',& ! iadd,irem,phasetuple(iadd)%lokph,phasetuple(irem)%lokph 22 format(a,4i4) onetime=.false. endif ! write(*,*) ! restore constitutions ! write(*,*)'Restore constitutions 3',halfstep,axvalok,ceq%tpval(1) call restore_constitutions(ceq,copyofconst) call map_halfstep(halfstep,1,axvalok,mapline,axarr,ceq) if(gx%bmperr.eq.0) then ! jump back without setting halfstep=0 goto 320 elseif(nax.gt.1 .and. bytaxis.eq.0) then ! try to change axis with active condition. if(meqrec%tpindep(1)) then if(ocv()) write(*,*)'Restoring T 4: ',tsave,axvalok ceq%tpval(1)=tsave endif write(*,557)gx%bmperr,ceq%tpval(1),axvalok 557 format('Repeated error 8, try to change axis',i5,F8.2,1pe14.6) gx%bmperr=0 bytaxis=1 call map_force_changeaxis(maptop,mapline,mapline%meqrec,nax,axarr,& axvalok,ceq) if(gx%bmperr.eq.0) goto 320 call map_lineend(mapline,axvalok,ceq) else ! there is an error, take another line call map_lineend(mapline,axvalok,ceq) endif !----------------------------------------------------- ! phasechange elseif: a new phase stable or a stable wants to disappear elseif(irem.gt.0 .or. iadd.gt.0) then ! write(*,*)'SMP2A new phase 2: ',iadd,irem,mapline%nodfixph,& ! mapline%number_of_equilibria if(mapline%number_of_equilibria.lt.2 .and.& ((irem.gt.0 .and. irem.eq.mapline%nodfixph) .or. & (iadd.gt.0 .and. iadd.eq.mapline%nodfixph))) then mapline%axandir=-mapline%axandir write(*,*)'Ignore same phase as at startnode: ',1,mapline%nodfixph write(*,*)'Phase set dormant ',mapline%nodfixph meqrec%phr(mapline%nodfixph)%phasestatus=PHDORM ! if iadd or irem is equal to mapline%nodfixph change ! direction of the axis irem=0; iadd=0 goto 320 elseif(mapline%number_of_equilibria.le.5 .and.& ((irem.gt.0 .and. irem.eq.mapline%nodfixph) .or. & (iadd.gt.0 .and. iadd.eq.mapline%nodfixph))) then ! write(*,*)'Startnode phase ignored: ',2,mapline%nodfixph,& ! ceq%tpval(1) iadd=0; irem=0 ! set the phase dormant and decrease step ! write(*,559)mapline%nodfixph,axvalok 559 format('Phase set dormant ',i5,1pe14.6) meqrec%phr(mapline%nodfixph)%phasestatus=PHDORM call map_halfstep(halfstep,1,axvalok,mapline,axarr,ceq) if(gx%bmperr.eq.0) then ! jump back without setting halfstep=0 goto 320 elseif(nax.gt.1 .and. bytaxis.eq.0) then ! try to change axis with active condition. if(meqrec%tpindep(1)) then if(ocv()) write(*,*)'Restoring T 7: ',tsave,axvalok ceq%tpval(1)=tsave endif ! try to change fix phase ... write(*,*)'Trying to change fix phase' gx%bmperr=0 ! if active axis condition is extensive we must change condition value!! ! bytaxis=abs(mapline%axandir) call locate_condition(axarr(bytaxis)%seqz,pcond,ceq) if(gx%bmperr.ne.0) then write(*,*)'Cannot locate condition: ',axarr(bytaxis)%seqz goto 1000 endif svrrec=>pcond%statvar(1) call condition_value(1,pcond,zzz,ceq) if(gx%bmperr.ne.0) goto 1000 if(svrrec%argtyp.eq.1 .and. svrrec%statevarid.ge.10) then ! 0 is not good check, it can be a component ! NOTE: If we extract value for currect fix phase we must change axvals/axvals2 ! i1=svr2%argtyp; i2=svr2%phase; i3=svr2%compset svrtarget=svrrec svrtarget%argtyp=3 svrtarget%phase=mapline%stableph(1)%ixphase svrtarget%compset=mapline%stableph(1)%compset ! This extracts the composition of the entered phase for first new line ! we must use a pointer in state_variable_val svr2=>svrtarget call state_variable_val(svr2,xxx,ceq) if(gx%bmperr.ne.0) goto 1000 ! first argument 1 means to extract the value, 0 means to set the value call condition_value(0,pcond,xxx,ceq) ! write(*,*)'Old/New axis condition: ',zzz,xxx,pcond%prescribed ! else ! write(*,*)'Axis is potential, same value',svrrec%statevarid endif !------------------------------------------------- call map_bytfixphase(mapline,nax,mapline%meqrec,xxx,ceq) if(gx%bmperr.eq.0) then axvalok=zero; goto 320 endif ! write(*,561)gx%bmperr,ceq%tpval(1),axvalok 561 format('Repeated error 9, try to change axis',i5,F8.2,1pe14.6) write(*,*)'Trying to change axis with acitive condition' gx%bmperr=0 bytaxis=1 call map_force_changeaxis(maptop,mapline,mapline%meqrec,& nax,axarr,axvalok,ceq) if(gx%bmperr.eq.0) goto 320 call map_lineend(mapline,axvalok,ceq) else ! there is a persistent error, take another line, set error code if(gx%bmperr.eq.0) then write(*,*)'SMP2A persistent error?' gx%bmperr=4399 endif call map_lineend(mapline,axvalok,ceq) endif endif if(mapline%more.eq.0) then ! This is the last equilibrium at axis limit if(irem.gt.0) then ! terminate the line and check if there are other lines to calculate call map_lineend(mapline,axvalok,ceq) goto 300 elseif(iadd.gt.0) then if(ocv()) write(*,*)'New phase at axis limit, IGNORE',iadd meqrec%phr(iadd)%dormlink=meqrec%dormlink meqrec%dormlink=iadd meqrec%phr(iadd)%phasestatus=PHDORM ! meqrec%phr(iadd)%curd%status2=& ! ibset(meqrec%phr(iadd)%curd%status2,CSSUS) ! meqrec%phr(iadd)%curd%status2=& ! ibset(meqrec%phr(iadd)%curd%status2,CSFIXDORM) goto 320 endif endif ! write(*,*)'New set of stable phases: ',iadd,irem,ceq%tpval(1) ! calculate the exact value of the variable axis for the phase change ! then check if we have already found this node point and if not ! generate new start points with and without the phase ! HERE WE CREATE A NODE WITH NEW EXIT LINES call map_calcnode(irem,iadd,maptop,mapline,mapline%meqrec,axarr,ceq) ! segmentation fault in map_calcnode 170518 !! ! write(*,*)'Back from map_calcnode',gx%bmperr,irem,iadd,noderrmess if((gx%bmperr.ne.0 .or. irem.ne.0 .or. iadd.ne.0) .and. noderrmess) then write(*,777)gx%bmperr,irem,iadd,ceq%tpval(1) 777 format('SMP2A problem calculating node: ',3i5,' at T=',F8.2) ! this occured in an STEP caculation for an 18 element nuclear fuel, ! If only one axis return to calculate line ! segmentation fault using debugged compiled OC6 ! write(*,*)'SMP2A step-epz.OCM oc6D seg fault after this' ! write(*,*)'SMP2A associated? ',associated(maptop),associated(pcond) ! write(*,*)'SMP2A ',maptop%number_ofaxis,pcond%statev ! pcond not associated !! just ignore it? YES noderrmess=.false. ! if(maptop%number_ofaxis.eq.1 .and. pcond%statev.eq.1) then if(maptop%number_ofaxis.eq.1) then gx%bmperr=0 ! write(*,*)'SMP2A tries to continue' ! call list_conditions(kou,ceq) call restore_constitutions(ceq,copyofconst) gx%bmperr=0; goto 716 endif endif noderror: if(gx%bmperr.ne.0) then ! if error one can try to calculate using a shorter step or other things ... ! write(*,*)'SMP2A Error return from map_calcnode: ',gx%bmperr if(gx%bmperr.eq.4353) then ! this means node point not global, the line leading to this is set inactive ! and we should not generate any startpoint. write(*,*)'Setting line inactive',mapline%lineid mapline%status=ibset(mapline%status,EXCLUDEDLINE) call map_lineend(mapline,axvalok,ceq) goto 805 endif if(meqrec%tpindep(1)) then ! restore the original temperature, maybe also compositions ... ! write(*,*)'Restored T 5: ',tsave,axvalok ceq%tpval(1)=tsave endif ! restore here creates an infinite loop with no axis increment in map2-crmo ! write(*,*)'SMP2A oc6D restore_constitutions 4' ! segmentation fault with step_epz.OCM, in gtp3X.F90 call restore_constitutions(ceq,copyofconst) ! write(*,800)'SMP2A map_calcnode error, trying smaller step: ',& ! gx%bmperr,mapline%lasterr,axvalok 800 format(a,3i5,1pe12.4) gx%bmperr=0 ! write(*,*)'SMP2A Restore call map_halfstep' call map_halfstep(halfstep,0,axvalok,mapline,axarr,ceq) ! write(*,*)'back from halfstep 2',halfstep,gx%bmperr ! if(gx%bmperr.eq.0.and. halfstep.le.5) then ! write(*,*)'SMP2A back from halfstep',gx%bmperr,halfstep if(gx%bmperr.eq.0.and. halfstep.le.4) then goto 320 elseif(nax.gt.1 .and. bytaxis.eq.0) then ! try to change axis with active condition. if(ocv()) write(*,*)'Trying to change axis with active condition' gx%bmperr=0 if(meqrec%tpindep(1)) then if(ocv()) write(*,*)'Restoring T 6: ',tsave,axvalok ceq%tpval(1)=tsave endif if(ocv()) write(*,803)'Repeated error 2, try to change axis',& gx%bmperr,halfstep,ceq%tpval(1) 803 format(a,i5,i3,1pe12.4) bytaxis=1; gx%bmperr=0 call map_force_changeaxis(maptop,mapline,mapline%meqrec,& nax,axarr,axvalok,ceq) if(gx%bmperr.eq.0) goto 320 call map_lineend(mapline,axvalok,ceq) ! elseif(bypass.eq.0) then ! Problem with 18 component system a phase pops up and down ! Cleanup needed ... ! bypass=1 ! write(*,*)'SMP2A problem calculate node, try bypass' ! goto 310 else ! write(*,*)' *** Repeated errors calling map_calcnode,',& ! ' terminate line',gx%bmperr ! terminate line and follow another line, error reset inside map_lineend if(gx%bmperr.eq.0) gx%bmperr=4369 call map_lineend(mapline,axvalok,ceq) endif endif noderror ! we come here if a new node has been calculated and stored axvalok=zero else ! phasechance: else: Here neither iadd or irem>0, we should never be here ! and no error ... we should go back to label 300 write(*,*)'SMPA no phase change?',gx%bmperr,iadd,irem stop 'Report this error to the OC development team!' endif phasechange ! we have finished a line and look for another at label 300 805 continue write(kou,808)mapline%number_of_equilibria,ceq%tpval(1),axarr(1)%lastaxval 808 format('Finishing line with ',i5,' equilibria at T=',0pF8.2,& ', xaxis:',1pe12.4,' ') mapline%problems=0 mapline%lasterr=0 goto 300 !----------------------------------------------------- ! we come here when there are no more lines to calculate 900 continue !----------------------------------------------------- ! jump here if faital errors above 1000 continue if(gx%bmperr.ne.0) write(*,*)'Exit map_doallines due to error:',gx%bmperr !-------------------------------------------------- return end subroutine map_doallines !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine bombmatta !\begin{verbatim} subroutine bombmatta(maptop,nax,axarr,seqxyz,starteqs) ! calculate a number of equilibria inside the region of x and y ! ! nax is the number of axis (can be just one for STEP) ! axarr is an array of records specifying the axis for the step/map ! seqxyz are intial values for number of nodes and lines ! starteq is an equilibrium data record, if there are more start equilibria ! they are linked using the ceq%next index implicit none integer nax,seqxyz(*) type(map_axis), dimension(nax) :: axarr ! TYPE(gtp_equilibrium_data), pointer :: starteq TYPE(starteqlista), dimension(*) :: starteqs TYPE(map_node), pointer :: maptop !\end{verbatim} TYPE(gtp_equilibrium_data), pointer :: ceq,starteq type(gtp_condition), pointer :: xcond,ycond type(gtp_phase_varres), pointer :: phres integer s1,s2,s3,n1,n2,lokcs,nel,globalstatus,iph,potax,touse,newset integer, allocatable, dimension(:,:) :: phstable,phused double precision xval,yval,xlen,ylen integer, parameter :: nss=5 ! start in the middle, close to end points at the end double precision, dimension(nss), parameter :: axinc=& [0.49D0, 0.78D0, 0.22D0, 0.01D0, 0.99D0] character name*24 double precision, dimension(nss*nss) :: xuse,yuse ! starteq=>starteqs(1)%p1 if(nax.ne.2) then write(*,*)'S2A only for map with 2 axis' goto 1000 endif nel=noel() if(allocated(phstable)) then deallocate(phstable) deallocate(phused) endif newset=nooftup() ! there cannot be more than nel phases stable allocate(phstable(0:nel,nss*nss+5)) allocate(phused(0:nel,2*nss)) phstable=0 write(*,*)'S2A allocate phstable: ',nel,50,size(phstable),newset ceq=>starteq ! supress messages from minimizer globalstatus=globaldata%status globaldata%status=ibset(globaldata%status,GSSILENT) potax=0 ! extrahera axis variables and their min and max ! identify any potential axis, statevarid=1=T; 2=P; 3=MU, 4=AC; 5=LNAC call locate_condition(axarr(1)%seqz,xcond,ceq) if(xcond%statvar(1)%statevarid.le.5) potax=1 call locate_condition(axarr(2)%seqz,ycond,ceq) if(ycond%statvar(1)%statevarid.le.5) potax=2 if(gx%bmperr.ne.0) goto 1000 if(potax.gt.0) write(*,*)'S2A potential axis: ',potax xlen=axarr(1)%axmax-axarr(1)%axmin ylen=axarr(2)%axmax-axarr(2)%axmin write(*,*)'S2A axis length: ',xlen,ylen ! start loop n1=0 xloop: do s1=1,nss ! calculate at intervals 0.02 0.1 0.3 0.5 0.7 0.9 0.98 in x and y axis (49 eq) ! set condionon on x axis xval=axarr(1)%axmin+axinc(s1)*xlen ! first argument 0 is to set condition, 1 means extract value call condition_value(0,xcond,xval,ceq) if(gx%bmperr.ne.0) cycle xloop yloop: do s2=1,nss yval=axarr(2)%axmin+axinc(s2)*ylen write(*,'(a,i2,4(1pe12.4))')'S2A x,y: ',n1+1,xval,yval ! set condition on y axis call condition_value(0,ycond,yval,ceq) if(gx%bmperr.ne.0) cycle yloop call calceq2(1,ceq) if(gx%bmperr.ne.0) then write(*,*)'S2A failed calculation',gx%bmperr gx%bmperr=0; cycle yloop endif n1=n1+1 xuse(n1)=xval yuse(n1)=yval ! loop to extract stable phases, there can be new composition sets n2=0 ! start from 2 as first phase_varres is the stable_el_refernce phase do lokcs=2,nooftup() phres=>ceq%phase_varres(lokcs) if(phres%phstate.ge.PHENTSTAB) then n2=n2+1 iph=phres%phlink call get_phase_name(iph,1,name) if(gx%bmperr.ne.0) gx%bmperr=0 write(*,'(a,2i2,i5,2x,a)')'S2A stable:',s1,n1,lokcs,trim(name) ! save lokcs as we can have several composition sets phstable(n2,n1)=lokcs endif enddo ! number of stable phases at this equilibrium phstable(0,n1)=n2 enddo yloop enddo xloop ! we have calculate all 25 equilibria do s1=1,n1 write(*,'(a,i3,2x,i2,2x,5i5)')'S2A equil: ',s1,(phstable(s2,s1),s2=0,nel) enddo ! now decide which points to use as start points, skip points with phused=0 touse=0 ! skip points with phases already used all: do s1=1,n1 if(phstable(0,s1).eq.0) cycle all write(*,'(a,5i5)')'S2A compare equil',s1,n1,phstable(0,s1),touse phases: do s2=1,phstable(0,s1) newset1: do s3=1,touse ! compare with saved equil, skip if an equilibrium has the same phases if(phstable(s2,s1).eq.phused(s2,s3)) cycle newset1 enddo newset1 enddo phases ! if s3 is less than touse we have an equil with a new set of phases write(*,*)'S2A skip as same: ',s3,touse if(touse.gt.0 .and. s3.gt.touse) cycle all ! this equilibrium has a new set of phases touse=touse+1 do s3=1,phstable(0,s1) phused(s3,touse)=phstable(s3,s1) enddo write(*,'(a,i3,2x,2F12.5,i2,2x,5i5)')'S2A use: ',s1,xuse(s1),yuse(s1),& (phused(s2,s1),s2=0,nel) enddo all newset=nooftup()-newset if(newset.gt.0) write(*,*)'S2A created ',newset,' composition sets' write(*,*)'S2A equilibria to use: ',touse 1000 continue ! reset the globaldata%status globaldata%status=globalstatus return end subroutine bombmatta !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine map_startpoint !\begin{verbatim} subroutine map_startpoint(maptop,nax,axarr,seqxyz,inactive,ceq) ! convert a start equilibrium to a start point replacing all but one axis ! conditions with fix phases. The start equilibrium must be already ! calculated. ceq is a datastructure with all relevant data for the equilibrium ! A copy of ceq and the corresponing meqrec must be made and linked from maprec ! the axis conditions replaced by fix phases are inactive ! maptop is returned as a first nodepoint(although it is not a node) ! nax is number of axis, axarr records with axis information ! seqxyz is array with indices for numbering nodepoints and lines ! inactive is used for map to replaced axis by fix phase ! and for step inactive(1) nonzero means create just one linehead ! ceq is equilibrium record implicit none TYPE(gtp_equilibrium_data), pointer :: ceq TYPE(map_node), pointer :: maptop integer nax,seqxyz(*) integer inactive(*) type(map_axis), dimension(nax) :: axarr !\end{verbatim} TYPE(gtp_equilibrium_data), pointer :: neweq TYPE(gtp_condition), pointer :: condition,lastcond type(meq_setup), pointer :: meqrec TYPE(map_line), pointer :: mapline TYPE(map_line), dimension(3) :: tmpline TYPE(map_node), pointer :: mapnode,tmpnode type(gtp_phasetuple), dimension(3) :: forbidden type(map_fixph), allocatable :: mapfix ! type(map_fixph), pointer :: mapfix type(gtp_phasetuple), dimension(:), allocatable :: mapfixph integer mode,axactive,iax,jp,ieq,naxvar,seqx,kp,zz,kpos,seqy character eqname*24 double precision value ! write(*,*)"Entering map_startpoint",nax nullify(tmpnode) ! replace all but one axis conditions with fix phases. In ceq we have ! a calculated equilibrium with all conditions. make sure it works ! (without global minimization). We will save the meq_setup record! ! write(*,*)'meq_startpoint: allocating meqrec' allocate(meqrec) meqrec%status=0 ! We must use mode=-1 for map_replaceaxis below has to calculate several equil ! and the phr array must not be deallocated. mapfix will be used later to ! indicate fix and stable phases for different lines (maybe ...) mode=-1 if(allocated(mapfix)) deallocate(mapfix) ! nullify(mapfix) ! write(*,*)'SMP2A meq_startpoint: after allocating meqrec 1' call calceq7(mode,meqrec,mapfix,ceq) if(gx%bmperr.ne.0) then ! try using grid minimizer gx%bmperr=0 ! most data inside meqrec like meqrec%phr are deallocated inside calceq7 ! but calling it with mode=-1 it is kept so it must be deallocated here ! BUG here 2019.03.03 not allocated! if(allocated(meqrec%phr)) deallocate(meqrec%phr) call calceq7(1,meqrec,mapfix,ceq) if(gx%bmperr.ne.0) then write(*,*)'Error calling calceq7 in map_startpoint A',gx%bmperr goto 1000 endif call calceq7(mode,meqrec,mapfix,ceq) if(gx%bmperr.ne.0) then write(*,*)'Error calling calceq7 in map_startpoint B',gx%bmperr goto 1000 endif endif ! check if equilibrium inside axis limits ... do iax=1,nax call locate_condition(axarr(iax)%seqz,condition,ceq) if(gx%bmperr.ne.0) goto 1000 call condition_value(1,condition,value,ceq) if(gx%bmperr.ne.0) goto 1000 if(value.lt.axarr(iax)%axmin .or. value.gt.axarr(iax)%axmax) then write(*,*)'Startpoint outside axis limits',iax,value gx%bmperr=4225; goto 1000 endif enddo ! write(*,1001)'After calceq7: ',(meqrec%phr(jp)%curd%amfu,& ! jp=1,meqrec%nphase) 1001 format(a,6(1pe12.4)) 200 continue !---------------------------------- moved before creating first linehead ! create map_node normally with two exiting lines but in some cases more. if(associated(maptop)) then ! we have already a maptop record, add a new mapnode at the circular list end ! set appropriate next/previous/first links tmpnode=>maptop%previous allocate(maptop%previous) ! initiate all status bits to zero maptop%previous%status=0 tmpnode%next=>maptop%previous mapnode=>maptop%previous ! initiate mapnode mapnode%noofstph=-1 mapnode%previous=>tmpnode mapnode%next=>maptop mapnode%first=>maptop mapnode%seqx=tmpnode%seqx+1 mapnode%nodefix%ixphase=0 mapnode%status=0 mapnode%artxe=0 mapnode%globalcheckinterval=mapglobalcheck ! write(*,*)'creating another mapnode record',mapnode%seqx ! nullify here indicates more than one node record nullify(tmpnode) else ! This is the first (and maybe only) mapnode record (later maptop) ! write(*,*)'Creating first maptop' ! UNFINISHED: VALGRIND indicates loss of >24000 bytes in map_startpoint allocate(maptop) mapnode=>maptop ! inititate status and links mapnode%status=0 mapnode%noofstph=meqrec%nstph mapnode%savednodeceq=-1 ! mapnode%noofstph=-1 mapnode%next=>mapnode mapnode%previous=>mapnode mapnode%first=>mapnode mapnode%number_ofaxis=nax mapnode%nodefix%ixphase=0 mapnode%status=0 mapnode%artxe=0 ! type_of_node =1 step special; =2 step scheil; =3 step tzero; ! =4 step paraequil; =5 step nple ! same indices used in stepspecial in pmon mapnode%type_of_node=0 mapnode%globalcheckinterval=mapglobalcheck ! if there is a previous MAP/STEP then ! seqx and seqy pass on the last used indices for _MAPNODE and _MAPLINE ! write(*,*)'Seqxyz 1: ',seqxyz(1),seqxyz(2) ! seqx is set to 0 here, will be increemented by 1 at copy_equilibrium mapnode%seqx=seqxyz(1) mapnode%seqy=seqxyz(2) if(ocv()) write(*,*)'created maptop',maptop%seqx ! set the tieline_inplane or not ! For step calculation, tieline_inplane=0 ! if there are more than one condition on an extensive_variable ! that is not an axis variable then no tielines in plane, tieline_inplane=-1 ! If there are tie_lines in plane then tieline_inplane=1 mapnode%tieline_inplane=tieline_inplane(nax,axarr,ceq) if(mapnode%tieline_inplane.lt.0) then write(*,*)'Mapping without tie-lines in the plane' endif tmpnode=>maptop ! forgetting to do this created a crash when plotting ... nullify(maptop%plotlink) endif ! !----------------------------------------------------------------- ! if naxvar>1 find a phase to set fix to replace an axis variable naxvar=nax if(naxvar.gt.1) then ! in tmpline info on fix/stable phases to be stored in linehead records call map_replaceaxis(meqrec,axactive,ieq,nax,axarr,tmpline,inactive,& forbidden,ceq) if(ocv()) write(*,205)'Back from replaceaxis with: ',gx%bmperr,& axactive,ieq,& tmpline(1)%linefixph(1)%ixphase,tmpline(1)%linefixph(1)%compset,& tmpline(1)%stableph(1)%ixphase,tmpline(1)%stableph(1)%compset 205 format(a,3i5,5x,2(2i3)) if(gx%bmperr.ne.0) goto 1000 if(ieq.gt.2) then write(*,*)'Ignoring 3rd exit from invariant!' ieq=2 endif else ! only one axis, i.e. a step command, create a map_node record with 2 lines axactive=1 if(inactive(1).eq.0) then ieq=2 else ieq=1 endif endif ! write(*,1001)'After replace: ',(meqrec%phr(jp)%curd%amfu,& ! jp=1,meqrec%nphase) !----------------------------------------------------------------------- ! finished converting a start equilibrium to a start point, ! mapnode%type_of_node=0 mapnode%lines=ieq ! debug listing of links for maptop ... ! write(*,*)'maptop: ',maptop%noofstph ! write(*,*)'maptop next: ',maptop%next%noofstph ! write(*,*)'maptop prev: ',maptop%previous%noofstph ! write(*,*)'maptop next next: ',maptop%next%next%noofstph ! write(*,*)'maptop prev prev: ',maptop%previous%previous%noofstph ! write(*,*)'maptop next prev: ',maptop%next%previous%noofstph ! if(associated(maptop,maptop%next)) then ! write(*,*)'maptop and maptop%next is same record' ! endif ! ! Save the T, P and chemical potentials allocate(mapnode%chempots(meqrec%nrel)) do jp=1,meqrec%nrel mapnode%chempots(jp)=ceq%cmuval(jp) enddo mapnode%tpval=ceq%tpval mapnode%nodeceq=>ceq !----------------------------------------------------------------------- if(ocv()) write(*,*)'allocating lineheads: ',ieq,maptop%seqy ! ensure mapnode%lines is correctly set allocate(mapnode%linehead(ieq)) mapnode%lines=ieq ! mapnode%type_of_node=0 ! meqrec%status do jp=1,ieq mapnode%linehead(ieq)%meqrec%status=0 enddo ! we can have 3 or more exits if starting inside a 3 phase triagle for isotherm if(ieq.lt.3) then ! STEP command: set one exit in each direction of the active axis axactive ! or we found a phase to set fix in a map command? ! do jp=1,2 do jp=1,ieq !--------------------- code moved from map_findline ! make a copy of the equilibrium record if(ocv()) write(*,*)'We found a line from node: ',mapnode%seqx eqname='_MAPLINE_' ! kpos=10 means write number from position 10 kpos=10 seqy=maptop%seqy+1 call wriint(eqname,kpos,seqy) ! write(*,*)'Calling copy_equilibrium' call copy_equilibrium(neweq,eqname,mapnode%nodeceq) ! write(*,*)'back from copy_equilibrium 6' if(gx%bmperr.ne.0) then write(*,*)'Error creating equilibrium: ',eqname goto 1000 endif maptop%seqy=seqy !------------------------------ end code copied ! one line has +axactive, the other -axactive if(ieq.eq.2) then mapnode%linehead(jp)%axandir=(3-2*jp)*axactive else ! this is used for Scheil-Gulliver step with just one axis ! write(*,*)'SMP2A Scheil map_startpoint: ',inactive(1),jp,ieq mapnode%linehead(jp)%axandir=inactive(1) endif mapnode%linehead(jp)%number_of_equilibria=0 mapnode%linehead(jp)%first=0 mapnode%linehead(jp)%last=0 ! mapnode%linehead(jp)%axchange=0 ! careful balance between map4 (U-O) and Fe-Mo (map5) macros mapnode%linehead(jp)%axchange=-1 ! mapnode%linehead(jp)%axchange=-2 ! lineid is set when calculations along the line starts ! mapnode%linehead(jp)%lineid=0 mapnode%linehead(jp)%done=0 mapnode%linehead(jp)%status=0 mapnode%linehead(jp)%more=1 mapnode%linehead(jp)%termerr=0 mapnode%linehead(jp)%firstinc=zero ! saving equilibrium pointer in lineceq mapnode%linehead(jp)%lineceq=>neweq ! mapnode%linehead(jp)%evenvalue=zero ! to ensure small initial steps mapnode%linehead(jp)%evenvalue=value+(3-2*jp)*axarr(1)%axinc ! write(*,*)'evenvalue: ',mapnode%linehead(jp)%evenvalue,value mapnode%linehead(jp)%start=>mapnode mapnode%linehead(jp)%axfact=1.0D-2 ! this is set to zero indicating the stable phases are saved in ceq record mapnode%linehead(jp)%nstabph=0 mapnode%linehead(jp)%lineid=seqy ! write(*,*)'mapline%lineid assigned',seqy mapnode%linehead(jp)%nodfixph=0 ! %more is 1 while line is calculated, 0 means terminated at axis limit ! > 0 means error code <0 means exit removed ?? or is it %done ?? mapnode%linehead(jp)%more=1 !------------------------- if(maptop%tieline_inplane.lt.0) then ! tie-lines not in plane, code just copied with some mods from tielines in plane kp=tmpline(1)%nfixphases mapnode%linehead(jp)%nfixphases=kp allocate(mapnode%linehead(jp)%linefixph(kp)) allocate(mapnode%linehead(jp)%linefix_phr(kp)) ! write(*,454)jp,axactive,mapnode%linehead(jp)%axandir,kp 454 format('Axis direction etc: ',i2,2i4,2x,i3) do zz=1,kp mapnode%linehead(jp)%linefixph(zz)=tmpline(1)%linefixph(zz) mapnode%linehead(jp)%linefix_phr(zz)=tmpline(1)%linefix_phr(zz) enddo ! we can have many stable phases mapnode%linehead(jp)%nstabph=tmpline(1)%nstabph allocate(mapnode%linehead(jp)%stableph(tmpline(1)%nstabph)) allocate(mapnode%linehead(jp)%stablepham(tmpline(1)%nstabph)) allocate(mapnode%linehead(jp)%stable_phr(tmpline(1)%nstabph)) do kp=1,mapnode%linehead(jp)%nstabph mapnode%linehead(jp)%stableph(kp)=tmpline(1)%stableph(kp) mapnode%linehead(jp)%stablepham(kp)=tmpline(1)%stablepham(kp) mapnode%linehead(jp)%stable_phr(kp)=tmpline(1)%stable_phr(kp) enddo ! write(*,*)'allocated size of stableph 1: ',jp,& ! size(mapnode%linehead(jp)%stableph) if(ocv())write(*,27)'We have a startpoint for no tie-lines map:',& ! axactive,mapnode%linehead(jp)%linefixph(1)%phaseix,& axactive,mapnode%linehead(jp)%linefixph(1)%ixphase,& mapnode%linehead(jp)%linefixph(1)%compset,& mapnode%linehead(jp)%nstabph,& (mapnode%linehead(jp)%stableph(kp)%ixphase,& mapnode%linehead(jp)%stableph(kp)%compset,& kp=1,mapnode%linehead(jp)%nstabph) 27 format(a,i3,5x,2i3,5x,i3,2x,10(i5,i2)) !------------------------- below for tielines in plane elseif(maptop%tieline_inplane.gt.0) then ! if there are 2 axis there is one fix phase, if 3 axis there are two ! This is not really necessary here but for other nodes with branches it is kp=tmpline(1)%nfixphases ! write(*,*)'tip: Number of fixed phases: ',jp,kp mapnode%linehead(jp)%nfixphases=kp allocate(mapnode%linehead(jp)%linefixph(kp)) allocate(mapnode%linehead(jp)%linefix_phr(kp)) do zz=1,kp mapnode%linehead(jp)%linefixph(zz)=tmpline(1)%linefixph(zz) mapnode%linehead(jp)%linefix_phr(zz)=tmpline(1)%linefix_phr(zz) enddo ! there is just one stable phase allocate(mapnode%linehead(jp)%stableph(1)) allocate(mapnode%linehead(jp)%stable_phr(1)) mapnode%linehead(jp)%nstabph=1 mapnode%linehead(jp)%stableph=tmpline(1)%stableph mapnode%linehead(jp)%stable_phr=tmpline(1)%stable_phr ! WOW I forgot to allocate stablepham if(allocated(tmpline(1)%stableph)) then kp=size(tmpline(1)%stableph) allocate(mapnode%linehead(jp)%stablepham(kp)) else write(*,*)'SMP: no stablepham array allocated' stop endif if(ocv()) write(*,25)'We have saved a startpoint for map:',& ! axactive,mapnode%linehead(jp)%linefixph(1)%phaseix,& axactive,mapnode%linehead(jp)%linefixph(1)%ixphase,& mapnode%linehead(jp)%linefixph(1)%compset,& mapnode%linehead(jp)%nstabph,& mapnode%linehead(jp)%stableph(1)%ixphase,& mapnode%linehead(jp)%stableph(1)%compset 25 format(a,i3,5x,2i3,5x,i3,2x,2i3) !------------------------- below for STEP else ! this is for STEP if(ocv()) write(*,*)'For STEP no need of fixed phases.' ! write(*,*)'SMP2A Scheil step here?' mapnode%linehead(jp)%nfixphases=0 allocate(mapnode%linehead(jp)%stableph(meqrec%nstph)) allocate(mapnode%linehead(jp)%stable_phr(meqrec%nstph)) ! UNFINISHED check why no allocation of stablepham ?? mapnode%linehead(jp)%nstabph=meqrec%nstph do kp=1,mapnode%linehead(jp)%nstabph zz=meqrec%stphl(kp) mapnode%linehead(jp)%stableph(kp)%ixphase=meqrec%phr(zz)%iph mapnode%linehead(jp)%stableph(kp)%compset=meqrec%phr(zz)%ics mapnode%linehead(jp)%stable_phr(kp)=zz enddo endif !------------------------- nullify(mapnode%linehead(jp)%end) mapnode%linehead(jp)%nodfixph=0 enddo else ! when more than two exits the set of stable phases must be different for ! each line. This can happen if we start in a three-phase region in an ! isothermal section with tie-lines in plane write(*,*)'Cannot handle more than two exits from start equilibrium' gx%bmperr=4226; goto 1000 endif ! mapnode must have pointers to its own copies of ceq and meqrec eqname='_MAPNODE_' jp=10 ! maptop%next is the most recent created mapnode ?? seqx=maptop%next%seqx+1 ! write(*,*)'SMP2A New mapnode index: ',seqx,& ! maptop%next%seqx,maptop%previous%seqx seqx=max(maptop%next%seqx,maptop%previous%seqx)+1 maptop%next%seqx=seqx ! write(*,666)seqx,maptop%seqx,maptop%next%seqx,maptop%previous%seqx 666 format('maptop seqx: ',10i3) call wriint(eqname,jp,seqx) ! make a copy of ceq in a new equilibrium record with the pointer neweq ! This copy is a record in the array "eqlista" of equilibrium record, thus ! it will be updated if new composition sets are created in other threads. call copy_equilibrium(neweq,eqname,ceq) ! write(*,*)'Created MAPNODE ',seqx if(gx%bmperr.ne.0) then write(*,*)'Error in startpoint creating equilibrium: ',eqname goto 1000 endif if(associated(mapnode,maptop)) maptop%seqx=seqx mapnode%nodeceq=>neweq ! If the new node has two stoichiometric phases then mapline%status ! Copy the current meqrec to mapnode, the mapline records ! will generate their own new meqrec records when they are activated ! if the phr array is allocated then deallocate it as it is no longer needed if(allocated(meqrec%phr)) then deallocate(meqrec%phr) endif mapnode%meqrec=meqrec ! trying to reduce memory loss deallocate(meqrec) ! write(*,*)'We are here 15!' ! NOTE: The phr array has been deallocated, maybe it should be kept ... ! but then we must change mode to -1 in the call to calceq7 above !--------------------- ! The lines below must be done when creating the mapnod%linehead record ! we must have separate copies of meqrec and ceq for use in each thread ! mapline%meqrec=mapnode%meqrec ! mapline%ceq=mapnode%ceq ! finished what must be done when creating mapnode%linehead ! if(ocv()) write(*,*)'Exiting map_startpoint',gx%bmperr 1000 continue if(gx%bmperr.ne.0 .and. associated(tmpnode)) then ! we have created a maptop record but then had an error, nullify mapnode write(*,*)'Nullifying maptop: ',gx%bmperr nullify(maptop) endif return end subroutine map_startpoint !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine map_replaceaxis !\begin{verbatim} subroutine map_replaceaxis(meqrec,axactive,ieq,nax,axarr,tmpline,& inactive,forbidden,ceq) ! replace an axis condition with a fix phase ! meqrec is equilibrium calculation record ! axactive is the axis with active condition, ieq is number of exiting lines ! ieq is the number of lines exiting from the startpoint ! nax is number of axis, axarr are description of the axis ! axarr is array with axis records ! tmpline is to transfer some line data to calling routine ! inactive is not really used. ! forbidden are phasetupes with forbidden phases ! ceq is equilibrium record implicit none type(meq_setup), pointer :: meqrec integer nax,axactive,ieq type(map_axis), dimension(nax) :: axarr type(gtp_equilibrium_data), pointer :: ceq type(map_line), dimension(3) :: tmpline integer inactive(*) type(gtp_phasetuple), dimension(*) :: forbidden !\end{verbatim} integer iph,jph,naxvar,iax,tip,jj,jax,irem,iadd,kj,nrel,sj,kax integer ics,lokph,lokcs,kph,kcs,forbiddenix,sph,mapx double precision aval,avalm,xxx,yyy,savamfu(3) ! dummy phase tuple, maybe use nullify instead? type(gtp_phasetuple) :: zerotup type(gtp_condition), pointer :: pcond integer, dimension(:), allocatable :: axis_withnocond ! handle change of condition value type(gtp_state_variable), pointer :: svrrec,svr2 type(gtp_state_variable), target :: svrtarget ! turns off converge control for T integer, parameter :: inmap=1 ! zerotup%lokph=0 zerotup%compset=0 zerotup%ixphase=0 zerotup%lokvares=0 zerotup%nextcs=0 ! nrel=noel() tip=tieline_inplane(nax,axarr,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'In map_replaceaxis ',tip !----------------------------------------------------------------- ! check if start point is an invariant equilibria, can easily happen in ! ternary isotherms if(inveq(jj,ceq)) then if(tip.gt.0) then ! ignore this for less than 3 components if(nrel.eq.3) then ! we are in an isothermal triangle, 3 startlines write(*,*)'Start equilibrium is invariant',jj ieq=3 ! goto 1000 elseif(nrel.gt.3) then ! I do not know what kind of equilibrium this is write(*,160) 160 format('Start equilibrium invariant with tie-lines in plane',& ' but not 3 components'/'I do not know how to handle this') gx%bmperr=4399 goto 1000 endif else ! start equilibrium for a system without tie-lines in plane is invariant ! a rare case write(*,161) 161 format('Start equilibrium invariant without tie-lines in plane'/& 'I do not know how to handle this') gx%bmperr=4399 goto 1000 endif endif naxvar=nax ! zero the number of fix phases and allocate data for the lines needed tmpline%nfixphases=0 allocate(tmpline(1)%linefixph(naxvar-1)) allocate(tmpline(1)%linefix_phr(naxvar-1)) !========================================================== tie-lines in plane tieline_in_plane: if(tip.eq.1) then ! We have tie-lines in the plane, only one stable phase in addition to fix ! write(*,*)'map_replaceaxis: allocate: tmpline(1)%stableph(1)' allocate(tmpline(1)%stableph(1)) allocate(tmpline(1)%stablepham(1)) allocate(tmpline(1)%stable_phr(1)) allocate(axis_withnocond(nax)) axis_withnocond=0 stablephases: if(meqrec%nstph.gt.1) then ! and we have two or more stable phase, we can directly generate startpoints 100 continue if(meqrec%nstph.eq.3) then ! this is a unique case when we must create 3 lines ! write(*,*)'Startpoint inside invariant not yet implemented' ! gx%bmperr=4399; goto 1000 ! ! save some data ...?? ! do jph=1,3 ! jj=meqrec%stphl(jph) ! savamfu(iph)=meqrec%phr(jj)%curd%amfu ! stableph(1,jph)=meqrec%phr(jj)%iph ! stableph(2,jph)=meqrec%phr(jj)%ics ! enddo ! loop for the 3 stable phases setting one of them as fix in turn meqrec%nfixph=1 meqrec%nstph=1 forbiddenix=3 fixphaseloop: do jph=1,3 ! all phases are already set as stable kj=meqrec%stphl(jph) ! write(*,*)'tmpline 1: ',jph,kj if(jph.gt.1) then allocate(tmpline(jph)%linefixph(1)) allocate(tmpline(jph)%linefix_phr(1)) allocate(tmpline(jph)%stableph(1)) allocate(tmpline(jph)%stablepham(1)) allocate(tmpline(jph)%stable_phr(1)) endif ! do we need to set values in meqrec?? ! meqrec%fixph(1,1)=meqrec%phr(kj)%iph ! meqrec%fixph(2,1)=meqrec%phr(kj)%ics ! meqrec%fixpham(1)=zero tmpline(jph)%nfixphases=1 tmpline(jph)%linefixph(1)=zerotup ! write(*,*)'tmpline 2A: ',jph,kj ! write(*,*)'tmpline 2C: ',allocated(meqrec%phr) ! write(*,*)'tmpline 2B: ',meqrec%phr(kj)%iph ! write(*,*)'tmpline 2C: ',allocated(tmpline(jph)%linefixph) tmpline(jph)%linefix_phr(1)=kj tmpline(jph)%linefixph(1)%ixphase=meqrec%phr(kj)%iph ! write(*,*)'SMP2A tmpline 3: ',jph,kj tmpline(jph)%linefixph(1)%compset=meqrec%phr(kj)%ics ! write(*,*)'SMP2A tmpline 4: ',jph,kj tmpline(jph)%nstabph=1 kph=jph+1 if(kph.gt.3) kph=1 sph=meqrec%stphl(kph) tmpline(jph)%axandir=1 write(*,*)'tmpline',kph,sph,tmpline(jph)%axandir tmpline(jph)%stableph(1)=zerotup tmpline(jph)%stableph(1)%ixphase=meqrec%phr(sph)%iph tmpline(jph)%stableph(1)%compset=meqrec%phr(sph)%ics tmpline(jph)%stablepham(1)=one tmpline(jph)%stable_phr(1)=sph ! lines: (fix,stable,forbidden) : (1,2,3); (2,3,1); (3,1,2) ! we must mark the third phase as forbidden !!! jj=meqrec%stphl(forbiddenix) write(*,*)'tmpline 5',forbiddenix,jj forbidden(jph)=zerotup forbidden(jph)%ixphase=meqrec%phr(jj)%iph forbidden(jph)%compset=meqrec%phr(jj)%ics forbiddenix=forbiddenix+1 if(forbiddenix.gt.3) forbiddenix=1 enddo fixphaseloop write(*,65)'Lines: ',& tmpline(1)%linefixph(1)%ixphase,& tmpline(1)%stableph(1)%ixphase,forbidden(1)%ixphase,& tmpline(2)%linefixph(1)%ixphase,& tmpline(2)%stableph(1)%ixphase,forbidden(2)%ixphase,& tmpline(3)%linefixph(1)%ixphase,& tmpline(3)%stableph(1)%ixphase,forbidden(3)%ixphase 65 format(a,3i4,5x,3i4,5x,3i4) ! we should set the axis composition to the stable phase ... ! and we should test ... goto 1000 ! this is end of generating startpoint from a ternary isothermal triangle endif write(*,*)'Tie-lines in the plane and start equilibrium with',& ' several stable phases' jax=0 ! call list_conditions(kou,ceq) do iax=1,nax call locate_condition(axarr(iax)%seqz,pcond,ceq) ! skip axis already removed if(pcond%active.eq.1) cycle if(pcond%statev.ge.10) then ! Best to replace an extensive variable with a fix phase ! But we cannot use a condition N=1 or B=1 for example. It must depend on ! a component ! write(*,*)'Condition 1: ',iax,pcond%seqz ! if(pcond%indices(1,1).eq.0) cycle if(pcond%statvar(1)%argtyp.eq.0) cycle ! write(*,*)'Condition 2: ',iax,pcond%indices(1,1) jax=iax; exit endif enddo if(jax.eq.0) then ! we must accept to replace a potential axis, use one depending on a component ! If we have a P-T diagram? This would not work do iax=1,nax call locate_condition(axarr(iax)%seqz,pcond,ceq) if(pcond%statev.gt.2) then jax=iax; exit endif enddo endif !---------------------------------------------- ! determine a phase to set fix with zero amount avalm=1.0D5 if(ocv()) write(*,*)'Removing axis ',jax,& ', looking for the phase to fix' ! select the phase with smallest amount ... phr has been deallocated ... ! aval=ceq%phase_varres(lokcs)%amfu do jph=1,meqrec%nstph jj=meqrec%stphl(jph) ! amfu is amount formula units, abnorm(1) is atoms/formula units aval=meqrec%phr(jj)%curd%amfu*meqrec%phr(jj)%curd%abnorm(1) if(aval.lt.avalm) then kph=meqrec%phr(jj)%iph kcs=meqrec%phr(jj)%ics kj=jj avalm=aval ! we have 2 stable phases, jph is 1 or 2 sj=3-jph endif enddo ! The phase meqrec%phr(kj)%iph/ics should be set fix sj=meqrec%stphl(sj) ! write(*,73)'Fix phase: ',kj,meqrec%phr(kj)%iph,meqrec%phr(kj)%ics,& ! ' Stable phase: ',sj,meqrec%phr(sj)%iph,meqrec%phr(sj)%ics 73 format(a,3i4,a,3i4) meqrec%phr(kj)%curd%dgm=zero meqrec%phr(kj)%curd%amfu=zero meqrec%phr(kj)%stable=1 meqrec%phr(kj)%phasestatus=PHFIXED ! The array fixph contains also phases with explicit condition to be fixed meqrec%nfixph=meqrec%nfixph+1 meqrec%fixph(1,meqrec%nfixph)=kph meqrec%fixph(2,meqrec%nfixph)=kcs meqrec%fixpham(meqrec%nfixph)=zero ! and the axis condition pcond should be removed pcond%active=1 inactive(1)=inactive(1)+1 inactive(inactive(1))=pcond%seqz ! meqrec%inactiveaxis(1)=pcond%seqz ! write(*,77)jax,pcond%seqz,pcond%prescribed 77 format(' Removing condition: ',2i3,2(1pe12.4)) ! We have tried not to replace T or P, ! but if this is done it must be indicated specially like this if(pcond%statev.eq.1) then meqrec%tpindep(1)=.TRUE. if(ocv()) write(*,*)'Marking that T is variable' elseif(pcond%statev.eq.2) then meqrec%tpindep(2)=.TRUE. endif ! set amount of stable phase meqrec%phr(sj)%curd%amfu=one ! if both axis are extensive (isothermal section) modify active axis condition ! to be the composition of the stable phase kax=3-jax call locate_condition(axarr(kax)%seqz,pcond,ceq) if(gx%bmperr.ne.0) then write(*,*)'Cannot locate condition: ',axarr(kax)%seqz goto 1000 endif ! first argument 1 means extract value of condition call condition_value(1,pcond,xxx,ceq) if(pcond%statev.ge.10) then ! write(*,*)'isothermal section' svrrec=>pcond%statvar(1) ! NOTE: If we change fix/entered phase we must change axvals/axvals2 svrtarget=svrrec svrtarget%argtyp=3 svrtarget%phase=meqrec%phr(sj)%iph svrtarget%compset=meqrec%phr(sj)%ics ! This extracts the composition of the entered phase for first new line ! we must use a pointer in state_variable_val svr2=>svrtarget call state_variable_val(svr2,yyy,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,71)jax,xxx,yyy 71 format('Change ',i3,' axis condition from/to ',2F10.6) ! first argument 1 means to extract the value, 0 means to set the value call condition_value(0,pcond,yyy,ceq) if(gx%bmperr.ne.0) then write(*,*)'Cannot set axis condition' gx%bmperr=4399; goto 1000 endif endif !--------------------------------------------------- ! calculate the equilibrium with the new set of conditions if(ocv()) write(*,*)'Calling meq_sameset inside map_replaceaxis' irem=0; iadd=0; ! write(*,*)'smp2A calling meq_sameset from map_replaceaxis' call meq_sameset(irem,iadd,mapx,meqrec,meqrec%phr,inmap,ceq) if(gx%bmperr.ne.0) then write(*,*)'Error calling meq_sameset in startpoint: ',gx%bmperr goto 1000 elseif(irem.gt.0 .or. iadd.gt.0) then write(*,*)'Change of phase set in startpoint...',irem,iadd gx%bmperr=4227; goto 1000 endif !------------------------------------------------------ if(ocv()) write(*,*)'A successful calculation with one axis',& ' condition replaced by a fix phase.' if(ocv()) write(*,*)'Released axis: ',jax,' fix phase: ',kph,kcs axis_withnocond(jax)=1 naxvar=naxvar-1 if(naxvar.eq.1) then ! when we are here we have a start point and can determine the number of exits ! for the moment just assume 2nd axis is the remaining condition!! tmpline(1)%nfixphases=1 tmpline(1)%linefixph=zerotup ! kj and kph set in loop above ... hope they have not changed tmpline(1)%linefixph%ixphase=kph tmpline(1)%linefixph%compset=kcs tmpline(1)%linefix_phr=kj tmpline(1)%nstabph=0 ! Note meqrec%phr is a TYPE meq_phase with an link curd to phase_varres ! meqrec%phr is a more complex TYPE do jph=1,meqrec%nstph jj=meqrec%stphl(jph) if(meqrec%phr(jj)%iph.eq.kph .and.& meqrec%phr(jj)%ics.eq.kcs) cycle tmpline(1)%stableph(1)=zerotup tmpline(1)%stableph(1)%ixphase=meqrec%phr(jj)%iph tmpline(1)%stableph(1)%compset=meqrec%phr(jj)%ics tmpline(1)%stable_phr(1)=jj tmpline(1)%nstabph=tmpline(1)%nstabph+1 ! tmpline(1)%nstabph=1 ! why exit?? Maybe because there can only be a single phase!! ! exit enddo if(tmpline(1)%nstabph.eq.0) then write(*,*)'No stable phase !!' stop endif ! This is the axis with active condition axactive=2 ieq=2 else write(*,*)'Not implemented more than 2 axis' gx%bmperr=4228; goto 1000 endif ! ========================================== tie-lines in plane and one phase else ! we have just a single phase stable we must move in some direction ! ceq%multiuse is direction ! write(*,*)'SMP2A Tie-line in plane and single phase,',& ! ' This may not work ... ' call map_startline(meqrec,axactive,ieq,nax,axarr,tmpline,ceq) if(gx%bmperr.ne.0) goto 1000 endif stablephases ! ============================================= no tie-lines in plane else !tie-lines NOT in the plane ! I am not sure what stableph and axis_withnocond are used for ... ! write(*,*)'SMP2A multiple startpoint without tie-lines in plane not allowed' ! gx%bmperr=4399; goto 1000 allocate(axis_withnocond(nax)) axis_withnocond=0 call map_startline(meqrec,axactive,ieq,nax,axarr,tmpline,ceq) if(gx%bmperr.ne.0) goto 1000 endif tieline_in_plane ! ! check if more axis must be released 900 continue if(nax.gt.2) then write(*,*)'SMP2A Cannot handle more than 2 axis at present' gx%bmperr=4228 endif 1000 continue ! write(*,*)'Return from map_replaceaxis with conditions: ' ! call list_conditions(kou,ceq) return end subroutine map_replaceaxis !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine map_startline !\begin{verbatim} subroutine map_startline(meqrec,axactive,ieq,nax,axarr,tmpline,ceq) ! find a phase to fix to replace an axis condition when we ! do not have tie-lines in the plane or when we ! have tie-lines in the plane but start in a single phase region ! meqrec is equilibrium record already initiated ! axactive is set to the axis with active condition ! ieq is the number of lines exiting from the startpoint ! nax is number of axis, axarr are description of the axis ! axarr are axis records ! tmpline is a line record ... not needed ... ?? implicit none integer nax,axactive,ieq type(meq_setup), pointer :: meqrec type(map_line), dimension(2) :: tmpline type(map_axis), dimension(nax) :: axarr type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer jax,iax,idir,irem,iadd,iph,jj,jph,kph,ll,mapx integer :: maxtry=0 integer, parameter :: nstabphdim=20 ! data for more than 3 axis ... integer axfree(5) double precision curval,startval type(gtp_condition), pointer :: pcond ! turns off converge control for T integer, parameter :: inmap=1 save maxtry ! with 3 or more axes one will have several linefixph ! ! write(*,*)'In map_startline, find a phase to set fix',ceq%multiuse ! start in negative direction unless direction given axfree=0 idir=-1 if(ceq%multiuse.ne.0) then if(abs(ceq%multiuse).gt.nax) then write(*,*)'Error in direction, no such axis, ',ceq%eqno,ceq%multiuse ! this can happen for startpoints. 21 is lower left, 22 is lower right ! 23 is upper left, 24 is upper right and 30 is in the middle ! Try to generate several directions for each, at present just one if(ceq%multiuse.eq.21) then ! directions +1 and +2 call list_conditions(kou,ceq) jax=1; idir=1 elseif(ceq%multiuse.eq.22) then ! directions +1 and -2 call list_conditions(kou,ceq) jax=2; idir=-1 elseif(ceq%multiuse.eq.23) then ! directions -1 and +2 call list_conditions(kou,ceq) jax=1; idir=-1 elseif(ceq%multiuse.eq.24) then ! directions -1 and -2 call list_conditions(kou,ceq) jax=2; idir=-1 elseif(ceq%multiuse.eq.30) then ! all 4 directions ... call list_conditions(kou,ceq) else write(*,*)'Error in direction, no such axis, ',ceq%multiuse gx%bmperr=4229; goto 1000 endif else ! direction is +/-axis ! write(*,*)'SMP2A direction: ',ceq%multiuse if(ceq%multiuse.gt.0) idir=1 jax=abs(ceq%multiuse) call locate_condition(axarr(jax)%seqz,pcond,ceq) ! write(*,*)'SMP2A axis condition: ',pcond%statev,gx%bmperr if(gx%bmperr.ne.0) goto 1000 endif else ! no axis selected ! write(*,*)'SMP2A no direction',ceq%multiuse,nax jax=0 idir=-1 findax: do iax=1,nax call locate_condition(axarr(iax)%seqz,pcond,ceq) if(gx%bmperr.ne.0) goto 1000 if(pcond%statev.lt.10) then ! this means intensive variable (T,P chemical potential) idir=-1; jax=iax; exit findax endif enddo findax ! both axis are extensive, take the first axix if(jax.eq.0) jax=1 call locate_condition(axarr(jax)%seqz,pcond,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'Searching for phase to fix along axis: ',jax endif call condition_value(1,pcond,curval,ceq) ! write(*,'(a,3i4,F10.2)')'SMP2A initial value: ',gx%bmperr,jax,idir,curval if(gx%bmperr.ne.0) goto 1000 ! it seems OK until here .... startval=curval ! increment axis variable using axinc and calculate with meq_sameset 100 continue curval=curval+idir*axarr(jax)%axinc call condition_value(0,pcond,curval,ceq) ! write(*,'(a,i5,F12.5)')'SMP2A current value: ',gx%bmperr,curval if(gx%bmperr.ne.0) goto 1000 irem=0; iadd=0; meqrec%noofits=0 ! write(*,*)'SMP2A calling meq_sameset from map_startline 1' call meq_sameset(irem,iadd,mapx,meqrec,meqrec%phr,inmap,ceq) ! if(ocv()) write(*,110)'Search for phase change: ',& ! write(*,110)'Search for phase change: ',& ! idir*jax,gx%bmperr,irem,iadd,ceq%tpval(1),curval,axarr(jax)%axinc 110 format(a,i2,3i5,2x,F8.2,2(1pe12.4)) maxtry=maxtry+1 if(maxtry.gt.1000) then write(*,*)'SMP2A eternal loop: ',maxtry stop endif if(gx%bmperr.ne.0) goto 1000 nophasechange: if(irem.eq.0 .and. iadd.eq.0) then if(idir.lt.0) then if(curval.le.axarr(jax)%axmin) then ! change direction idir=1 curval=startval endif elseif(idir.gt.0) then if(curval.ge.axarr(jax)%axmax) then write(*,*)'No phase change along this axis' goto 1010 endif endif goto 100 endif nophasechange !---------------------------------------------------------- ! we found a phase to set fix! meqrec%nfixph=meqrec%nfixph+1 write(*,*)'SMP2A meqrec%nfixph and nax:',meqrec%nfixph,nax ! This is written to handle several axis i.e. several fix phases. ! write(*,*)'SMP2A found a phase change: ',irem,iadd fixfas: if(irem.gt.0) then if(meqrec%nstph.eq.1) then write(*,*)'Attempt to set the only phase as fix!' gx%bmperr=4230; goto 1000 endif ! write(*,*)'Remove axis condition and set stable phase fix: ',irem ! phase already in lists, just mark it is no fixed with zero amount meqrec%phr(irem)%stable=1 meqrec%phr(irem)%curd%amfu=zero meqrec%phr(irem)%curd%dgm=zero ! set that the phase has fixed amount meqrec%phr(irem)%phasestatus=PHFIXED meqrec%fixph(1,meqrec%nfixph)=meqrec%phr(irem)%iph meqrec%fixph(2,meqrec%nfixph)=meqrec%phr(irem)%ics kph=irem !--------------------------------------------------------------- else !fixfas iadd ! write(*,*)'SMP2A set new phase fix: ',iadd if(meqrec%nstph.eq.meqrec%maxsph) then write(*,*)'Too many phases stable',meqrec%maxsph gx%bmperr=4231; goto 1000 endif ! copied from meq_phaseset ! the phase must be added in sequential order of phase and composition set no findplace: do jph=1,meqrec%nstph jj=meqrec%stphl(jph) if(meqrec%phr(iadd)%iph.gt.meqrec%phr(jj)%iph) then cycle endif if(meqrec%phr(iadd)%iph.lt.meqrec%phr(jj)%iph) then exit endif ! if same phase number compare composition set numbers if(meqrec%phr(iadd)%iph.eq.meqrec%phr(jj)%iph) then if(meqrec%phr(iadd)%ics.gt.meqrec%phr(jj)%ics) then cycle else exit endif endif enddo findplace do kph=meqrec%nstph,jph,-1 meqrec%stphl(kph+1)=meqrec%stphl(kph) enddo ! write(*,*)'SMP2A still trying to fix conditions ...' ! phase added at jph, (note jph may be equal to nstph+1) meqrec%stphl(jph)=iadd meqrec%nstph=meqrec%nstph+1 meqrec%phr(iadd)%itadd=meqrec%noofits meqrec%phr(iadd)%curd%dgm=zero meqrec%phr(iadd)%stable=1 ! set that the phase has fixed amount meqrec%phr(iadd)%phasestatus=PHFIXED meqrec%fixph(1,meqrec%nfixph)=meqrec%phr(iadd)%iph meqrec%fixph(2,meqrec%nfixph)=meqrec%phr(iadd)%ics kph=iadd endif fixfas ! meqrec%nfixph is used to reduce the number of variables in the system ! matrix. Fix phases have no variable amount. meqrec%fixpham(meqrec%nfixph)=zero ! ! write(*,*)'Now release axis condition: ',kph,pcond%active ! Must not forget to set if T or P is variable! pcond%active=1 if(pcond%statev.eq.1) then meqrec%tpindep(1)=.TRUE. elseif(pcond%statev.eq.2) then meqrec%tpindep(2)=.TRUE. endif ! calling meq_sameset with iadd=-1 turn on verbose irem=0; iadd=0 ! write(*,*)'SMP2A calling meq_sameset from map_startline 2' call meq_sameset(irem,iadd,mapx,meqrec,meqrec%phr,inmap,ceq) ! if(ocv()) write(*,110)'meq_sameset calculated: ',& if(gx%bmperr.gt.0) then write(*,*)'Failed to calculate with fix phase',gx%bmperr goto 1000 elseif(iadd.gt.0 .or. irem.gt.0) then write(*,*)'Another phase want to be stable: ',iadd,irem gx%bmperr=4232; goto 1000 endif if(nax.gt.2) then ! handling of more than 2 axes ! unfinished vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv below axfree(jax)=1 write(*,*)'SMP2A more than 2 axes, fix phase: ',meqrec%nfixph,nax,jax do kph=1,meqrec%nfixph write(*,*)'smp2a: linefix: ',meqrec%fixph(1,kph),meqrec%fixph(2,kph) enddo if(nax-meqrec%nfixph.gt.1) then write(*,'(a,5i3)')'smp2a axfree: ',axfree ! more than 2 axis, more than 1 fix phase along the line ! Hm what is linefix_phr used for when one can have several fix phases??? moreax: do jax=1,nax ! skip axis already replaced by fix phase but accept any other if(axfree(jax).ne.0) cycle moreax call locate_condition(axarr(jax)%seqz,pcond,ceq) if(gx%bmperr.ne.0) goto 1000 call condition_value(1,pcond,curval,ceq) if(gx%bmperr.ne.0) goto 1000 enddo moreax if(jax.gt.nax) stop 'no such axis' ! it seems OK until here .... startval=curval ! return seaching for another phase to set fix write(*,*)'smp2a tries to replace axis ?',jax,curval goto 100 endif ! unfinished ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ above !>>>>>>>>>>>>> we have not finished mapping with 3 or more axis endif ! write(*,110)'SMP2A start calculated: ',0,gx%bmperr,irem,iadd,ceq%tpval(1) ! if(gx%bmperr.ne.0) goto 1000 ! ! we must return some values ! write(*,*)'SMP2A now create start node and line equilibria' ! two exits ieq=2 if(nax.gt.2) then write(*,*)'SMP2A sorry not implemented more than 2 axis' gx%bmperr=4399; goto 1000 else ! active axis, the remaining one, if jax=1 then 2, if jax=2 then 1 axactive=3-jax ! templine is map_line record, some data must be set tmpline(1)%nfixphases=1 tmpline(1)%linefixph%ixphase=meqrec%phr(kph)%iph tmpline(1)%linefixph%compset=meqrec%phr(kph)%ics tmpline(1)%linefix_phr=kph endif ! allocate space for all stable phases minus one as fix, may already be alloc ! The number of stable phases can vary for different MAP commands if(allocated(tmpline(1)%stableph)) then deallocate(tmpline(1)%stableph) deallocate(tmpline(1)%stablepham) deallocate(tmpline(1)%stable_phr) endif ! write(*,*)'map_startline: allocate 2: ',nstabphdim allocate(tmpline(1)%stableph(nstabphdim)) allocate(tmpline(1)%stablepham(nstabphdim)) allocate(tmpline(1)%stable_phr(nstabphdim)) ll=0 tmpline(1)%nstabph=0 do jph=1,meqrec%nstph jj=meqrec%stphl(jph) ! write(*,*)'Stable phase: ',meqrec%nstph,kph,jj if(jj.eq.kph) cycle ! if(meqrec%phr(jj)%iph.eq.kph .and.& ! meqrec%phr(jj)%ics.eq.kcs) cycle ! write(*,66)'smp3: upper bound: ',jph,jj,size(tmpline(1)%stableph),& ! nstabphdim,meqrec%nstph 66 format(a,10i4) ll=ll+1 ! write(*,*)'Store stable phase: ',jj,ll tmpline(1)%stableph(ll)%ixphase=meqrec%phr(jj)%iph tmpline(1)%stableph(ll)%compset=meqrec%phr(jj)%ics tmpline(1)%stablepham(ll)=meqrec%phr(jj)%curd%amfu tmpline(1)%stable_phr(ll)=jj tmpline(1)%nstabph=tmpline(1)%nstabph+1 ! why exit? ! exit enddo ! if(ocv()) write(*,300)axactive,kph,tmpline(1)%linefixph%phaseix,& ! write(*,300)axactive,kph,tmpline(1)%linefixph%ixphase,& ! tmpline(1)%linefixph%compset,tmpline(1)%nstabph,& ! (tmpline(1)%stableph(jj)%ixphase,tmpline(1)%stableph(jj)%compset,& ! jj=1,tmpline(1)%nstabph) 300 format('exit map_startline: ',i2,i3,2x,2i3,2x,i2,10(2x,i3,i2)) if(tmpline(1)%nstabph.eq.0) then write(*,*)'No stable phase !!' stop endif 1000 continue return 1010 continue gx%bmperr=4233 goto 1000 end subroutine map_startline !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine map_checkstep !\begin{verbatim} subroutine map_checkstep(mapline,value,jj,axarr,nax,saveceq) ! check if step too large ! mapline is line record ! axarr is array with axis records ! nax is number of axis ! saveceq is record for saved equilibria implicit none integer nax type(map_line), pointer :: mapline type(map_axis), dimension(nax) :: axarr type(map_ceqresults), pointer :: saveceq !\end{verbatim} integer place,jph,jj type(meq_setup), pointer :: meqrec type(gtp_state_variable), target :: axstv1 type(gtp_state_variable), pointer :: axstv double precision value character ch1*1 logical saveonfile ! pointer to last calculated (can be zero) and last free ! store last calulated axis values in axarr(iax)%lastaxval ! write(*,*)'In map_checkstep',mapline%start%number_ofaxis,nax ! do jj=1,nax ! axstv1=axarr(jj)%axcond(1) ! axstv=>axstv1 ! call state_variable_val(axstv,value,mapline%lineceq) ! if(gx%bmperr.gt.0) goto 1000 ! if(nax.gt.1) then ! when several axis check if any has a big change ... ! if(mapline%number_of_equilibria.gt.3) then if(abs(axarr(jj)%lastaxval-value).gt.& 1.0D-1*(axarr(jj)%axmax-axarr(jj)%axmin)) then write(*,17)jj,mapline%axandir,mapline%number_of_equilibria,& axarr(jj)%lastaxval,value 17 format(' *** Too large change in axis: ',2i3,' at ',i4,& 2(1pe14.6)) gx%bmperr=4360; goto 1000 endif 1000 continue return end subroutine map_checkstep !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine map_store !\begin{verbatim} subroutine map_store(mapline,axarr,nax,saveceq) ! store a calculated equilibrium ! mapline is line record ! axarr is array with axis records ! nax is number of axis ! saveceq is record for saved equilibria implicit none integer nax type(map_line), pointer :: mapline type(map_axis), dimension(nax) :: axarr type(map_ceqresults), pointer :: saveceq !\end{verbatim} integer place,jph,jj,lokcs type(meq_setup), pointer :: meqrec type(gtp_state_variable), target :: axstv1 type(gtp_state_variable), pointer :: axstv double precision value character ch1*1 logical saveonfile,testforspinodal ! pointer to last calculated (can be zero) and last free ! store last calulated axis values in axarr(iax)%lastaxval ALLOCATE ! write(*,*)'SMP in map_store',gx%bmperr,globaldata%sysparam(2) ! insert a test for spinodal at every iii equilibriia testforspinodal=.FALSE. if(globaldata%sysparam(2).gt.0) then if(mod(mapline%number_of_equilibria,globaldata%sysparam(2)).eq.0) & testforspinodal=.TRUE. endif ! do jj=1,nax axstv1=axarr(jj)%axcond(1) axstv=>axstv1 call state_variable_val(axstv,value,mapline%lineceq) if(gx%bmperr.gt.0) goto 1000 ! write(*,*)'map_store: ',value ! this check could be moved before store to take halfstep?? if(nax.gt.1 .and. mapline%number_of_equilibria.gt.3) & call map_checkstep(mapline,value,jj,axarr,nax,saveceq) if(gx%bmperr.ne.0) goto 1000 ! if(nax.gt.1) then ! when several axis check if any has a big change ... ! if(mapline%number_of_equilibria.gt.3) then ! if(abs(axarr(jj)%lastaxval-value).gt.& ! 1.0D-1*(axarr(jj)%axmax-axarr(jj)%axmin)) then ! 2.0D-2*(axarr(jj)%axmax-axarr(jj)%axmin)) then ! write(*,17)' *** map_store large step in axis: ',& ! mapline%number_of_equilibria,jj,& ! mapline%axandir,axarr(jj)%lastaxval,value !17 format(a,3i3,2(1pe14.6)) ! gx%bmperr=4360; goto 1000 ! read(*,'(a)')ch1 ! endif ! endif ! endif axarr(jj)%lastaxval=value enddo if(repeatederr.ge.2) then ! VERY STRANGE BEHAVIOUR HERE, repeatederr not reset ?? ! maybe not store if repeatederr nonzero jj=repeatederr; repeatederr=0 ! write(*,*)'SMP in map_store',jj,repeatederr,gx%bmperr ! Finnaly I will store the calculated equilibrium but skip it for plotting ! if lasterr nonzero. ! gx%bmperr=4399 ! goto 1000 endif repeatederr=0 ! write(*,18)'stored: ',mapline%number_of_equilibria,(axarr(jj)%lastaxval,& ! jj=1,mapline%start%number_ofaxis) !18 format(a,i3,5(1pe14.6)) !----------------------- saveonfile=.FALSE. ! >>>> begin treadprotected ! write(*,*)'map_store: ',saveonfile call reserve_saveceq(place,saveceq) if(gx%bmperr.eq.4219) then ! the memory is full, save this equilibrium, clean up and empty all on file saveonfile=.TRUE. gx%bmperr=0 elseif(gx%bmperr.ne.0) then ! some other fatal error goto 1000 endif if(repeatederr.gt.0) then ! maybe not store if repeatederr nonzero ! write(*,*)'SMP in map_store',repeatederr,gx%bmperr,place repeatederr=0 endif ! write(*,*)'map_store: ',place,allocated(mapline%meqrec%phr) ! write(*,*)'map_store: ',place,assigned(mapline%meqrec) ! >>>> end threadprotected !----------------------- ! when step_tzero and some other step procedures MEQREC is not used if(.not.allocated(mapline%meqrec%phr)) goto 600 ! loop through all phases and if their status is entered set it as PHENTUNST ! then loop through all stable to set status PHENTSTAB ! That is important for extracting values later ... meqrec=>mapline%meqrec do jph=1,meqrec%nphase ! write(*,*)'phase and status: ',jph,meqrec%phr(jph)%curd%phstate,& ! PHENTSTAB ! if(meqrec%phr(jph)%curd%phstate.ge.PHENTUNST .and. & ! meqrec%phr(jph)%curd%phstate.le.PHENTSTAB) then ! meqrec%phr(jph)%curd%phstate=PHENTUNST if(meqrec%phr(jph)%curd%phstate.ge.PHENTUNST .and. & meqrec%phr(jph)%curd%phstate.le.PHENTERED) then meqrec%phr(jph)%curd%phstate=PHENTUNST ! else ! write(*,*)'map_store found a phase with status: ',& ! meqrec%phr(jph)%curd%phstate endif enddo ! write(*,*)'map_store, stable phases',meqrec%nstph,place do jph=1,meqrec%nstph jj=meqrec%stphl(jph) if(meqrec%phr(jj)%curd%phstate.lt.PHFIXED) then meqrec%phr(jj)%curd%phstate=PHENTSTAB ! check if phase is inside miscibility gap if(testforspinodal) then lokcs=phasetuple(meqrec%phr(jj)%curd%phtupx)%compset call calc_qf(lokcs,value,mapline%lineceq) write(*,'(a,i3,F8.2,4(1pe12.4))')'SMP qf: ',lokcs,& mapline%lineceq%tpval(1),value if(gx%bmperr.ne.0) then write(*,*)'SMP error chacking for instability',lokcs gx%bmperr=0 elseif(value.lt.zero) then write(*,*)'SMP detected phase inside spinodal: ',lokcs gx%bmperr=4399; goto 1000 endif endif ! else ! write(*,*)'Fix phase 1: ',jj,meqrec%phr(jj)%iph,meqrec%phr(jj)%ics endif enddo ! write(*,201)' map store, stable phases: ',& ! (meqrec%phr(meqrec%stphl(jj))%iph,& ! meqrec%phr(meqrec%stphl(jj))%ics,jj=1,meqrec%nstph) 201 format(a,10(2i3,2x)) !----------------------------------------- 600 continue ! this copies the whole data structure !!! ! LIKELY PLACE FOR SEGMENTATION FAULT !!! ! write(*,*)'SMP storing equilibrium record: ',place ! The = means copy the record, all internal structures copied ! BUT conditions are NOT saved ... because they are a linked list. saveceq%savedceq(place)=mapline%lineceq ! remove index of nexeq (free list?) saveceq%savedceq(place)%nexteq=0 ! MAYBE one should nullify the pointers lastcontition and lastexperinet ! in saveceq%savedceq(place). They point to mapline%lineceq ... ! IF I NULLIFY here I cannot plot CP which requires the conditions to be set!! ! nullify(saveceq%savedceq(place)%lastcondition) ! nullify(saveceq%savedceq(place)%lastexperiment) ! I have to be careful using these conditions .... ! The calculated results are saved in allocated arrays ! All map examples tested OK !------------------------------------------------------ above added 20210707 if(mapline%last.gt.0) then saveceq%savedceq(mapline%last)%nexteq=place endif mapline%last=place mapline%number_of_equilibria=mapline%number_of_equilibria+1 if(mod(mapline%number_of_equilibria,20).eq.0) & write(kou,'("Equilibria calculated ",i5)')mapline%number_of_equilibria if(mapline%first.eq.0) mapline%first=place ! this counter is zeroed when starting a new map/step unless old saved kept totalsavedceq=totalsavedceq+1 if(totalsavedceq.gt.maxsavedceq) then write(kou,202)totalsavedceq 202 format(78('*')/'SMP saved equilibria overflow ',i5,& ' and save on file is not implemented.'/& 'Use smaller increments or reinitiate before STEP or MAP'/78('*')/) gx%bmperr=4219 endif if(saveonfile) then ! We have to wind up all unfinished lines to continue step/map ! but this is not yet implemented write(*,207) 207 format(/' *** Buffer full and save on file not yet implemented,',& ' terminating step/map'/) gx%bmperr=4219 endif 1000 continue ! nothing allocated? ! write(*,*)'SMP exit map_store',place return end subroutine map_store !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine map_lineend !\begin{verbatim} subroutine map_lineend(mapline,value,ceq) ! terminates gracefully a line at an axis limit or an error. ! mapline probably not needed except for testing ! value is last calculated axis value ! ceq is equilibrium record implicit none integer mode type(map_line), pointer :: mapline type(gtp_equilibrium_data), pointer :: ceq double precision value !\end{verbatim} ! type(meq_setup), pointer :: meqrec ! this will be called when a line ends at an axis limit, nothing to do? if(gx%bmperr.ne.0) then write(kou,75)mapline%number_of_equilibria,value,gx%bmperr 75 format('Terminating line with ',i4,' equilibria at ',1pe12.4,& ' due to error',i5) mapline%termerr=gx%bmperr gx%bmperr=0 ! maybe do some cleanup ?? else write(kou,77)mapline%number_of_equilibria,value 77 format('Terminating line with ',i4,' equilibria at axis limit ',1pe12.4) mapline%termerr=0 endif ! mark there is no node at the end nullify(mapline%end) 1000 continue ! This routine should clear any error code gx%bmperr=0 return end subroutine map_lineend !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine map_changeaxis !\begin{verbatim} subroutine map_changeaxis(mapline,nyax,oldax,nax,axarr,axval,bytax,ceq) ! changes the axis with active condition to nyax ! mapline is line record ! nyax is index of new active axis ! oldax is index of old active axis ! nax is number of axis (always 2?) ! axarr is array with axis records ! axval the value to set as condition on new axis ! bytax logical, if true ignore axval ?? also used to indicate change of fix ph ! ceq is equilibrium record type(map_line), pointer :: mapline type(gtp_equilibrium_data), pointer :: ceq type(map_axis), dimension(nax) :: axarr logical bytax integer nyax,nax,oldax double precision axval !\end{verbatim} %+ type(gtp_condition), pointer :: pcond,lastcond type(gtp_state_variable), pointer :: axcondrec integer jax,iadd,irem,ierr,mapx double precision value ! turns off converge control for T integer, parameter :: inmap=1 ! look for the condition record for new axis ! write(*,*)'In map_changeaxis: ',nyax,axval call locate_condition(axarr(nyax)%seqz,pcond,ceq) if(gx%bmperr.ne.0) goto 1000 !----------- 120 continue ! calculate the value of the inactive axis (nyax) condition. An inactive ! condition is not updated automatically. Set prescribed value and ! activate the condition. if(pcond%active.eq.0) then write(*,*)'In map_changeaxis, new axis condition is already acive!' goto 1000 endif if(ocv()) write(*,*)'Axis condition: ',axarr(nyax)%axcond(1)%oldstv ! svrrec=>pcond%statvar(1) axcondrec=>pcond%statvar(1) ! axcondrec=>axarr(nyax)%axcond(1) 127 format('Map_changeaxis: ',2i2,2x,i3,2x,4i3,2x,i5,2x,2i5) call state_variable_val(axcondrec,value,ceq) if(gx%bmperr.ne.0) goto 1000 if(ocv()) write(*,130)'New axis, current and prescribed: ',nyax,& value,axval,mapline%axvalx(nyax) 130 format(a,i2,2(1pe12.4)) ! when called from bytaxis we should ignore current value ... if(bytax) then pcond%prescribed=axval else pcond%prescribed=value endif pcond%active=0 ! we must indicate if T or P are now fixed ... if(pcond%statev.eq.1) then mapline%meqrec%tpindep(1)=.FALSE. if(ocv()) write(*,*)'Marking that T is variable' elseif(pcond%statev.eq.2) then mapline%meqrec%tpindep(2)=.FALSE. endif !------------------------------------------- ! this is the old axis with active condition, look for its condition call locate_condition(axarr(oldax)%seqz,pcond,ceq) if(gx%bmperr.ne.0) goto 1000 if(pcond%active.ne.0) then if(ocv()) write(*,*)'Wow, old axis condition is still active' else ! deactivate condition if(ocv())write(*,*)'Current value of old axis cond: ',pcond%prescribed pcond%active=1 endif ! we must indicate if T or P are not fixed ... if(pcond%statev.eq.1) then ! in one case the value ceq%tpval was zero whereas the condition was positive ! This was due to a failed calculation of a new invariant equilibrium. mapline%meqrec%tpindep(1)=.TRUE. if(ocv()) write(*,*)'Marking that T is variable',ceq%tpval(1) ceq%tpval(1)=pcond%prescribed elseif(pcond%statev.eq.2) then mapline%meqrec%tpindep(2)=.TRUE. endif !---------------------------------------------------------- ! now we calculate the same equilibrium but with different axis condition! irem=0 iadd=0 ! add=-1 turn on verbose in meq_sameset ! iadd=-1 ! if(bytax) then ! write(*,*)'Calling meq_sameset in map_bytaxis:' ! call list_conditions(kou,ceq) ! iadd=-1 ! endif if(ocv()) write(*,*)'Map_changeaxis call meq_sameset, T=',ceq%tpval(1) ! write(*,*)'SMP2A calling meq_sameset from map_changeaxis' call meq_sameset(irem,iadd,mapx,mapline%meqrec,mapline%meqrec%phr,inmap,ceq) if(gx%bmperr.ne.0) then ! write(*,*)'Error from meq_sameset when trying to change axis',gx%bmperr endif ! ierr=gx%bmperr; gx%bmperr=0 ! write(*,*)'Error trying to change axis: ',ierr ! call list_conditions(kou,ceq) ! gx%bmperr=ierr ! if(ocv()) write(*,*)'Something really wrong ...',gx%bmperr,ceq%tpval(1) ! else ! write(*,990)gx%bmperr,irem,iadd,ceq%tpval(1) !990 format(//' *** sucess *** ',3i5,1pe15.7//) ! endif ! 1000 continue return end subroutine map_changeaxis !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine map_force_changeaxis !\begin{verbatim} %- subroutine map_force_changeaxis(maptop,mapline,meqrec,nax,axarr,axvalok,ceq) ! force change of axis with active condition. Works only with 2 axis. ! (and for tie-line not in plane ??). Calls map_changeaxis ... ! maptop is node record ! mapline is line record ! meqrec is equilibrium calculation record ! nax is number of axis, also in maptop record ! axarr is array with axis records ! axvalok is last successfully calculated axis value ! ceq is equilibrium record implicit none integer nax type(map_node), pointer :: maptop type(map_line), pointer :: mapline type(meq_setup) :: meqrec type(gtp_equilibrium_data), pointer :: ceq type(map_axis), dimension(*) :: axarr double precision axvalok !\end{verbatim} double precision axfact,slope,xxx,value,axval,zzz integer nyax,seqz,jaxwc,oldax type(gtp_condition), pointer :: pcond type(gtp_state_variable), pointer :: svrrec ! copied from map_step if(ocv()) write(*,*)'Force change of axis with active condition: ',& mapline%axandir ! We have to change the axis with active condition, assume 2 axis jaxwc=abs(mapline%axandir) nyax=3-jaxwc oldax=jaxwc if(ocv()) write(*,101)mapline%number_of_equilibria,jaxwc,& nyax,xxx,mapline%axvals(oldax),ceq%tpval(1) 101 format('Bytaxis slope ',i3,2x,2i2,6(1pe12.4)) axfact=1.0D-2 ! ! Extract the current value of the (old) axis state variable items using pcond seqz=axarr(nyax)%seqz call locate_condition(seqz,pcond,ceq) if(gx%bmperr.ne.0) goto 1000 zzz=pcond%prescribed svrrec=>pcond%statvar(1) call state_variable_val(svrrec,axval,ceq) if(gx%bmperr.ne.0) goto 1000 ! find the direction if(mapline%axvals(nyax)-mapline%axvalx(nyax).lt.0) then ! set negative direction and a small step ! write(*,*)'Force_changeaxis 1: ',mapline%axandir,-nyax mapline%axandir=-nyax ! xxx=mapline%axvals(nyax)-1.0D-2*axarr(nyax)%axinc else ! set positive direction ! write(*,*)'Force_changeaxis 2: ',mapline%axandir,nyax mapline%axandir=nyax ! xxx=mapline%axvals(nyax)+1.0D-2*axarr(nyax)%axinc endif xxx=zzz if(ocv()) write(*,62)'New axis direction: ',mapline%axandir,& mapline%axvals(nyax),mapline%axvalx(nyax) 62 format(a,i3,2x,2(1pe14.6)) ! set new axis value as prescribed ... otherwise problems in map_changeaxis pcond%prescribed=xxx if(ocv()) write(*,63)'Call map_changeaxis',nyax,mapline%axchange,& mapline%number_of_equilibria,axval,zzz,xxx,ceq%tpval(1) 63 format(a,i2,2i3,4(1pe12.4)) ! call list_conditions(kou,ceq) call map_changeaxis(mapline,nyax,oldax,nax,axarr,xxx,.TRUE.,ceq) if(gx%bmperr.ne.0) then ! seqz=gx%bmperr; gx%bmperr=0 ! write(*,*)'Error back from map_changeaxis: ',seqz ! call list_conditions(kou,ceq) ! gx%bmperr=seqz goto 1000 endif ! change pcond!!! seqz=axarr(nyax)%seqz call locate_condition(seqz,pcond,ceq) ! write(*,*)'After map_change: ',nyax,pcond%seqz,pcond%statev jaxwc=nyax mapline%axchange=mapline%number_of_equilibria ! value below is assumed to be most recently calculated value value=mapline%axvals(jaxwc) if(ocv()) write(*,16)'Axis, old and new condition: ',& mapline%axandir,value,xxx,ceq%tpval(1) 16 format(a,i3,6(1pe12.4)) ! take a step in the axis variable. mapline%axandir is +/-jaxwc ! mark axis changed mapline%axchange=mapline%number_of_equilibria if(mapline%axandir.gt.0) then value=value+axfact*axarr(jaxwc)%axinc else value=value-axfact*axarr(jaxwc)%axinc endif if(ocv()) write(*,202)'In map_step new, step & T: ',jaxwc,& mapline%axandir,value,axfact*axarr(jaxwc)%axinc,ceq%tpval(1) 202 format(a,2i3,3(1pe14.6)) mapline%more=1 ! Make sure value is set for the active axis condition!! seqz=axarr(jaxwc)%seqz call locate_condition(seqz,pcond,ceq) ! this call sets value as condition on the axis! if(ocv()) write(*,207)'Axis condition: ',jaxwc,pcond%statev,value 207 format(a,i2,i4,1pe14.6) call condition_value(0,pcond,value,ceq) if(gx%bmperr.ne.0) goto 1000 ! 1000 continue return end subroutine map_force_changeaxis !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine map_step !\begin{verbatim} subroutine map_step(maptop,mapline,meqrec,phr,axvalok,nax,axarr,ceq) ! select old or new step method implicit none integer nax type(map_node), pointer :: maptop type(map_line), pointer :: mapline type(meq_setup) :: meqrec type(meq_phase), dimension(*), target :: phr type(gtp_equilibrium_data), pointer :: ceq type(map_axis), dimension(*) :: axarr double precision axvalok !\end{verbatim} ! User can set GSOLDMAP ! When not tielines inplane select old map ! if(btest(globaldata%status,GSOLDMAP) .or. maptop%tieline_inplane.lt.0) then if(btest(globaldata%status,GSOLDMAP)) then call map_step_old(maptop,mapline,meqrec,phr,axvalok,nax,axarr,ceq) else call map_step2(maptop,mapline,meqrec,phr,axvalok,nax,axarr,ceq) endif end subroutine map_step !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine map_step_old !\begin{verbatim} subroutine map_step_old(maptop,mapline,meqrec,phr,axvalok,nax,axarr,ceq) ! This is the OLD map_step routine used until 2018.01.31 ! used also for map as mapping is stepping in one axis with fix phase condition ! calculate the next equilibrium along a line. New phases can appear. ! axis with active condition can change and the direction. ! maptop is map node record ! mapline is line record ! phr is new array phase status (just for debugging) ! axvalok is last successfully calculated axis value ! nax number of axis, redundant as also in maptop record ! axarr is array with axis records ! ceq is equilibrium record implicit none integer nax type(map_node), pointer :: maptop type(map_line), pointer :: mapline type(meq_setup) :: meqrec type(meq_phase), dimension(*), target :: phr type(gtp_equilibrium_data), pointer :: ceq type(map_axis), dimension(*) :: axarr double precision axvalok !\end{verbatim} type(gtp_condition), pointer :: pcond integer seqz,jaxwc,jax,cmode,cmix(10),nyax,oldax,maybecongruent integer istv,indices(4),iref,iunit,ip,i1,i2,i3 double precision value,dax1(5),dax2(5),axval(5),axval2(5),axvalt(5) double precision laxfact,xxx,yyy,bigincfix double precision preval(5),curval(5),prefixval(5),curfixval(5) double precision, parameter :: endfact=1.0D-6 character ch1*1,statevar*24,encoded*24 type(gtp_state_variable), pointer :: svrrec,svr2 type(gtp_state_variable), target :: svrtarget logical tnip ! ! write(*,*)'In map_step1: ',mapline%number_of_equilibria !================================================================== new step ! tnip emergency to stop mapping outside limit for non-active axis tnip=.FALSE. laxfact=one maybecongruent=0 axis: if(mapline%more.eq.0) then ! this means the current equilibrium is the last, line is terminated mapline%more=-1 goto 1000 !================================================================== new step ! this is for STEP with one axis elseif(nax.eq.1) then seqz=axarr(1)%seqz ! write(*,*)'Condition index: ',seqx call locate_condition(axarr(1)%seqz,pcond,ceq) if(gx%bmperr.ne.0) goto 1000 call condition_value(1,pcond,value,ceq) if(gx%bmperr.ne.0) goto 1000 ! save last sucessfully calculated value in axvalok and axarr(1)%lastaxval axvalok=value axarr(1)%lastaxval=value ! good check point if(ocv()) write(*,16)'In map_step: ',mapline%number_of_equilibria,& mapline%axandir,value 16 format(a,2i3,6(1pe14.6)) if(mapline%evenvalue.ne.zero) then ! If there is a value in mapline%evenvalue this is the first step in a new ! region, take 3 very small steps before using that as next value on axis! if(mapline%number_of_equilibria.lt.3) then value=value+1.0D-3*(mapline%evenvalue-value) else value=mapline%evenvalue mapline%evenvalue=zero endif else ! just take a step in axis variable. mapline%axandir is -1 or +1 value=value+axarr(1)%axinc*mapline%axandir endif mapline%more=1 if(value.le.axarr(1)%axmin) then value=axarr(1)%axmin ! mapline%more=0 means this is the last calculation mapline%more=0 elseif(value.ge.axarr(1)%axmax) then value=axarr(1)%axmax mapline%more=0 endif call condition_value(0,pcond,value,ceq) if(gx%bmperr.ne.0) goto 1000 ! check conditions ! call list_conditions(kou,ceq) ! write(*,*)'New axis value: ',value,ceq%tpval(1) !=============================================================== new step ! This is for MAP with 2 or more axis, both tie-line in plane and not else ! at regular intervals check that phases with 2 or more composition sets have ! not identical constitutions!! if(mod(mapline%number_of_equilibria,3).eq.0) then call separate_constitutions(ceq) endif ! this is the current axis with acitive condition jaxwc=abs(mapline%axandir) bigincfix=one ! write(*,*)'map_step: Number of fix phases: ',mapline%meqrec%nfixph ! write(*,*)'map_step: Fix phase: ',mapline%meqrec%fixph(1,1),& ! mapline%meqrec%fixph(2,1) ! Here we must compare changes in all axis to determine the axis for ! next step and how long step. Last axis values stored in mapline%axvals ! Save previous currently in mapline%axvals in axval2 nyax=0 loopaxis: do jax=1,nax seqz=axarr(jax)%seqz ! write(*,*)'Locating axis condition: ',seqz call locate_condition(seqz,pcond,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'Found axis condition' svrrec=>pcond%statvar(1) call state_variable_val(svrrec,axval(jax),ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,53)'Axis value: ',svrrec%oldstv,svrrec%argtyp,svrrec%phase,& ! svrrec%compset,svrrec%component,axval(jax),mapline%axvals(jax) 53 format(a,5i4,2(1pe12.4)) if(mapline%number_of_equilibria.eq.1) then ! for first equilibria just save the axis value mapline%axvals(jax)=axval(jax) laxfact=1.0D-2 else ! for later equilibria calculate the slope preval(jax)=mapline%axvals(jax) curval(jax)=axval(jax) dax1(jax)=(axval(jax)-mapline%axvals(jax))/axarr(jax)%axinc ! write(*,*)'dax1: ',jax,dax1(jax) axval2(jax)=mapline%axvals(jax) mapline%axvalx(jax)=mapline%axvals(jax) mapline%axvals(jax)=axval(jax) endif !----------------------------- below tie-line in/not in plane separate new step tip1: if(maptop%tieline_inplane.gt.0) then ! if we have tie-lines in plane we must find the value of the axis condition ! for the fix phase or if it is a phase or component dependent state variable svrtarget=svrrec istv=svrrec%oldstv if(istv.ge.10) then ! in svrrec we have the axis variable for an extensive phase variable. ! The value in mapline%axvals is for the entered phase, extract the value ! for the fix phase. ! NOTE: If we change fix/entered phase we must change axvals/axvals2 ! i1=svr2%argtyp; i2=svr2%phase; i3=svr2%compset svrtarget%argtyp=3 svrtarget%phase=mapline%linefixph(1)%ixphase svrtarget%compset=mapline%linefixph(1)%compset endif ! we must use a pointer in state_variable_val svr2=>svrtarget call state_variable_val(svr2,xxx,ceq) if(gx%bmperr.ne.0) goto 1000 if(mapline%number_of_equilibria.eq.1) then ! for first equilibria just save the axisvalue for the fix phase mapline%axvals2(jax)=xxx else ! for later equilibria calculate the slope and check if close to limit dax2(jax)=(xxx-mapline%axvals2(jax))/axarr(jax)%axinc axvalt(jax)=mapline%axvals2(jax) if(jax.ne.jaxwc .and. istv.ge.10) then prefixval(jax)=xxx curfixval(jax)=mapline%axvals2(jax) if(abs(prefixval(jax)-curfixval(jax)).gt.& 0.5D0*axarr(jax)%axinc) then bigincfix=5.0D-1 endif ! for axis with inactive condition check if next step would pass min/max limit ! If so reduce the step in the active axis but do not change active axis!! ! xxx is last axis value, mapline%axvals2(jax) is previous if(mapline%number_of_equilibria-mapline%axchange.gt.3) then if(2*xxx-mapline%axvals2(jax).lt.axarr(jax)%axmin) then nyax=jax elseif(2*xxx-mapline%axvals2(jax).gt.axarr(jax)%axmax) then nyax=jax endif endif if(nyax.gt.0) then ! write(*,12)'Change nyax: ',nyax,& ! mapline%number_of_equilibria,curfixval(nyax),& ! curval(nyax) 12 format(a,2i3,6(1pe12.4)) ! This restriction needed to calculate two-phase regions with almost ! verical lines (in T) and with one composition close to the axis limit ! and the other quite far away (like U4O9-GAS in U-O system) ! it should perhaps be refined to check that the lines are vertical ... if(abs(curfixval(jax)-curval(jax)).gt.& axarr(jax)%axinc) then ! write(*,*)'Ignore axis chnage!! ',nyax nyax=0 endif endif else prefixval(jax)=xxx curfixval(jax)=mapline%axvals2(jax) ! This test is very sensitive and if maybecongruent is set nonzero ! it is too much to reduce the step by 1.0D-2 below. If so the map5 ! fails at low T and I calculate too many points. I set the ! reduction to 1.0D-1 which seems OK. if(istv.ge.10 .and. & abs(curval(jax)-curfixval(jax)).lt.& axarr(jax)%axinc) then ! 0.1*axarr(jax)%axinc) then ! if phase compositions are close decrease step!! ! write(*,93)'Phase compositions close:',jax,& ! mapline%number_of_equilibria,curval(jax),& ! curfixval(jax) 93 format(a,2i5,4(1pe12.4)) maybecongruent=jax endif endif mapline%axvals2(jax)=xxx ! check which change is the largest ! if(ocv()) write(*,99)mapline%number_of_equilibria,jax,jaxwc,& write(*,99)mapline%number_of_equilibria,jax,jaxwc,& nyax,mapline%axvals(jax),dax1(jax),& mapline%axvals2(jax),dax2(jax) 99 format('Slope: ',i3,2x,3i2,6(1pe12.4)) endif if(nyax.gt.0) then ! write(*,*)'axis change due to limits: ',nyax,jaxwc mapline%axchange=mapline%number_of_equilibria endif ! here we can calculate the extrapolated values of both phases ! last calculated value a if(istv.ge.10) then ! write(*,32)'stp xextra: ',jax,jaxwc,nyax,mapline%axandir,& ! curval(jax),preval(jax),curfixval(jax),prefixval(jax) 32 format(a,3i2,i3,6(1pe12.4)) endif else !------------------------------------------------------------ ! here we have not tie-lines in the plane, we may need to change active axis ! and length of the step. ! write(*,98)jax,axval(jax),mapline%axvals(jax),dax1(jax) 98 format('Tie-line not in plane, slope: ',i3,2x,6(1pe12.4)) ! action to check if axis outside limit or slope requires axis change ! is done at the tip2 statement below endif tip1 enddo loopaxis !------------------------------------------------------------- ! write(*,73)'Saved: ',(jax,mapline%axvalx(jax),& ! mapline%axvals(jax),jax=1,nax) !73 format(a,2(i4,2(1pe14.6))) ! dax1(jaxwc) is for active axis, if dax2(jaxw) is larger ! we should decrease the step length accordingly value=axval(jaxwc) if(mapline%number_of_equilibria.eq.1) then ! for the first step no slopes to check but take a very small step laxfact=1.0D-3 else tip2: if(maptop%tieline_inplane.gt.0) then ! We have tielines in plane ! check if we should reduce axis step or change axis with active condition xxx=abs(dax2(jaxwc)) if(nyax.eq.0) then nyax=jaxwc do jax=1,nax if(jax.ne.jaxwc) then ! good check point if(ocv()) write(*,33)jax,jaxwc,nyax,0,dax2(jax),xxx ! write(*,33)jax,jaxwc,nyax,0,dax2(jax),xxx if(mapline%number_of_equilibria-mapline%axchange.gt.3) then if(abs(dax2(jax)).gt.2*xxx) then ! write(*,*)'Change active axis due to slope to/from: ',jax,jaxwc xxx=abs(dax2(jax)); nyax=jax endif endif endif enddo 33 format('Checking slopes: ',4i2,6(1pe12.4)) endif if(nyax.ne.jaxwc) then ! We have to change the axis with active condition write(*,101)mapline%number_of_equilibria,jaxwc,& nyax,xxx,dax1(1),dax2(1),dax1(2),dax2(2) if(ocv()) write(*,101)mapline%number_of_equilibria,jaxwc,& nyax,xxx,mapline%axvals(1),dax1(1),& mapline%axvals2(2),dax2(2) 101 format('Slope 3: ',i3,2x,2i2,6(1pe12.4)) ! decrease the axis step factor mapline%axfact=1.0D-3 oldax=abs(mapline%axandir) if(dax1(nyax).lt.0) then ! set negative direction and a small step mapline%axandir=-nyax xxx=mapline%axvals(nyax)-1.0D-2*axarr(nyax)%axinc else ! set positive direction and small step mapline%axandir=nyax xxx=mapline%axvals(nyax)+1.0D-2*axarr(nyax)%axinc endif ! write(*,*)'axandir: ',nyax,mapline%axandir,xxx if(ocv()) write(*,63)'Call map_changeaxis',nyax,& mapline%axchange,& mapline%number_of_equilibria,dax1(nyax),dax2(nyax),xxx 63 format(a,i2,2i3,4(1pe12.4)) call map_changeaxis(mapline,nyax,oldax,nax,axarr,xxx,& .FALSE.,ceq) if(gx%bmperr.ne.0) goto 1000 ! change pcond!!! seqz=axarr(nyax)%seqz call locate_condition(seqz,pcond,ceq) if(ocv()) write(*,*)'After map_change: ',& nyax,pcond%seqz,pcond%statev jaxwc=nyax mapline%axchange=mapline%number_of_equilibria ! value below is assumed to be most recently calculated value value=mapline%axvals(jaxwc) if(ocv()) write(*,16)'Axis, old and new condition: ',& mapline%axandir,value,xxx,ceq%tpval(1) endif ! !----------------------------------------------------------------- elseif(maptop%tieline_inplane.lt.0) then ! Tie-lines not in the plane do jax=1,nax if(jax.eq.jaxwc) cycle ! check if outside axis limit of non-active condition if(axval(jax).le.axarr(jax)%axmin) then tnip=.TRUE. write(kou,310)'Below ',jax,axval(jax),axarr(jax)%axmin 310 format(a,' limit',i3,2(1pe14.6),' of non-active axis') elseif(axval(jax).ge.axarr(jax)%axmax) then tnip=.TRUE. write(kou,310)'Above ',jax,axval(jax),axarr(jax)%axmax endif ! check if bytaxis when tie-lines not in plane if(abs(dax1(jax)).gt.one) then write(*,*)'map_step_old: Change active axis: ',jax call map_force_changeaxis(maptop,mapline,mapline%meqrec,& nax,axarr,axvalok,ceq) if(gx%bmperr.eq.0) goto 1000 endif enddo endif tip2 endif !---------------------------------------------------------------------- ! Here we decide the step to take in the axis variable. ! mapline%axandir is +/-jaxwc ! laxfact takes into account if the fix phase changes more rapidly ! if maybecongruent is jaxwc then take small step i3=mapline%number_of_equilibria - mapline%axchange if(nax.gt.1) then if(i3.lt.3) then ! take small steps when starting a line or after axis change laxfact=1.0D-2 elseif(i3.lt.6) then laxfact=1.0D-1 ! else ! laxfact= 0.02, 0.04, 0.08, 0.16, 0.32, 0.64, 1.0 ! laxfact=min(1.0,2.0D0*laxfact) endif ! write(*,*)'stepcheck: ',nax,maybecongruent,i3 if(maybecongruent.gt.0 .and. i3.ge.3) then ! mapline%axfact=1.0D-2 mapline%axfact=1.0D-1 ! write(*,*)'Decrease step due to close compositions',mapline%axfact endif endif axvalok=value ! laxfact is not saved between calls ! bigincfix 0.5 if fix phase changes more than 0.5*axinc bigincfix=one if(mapline%axandir.gt.0) then value=value+bigincfix*laxfact*axarr(jaxwc)%axinc*mapline%axfact else value=value-bigincfix*laxfact*axarr(jaxwc)%axinc*mapline%axfact endif ! write(*,313)'laxfact: ',jaxwc,laxfact,value,& ! axarr(jaxwc)%axinc,mapline%axfact,axvalok 313 format(a,i3,6(1pe12.4)) ! good point for checking if(ocv()) write(*,65)'map_step: ',mapline%number_of_equilibria,& mapline%axandir,laxfact,mapline%axfact,ceq%tpval(1),axvalok,value 65 format(a,2i3,2(1pe10.2),4(1pe14.6)) if(ocv()) write(*,202)'In map_step new, step & T: ',jaxwc,& mapline%axandir,value,laxfact*axarr(jaxwc)%axinc,ceq%tpval(1) 202 format(a,2i3,3(1pe14.6)) if(mapline%axfact.lt.one) then ! calculation OK and no problems, make sure mapline%axfact approaches unity ! write(*,*)'Incrementing mapline%axfact: ',mapline%axfact ! mapline%axfact=min(one,1.2D0*mapline%axfact) ! Trying to make axfact decrease less (like line above) makes map worse ! mapline%axfact=min(one,2.0D0*mapline%axfact) ! factor above works well but sometimes too big increase mapline%axfact=min(one,1.5D0*mapline%axfact) endif !====================================================================== ! if the new axis value exceeds the min or max limit calculate for the limit mapline%more=1 if(value.le.axarr(jaxwc)%axmin) then value=axarr(jaxwc)%axmin ! if a condition is an extensive variable like mole fraction avoid calculate ! for x(a)=0 or x(a)=1 call locate_condition(axarr(jaxwc)%seqz,pcond,ceq) if(pcond%statev.gt.10) then value=value+endfact*axarr(jaxwc)%axinc endif ! mapline%more=0 means this is the last calculation ... At axis low limit write(kou,23)'low',value 23 format('At axis ',a,' limit',1pe12.4) mapline%more=0 elseif(value.ge.axarr(jaxwc)%axmax) then value=axarr(jaxwc)%axmax ! if a condition is an extensive variable like mole fraction avoid calculate ! for x(a)=0 or x(a)=1 ........ at axis high limit call locate_condition(axarr(jaxwc)%seqz,pcond,ceq) if(pcond%statev.gt.10) then value=value-endfact*axarr(jaxwc)%axinc endif write(*,23)'high',value mapline%more=0 endif if(ocv()) write(*,205)'Axis limits: ',mapline%more,axarr(jaxwc)%axmin,& value,axarr(jaxwc)%axmax 205 format(a,i2,3(1pe12.4)) ! Make sure value is set for the active axis condition!! seqz=axarr(jaxwc)%seqz call locate_condition(seqz,pcond,ceq) ! this call sets value as condition on the axis! if(ocv()) write(*,207)'Axis condition: ',jaxwc,pcond%statev,value ! write(*,207)'Axis condition: ',jaxwc,pcond%statev,value 207 format(a,i2,i4,1pe14.6) call condition_value(0,pcond,value,ceq) if(gx%bmperr.ne.0) goto 1000 endif axis !------------------------------------------ 1000 continue ! tnip set TRUE above if inactive axis outside limits and tie-line not in plane if(maptop%tieline_inplane.lt.0 .and. tnip) mapline%more=0 ! if error code set mapline%more<0 if(gx%bmperr.ne.0) mapline%more=-1 ! if(associated(pcond)) then ! write(*,*)'Exit map_step: ',nyax,pcond%seqz,ceq%tpval(1) ! endif ! To know which phase has nonzero amount ! write(*,1001)'step_am: ',(mapline%meqrec%phr(ip)%curd%amfu,& ! ip=1,mapline%meqrec%nphase),ceq%tpval(1) 1001 format(a,6(1pe12.4)) return end subroutine map_step_old !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine map_step2 !\begin{verbatim} subroutine map_step2(maptop,mapline,meqrec,phr,axvalok,nax,axarr,ceq) ! used for map and step, mapping is to step with all but one axis replaced ! by a fix phase condition. Map with tie-lines in plane special ! For map check if we should change independent (active) step axis. ! For tie-lines in plance check if we should change fix phase ! Set condition for the next equilibrium along the axis. New phases can appear. ! axis with active condition can change and the direction. ! maptop is map node record ! mapline is line record ! phr is new array phase status (just for debugging) ! axvalok is last successfully calculated axis value ! nax number of axis, redundant as also in maptop record ! axarr is array with axis records ! ceq is equilibrium record implicit none integer nax type(map_node), pointer :: maptop type(map_line), pointer :: mapline ! WOW type(meq_setup) :: meqrec type(meq_setup) :: meqrec ! Should maybe be type(meq_setup), pointer :: meqrec ! type(meq_phase), dimension(*), target :: phr type(gtp_equilibrium_data), pointer :: ceq type(map_axis), dimension(*) :: axarr double precision axvalok !\end{verbatim} type(gtp_condition), pointer :: pcond integer seqz,jaxwc,jax,cmode,cmix(10),nyax,oldax,maybecongruent,mapeqno integer istv,indices(4),iref,iunit,ip,i1,i2,i3,jxxx double precision value,dax1(5),dax2(5),axval(5),axval2(5) double precision laxfact,xxx,yyy,maxstep double precision preval(5),curval(5),prefixval(5),curfixval(5) double precision, parameter :: endfact=1.0D-6 ! trying to change step axis for mapping with tie-lines in plane integer fixbyte(2),twoextensiveaxis double precision isoent(2,2),isofix(2,2),isoe,isof,isofact double precision lastaxisvalue,stepfact character ch1*1,statevar*24,encoded*24 type(gtp_state_variable), pointer :: svrrec,svr2 type(gtp_state_variable), target :: svrtarget logical tnip,nyfixph,ignore,approach ! new check for large step when tie-lines in the plane double precision ysave save maxstep,isofix,isoent,fixbyte,ignore,ysave,approach ! mapeqno=mapline%number_of_equilibria ! the dgm variables are for Al3N2 in the Al-Ni system which is not found stable ! write(*,'(a,i4,F8.2)')'SMP2 In map_step2: ',mapeqno,ceq%tpval(1) ! write(*,'(a,i5,3i3,5(F10.2))')'In map_step2: ',mapeqno,meqrec%nv,& ! maptop%tieline_inplane,mapline%axandir,ceq%tpval(1),& ! ceq%phase_varres(3)%dgm,ceq%phase_varres(4)%dgm,& ! ceq%phase_varres(5)%dgm ! call list_conditions(kou,ceq) if(mapline%more.eq.0) then ! this means the current equilibrium is the last, line is terminated mapline%more=-1 goto 1000 endif ! tnip emergency to stop mapping outside limit for non-active axis tnip=.FALSE. laxfact=one twoextensiveaxis=0 maybecongruent=0 ! new global check for stable and metastable phases ! if(maptop%globalcheckinterval.gt.0 .and. & ! mod(mapeqno,maptop%globalcheckinterval).eq.0) then ! this may set error code if equilibrium should be recalculated ! and it may change constitutions of metastable phases ! call check_all_phases(0,ceq) ! if(gx%bmperr.ne.0) then ! these errors mean a new stable phase detected, we should terminate line ! if(gx%bmperr.eq.4364 .or. gx%bmperr.eq.4365) goto 1000 ! otherwise ignore any errors ! gx%bmperr=0 ! endif ! endif if(nax.eq.1) then !================================================================== new step ! this is for STEP with one axis seqz=axarr(1)%seqz ! write(*,*)'Condition index: ',seqx call locate_condition(axarr(1)%seqz,pcond,ceq) if(gx%bmperr.ne.0) goto 1000 call condition_value(1,pcond,value,ceq) if(gx%bmperr.ne.0) goto 1000 ! save last sucessfully calculated value in axvalok and axarr(1)%lastaxval axvalok=value axarr(1)%lastaxval=value ! good check point if(ocv()) write(*,16)'In map_step: ',mapeqno,mapline%axandir,value 16 format(a,2i3,6(1pe14.6)) if(mapline%evenvalue.ne.zero) then ! If there is a value in mapline%evenvalue this is the first steps in a new ! region, take 3 very small steps before using that as next value on axis! if(mapeqno.lt.3) then if(mapeqno.eq.1) then maxstep=mapline%evenvalue-value ! write(*,*)'SMP maxstep: ',mapeqno,maxstep endif value=value+1.0D-3*(mapline%evenvalue-value) elseif(mapline%evenvalue.ne.zero .and. mapeqno.lt.6) then ! take a few more small steps ... value=value+2.0D-1*maxstep else value=mapline%evenvalue mapline%evenvalue=zero endif else ! just take a step in axis variable. mapline%axandir is -1 or +1 value=value+axarr(1)%axinc*mapline%axandir endif ! write(*,*)'Next axis value: ',value mapline%more=1 if(value.le.axarr(1)%axmin) then value=axarr(1)%axmin ! mapline%more=0 means this is the last calculation mapline%more=0 elseif(value.ge.axarr(1)%axmax) then value=axarr(1)%axmax mapline%more=0 endif call condition_value(0,pcond,value,ceq) goto 1000 ! if(gx%bmperr.ne.0) goto 1000 endif !=============================================================== new map ! This is for MAP with 2 or more axis, both tie-line in plane and not if(mod(mapeqno,3).eq.0) then ! at regulaar intervals check that phases with 2 or more composition sets have ! not identical constitutions!! Should fix Cr-Fe metastable extrapolation!! ! It does not change anything for the stable phases call separate_constitutions(ceq) endif ! this is the current axis with acitive condition jaxwc=abs(mapline%axandir) ! bigincfix=one ! write(*,*)'map_step: Number of fix phases: ',mapline%meqrec%nfixph ! write(*,*)'map_step: Fix phase: ',mapline%meqrec%fixph(1,1),& ! mapline%meqrec%fixph(2,1) ! Here we must compare changes in all axis to determine the axis for ! next step and how long step. Last axis values stored in mapline%axvals ! Save previous currently in mapline%axvals in axval2 nyax=0 ! isofact is to keep check of changes in fix phase when tie-lines in plane isofact=one loopaxis: do jax=1,nax seqz=axarr(jax)%seqz call locate_condition(seqz,pcond,ceq) if(gx%bmperr.ne.0) goto 1000 svrrec=>pcond%statvar(1) call state_variable_val(svrrec,axval(jax),ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,53)'Axis value 1: ',svrrec%oldstv,svrrec%argtyp,svrrec%phase,& ! svrrec%compset,svrrec%component,axval(jax),mapline%axvals(jax) 53 format(a,5i4,2(1pe12.4)) if(mapeqno.eq.1) then ! for first equilibria just save the axis value approach=.true. mapline%axvals(jax)=axval(jax) laxfact=1.0D-2 ! isoent(2,jax)=axval(jax) else ! for later equilibria calculate the slope preval(jax)=mapline%axvals(jax) curval(jax)=axval(jax) ! CHECK CHANGE OF AXIS AND FIX PHASE HERE FOR ENTERED PHASE 1 of 3 if(ocv()) write(*,94)'New and old axis values: ',mapeqno,jax,jaxwc,& ! write(*,94)'New and old axis values: ',mapeqno,jax,jaxwc,& curval(jax),preval(jax),curval(jax)-preval(jax),& (curval(jax)-preval(jax))/axarr(jax)%axinc 94 format(a,i2,2x,2i2,2F10.4,2(1pe12.4)) dax1(jax)=(axval(jax)-mapline%axvals(jax))/axarr(jax)%axinc axval2(jax)=mapline%axvals(jax) mapline%axvalx(jax)=mapline%axvals(jax) mapline%axvals(jax)=axval(jax) ! isoent(1,jax)=isoent(2,jax) ! isoent(2,jax)=axval(jax) endif !----------------------------- below tie-line in/not in plane separate new step tip1: if(maptop%tieline_inplane.gt.0) then ! if we have tie-lines in plane we must find the value of the axis condition ! for the fix phase or if it is a phase or component dependent state variable svrtarget=svrrec istv=svrrec%oldstv ! istv>=10 means extensive condition (not potential) extvar: if(istv.ge.10) then ! in svrrec we have the axis variable for an extensive phase variable. ! The value in mapline%axvals is for the entered phase, extract the value ! for the fix phase. ! NOTE: If we change fix/entered phase we must change axvals/axvals2 twoextensiveaxis=twoextensiveaxis+1 ignore=.false. jxxx=jax svrtarget%argtyp=3 svr2=>svrtarget ! extract composition of entered phase svrtarget%phase=mapline%stableph(1)%ixphase svrtarget%compset=mapline%stableph(1)%compset ! we must use a pointer in state_variable_val call state_variable_val(svr2,yyy,ceq) if(gx%bmperr.ne.0) goto 1000 ! extract composition of fix phase svrtarget%phase=mapline%linefixph(1)%ixphase svrtarget%compset=mapline%linefixph(1)%compset ! we must use a pointer in state_variable_val svr2=>svrtarget call state_variable_val(svr2,xxx,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,99)'Axis value 2: ',1,jax,jaxwc,0,xxx if(mapeqno.eq.1) then ! for first equilibria just save the axisvalue for the fix phase mapline%axvals2(jax)=xxx isofix(1,jax)=zero isofix(2,jax)=xxx isoent(1,jax)=zero isoent(2,jax)=yyy fixbyte(1)=mapline%linefixph(1)%ixphase fixbyte(2)=mapline%linefixph(1)%compset else ! for later equilibria calculate the slope and check if close to limit ! dax2 is slope value for fix phase isofix(1,jax)=isofix(2,jax) isofix(2,jax)=xxx isoent(1,jax)=isoent(2,jax) isoent(2,jax)=yyy if(fixbyte(1).ne.mapline%linefixph(1)%ixphase .and.& fixbyte(2).ne.mapline%linefixph(1)%compset) then ignore=.true. fixbyte(1)=mapline%linefixph(1)%ixphase fixbyte(2)=mapline%linefixph(1)%compset endif dax2(jax)=(xxx-mapline%axvals2(jax))/axarr(jax)%axinc ! CHECK CHANGE OF AXIS AND FIX PHASE HERE FOR FIX PHASE 2/3 ! if(ocv()) write(*,94)'Fix phase values: ',& ! write(*,94)'Fix phase values: ',& ! mapeqno,jax,jaxwc,& ! xxx,mapline%axvals2(jax),xxx-mapline%axvals2(jax),& ! (xxx-mapline%axvals2(jax))/axarr(jax)%axinc mapline%axvals2(jax)=xxx if(jax.ne.jaxwc .and. istv.ge.10) then prefixval(jax)=xxx curfixval(jax)=mapline%axvals2(jax) ! for axis with inactive condition check if next step would pass min/max limit ! If so reduce the step in the active axis but do not change active axis!! ! xxx is last axis value, mapline%axvals2(jax) is previous if(mapeqno-mapline%axchange.gt.3) then if(2*xxx-mapline%axvals2(jax).lt.axarr(jax)%axmin) then nyax=jax elseif(2*xxx-mapline%axvals2(jax).gt.axarr(jax)%axmax) then nyax=jax endif ! if(nyax.gt.0) write(*,*)'SMP: change axis 1',isofact endif ! nothing happends here ... if(nyax.gt.0) then ! This restriction needed to calculate two-phase regions with almost ! verical lines (in T) and with one composition close to the axis limit ! and the other quite far away (like U4O9-GAS in U-O system) ! it should perhaps be refined to check that the lines are vertical ... if(abs(curfixval(jax)-curval(jax)).gt.& axarr(jax)%axinc) then ! write(*,*)'Ignore axis change!! ',nyax nyax=0 endif endif else prefixval(jax)=xxx curfixval(jax)=mapline%axvals2(jax) ! This test is very sensitive and if maybecongruent is set nonzero ! it is too much to reduce the step by 1.0D-2 below. If so the map5 ! fails at low T and I calculate too many points. I set the ! reduction to 1.0D-1 which seems OK. istv>=10 means extensive variable if(istv.ge.10 .and. & abs(curval(jax)-curfixval(jax)).lt.& axarr(jax)%axinc) then ! if phase compositions are close decrease step!! 93 format(a,2i5,4(1pe12.4)) maybecongruent=jax endif endif mapline%axvals2(jax)=xxx ! check which change is the largest ! if(ocv()) write(*,99)'Slope: ',mapeqno,jax,jaxwc,& ! write(*,97)'Slope: ',mapeqno,jax,jaxwc,& ! mapline%axvals(jax),dax1(jax),& ! mapline%axvals2(jax),dax2(jax) !97 format(a,11x,i4,2i2,2(F10.4),2x,2(F10.4)) ! write(*,99)'Slope: ',mapeqno,jax,jaxwc,nyax,& ! entph_dxy(1,jax),entph_dxy(2,jax),& ! fixph_dxy(1,jax),fixph_dxy(2,jax) 99 format(a,i3,3i2,4(F10.4),2x,2(F10.4)) endif if(nyax.gt.0) then mapline%axchange=mapline%number_of_equilibria endif else ! this axis is not extensive variable, same value as dax1(jax) dax2(jax)=dax1(jax) endif extvar ! end special for tie-lines in plane endif tip1 enddo loopaxis !------------------------------------------------------------- ! trying to avoid too big steps when two extensive axis variables if(twoextensiveaxis.eq.2) then ! UNFINISHED: this assumes both axis are compositions (fractions) !!!!!!!!! ! what about a composition and an enthalpy axis ?? isoe=sqrt((isoent(2,1)-isoent(1,1))**2+(isoent(2,2)-isoent(1,2))**2) isof=sqrt((isofix(2,1)-isofix(1,1))**2+(isofix(2,2)-isofix(1,2))**2) if(plottrace) write(*,888)'smp1: ',& mapeqno,isoent(2,1),isoent(1,1),isoent(2,2),& isoent(1,2),isofix(2,1),isofix(1,1),isofix(2,2),isofix(1,2) if(mapeqno.gt.1) then i3=abs(mapline%axandir) if(plottrace) write(*,888)'smp2: ',mapline%axandir,isoe,isof,& axarr(i3)%axinc 888 format(a,i3,4F8.5,2x,4F8.5) ! if(.not.ignore .and. isof.gt.3.0D0*isoe) then if(.not.ignore) then ! isofact is set to unity above ! THE TESTS HERE ARE QUITE CRAY BUT THEY WORK REASONABLY FOR ! MAP-10, BEF-500Y, CRFEMO(1400K), BEF-1500 and BEF-2500 if(isoe.gt.2.0D0*axarr(i3)%axinc) then ! change in entered phase larger than max step isofact=axarr(i3)%axinc/isoe ! elseif(isof.gt.3.0D0*axarr(i3)%axinc) then elseif(isof.gt.3.0D0*isoe) then ! if(isof.gt.3.0D0*isoe) then ! if(isof.gt.3.0D0*axarr(i3)%axinc) then isofact=isoe/isof ! isofact=axarr(i3)%axinc/isof endif if(plottrace) write(*,'(a,3(1pe12.4))')'smp3: ',isoe,isof,isofact endif endif endif !------------------------------------------------------------- ! for understanding what is happening .... ! if(maptop%tieline_inplane.gt.0) then ! write(*,59)'tieline: ',mapeqno,jaxwc,jxxx,nyax,& ! mapline%stableph(1)%ixphase,mapline%linefixph(1)%ixphase,& ! mapline%axvals(jxxx),mapline%axvals2(jxxx),& ! mapline%axvals(3-jxxx),preval(jxxx),prefixval(jxxx) !59 format(a,i4,3i2,2i3,2F10.5,f10.2,2(f10.5)) ! endif ! list last calculated tie-line ! we should check for the step length accordingly value=axval(jaxwc) if(mapeqno.eq.1) then ! for the first step no slopes to check but take a very small step laxfact=1.0D-3 else tip2: if(maptop%tieline_inplane.gt.0) then ! We have tielines in plane ! check if we should reduce axis step or change axis with active condition ! xxx=abs(dax2(jaxwc)) ! xxx is set to the slope for the current independent axis and fix phase xxx=abs(dax1(jaxwc)) nyfixph=.false. ! write(*,*)'Attention 1: ',mapeqno,nyax,jaxwc if(nyax.eq.0) then nyax=jaxwc do jax=1,nax if(jax.ne.jaxwc) then ! good check point ?? YES ! write(*,33)mapeqno,jaxwc,jax,nyax,mapline%axandir,& ! meqrec%nv,& ! dax2(jax),xxx,dax1(jax),ceq%tpval(1) 33 format('Check 7: ',6i3,6(1pe12.4)) ! MISSING check for changing of fix/stable phase but keep same axis!! if(mapeqno.gt.3 .and. mapeqno-mapline%axchange.gt.3) then isotest1: if(isofact.eq.one) then ! ignore changing axis if isofact not unity if(abs(dax2(jax)).gt.2*xxx) then ! dependent axis changes more! change independent axis xxx=abs(dax2(jax)) 58 format(a,2i3,2(1pe12.4)) nyfixph=.true. nyax=jax elseif(abs(dax1(jax)).gt.2*xxx) then xxx=abs(dax1(jax)) nyax=jax endif endif isotest1 endif else ! if the independent axis is extensive check if we should change fix phase seqz=axarr(jax)%seqz call locate_condition(seqz,pcond,ceq) if(gx%bmperr.ne.0) goto 1000 svrrec=>pcond%statvar(1) ! call state_variable_val(svrrec,axval(jax),ceq) ! if(gx%bmperr.ne.0) goto 1000 ! If independent axis is an extensive variable check for fix phase change ! This does not seem to change anything!!! if(svrrec%oldstv.ge.10) then if(mapeqno-mapline%axchange.gt.3 .and. & abs(dax2(jax)).gt.abs(dax1(jax))) then ! dependent axis for fix phase changes more, change axis and fix phase! nyfixph=.true. ! write(*,101)'Change fix phase?',mapeqno,jaxwc,& ! nyax,mapline%linefixph(1)%ixphase,& ! mapline%stableph(1)%ixphase,nyfixph,& ! dax2(jax),dax1(jax) endif endif endif enddo endif ! This is all for tie-lines in the plane!! ! if(nyax.ne.jaxwc) write(*,*)'Attention 2: ',mapeqno,nyax,jaxwc ! write(*,152)'Attention 2: ',mapeqno,nyax,jaxwc,.FALSE.,& ! dax1(nyax),dax2(nyax),dax1(3-nyax),dax2(3-nyax),ceq%tpval(1) limits: if(nyax.eq.jaxwc .and. jaxwc.ne.jxxx .and. & mapeqno-mapline%axchange.gt.3 .and. .not.nyfixph) then ! Problems in U-O system with gas and U3O8 when gas is almost pure O ! If the entered (not fixed) phase cannot vary its composition ! that is bad but do nothing here if(fixedcomposition(mapline%stableph(1)%ixphase)) then ! write(*,*)'Continue as entered phase has fixed composition!' exit limits endif ! check if phase compositions are close if(abs(mapline%axvals(jxxx)-mapline%axvals2(jxxx)).gt.& axarr(jxxx)%axinc) then ! write(*,69)'Continue as phase compositions not close',& ! mapline%axvals(jxxx),mapline%axvals2(jxxx) 69 format(a,2F10.6) ! They are not ... do nothing exit limits endif ! No changes, check if we are close to the end of the extensive variable axis if(2*mapline%axvals(jxxx)-preval(jxxx).gt.& axarr(jxxx)%axmax) then ! write(*,91)'high',jxxx,2*mapline%axvals(jxxx)-preval(jxxx) nyax=jxxx ! write(*,*)'SMP nyax 4:',nyax 91 format('At ',a,' limit, change axis to: ',i2,F10.6) elseif(2*mapline%axvals(jxxx)-preval(jxxx).lt.& axarr(jxxx)%axmin) then ! write(*,91)'low',jxxx,2*mapline%axvals(jxxx)-preval(jxxx) nyax=jxxx ! write(*,*)'SMP nyax 5:',nyax endif endif limits ! ! write(*,152)'Attention 3: ',mapeqno,nyax,jaxwc,nyfixph,& ! dax1(nyax),dax2(nyax),dax1(3-nyax),dax2(3-nyax),ceq%tpval(1) newaxis: if(nyax.ne.jaxwc) then ! We have to change the axis with active condition ! write(*,101)'Slope 3: ',mapeqno,jaxwc,nyax,& ! mapline%linefixph(1)%ixphase,& ! mapline%stableph(1)%ixphase,nyfixph,& ! mapline%axvals(nyax),mapline%axvals2(nyax),& ! dax1(nyax),dax2(nyax) 101 format(a,5i3,l2,6(1pe12.4)) ! decrease the axis step factor mapline%axfact=1.0D-3 oldax=abs(mapline%axandir) ! emergency fix: if dax1(nyax) is zero we must change fix phase! if(dax1(nyax).eq.zero .and. .not.nyfixph) nyfixph=.TRUE. ! write(*,152)'SMP: change active axis: ',nyax,mapline%axandir,& ! jaxwc,nyfixph,dax1(nyax),dax2(nyax),& ! dax1(3-nyax),dax2(3-nyax),ceq%tpval(1) 152 format(a,3i3,l2,5(1pe10.2)) if(nyfixph) then ! We must set new fix phase, take the direction from dax2 if(dax2(nyax).lt.0) then ! set negative direction and a small step mapline%axandir=-nyax xxx=mapline%axvals2(nyax)-1.0D-2*axarr(nyax)%axinc else ! set positive direction and small step mapline%axandir=nyax xxx=mapline%axvals2(nyax)+1.0D-2*axarr(nyax)%axinc endif else if(dax1(nyax).lt.0) then ! set negative direction and a small step mapline%axandir=-nyax xxx=mapline%axvals(nyax)-1.0D-2*axarr(nyax)%axinc else ! set positive direction and small step mapline%axandir=nyax xxx=mapline%axvals(nyax)+1.0D-2*axarr(nyax)%axinc endif endif if(ocv()) write(*,63)'Call map_changeaxis',nyax,& mapline%axchange,& mapeqno,dax1(nyax),dax2(nyax),xxx 63 format(a,i2,2i3,4(1pe12.4)) ! bytax is TRUE if axval is new axis condition ! if(nyfixph) then ! call list_conditions(kou,ceq) ! endif if(nyfixph) then ! This routine switches the fix and entered phases if(plottrace) write(*,*)'new fix phase: ',nyfixph call map_bytfixphase(mapline,oldax,meqrec,xxx,ceq) if(gx%bmperr.ne.0) goto 1000 ignore=.TRUE. endif ! write(*,*)'New independent axis and value: ',nyax,xxx,nyfixph call map_changeaxis(mapline,nyax,oldax,nax,axarr,xxx,& nyfixph,ceq) ! call map_changeaxis(mapline,nyax,oldax,nax,axarr,xxx,& ! .FALSE.,ceq) ! if(nyfixph) then ! call list_conditions(kou,ceq) ! write(*,*)'new fix phase ',mapline%axandir,ceq%tpval(1) ! read(*,62)ch1 !62 format(a) ! endif if(gx%bmperr.ne.0) goto 1000 ! change pcond!!! seqz=axarr(nyax)%seqz call locate_condition(seqz,pcond,ceq) if(ocv()) write(*,*)'After map_change: ',& nyax,pcond%seqz,pcond%statev jaxwc=nyax mapline%axchange=mapline%number_of_equilibria ! value below is assumed to be most recently calculated value value=mapline%axvals(jaxwc) if(ocv()) write(*,16)'Axis, old and new condition: ',& mapline%axandir,value,xxx,ceq%tpval(1) endif newaxis ! !----------------------------------------------------------------- elseif(maptop%tieline_inplane.lt.0) then ! Tie-lines not in the plane do jax=1,nax if(jax.eq.jaxwc) cycle ! check if outside axis limit of non-active condition if(axval(jax).le.axarr(jax)%axmin) then tnip=.TRUE. write(kou,310)'Below ',jax,axval(jax),axarr(jax)%axmin 310 format(a,' limit',i3,2(1pe14.6),' of non-active axis') elseif(axval(jax).ge.axarr(jax)%axmax) then tnip=.TRUE. write(kou,310)'Above ',jax,axval(jax),axarr(jax)%axmax endif ! check if bytaxis when tie-lines not in plane if(abs(dax1(jax)).gt.one) then ! write(*,*)'map_step: Change active axis: ',jax call map_force_changeaxis(maptop,mapline,mapline%meqrec,& nax,axarr,axvalok,ceq) if(gx%bmperr.eq.0) goto 1000 endif enddo ! end check for tie-lines in plane endif tip2 endif !---------------------------------------------------------------------- ! Here we decide the step to take in the axis variable. ! mapline%axandir is +/-jaxwc ! laxfact takes into account if the fix phase changes more rapidly ! if maybecongruent is jaxwc then take small step i3=mapline%number_of_equilibria - mapline%axchange if(nax.gt.1) then if(i3.lt.3) then ! take small steps when starting a line or after axis change laxfact=1.0D-2 elseif(i3.lt.6) then laxfact=1.0D-1 endif if(maybecongruent.gt.0 .and. i3.ge.3) then mapline%axfact=1.0D-1 endif endif axvalok=value ! laxfact is not saved between calls ! bigincfix 0.5 if fix phase changes more than 0.5*axinc ! bigincfix=one lastaxisvalue=value if(mapline%axandir.gt.0) then value=value+isofact*laxfact*axarr(jaxwc)%axinc*mapline%axfact else value=value-isofact*laxfact*axarr(jaxwc)%axinc*mapline%axfact endif ! good point for checking if(ocv()) write(*,65)'map_step: ',mapeqno,& mapline%axandir,laxfact,mapline%axfact,ceq%tpval(1),axvalok,value 65 format(a,2i3,2(1pe10.2),4(1pe14.6)) if(ocv()) write(*,202)'In map_step new, step & T: ',jaxwc,& mapline%axandir,value,laxfact*axarr(jaxwc)%axinc,ceq%tpval(1) 202 format(a,2i3,3(1pe14.6)) if(mapline%axfact.lt.one) then ! calculation OK and no problems, make sure mapline%axfact approaches unity ! write(*,*)'Incrementing mapline%axfact: ',mapline%axfact ! mapline%axfact=min(one,1.2D0*mapline%axfact) ! Trying to make axfact decrease less (like line above) makes map worse mapline%axfact=min(one,2.0D0*mapline%axfact) endif !====================================================================== ! if the new axis value exceeds the min or max limit calculate for the limit mapline%more=1 if(value.le.axarr(jaxwc)%axmin) then value=axarr(jaxwc)%axmin ! if a condition is an extensive variable like mole fraction avoid calculate ! for x(a)=0 or x(a)=1 call locate_condition(axarr(jaxwc)%seqz,pcond,ceq) if(pcond%statev.gt.10) then value=value+endfact*axarr(jaxwc)%axinc endif ! mapline%more=0 means this is the last calculation write(kou,23)'low',value 23 format('At axis ',a,' limit',1pe12.4) mapline%more=0 elseif(value.ge.axarr(jaxwc)%axmax) then value=axarr(jaxwc)%axmax ! if a condition is an extensive variable like mole fraction avoid calculate ! for x(a)=0 or x(a)=1 call locate_condition(axarr(jaxwc)%seqz,pcond,ceq) if(pcond%statev.gt.10) then value=value-endfact*axarr(jaxwc)%axinc endif write(*,23)'high',value mapline%more=0 endif !....... special for axis limits of isothermal sections DOES NOT WORK ! check if we are close to an axis limit for isothermal sections if(mapeqno.gt.2 .and. twoextensiveaxis.eq.2) then ! The fraction of the third component of entered phase (where we step): call locate_condition(axarr(jaxwc)%seqz,pcond,ceq) if(pcond%statev.gt.10) then xxx=pcond%prescribed endif yyy=one-isoent(2,jaxwc)-isoent(2,3-jaxwc) if(yyy.le.0.5D0*axarr(jaxwc)%axinc) then ! changing the axis variable will make third fraction negative ! we should decrease value ... ! write(*,'(a,i3,F9.5,7F8.5)')'At boundary? ',mapeqno,yyy,& ! isoent(2,jaxwc),isoent(2,3-jaxwc),& ! isofix(2,jaxwc),isofix(2,3-jaxwc),xxx,value,value-xxx if(approach) then ! I am not sure this is useful .... approach never used .... write(*,*)'SMP2A approaching limit of third component' approach=.false. endif ! ysave is never initiated .... ! if(yyy.gt.zero) then ! if(yyy.lt.ysave) then ! value=xxx+0.9D0*yyy ! endif ! ysave=yyy ! else ! yyy is negative ! write(*,*)'SMP2A impossible!',yyy ! endif endif endif !...... if(ocv()) write(*,205)'Axis limits: ',mapline%more,axarr(jaxwc)%axmin,& value,axarr(jaxwc)%axmax 205 format(a,i2,3(1pe12.4)) ! Make sure value is set for the active axis condition!! seqz=axarr(jaxwc)%seqz call locate_condition(seqz,pcond,ceq) ! CHECK CHANGE OF AXIS AND FIX PHASE HERE 3/3 if(ocv()) write(*,207)'New axis condition: ',jaxwc,pcond%statev,value,& value-lastaxisvalue 207 format(a,i2,i4,2(1pe14.6)) call condition_value(0,pcond,value,ceq) if(gx%bmperr.ne.0) goto 1000 !------------------------------------------ 1000 continue ! tnip set TRUE above if inactive axis outside limits and tie-line not in plane if(maptop%tieline_inplane.lt.0 .and. tnip) mapline%more=0 ! if error code set mapline%more<0 if(gx%bmperr.ne.0) mapline%more=-1 ! if(associated(pcond)) then ! write(*,*)'Exit map_step: ',nyax,pcond%seqz,ceq%tpval(1) ! endif ! To know which phase has nonzero amount ! write(*,1001)'step_am: ',(mapline%meqrec%phr(ip)%curd%amfu,& ! ip=1,mapline%meqrec%nphase),ceq%tpval(1) 1001 format(a,6(1pe12.4)) ! write(*,*)'Leaving map_step2 ' return ! axis limit end subroutine map_step2 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine map_bytfixphase !\begin{verbatim} subroutine map_bytfixphase(mapline,axis,meqrec,xxx,ceq) ! Try to change the fix phase for axis ! the new axis value is in xxx (not needed??) ! mapline is map line record ! ceq is equilibrium record implicit none type(map_line), pointer :: mapline integer axis type(meq_setup) :: meqrec double precision xxx type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} ! REMEMBER: %stableph(..) and %linefixph are arrays of phase tuples !!! ! 5 integers: lokph,compset,ixphase,lokvares,nextcs, only ixphase/compset set ! we need meqrec!!! type(gtp_phasetuple) :: phtup1 integer lokcs,phrix double precision x1,x2 ! just as check x1=mapline%stablepham(1) ! write(*,33)'Phase change 1:',meqrec%fixph(1,1),meqrec%fixph(2,1),& ! meqrec%iphl(1),meqrec%icsl(1),meqrec%iphl(2),meqrec%icsl(2),& ! meqrec%aphl(1),meqrec%aphl(2),xxx 33 format(a,3(i3,i2,2x),3F8.3) ! we must change in meqrec also!! This is for tie-lines in plane, ! one fix phase, one stable phase phtup1=mapline%linefixph(1) phrix=mapline%linefix_phr(1) mapline%linefixph(1)=mapline%stableph(1) mapline%linefix_phr(1)=mapline%stable_phr(1) if(meqrec%nfixph.ne.1) then write(*,*)'MAP wants to change ONE fix phase: ',meqrec%nfixph gx%bmperr=4399; goto 1000 endif meqrec%fixph(1,1)=mapline%linefixph(1)%ixphase meqrec%fixph(2,1)=mapline%linefixph(1)%compset meqrec%fixpham(1)=zero meqrec%iphl(1)=mapline%linefixph(1)%ixphase meqrec%icsl(1)=mapline%linefixph(1)%compset !------------- now the stable phase ?? value of stable_phr=?? mapline%stableph(1)=phtup1 mapline%stable_phr(1)=phrix ! write(*,*)'SMP2A phrix switching fix/stable phase: ',phrix ! nstabph is part of mapfix record ... saved in meqrec%nv ! we are not changing the number of fix or stable phases ... if(meqrec%nv.ne.2) then write(*,*)'MAP wants to change ONE stable phase: ',meqrec%nv gx%bmperr=4399; goto 1000 endif meqrec%iphl(2)=phtup1%ixphase meqrec%icsl(2)=phtup1%compset meqrec%aphl(2)=x1 ! we have changed the stable phase, set a positive amount mapline%stablepham(1)=x1 ! write(*,33)'Phase change 2:',meqrec%fixph(1,1),meqrec%fixph(2,1),& ! meqrec%iphl(1),meqrec%icsl(1),meqrec%iphl(2),meqrec%icsl(2),& ! meqrec%aphl(1),meqrec%aphl(2),xxx 1000 continue return end subroutine map_bytfixphase !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine map_calcnode !\begin{verbatim} subroutine map_calcnode(irem,iadd,maptop,mapline,meqrec,axarr,ceq) ! we have found a change in the set of stable phases. check if this node ! already been found and if so eliminate a line record. Otherwise ! create a new node record with line records and continue mapping one ! of these. ! irem and iadd are indices (in phr?) of phase that will disappear/appear ! maptop is map node record ! mapline is map line record ! meqrec is equilibrium calculation record, ! Note changes in meqrec is local, ! not copied to mapline%meqrec!!! ! axarr is array with axis records ! ceq is equilibrium record implicit none integer irem,iadd type(map_node), pointer :: maptop type(map_line), pointer :: mapline type(meq_setup) :: meqrec type(map_axis), dimension(*) :: axarr type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} type(gtp_condition), pointer :: lastcond,pcond integer iremsave,iaddsave,iph,ics,jj,jph,kph,phfix,seqx,jax,haha integer what,type,cmix(10),maxstph,noplot,mode,addtupleindex,mapx,sameadd double precision, parameter :: addedphase_amount=1.0D-2 double precision value,axval,axvalsave,tx,nodefixpham type(gtp_state_variable), pointer :: svrrec logical global double precision, allocatable, dimension(:) :: yfra type(gtp_equilibrium_data), target :: tceq type(gtp_equilibrium_data), pointer :: pceq character phname*32 ! turns off converge control for T integer, parameter :: inmap=1 ! ! write(*,*)'In map_calcnode phase change add/remove: ',iadd,irem ! we have already called same_composition(iadd...) iremsave=irem iaddsave=iadd if(irem.gt.0) then if(iadd.gt.0) then write(*,*)'Confusion, both add and remove phases?' ! check if phase to be added is already stable if(same_composition(iadd,meqrec%phr,meqrec,ceq,zero)) then iadd=0 phfix=-irem else ! go back and calculate with half the step ... gx%bmperr=4220; goto 1000 endif else phfix=-irem iadd=irem endif else phfix=iadd endif !-------------------------------------------- ! remove here the axis condition, abs(mapline%axandir) gives active axis ! axandir is the axis with active condition. It can be negative jax=abs(mapline%axandir) ! write(*,*)'Remove axis condition: ',jax,axarr(jax)%seqz lastcond=>ceq%lastcondition if(.not.associated(lastcond)) then write(*,*)'in map_calcnode, no conditions: ',jax gx%bmperr=4221; goto 1000 endif pcond=>lastcond 60 continue pcond=>pcond%next if(pcond%seqz.eq.axarr(jax)%seqz) goto 70 if(.not.associated(pcond,lastcond)) goto 60 write(*,*)'in map_calcnode the axis condition not found: ',jax gx%bmperr=4221; goto 1000 ! 70 continue ! this removes the condition, remember pcond as condition will be set again!! pcond%active=1 axval=pcond%prescribed if(ocv()) write(*,77)pcond%seqz,pcond%prescribed,ceq%tpval(1),axval 77 format('Removing condition: ',i3,6(1pe12.4)) ! if the condition is T or P this must be indicated specially ! if a potential condition released we can have one more stable phse maxstph=0 if(pcond%statev.eq.1) then meqrec%tpindep(1)=.TRUE. if(ocv()) write(*,*)'Marking that T is variable' maxstph=1 elseif(pcond%statev.eq.2) then meqrec%tpindep(2)=.TRUE. maxstph=1 endif !-------------------------------------------- ! independently if iadd or irem >0 set this phase, phfix, fix with zero amount ! we may return here if there is problems calculate the node equilibrium 100 continue ! set phfix fix with amount nodefixpham nodefixpham=zero ! NOTE it must be added so meqrec%stphl in ascending order if(phfix.gt.0 .and. meqrec%nstph.eq.meqrec%maxsph+maxstph) then ! No more phases allowed, we must see if some other phase may be removed ! write(*,*)'Too many stable phases at nodepoint',meqrec%maxsph ! set back pcond as active, this saved top of miscibility gap in Cr-Mo !!! pcond%active=0 ! if(same_composition(iadd,meqrec%phr,meqrec,ceq,zero)) then ! iadd=0; goto 201 ! endif ! write(*,'(a,10i5)')'SMP node with too many stable phases: ',& ! iremsave,iaddsave,phfix,meqrec%nstph,maxstph gx%bmperr=4223; goto 1000 else if(ocv()) write(*,*)'Number of stable phases at nodepoint',& meqrec%nstph,maxstph endif if(phfix.gt.0) then ! the phase must be added in sequential order of phase and composition set no findplace: do jph=1,meqrec%nstph jj=meqrec%stphl(jph) if(meqrec%phr(phfix)%iph.gt.meqrec%phr(jj)%iph) then cycle endif if(meqrec%phr(phfix)%iph.lt.meqrec%phr(jj)%iph) then exit endif ! if same phase number compare composition set numbers if(meqrec%phr(phfix)%iph.eq.meqrec%phr(jj)%iph) then if(meqrec%phr(phfix)%ics.gt.meqrec%phr(jj)%ics) then cycle else exit endif endif enddo findplace ! one should come here at exit, iadd should be inserted before ! meqrec%stphl(jph), jph can be nstph+1 if added phase should be the last ! otherwise shift previous phases one step up. do kph=meqrec%nstph,jph,-1 meqrec%stphl(kph+1)=meqrec%stphl(kph) enddo ! phase added at jph, (note jph may be equal to nstph+1) meqrec%stphl(jph)=phfix meqrec%nstph=meqrec%nstph+1 meqrec%phr(phfix)%itadd=meqrec%noofits meqrec%phr(phfix)%curd%dgm=zero meqrec%phr(phfix)%curd%amfu=nodefixpham meqrec%phr(phfix)%stable=1 ! set that the phase has fixed amount meqrec%phr(phfix)%phasestatus=PHFIXED else ! we are removing a phase, abs(phfix) already in meqrec%phr ! meqrec%stphl(jph)=phfix ! meqrec%nstph=meqrec%nstph+1 ! write(*,*)'Removing a phase: ',phfix if(phfix.ge.0) then gx%bmperr=4234 goto 1000 endif meqrec%phr(-phfix)%itadd=meqrec%noofits meqrec%phr(-phfix)%curd%dgm=zero meqrec%phr(-phfix)%curd%amfu=nodefixpham meqrec%phr(-phfix)%stable=1 ! set that the phase has fixed amount meqrec%phr(-phfix)%phasestatus=PHFIXED endif !-------------- ! mark that the phase is fix, we have to be careful not to exceed size ! Sigh, the fixed phases must be in sequential order ??? ... not done here ! ... maybe not needed ?? ! write(*,*)'added fix phase: ',phfix meqrec%nfixph=meqrec%nfixph+1 if(meqrec%nfixph.gt.size(meqrec%fixpham)) then write(*,*)'Too many phases set fixed during mapping',& meqrec%nfixph,size(meqrec%fixpham) gx%bmperr=4235; goto 1000 endif ! meqrec%nfixph is used to reduce the number of variables in the system ! matrix. Fix phases have no variable amount. meqrec%fixph(1,meqrec%nfixph)=meqrec%phr(abs(phfix))%iph meqrec%fixph(2,meqrec%nfixph)=meqrec%phr(abs(phfix))%ics meqrec%fixpham(meqrec%nfixph)=zero ! write(*,*)'Set fixed phase: ',meqrec%nfixph,& ! meqrec%phr(abs(phfix))%iph,meqrec%phr(abs(phfix))%ics,PHFIXED ! I am not sure what this make but error allocating svar inside meq_sameset ! meqrec%nv=meqrec%nv+1 !--------------------------------------------------- ! call meq_sameset with new set of phases and axis condition removed ! If there is a phase change (iadd or irem nonzero) or error it exits sameadd=0 200 continue iadd=0; irem=0 ! write(*,'(a,3i5)')'In map_calcnode calling sameset for new node: ',& ! meqrec%nstph,phfix ! ! write(*,*)'SMP2A Calling meq_sameset from map_calcnode' call meq_sameset(irem,iadd,mapx,meqrec,meqrec%phr,inmap,ceq) ! ! write(*,202)'Calculated node with fix phase: ',gx%bmperr,irem,iadd,ceq%tpval 202 format(a,3i4,2(1pe12.4)) 201 continue !------------------------------------------------- ! trouble if error or another phase wants to be stable/dissapear ! We may have to calculate with the axis fix again, maybe even read up ! the previous calculated equilibrium if(gx%bmperr.ne.0) then write(*,*)'Error trying to calculate a node point',gx%bmperr ! Below is code to reset the fix phase to continue map/step unless error 4187 if(gx%bmperr.eq.4187) goto 1000 elseif(irem.gt.0) then write(*,207)gx%bmperr,irem 207 format('Failed calculating a node when another phase',& ' wants to disappear',2i5) gx%bmperr=4222 elseif(iadd.gt.0) then ! another phase wants to be stable ! write(*,*)'SMPNODE: Another phase wants to be stable ',iadd,sameadd,phfix if(same_composition(iadd,meqrec%phr,meqrec,ceq,zero)) then iadd=0; goto 201 endif ! write(*,'(a,3i5,F10.2)')'Error: new phase stable: ',& ! iremsave,iaddsave,iadd,ceq%tpval(1) gx%bmperr=4223 else ! It worked to calculate with a new fix phase releasing all axis condition!!! ! ************************************************************* ! check that the node point is global using grid minimizer ! ceq is copied inside global_equil_check and not destroyed??. ! mode=0 means do not recalculate if gridpoint below is found mode=0 ! write(*,*)'NOT Calling global check' ! global=.TRUE. ! write(*,*)'Check if nodepoint global' ! make a copy of the whole equilibrium record and set a pointer to the copy ! Does this really make a copy of the conditions etc inside ceq? ! tceq=ceq ! pceq=>tceq ! write(*,*)'SMP value of T: ',pceq%tpval(1) ! SEGMENTATION FAULT and other strange errors after this call ! very difficult to find ... puhhhhh ! --- BUT THERE is still a segmentation fault ! global=global_equil_check1(mode,addtupleindex,yfra,pceq) global=global_equil_check1(mode,addtupleindex,yfra,ceq) if(.not.global) then write(*,*)'gridminimizer found node point not global' ! set this line as INACTIVE and do not generate any start points mapline%status=ibset(mapline%status,EXCLUDEDLINE) gx%bmperr=4353 goto 1000 endif ! ************************************************************* goto 500 endif ! Problems, the simplest is to go back and try a smaller step ! But we must first remove the fix phase and restore the axis condition ! write(*,54)'Error calculating node point? ',gx%bmperr,mapline%lasterr,& ! irem,iadd,phfix,pcond%statev,mapline%problems,axval 54 format(a,2i5,5i3,1pe12.4) ! if(maptop%tieline_inplane.gt.0) then ! if <0 isopleth, 0 step, >0 tie-lines in plane ! write(*,*)'Tie-lines in plane:' ! if T axis maybe change to extensive axis ... ! endif if(ocv()) write(*,*)'Error calculating node point, take shorter step' pcond%active=0 pcond%prescribed=axval if(pcond%statev.eq.1) then meqrec%tpindep(1)=.FALSE. if(ocv()) write(*,55)'Marking that T is a condition again',& axval,ceq%tpval(1) 55 format(a,6(1pe14.6)) elseif(pcond%statev.eq.2) then meqrec%tpindep(2)=.FALSE. ! ceq%tpval(2)=value endif ! write(*,*)'error in map_calcnode, remove phfix: ',phfix if(phfix.gt.0) then ! we must remove phfix from the list of stable phases and shift down meqrec%nstph=meqrec%nstph-1 do iph=1,meqrec%nstph jj=meqrec%stphl(iph) if(jj.ge.phfix) then meqrec%stphl(iph)=meqrec%stphl(iph+1) endif enddo ! we must zero the last stable phase !! meqrec%stphl(meqrec%nstph+1)=0 meqrec%phr(phfix)%itrem=meqrec%noofits meqrec%phr(phfix)%prevam=zero meqrec%phr(phfix)%stable=0 meqrec%phr(phfix)%curd%amfu=zero ! we do not need to do anyting if -phfix should have been removed, then it ! is should remain among the stable phases, just remove it as fixed endif meqrec%fixph(1,meqrec%nfixph)=meqrec%phr(abs(phfix))%iph meqrec%fixph(2,meqrec%nfixph)=meqrec%phr(abs(phfix))%ics meqrec%nfixph=meqrec%nfixph-1 mapline%lasterr=gx%bmperr ! write(*,*)'SMP lasterr: ',mapline%lasterr,& ! gx%bmperr,phfix,meqrec%phr(phfix)%phasestatus ! I had forgotten this!! meqrec%phr(abs(phfix))%phasestatus=0 ! exit as no node found goto 1000 !------------------------------------------------------ ! When we are there we have successfully calculated an equilibrium with a ! new phase set create a node with this equilibrium and a new line records 500 continue ! write(*,*)'SMP2 Successful calculation of a node point',phfix ! phfix is set negative if phase should be removed ! NOTE the phase set fix in the node may not be the same which ! wanted to disappear/appear when calling the map_calcnode!! ! If iremsave=phfix the fix phase is one to be removed. ! write(*,*)'SM2A node with new fix phase: ',phfix,iremsave,iaddsave ! I do not understand the next IF statement/BoS 200222 if(iremsave.eq.-phfix) then ! write(*,*)'In SMP2A with strange assignment ...',iremsave,-phfix phfix=-abs(phfix) endif ! if the user wants to have global minimization during mapping this is ! time to test if the current equilibrium is the global one. We can use ! a temporary ceq record and chech the set of phases and chemical potentials ! ! NOTE that after a global equilibrium new composition set can have been ! created ... that should not be allowed unless they are really stable ... ! and one may have the same phases but different composition sets ... it ! can be quite messy. ! We have to set back the axis condition, before or after creating the node? ! and the new value ... if(pcond%noofterms.gt.1) then write(*,*)'Cannot handle conditions with several terms' gx%bmperr=4236; goto 1000 endif ! this sets the condition as active pcond%active=0 svrrec=>pcond%statvar(1) call state_variable_val(svrrec,value,ceq) if(gx%bmperr.ne.0) goto 1000 if(ocv()) write(*,510)'Checking condition value; ',lastcond%seqz,& value,pcond%prescribed,ceq%tpval(1) 510 format(a,i3,6(1pe12.4)) ! set the new condition value on the axis pcond%prescribed=value if(pcond%statev.eq.1) then meqrec%tpindep(1)=.FALSE. ceq%tpval(1)=value if(ocv()) write(*,*)'Marking that T is a condition again',value elseif(pcond%statev.eq.2) then meqrec%tpindep(2)=.FALSE. ceq%tpval(2)=value endif ! Save this as the last equilibrium of the line if(maptop%tieline_inplane.gt.0) then ! remove phfix as fix, otherwise graphics will be strange! 517 format(a,2i3,5x,5(2i3)) ! remove phfix as fix if(phfix.lt.0) then write(*,*)'SM2A negative phfix used as index?',phfix endif mapline%meqrec%phr(phfix)%curd%phstate=PHENTERED ! this is necessary not to have data from this phase interfering with the line if(ocv()) write(*,519)phfix,mapline%meqrec%phr(phfix)%iph,& mapline%meqrec%phr(phfix)%ics,phentunst 519 format('Removing ',i3,2x,2i3,' as stable as last line equil',i3) !????????????????????????????????????????? mapline%meqrec%nstph=mapline%meqrec%nstph-1 endif ! write(*,*)'Storing last point on line',phfix,maptop%tieline_inplane call map_store(mapline,axarr,maptop%number_ofaxis,maptop%saveceq) if(gx%bmperr.ne.0) then ! if(gx%bmperr.eq.4300) write(*,*)'Node point ignored' goto 1000 endif ! If we have an error here it may be that the node axis has big jumps ! Do not save any node ! here we have stored the last equilibrium that lead to th enode ! now update all condition records related to axis !-------------------- ! now store all axis values as prescribed vaules in the condition records ! A rather clumsy way and cannot handle expressions ... lastcond=>ceq%lastcondition pcond=>lastcond 600 continue pcond=>pcond%next do jax=1,maptop%number_ofaxis if(pcond%seqz.eq.axarr(jax)%seqz) then ! write(*,*)'At node set axis ',jax,axarr(jax)%lastaxval pcond%prescribed=axarr(jax)%lastaxval endif enddo if(.not.associated(pcond,lastcond)) goto 600 !------------------- if(maptop%tieline_inplane.gt.0) then ! Now set phfix back again for storing at the node record!! iph=1 do jj=mapline%meqrec%nstph,1,-1 if(mapline%meqrec%stphl(jj).gt.phfix) then mapline%meqrec%stphl(jj+1)=mapline%meqrec%stphl(jj) else iph=jj+1; exit endif enddo mapline%meqrec%stphl(iph)=phfix mapline%meqrec%phr(meqrec%stphl(iph))%curd%phstate=PHENTSTAB mapline%meqrec%nstph=mapline%meqrec%nstph+1 if(ocv())write(*,517)'In map_calcnode: ',phfix,meqrec%nstph,& (meqrec%phr(meqrec%stphl(jj))%iph,meqrec%phr(meqrec%stphl(jj))%ics,& jj=1,meqrec%nstph) ! meqrec%phr(meqrec%stphl(jj))%phstate,jj=1,meqrec%nstph) 518 format(a,2i3,5x,5(2i3,i2,2x)) endif !-------------------------------------------------------- ! if(mapline%evenvalue.ne.zero) then ! if we have taken halfsteps then use the original even step if(ocv()) write(*,*)'Using original even step: ',mapline%evenvalue axval=mapline%evenvalue endif ! ! Finally create the new node and with new exit lines haha=0 if(maptop%tieline_inplane.lt.0) then ! test if invariant ... if(inveq(haha,ceq)) then ! haha is set to number of stable phases at invariant. ! the number of lines ending at an invariant isopleth is 2*haha ! current number of stable phases is meqrec%nstph. ! sign(1,phfix) is 1 if phfix>0; -1 if phfix<0 ! write(*,21)meqrec%nstph,haha,phfix,meqrec%nstph-haha+sign(1,phfix) 21 format('SMP2A stable phases mm: ',3i5,i10) endif endif ! write(*,*)'SMP2A Test for invariant equilibrium: ',haha call get_phase_name(meqrec%phr(abs(phfix))%iph,meqrec%phr(abs(phfix))%ics,& phname) if(gx%bmperr.ne.0) then write(*,*)'SMP2A illegal phase name: ',phfix goto 1000 endif if(phfix.gt.0) then write(*,501)ceq%tpval(1),trim(phname) 501 format('Creating a node at ',F10.2,' where ',a,' appears') else write(*,502)ceq%tpval(1),trim(phname) 502 format('Creating a node at ',F10.2,' where ',a,' disappear') endif ! write(*,*)'calling map_newnode: ',mapline%meqrec%nfixph,meqrec%nfixph,haha ! if(haha.gt.1) & ! write(*,*)'SMP2A invariant!! we should greate several exits ',haha ! inside map_newnode the approriate number of exits will be generated call map_newnode(mapline,meqrec,maptop,axval,jax,axarr,phfix,haha,ceq) if(gx%bmperr.ne.0) then !lookingforbug ! write(*,*)'Error return from map_newnode: ',gx%bmperr if(ocv()) write(*,*)'Error return from map_newnode: ',gx%bmperr endif ! write(*,*)'Back from map_newnode',phfix ! all done?? 1000 continue return end subroutine map_calcnode !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine map_newnode !\begin{verbatim} subroutine map_newnode(mapline,meqrec1,maptop,axval,lastax,axarr,& phfix,haha,ceq) ! must be partially THREADPROTECTED ! first check if a node with this equilibrium already exists ! if not add a new node with appropriate lineheads and arrange all links ! Take care if tie-lines in the plane all lines do not have to be calculated ! NOTE: meqrec1 not the same as mapline%meqrec !! ?? ! mapline is line record for current line ! meqrec1 has information about last calculated equilibrium ! maptop is node record ! axval is the axis value attemped to calculate when phase set wanted to change ! lastax is index of last active axis ! axarr are axis records ! phfix is phase which is set fix at node point ! haha is larger than 1 if the calculated equilibrium is invariant ! ceq is equilibrium record implicit none type(map_node), pointer :: maptop type(meq_setup) :: meqrec1 type(map_line), pointer :: mapline,nodexit type(map_axis), dimension(*) :: axarr type(gtp_equilibrium_data), pointer :: ceq integer phfix,lastax,haha double precision axval !\end{verbatim} type(gtp_equilibrium_data), pointer :: newceq,tmpceq type(map_node), pointer :: mapnode,newnode type(map_line), pointer :: linenode,tmpline type(gtp_condition), pointer :: pcond type(gtp_state_variable), pointer :: svrrec,svr2 type(map_fixph), allocatable :: mapfix type(meq_setup), pointer :: meqrec2 type(gtp_state_variable), target :: svrtarget integer remph,addph,nel,iph,ics,jj,seqx,nrel,jphr,stabph,kph,kcs,kk,lfix integer zph,stepax,kpos,seqy,jp,nopotax,lokcs,lokph,haha2,linefphr ! there should be 8 significant digits, first step factor ! double precision, parameter :: vz=1.0D-9,axinc1=1.0D-3 double precision, parameter :: vz=1.0D-8,axinc1=1.0D-3 character eqname*24,phases*60 double precision stepaxval,middle,testv,xxx ! mark that line ended with two stoichometric phases and data for isopleth inv integer twostoichset,errall,jfix,jstab,jlast,kstab,zp,phrix,infix3,nexit integer onlyone,notone,jused,zz,tz,qy,savefix1,savefix2,nodein(2),nodeut(2) ! lifexix, nodefix and prevfix are used to fix pair of phases that have zero ! amount at the exit points of lines from an invariant equilibrium. integer linefix,nodefix,infix,infix2,doubline,twice,firstoutfix,outfix,qq integer, allocatable, dimension(:,:) :: invph,nodeout ! double precision, allocatable, dimension(:) :: exitcomp,eqcopy logical stepinvariantnode ! lfix=0 ! the phase kept fix with zero amount at the node is phfix It can be ! negative at STEP if it is a phase that will dissapear. if(ocv()) write(*,87)'We are in map_newnode with a fix phase: ',& phfix,ceq%tpval(1) 87 format(a,i4,2x,1pe12.4) ! write(*,*)'We have access to phr: ',meqrec1%phr(abs(phfix))%iph,& ! meqrec1%phr(abs(phfix))%ics ! mapnode should be set to point at maptop twostoichset=0 if(btest(mapline%status,TWOSTOICH)) then twostoichset=1 write(*,'(a)')'SMP line ended with two stochiometric allotropes stable' endif mapnode=>maptop nrel=meqrec1%nrel 100 continue !--------------------------------------------------------------------- ! loop all mapnodes to check if any has the same chemical potentials !--------------------------------------------------------------------- ! write(*,*)'Comparing with node: ',mapnode%seqx,nrel ! write(*,105)'T diff: ',ceq%tpval(1),mapnode%tpval(1),& ! abs(ceq%tpval(1)-mapnode%tpval(1)),abs(vz*mapnode%tpval(1)) ! write(*,105)'P diff: ',ceq%tpval(2),mapnode%tpval(2),& ! abs(ceq%tpval(2)-mapnode%tpval(2)),abs(vz*mapnode%tpval(2)) if(abs(ceq%tpval(1)-mapnode%tpval(1)).gt.abs(vz*mapnode%tpval(1)) .or.& abs(ceq%tpval(2)-mapnode%tpval(2)).gt.abs(vz*mapnode%tpval(2))) then ! write(*,*)'Not same, compare with next' goto 110 endif do nel=1,nrel ! write(*,105)'Chempot: ',ceq%cmuval(nel),mapnode%chempots(nel),& ! abs(ceq%cmuval(nel)-mapnode%chempots(nel)),& ! abs(vz*mapnode%chempots(nel)) 105 format(a,5(1pe16.8)) if(abs(ceq%cmuval(nel)-mapnode%chempots(nel)).gt.& abs(2.0D1*vz*mapnode%chempots(nel))) then ! write(*,'(a,3(1pe12.4))')'SMP not same chempots, at this node',& ! abs(ceq%cmuval(nel)-mapnode%chempots(nel)),& ! abs(2.0D1*vz*mapnode%chempots(nel)) goto 110 endif enddo ! We can come here with a STEP command without any fix phases if(maptop%tieline_inplane.eq.0) then write(*,*)'SMP2A map_calcnode: Step command' goto 800 endif ! T, P and all chemical potentials the same, one should maybe check phases?? iph=mapline%linefixph(1)%ixphase ics=mapline%linefixph(1)%compset ! if(ocv()) write(*,107)'Node exist: ',& ! write(*,107)'Node already exist: ',& ! mapnode%seqx,size(mapnode%linehead),iph,ics 107 format(a,i5,i3,i5,i2) ! do not remove exits from invariant nodes ... if(btest(mapnode%status,MAPINVARIANT)) goto 800 removexit: do jj=1,size(mapnode%linehead) ! loop for all exits nodexit=>mapnode%linehead(jj) if(ocv()) write(*,108)'Exit: ',jj,nodexit%done,& nodexit%linefixph(1)%ixphase,nodexit%linefixph(1)%compset ! nodexit%linefixph(1)%phaseix,nodexit%linefixph(1)%compset 108 format(a,i4,i7,i5,i2) if(nodexit%done.le.0) cycle if(nodexit%linefixph(1)%ixphase.eq.iph .and. & nodexit%linefixph(1)%compset.eq.ics) then ! write(*,*)'Number of stable phases: ',& ! nodexit%nstabph,mapline%nstabph if(nodexit%nstabph.eq.mapline%nstabph) then ! if we have same number of stable phases they must be checked (invariant) ! write(*,*)'Can be an invariant equilibrium!',mapline%nstabph endif mapnode%linehead(jj)%done=-1 write(*,106)mapnode%linehead(jj)%lineid,jj,mapnode%seqx 106 format('Removed line ',i2,', exit ',i3,' from node: ',i3) exit removexit endif enddo removexit goto 800 ! take next mapnode 110 continue ! difficult error to detect, I had written mapnode=mapnde%next !!! mapnode=>mapnode%next ! the next links should form a circular list ... if(.not.associated(mapnode,maptop)) goto 100 !================================================================== ! 120 continue mapnode=>maptop%next seqx=mapnode%seqx+1 ! if maptop%next is maptop do not nullify this pointer !! ! Always add the new record as the next link to maptop if(associated(mapnode,maptop)) then ! a single maptop record ! write(*,*)'allocate mapnone%next 1' allocate(mapnode%next) mapnode%next%status=0 else ! there is more mapnode records ... allocation here means memory leak ! I do not know how to fix ... it seems one can deallocate pointers!! no leak ! write(*,*)'allocate mapnone%next 2' allocate(maptop%next) maptop%next%status=0 endif newnode=>maptop%next newnode%first=>maptop newnode%next=>mapnode newnode%previous=>maptop mapnode%previous=>newnode newnode%seqx=seqx ! write(*,*)'Maptop and next: ',maptop%seqx,maptop%next%seqx,newnode%seqx ! eqname='_MAPNODE_' jj=10 ! write(*,*)'SMP2A map_newnode copy equilibrium: ',seqx,nrel call wriint(eqname,jj,seqx) ! This copy is a record in the array "eqlista" of equilibrium record, thus ! it will be updated if new composition sets are created in other threads. ! write(*,*)'Check 1: ',mapline%meqrec%nfixph,meqrec%nfixph,mapline%lineid,& ! mapnode%seqx call copy_equilibrium(newceq,eqname,ceq) if(gx%bmperr.ne.0) then write(*,*)'Error creating equilibrium: ',eqname goto 1000 endif newnode%nodeceq=>newceq ! if twostoichset is set then add a comment in the new equilibrium newnode%artxe=0 if(twostoichset.eq.1) then ! write(*,*)'SMP2A setting artxe' newnode%artxe=1 endif ! save a copy of ceq also in result (reserve is threadprotected) if(ocv()) write(*,*)'Copies node ceq to saveceq' call reserve_saveceq(jj,maptop%saveceq) if(gx%bmperr.ne.0) goto 1000 maptop%saveceq%savedceq(jj)=newceq newnode%savednodeceq=jj ! write(*,*)'Copy successful' ! write(*,*)'Before copying meqrec: ',mapline%meqrec%nfixph,meqrec%nfixph ! maybe it is not necessary to save meqrec and chemical potentials?? newnode%meqrec=meqrec1 ! write(*,*)'New node index: ',newnode%seqx allocate(newnode%chempots(nrel)) newnode%chempots=ceq%cmuval newnode%tpval=ceq%tpval ! newnode%type_of_node=0 ! correct value of lines will be set later newnode%lines=0 newnode%tieline_inplane=maptop%tieline_inplane ! this seems to be wrong, maptop%number_ofaxis is zero when step separate newnode%number_ofaxis=maptop%number_ofaxis ! save index of the phase set fix at the node ! write(*,*)'SMP Saving index of new fix phase: ',abs(phfix) if(phfix.lt.0) then newnode%nodefix%ixphase=-meqrec1%phr(abs(phfix))%iph else newnode%nodefix%ixphase=meqrec1%phr(abs(phfix))%iph endif newnode%nodefix%compset=meqrec1%phr(abs(phfix))%ics ! write(*,*)'Saved node fix phase: ',newnode%nodefix%phase,& ! newnode%nodefix%compset ! the set of stable phases newnode%noofstph=meqrec1%nstph allocate(newnode%stable_phases(newnode%noofstph)) do jj=1,newnode%noofstph ! newnode%stable_phases(jj)%phaseix=meqrec1%iphl(jj) newnode%stable_phases(jj)%ixphase=meqrec1%iphl(jj) newnode%stable_phases(jj)%compset=meqrec1%icsl(jj) enddo ! ! >>>>>>>>>>>>>>>>>>> add code here to generate 2*haha-1 exuts ! if(haha.gt.0) write(*,*)'SMP2A found invariant with exits: !!',2*haha-1 ! >>>>>>>>>>>>>>>>>>>>>>>>>>>>> ! ! Thats all in the newnode ... except the lineheads .... ! Hm, when taking the different exits we must know phase sets and axis ! directions, with some efforts one could check which axis variable will ! change most rapidly for each exit but that can wait. But I must know ! which phase set to have stable in the different lines ... but not for step. ! For invariant equilibra with tie-lines not in the plane that can be quite ! messy if I remeber correctly !----------------------------------------------------- ! create mapline records in newnode with different sets of stable phases if(ocv()) write(*,*)'now generate lineheads',maptop%tieline_inplane,& mapline%meqrec%nfixph,meqrec1%nfixph if(maptop%tieline_inplane.eq.0) then ! this is a step, just one line and one exit with the new set of stable phases newnode%lines=1 if(noel().eq.1) then ! step with single phase: problems with phase change as old phase still stable call get_phase_compset(phfix,1,lokph,lokcs) ! this change will reomve the previously stable phase in newnode and ! below also in meqrec1 jj=newnode%stable_phases(1)%ixphase newnode%stable_phases(1)=phasetuple(phfix) phfix=-jj newnode%nodeceq%phase_varres(lokcs)%PHSTATE=PHENTSTAB newnode%nodeceq%phase_varres(lokcs)%amfu=one newnode%noofstph=1 ! write(*,*)'SMP phases 1A: ',phfix,newnode%stable_phases(1)%ixphase,& ! newnode%stable_phases(2)%ixphase ! But I had to remove the previously stable phase also this way !! call get_phase_compset(-phfix,1,lokph,lokcs) newnode%nodeceq%phase_varres(lokcs)%PHSTATE=PHENTUNST newnode%nodeceq%phase_varres(lokcs)%amfu=zero endif elseif(maptop%tieline_inplane.gt.0) then ! mapping with tie-lines in plane. Always 3 lines meet ... 2 new exits ?? ! the number of exits depends on number of axis, ! for 2 axis 3 lines meet, for 3 axis (one of which is a potential) 4 lines newnode%lines=2 elseif(haha.gt.0) then ! for mapping without tie-lines in plane and haha is nonzero then we are at ! an invariant equlibrium with haha stable phases and 2*haha-1 exiting lines ! newnode%lines=2*jj-1 if(inveq(haha2,ceq)) then ! newnode%lines=2*haha-1 ! Only few of the exit lines will be in the plane f the diagram. Assume 8 ! i.e. there will be 7 exits newnode%lines=7 else newnode%lines=3 endif else ! mapping without tie-lines in plane ! at other node points 4 lines meets, 3 exits write(*,*)'Unknown type of node create exit lines: ',newnode%lines newnode%lines=3 endif ! set link to end node in mapline mapline%end=>newnode !============================================================================= ! we must create sufficient linehead records and initiate their content ! differently depening on STEP (case 1), MAP with tie-lines in plane (case 2) ! and MAP without tie-lines in plane (case 3). In the latter case special ! care must be taken for invariant nodes. (for case 2 all nodes are invariants) ! check if we have a potential axis and select that as axandir stepax=mapline%axandir nopotax=0 if(maptop%number_ofaxis.gt.1) then ! write(*,*)'Seach for step axis' kk=0 do jj=1,maptop%number_ofaxis if(axarr(jj)%axcond(1)%statevarid.lt.5) then ! positive or negative direction is unknown stepax=jj nopotax=jj ! the value of this condition is hopefully in the axarr(jj)%lastaxval ?? ! It was stored there after calculating the node ! write(*,*)'Found axis and value: ',axarr(jj)%lastaxval stepaxval=axarr(jj)%lastaxval endif ! save the axis with the value closest to the "middle" of the axis if(kk.eq.0) then kk=1 middle=abs(5.0D-1-axarr(jj)%lastaxval/& (axarr(jj)%axmax-axarr(jj)%axmin)) ! write(*,*)'middle: ',kk,middle else testv=abs(5.0D-1-axarr(jj)%lastaxval/& (axarr(jj)%axmax-axarr(jj)%axmin)) if(testv.lt.middle) then middle=testv kk=jj endif ! write(*,*)'middle: ',kk,middle,testv endif enddo if(nopotax.eq.0) then stepax=kk stepaxval=axarr(kk)%lastaxval endif ! write(*,*)'Set step axis to: ',stepax,& ! axarr(stepax)%axcond(1)%statevarid endif ! ! ! write(*,*)'SMP2A creating lineheads: ',haha,newnode%lines ! if(newnode%lines.gt.3) write(*,*)'SMP: generate exit lines: ',newnode%lines allocate(newnode%linehead(newnode%lines),stat=errall) if(errall.ne.0) then write(*,*)'SMP2A Allocation error 1: ',errall gx%bmperr=4370; goto 1000 endif ! newnode%type_of_node=0 ! do jp=1,newnode%lines !--------------------- code moved from map_findline ! COPY of the equilibrium record from newnode to newnode%linehead(jp)%lineceq if(ocv()) write(*,*)'We found a line from node: ',mapnode%seqx newnode%linehead(jp)%meqrec%status=0 eqname='_MAPLINE_' kpos=10 seqy=maptop%seqy+1 call wriint(eqname,kpos,seqy) call copy_equilibrium(newnode%linehead(jp)%lineceq,eqname,& newnode%nodeceq) if(gx%bmperr.ne.0) then write(*,*)'Error creating equilibrium: ',eqname goto 1000 endif ! write(*,*)'SMP phases 2: ',seqy,phfix,newnode%stable_phases(1)%ixphase,& ! newnode%nodeceq%phase_varres(lokcs)%phstate,newnode%noofstph maptop%seqy=seqy newnode%linehead(jp)%lineid=seqy newnode%linehead(jp)%nodfixph=0 ! mapline%more is positive for line to be calculated, 0 means end at axis limit newnode%linehead(jp)%more=1 enddo !------------------------------ end code copied ! ! write(*,*)'*** Trying to create node with # exit lines: ',haha,newnode%lines ! STEP has just 1 exit; ! MAP tie-line in plane 2; isopleth non-invariant 3; isopleth invariant >3 kpos=min(newnode%lines,4) ! select case(newnode%lines) exits: select case(kpos) !========================================================================== case default write(*,*)'SMP2A node error: exit lines= ',newnode%lines gx%bmperr=4237; goto 1000 !========================================================================== case(1)! step node with just one exit ! If phfix negative the fix phase wants to dissapear if(inveq(jj,ceq)) write(*,'(a)')'This is an invariant node' changephaseset: if(phfix.lt.0) then ! remove a phase --------------------------- remph=-phfix ! write(kou,88)remph,' disappears,',meqrec1%nstph 88 format('SMP a node created where phase ',i3,a,' stable phases:',i3) if(meqrec1%nstph.eq.1) then write(*,*)'Attempt to remove the only stable phase!!!' gx%bmperr=4238; goto 1000 endif ! shift phases after remph up?? in meqrec1%stphlnewnode%lines) ! irem is index to meqrec1%phr(), meqrec1%stphl(jph) is index to meqrec1%phr meqrec1%nstph=meqrec1%nstph-1 do iph=1,meqrec1%nstph jj=meqrec1%stphl(iph) if(jj.ge.remph) then meqrec1%stphl(iph)=meqrec1%stphl(iph+1) endif enddo ! we must zero the last phase, hm itrem is not really relevant ... meqrec1%stphl(meqrec1%nstph+1)=0 ! occational error because "remph" has illegal index value for meqrec1%phr if(remph.le.0) then write(*,*)'Occational error around line 4487',remph remph=-remph endif if(remph.gt.size(meqrec1%phr)) then ! error calculating Cp for pure Al in Al-Mo .... write(*,'(a,4i4)')'SMP Too large phase indes',& remph,phfix,meqrec1%nstph gx%bmperr=4399; goto 1000 endif meqrec1%phr(remph)%itrem=meqrec1%noofits meqrec1%phr(remph)%prevam=zero meqrec1%phr(remph)%stable=0 meqrec1%phr(remph)%curd%amfu=zero ! write(*,*)'SMP lineeq 3: ',meqrec1%nstph,meqrec1%stphl(1) elseif(phfix.gt.0) then ! we have to add phase phfix to the stable phase set, that is no problem ! as it is already in all lists, just remove that it should be fix ! write(kou,88)phfix,' appears, ',meqrec1%nstph ! meqrec1%nfixph seems not to be used .... ?? if(meqrec1%nfixph.gt.0) then meqrec1%fixph(1,meqrec1%nfixph)=0 meqrec1%fixph(2,meqrec1%nfixph)=0 meqrec1%phr(phfix)%phasestatus=PHENTSTAB meqrec1%nfixph=meqrec1%nfixph-1 endif stepinvariantnode=.FALSE. if(inveq(jj,ceq)) then ! ! if node is invariant we must remove one phase, which? NOT phfix stepinvariantnode=.TRUE. newnode%status=ibset(newnode%status,STEPINVARIANT) ! write(*,*)'SMP2A invariant node at step',phfix,newnode%status,& ! meqrec1%nstph ! set the invariant bit in the node and calculate en equilibrium at ! a very small step above the invariant to find the new set of phases newnode%linehead(1)%meqrec=meqrec1 tmpline=>newnode%linehead(1) ! do kk=1,meqrec1%nstph ! jj=meqrec1%stphl(kk) ! write(*,294)'SMP initial set of phases: ',kk,jj,& ! meqrec1%phr(jj)%iph,meqrec1%phr(jj)%curd%amfu ! enddo meqrec2=>tmpline%meqrec ! do kk=1,meqrec2%nstph ! jj=meqrec2%stphl(kk) ! write(*,294)'SMP same initial set of phases: ',kk,jj,& ! meqrec2%phr(jj)%iph,meqrec2%phr(jj)%ics,& ! meqrec2%phr(jj)%curd%amfu ! enddo 294 format(a,3i5,i2,1pe14.6) call locate_condition(axarr(1)%seqz,pcond,tmpline%lineceq) if(gx%bmperr.ne.0) goto 100 ! call list_conditions(kou,tmpline%lineceq) ! call list_sorted_phases(kou,tmpline%lineceq) ! if(gx%bmperr.ne.0) goto 100 pcond%prescribed=pcond%prescribed+& 1.0D-3*stepax*axarr(1)%axinc ! call list_conditions(kou,tmpline%lineceq) ! write(*,*)'SMP small step invariant to find phase which disappear' call calceq3(0,.FALSE.,tmpline%lineceq) ! first argument -1 to keep the datastructure in meqrec2 ! call calceq7(-1,meqrec2,mapfix,tmpline%lineceq) ! write(*,*)'Back from calceqx',gx%bmperr,meqrec1%nstph ! call list_sorted_phases(kou,tmpline%lineceq) ! NOTE the content of meqrec2 has not been updated as calceq3 creates a new ! independent meqrec structure. We must copy the values of phase amounts ! using a pointer directly to the phase_varres record ! list amount of phases after this small step. However, the layout of ! the meqrec records are the same, we can use phase indices and other things do kk=1,meqrec2%nstph-1 jj=meqrec2%stphl(kk) call get_phase_compset(meqrec2%phr(jj)%iph,meqrec2%phr(jj)%ics,& lokph,lokcs) xxx=tmpline%lineceq%phase_varres(lokcs)%amfu ! write(*,294)'SMP new set of phases: ',kk,jj,& ! meqrec2%phr(jj)%iph,meqrec2%phr(jj)%ics,xxx if(xxx.gt.zero) then meqrec2%phr(jj)%curd%amfu=xxx else do zz=kk,meqrec2%nstph-1 meqrec2%stphl(zz)=meqrec2%stphl(zz+1) enddo endif enddo meqrec2%nstph=meqrec2%nstph-1 ! do kk=1,meqrec2%nstph ! jj=meqrec2%stphl(kk) ! write(*,294)'SMP final initial set of phases: ',kk,jj,& ! meqrec2%phr(jj)%iph,meqrec2%phr(jj)%ics,& ! meqrec2%phr(jj)%curd%amfu ! enddo ! finally copy to meqrec1 ... meqrec1%nstph=meqrec2%nstph do kk=1,meqrec2%nstph meqrec1%stphl(kk)=meqrec2%stphl(kk) ! I assume the amounts are not needed, they should already be in lineceq ...?? enddo ! rearrange the array of stable phases, one should be removed ! stop 'all OK?' endif else write(*,*)'This is another never never error',phfix gx%bmperr=4239; goto 1000 endif changephaseset ! set values in linhead record if(ocv()) write(*,*)'Creating linehead node record in: ',newnode%seqx newnode%linehead(1)%number_of_equilibria=0 newnode%linehead(1)%first=0 newnode%linehead(1)%last=0 ! newnode%linehead(1)%lineid=0 ! newnode%linehead(1)%axchange=1 newnode%linehead(1)%axchange=-1 newnode%linehead(1)%done=1 newnode%linehead(1)%status=0 newnode%linehead(1)%more=1 newnode%linehead(1)%termerr=0 newnode%linehead(1)%axfact=1.0D-2 newnode%linehead(1)%nfixphases=0 ! try to get a nice output of stable phases below ! if(stepinvariantnode) then ! allocate(newnode%linehead(1)%stableph(meqrec2%nstph)) ! allocate(newnode%linehead(1)%stable_phr(meqrec2%nstph)) ! newnode%linehead(1)%nstabph=0 ! do iph=1,meqrec2%nstph ! newnode%linehead(1)%nstabph=newnode%linehead(1)%nstabph+1 ! jj=meqrec2%stphl(iph) ! newnode%linehead(1)%stableph(iph)%ixphase=meqrec2%phr(jj)%iph ! newnode%linehead(1)%stableph(iph)%compset=meqrec2%phr(jj)%ics ! newnode%linehead(1)%stable_phr(iph)=jj ! enddo ! else allocate(newnode%linehead(1)%stableph(meqrec1%nstph)) allocate(newnode%linehead(1)%stable_phr(meqrec1%nstph)) newnode%linehead(1)%nstabph=0 do iph=1,meqrec1%nstph newnode%linehead(1)%nstabph=newnode%linehead(1)%nstabph+1 jj=meqrec1%stphl(iph) newnode%linehead(1)%stableph(iph)%ixphase=meqrec1%phr(jj)%iph newnode%linehead(1)%stableph(iph)%compset=meqrec1%phr(jj)%ics newnode%linehead(1)%stable_phr(iph)=jj enddo ! endif ! end attempt newnode%linehead(1)%firstinc=1.0D-2*axarr(1)%axinc*mapline%axandir ! newnode%linehead(1)%firstinc=1.0D-3*axarr(1)%axinc*mapline%axandir newnode%linehead(1)%evenvalue=axval newnode%linehead(1)%start=>newnode nullify(newnode%linehead(1)%end) if(ocv()) write(*,333)mapline%axandir,newnode%linehead(1)%firstinc,& newnode%linehead(1)%evenvalue 333 format('linehead: ',i3,2(1pe15.6)) newnode%linehead(1)%axandir=mapline%axandir !============================================================================ case(2) ! Step node with two exits: Tie-lines in plane node, 3 lines meet, ! 2 new exits ! write(*,*)'Trying to implement "tie-lines in plane" nodes' if(ocv()) write(*,*)'Creating linehead node record in: ',newnode%seqx ! write(*,*)'Creating linehead node record in: ',newnode%seqx ! this is probably redundant, fixph already reset if(meqrec1%nfixph.gt.0) then meqrec1%fixph(1,meqrec1%nfixph)=0 meqrec1%fixph(2,meqrec1%nfixph)=0 meqrec1%phr(phfix)%phasestatus=PHENTSTAB meqrec1%nfixph=meqrec1%nfixph-1 endif !-------------- ! no need for loop here I guess ... but I am oldfashioned ! begin doublecheck if(newnode%lines.ne.size(newnode%linehead)) then write(*,*)'SMP2A Trouble ahead!!' stop endif ! end doublecheck do jj=1,2 ! initiate data in map_line record newnode%linehead(jj)%number_of_equilibria=0 newnode%linehead(jj)%first=0 newnode%linehead(jj)%last=0 ! newnode%linehead(jj)%lineid=0 ! newnode%linehead(jj)%axchange=1 newnode%linehead(jj)%axchange=-1 newnode%linehead(jj)%done=1 newnode%linehead(jj)%status=0 newnode%linehead(jj)%more=1 newnode%linehead(jj)%termerr=0 newnode%linehead(jj)%axfact=1.0D-2 ! newnode%linehead(jj)%axandir=mapline%axandir ! ??????????? can stepax be negative ??????????????? newnode%linehead(jj)%axandir=stepax newnode%linehead(jj)%nfixphases=1 ! this dimensioning is OK for two axis, if 3 it should be 2 etc. allocate(newnode%linehead(jj)%linefixph(1)) allocate(newnode%linehead(jj)%linefix_phr(1)) ! with tie-lines in the plane there is always just one stable phase allocate(newnode%linehead(jj)%stableph(1)) allocate(newnode%linehead(jj)%stablepham(1)) allocate(newnode%linehead(jj)%stable_phr(1)) ! a small first step in same axis as used to find the node ! We may have to change direction, in particular if the nodephase reappears ! newnode%linehead(jj)%firstinc=1.0D-2*axinc*mapline%axandir newnode%linehead(jj)%firstinc=axinc1*axarr(abs(stepax))%axinc newnode%linehead(jj)%evenvalue=zero ! node records at start and end newnode%linehead(jj)%start=>newnode nullify(newnode%linehead(jj)%end) enddo ! This node represent a point where 3 lines meet 4 if 3 axis), each with a ! different phase fix with zero amount. One line is the one we followed ! to find the node, no need to generate an exit for that. ! It seems we do not have to bother so much with nfixph and fixph ... ! In meqrec1%phr there are currently two fixed phases, one which was fixed ! along the line (LFIX in mapline%linefixph), the other fixed for the node ! point, given by PHFIX which is an index to meqrec1%phr. The third phase ! was stable with positive amount along the line LENT) ! The three lines are: FIX STABLE UNSTABLE ! already done LFIX LENT PHFIX ! exit 1 PHFIX LFIX LENT ! exit 2 LENT PHFIX LFIX jphr=0 if(allocated(mapline%linefixph)) then if(size(mapline%linefixph).gt.1) then ! If there are 3 axis this would be OK write(*,*)'SMP2B too many fix phases ...',size(mapline%linefixph) gx%bmperr=4240; goto 290 endif endif ! write(*,888)mapline%linefixph(1)%ixphase,mapline%linefixph(1)%compset,& ! phfix,meqrec1%nphase,abs(phfix) 888 format('Old fix phase 2: ',i3,i2,', new fix phase: ',i3,& ', number of phases: ',i3,' abs(phfix): ',i3) do jj=1,mapline%meqrec%nphase ! loop through whole phr array to be sure nothing is wrong if(mapline%meqrec%phr(jj)%stable.eq.1) then if(jj.eq.abs(phfix) .or.& (meqrec1%phr(jj)%iph.eq.mapline%linefixph(1)%ixphase .and.& meqrec1%phr(jj)%ics.eq.mapline%linefixph(1)%compset)) cycle if(jphr.gt.0) then write(*,*)'Problems, two entered phases: ',jj,jphr gx%bmperr=4241; goto 290 else jphr=jj ! write(*,*)'Found entered phase: ',jphr endif endif enddo ! jphr is the phase that was stable along the line if(jphr.eq.0) then write(*,*)'Problems, not a single entered phase!' gx%bmperr=4242; goto 290 endif zph=0 do jj=1,meqrec1%nphase if(meqrec1%phr(jj)%iph.eq.mapline%linefixph(1)%ixphase .and. & meqrec1%phr(jj)%ics.eq.mapline%linefixph(1)%compset) then ! this is the index in phr for the phase that was fix along the line zph=jj endif enddo if(zph.eq.0) then write(*,203)' *** warning: cannot find the fix phase: ',zph,& mapline%linefixph(1)%ixphase,mapline%linefixph(1)%compset 203 format(a,10i4) endif ! For isothermal sections with no potential axis we must change the axis ! condition when following a new line ! if(nopotax.eq.0) then ! write(*,*)'Changing the axis variable for the new entered phase' ! endif ! In mapnode there is a nfixph and array linefixph ! if(ocv()) write(*,207)mapline%linefixph(1)%phaseix,& ! if(ocv()) write(*,207)mapline%linefixph(1)%ixphase,& ! write(*,207)mapline%linefixph(1)%ixphase,& ! mapline%linefixph(1)%compset,& ! meqrec%phr(phfix)%iph,meqrec%phr(phfix)%ics,& ! meqrec%phr(jphr)%iph,meqrec%phr(jphr)%ics 207 format('LFIX: ',2i3,5x,' PHFIX: ',2i3,5x,' LENT: ',2i3) ! The two exits are: FIX STABLE UNSTABLE ! exit 1 PHFIX LFIX LENT ! exit 2 LENT PHFIX LFIX ! for alcrni iph=mapline%linefixph(1)%ixphase ics=mapline%linefixph(1)%compset linefphr=mapline%linefix_phr(1) phrix=mapline%linefix_phr(1) newnode%linehead(1)%linefixph%ixphase=meqrec1%phr(phfix)%iph newnode%linehead(1)%linefixph%compset=meqrec1%phr(phfix)%ics newnode%linehead(1)%linefix_phr=phfix newnode%linehead(1)%nstabph=1 ! the previously fix phase is set as entered with stablepham as initial amount newnode%linehead(1)%stableph(1)%ixphase=iph newnode%linehead(1)%stableph(1)%compset=ics ! value of %stable_phr=?? newnode%linehead(1)%stable_phr(1)=phrix newnode%linehead(1)%stablepham(1)=one ! store the phase number that must not become stable in nodfixph newnode%linehead(1)%nodfixph=jphr ! newnode%linehead(1)%nodfixtup=meqrec1%phr(jphr)%phtupix ! write(*,*)'SM2A nodfix:',phasetuple(meqrec1%phr(jphr)%phtupix)%ixphase,& ! meqrec1%phr(jphr)%ics !----------- newnode%linehead(2)%linefixph%ixphase=meqrec1%phr(jphr)%iph newnode%linehead(2)%linefixph%compset=meqrec1%phr(jphr)%ics newnode%linehead(2)%linefix_phr=jphr newnode%linehead(2)%nstabph=1 newnode%linehead(2)%stableph(1)%ixphase=meqrec1%phr(phfix)%iph newnode%linehead(2)%stableph(1)%compset=meqrec1%phr(phfix)%ics newnode%linehead(2)%stable_phr(1)=phfix newnode%linehead(2)%stablepham(1)=one ! store the phase number that must not become stable in nodfixph newnode%linehead(2)%nodfixph=zph ! newnode%linehead(1)%nodfixtup=meqrec1%phr(zph)%phtupix if(nopotax.eq.0) then ! If we have no potential axis we MUST change the axis condition ! to represent the axis composition of the new stable phase write(*,712)stepax,axarr(abs(stepax))%axcond(1)%statevarid,stepaxval 712 format('Creating nodepoint with no potential axis: ',2i4,1pe12.4) ! we have to change the axis condition to be the current composition of the ! new stable phase. ! write(*,*)'Conditions at node point' ! call list_conditions(kou,newnode%nodeceq) ! change condition value for the lines exiting this node point tmpceq=>newnode%linehead(1)%lineceq call locate_condition(axarr(stepax)%seqz,pcond,tmpceq) if(gx%bmperr.ne.0) then write(*,*)'Cannot locate condition: ',axarr(stepax)%seqz goto 1000 endif svrrec=>pcond%statvar(1) ! call state_variable_val(svrrec,xxx,tmpceq) ! if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'Condition/State variable value: ',xxx ! NOTE: If we change fix/entered phase we must change axvals/axvals2 ! i1=svr2%argtyp; i2=svr2%phase; i3=svr2%compset svrtarget=svrrec svrtarget%argtyp=3 svrtarget%phase=newnode%linehead(1)%stableph(1)%ixphase svrtarget%compset=newnode%linehead(1)%stableph(1)%compset ! This extracts the composition of the entered phase for first new line ! we must use a pointer in state_variable_val svr2=>svrtarget call state_variable_val(svr2,xxx,tmpceq) if(gx%bmperr.ne.0) goto 1000 ! first argument 1 means to extract the value, 0 means to set the value call condition_value(0,pcond,xxx,tmpceq) if(gx%bmperr.ne.0) then write(*,*)'Error setting new conditions in lineceq' goto 1000 endif ! write(*,*)'Setting condition for line 1 to ',xxx ! write(*,211)'New conditions at line: ',newnode%linehead(1)%lineid,& ! trim(newnode%linehead(1)%lineceq%eqname),& ! svr2%phase,svr2%compset,xxx 211 format(a,i3,a,2x,' phase/set: ',2i3,2x,1pe12.4) ! call list_conditions(kou,newnode%linehead(1)%lineceq) !--------- second exit tmpceq=>newnode%linehead(2)%lineceq call locate_condition(axarr(stepax)%seqz,pcond,tmpceq) if(gx%bmperr.ne.0) then write(*,*)'Cannot locate condition: ',axarr(stepax)%seqz goto 1000 endif svrrec=>pcond%statvar(1) svrtarget=svrrec svrtarget%argtyp=3 svrtarget%phase=newnode%linehead(2)%stableph(1)%ixphase svrtarget%compset=newnode%linehead(2)%stableph(1)%compset ! This extracts the composition of the entered phase for second new line ! ONLY CHANGE ... has no influence on the problem ... svr2=>svrtarget ! the line above should be there I think but was missing ... xxx below wrong?? call state_variable_val(svr2,xxx,tmpceq) if(gx%bmperr.ne.0) goto 1000 call condition_value(0,pcond,xxx,tmpceq) if(gx%bmperr.ne.0) then write(*,*)'Error setting new conditions in lineceq' goto 1000 endif ! write(*,*)'Setting condition for line 2 to ',xxx ! write(*,211)'New conditions at line: ',newnode%linehead(2)%lineid,& ! trim(newnode%linehead(2)%lineceq%eqname),& ! svr2%phase,svr2%compset,xxx ! call list_conditions(kou,newnode%linehead(2)%lineceq) endif ! list the exits: if(ocv()) write(*,56)'Created linehead 1 for node: ',newnode%seqx,& ! write(*,56)'Created linehead 1 for node: ',newnode%seqx,& newnode%linehead(1)%linefixph%ixphase,& newnode%linehead(1)%linefixph%compset,& newnode%linehead(1)%stableph(1)%ixphase,& newnode%linehead(1)%stableph(1)%compset,& newnode%linehead(1)%nodfixph if(ocv()) write(*,56)'Created linehead 2 for node: ',newnode%seqx,& ! write(*,56)'Created linehead 2 for node: ',newnode%seqx,& newnode%linehead(2)%linefixph%ixphase,& newnode%linehead(2)%linefixph%compset,& newnode%linehead(2)%stableph(1)%ixphase,& newnode%linehead(2)%stableph(1)%compset,& newnode%linehead(2)%nodfixph 56 format(a,i3,5x,2i3,5x,2i3,5x,2i3) if(newnode%lines.ne.2) then write(*,*)'SMP2A setting newnode%lines' newnode%lines=2 endif ! the fix and stable phases must be copied to meqrec1 when line is started ! write(*,*)'Created node with 2 exits: ',newnode%seqx,ceq%tpval(1) ! prevent the lines from being used as that makes the program crash 290 continue !====================================================================== case(3) ! Normal node in a phase diagram without tie-lines in plane ! Two crossing lines, one in and 3 exits ! THERE IS NO CASE WHEN FINDING AN INVARIANT ! this is probably redundant, fixph already reset if(meqrec1%nfixph.gt.0) then ! write(*,*)'Not redundant ...' meqrec1%fixph(1,meqrec1%nfixph)=0 meqrec1%fixph(2,meqrec1%nfixph)=0 meqrec1%phr(abs(phfix))%phasestatus=PHENTSTAB meqrec1%nfixph=meqrec1%nfixph-1 endif !-------------- ! no need for loop here I guess ... but I am oldfashioned do jj=1,3 ! initiate data in map_line record newnode%linehead(jj)%number_of_equilibria=0 newnode%linehead(jj)%first=0 newnode%linehead(jj)%last=0 ! newnode%linehead(jj)%lineid=0 ! newnode%linehead(jj)%axchange=1 newnode%linehead(jj)%axchange=-1 newnode%linehead(jj)%done=1 newnode%linehead(jj)%status=0 newnode%linehead(jj)%more=1 newnode%linehead(jj)%termerr=0 newnode%linehead(jj)%axfact=1.0D-2 ! newnode%linehead(jj)%axandir=mapline%axandir newnode%linehead(jj)%axandir=stepax newnode%linehead(jj)%nfixphases=1 ! this dimensioning is OK for two axis, if 3 axis it should be 2 etc. allocate(newnode%linehead(jj)%linefixph(1)) allocate(newnode%linehead(jj)%linefix_phr(1)) ! There will be different number of stable phases in the lines ! if new phase appear, 2 lines with jphr+1, one with jphr ! if old phase dissapear, 2 lines with jphr-1, one with jphr jphr=mapline%nstabph if(jphr.eq.1 .and. phfix.lt.0) then write(*,*)'Trying to remove the only entered phase !' gx%bmperr=4238; goto 1000 endif if(jj.eq.3) then ! write(*,*)'Allocating stableph: ',jj,jphr allocate(newnode%linehead(jj)%stableph(jphr)) allocate(newnode%linehead(jj)%stablepham(jphr)) allocate(newnode%linehead(jj)%stable_phr(jphr)) else if(phfix.lt.0) then ! write(*,*)'Allocating stableph: ',jj,jphr-1 allocate(newnode%linehead(jj)%stableph(jphr-1)) allocate(newnode%linehead(jj)%stablepham(jphr-1)) allocate(newnode%linehead(jj)%stable_phr(jphr-1)) else ! write(*,*)'Allocating stableph: ',jj,jphr+1 allocate(newnode%linehead(jj)%stableph(jphr+1)) allocate(newnode%linehead(jj)%stablepham(jphr+1)) allocate(newnode%linehead(jj)%stable_phr(jphr+1)) endif endif ! a small first step in same axis as used to find the node ! We may have to change direction, in particular if the nodephase reappears ! evenvalue important only for STEP with one axis ! newnode%linehead(jj)%firstinc=1.0D-2*axinc*mapline%axandir ! newnode%linehead(jj)%firstinc=axinc1*axinc*mapline%axandir newnode%linehead(jj)%firstinc=axinc1*axarr(abs(stepax))%axinc newnode%linehead(jj)%evenvalue=zero ! links to node records at start and end of line newnode%linehead(jj)%start=>newnode nullify(newnode%linehead(jj)%end) enddo ! if(allocated(mapline%linefixph)) then if(size(mapline%linefixph).gt.1) then ! error if 2 axis but would be OK if 3 axis write(*,*)'Problem, many fix phases!',size(mapline%linefixph) gx%bmperr=4240; goto 390 endif endif stabph=0 do jj=1,meqrec1%nphase ! loop through whole phr array to be sure nothing is wrong if(meqrec1%phr(jj)%stable.eq.1) then ! there should be 2 fixed phases, one along the line and one at the node ! If 3 or more axis there will be more fixed phases, phfix can be negative ! if(jj.eq.abs(phfix) .or.& ! (meqrec1%phr(jj)%iph.eq.mapline%linefixph(1)%phase .and.& ! meqrec1%phr(jj)%ics.eq.mapline%linefixph(1)%compset)) cycle ! we should include phfix in stabph!! ! if(meqrec1%phr(jj)%iph.eq.mapline%linefixph(1)%phaseix .and.& if(meqrec1%phr(jj)%iph.eq.mapline%linefixph(1)%ixphase .and.& meqrec1%phr(jj)%ics.eq.mapline%linefixph(1)%compset) cycle stabph=stabph+1 endif enddo ! Hm, stabph calculated this way is wrong, use mapline%nstabph ! write(*,312)meqrec1%nphase,stabph,mapline%nstabph,phfix,& ! mapline%linefixph(1)%phase,mapline%linefixph(1)%compset 312 format('In map_newnode 312: ',i3,i5,i3,i5,i3,i2,10i5) stabph=mapline%nstabph if(stabph.eq.0) then write(*,*)'Problems, no entered phase!' gx%bmperr=4242; goto 390 endif ! 4 lines meet in all nodes except invariants ! We have 1 fix phase and f=stabph enterend phases and 1 new/old (+/-PHFIX) ! LFIX is phase fix along line up to node ! +PHFIX is a new phase becommong stable, -PHFIX is stable phase dissapearing ! if not invariant generate 3 exits, with PHFIX>0 these are ! The three exits are: FIX STABLE phases nodfixph ! exit 1 LFIX f+1 (+PHFIX) PHFIX ! exit 2 PHFIX f+1 (+LFIX) LFIX ! exit 3 PHFIX f (-PHFIX and add LFIX) LFIX ! If PHFIX<0 is an old phase becommong unstable ! The three exits are: FIX STABLE not allwed appear/disappear ! exit 1 LFIX f-1 (-PHFIX) PHFIX ! exit 2 PHFIX f-1 (-PHFIX not LFIX) LFIX ! exit 3 PHFIX f (-PHFIX and add LFIX) LFIX iph=mapline%linefixph(1)%ixphase ics=mapline%linefixph(1)%compset linefphr=mapline%linefix_phr(1) ! for use below I need to know the position of iph+ics in meqrec1%phr ... flfix: do jj=1,meqrec1%nstph if(meqrec1%phr(jj)%iph.eq.iph .and. meqrec1%phr(jj)%ics.eq.ics) then lfix=jj; exit flfix endif enddo flfix kph=mapline%meqrec%phr(abs(phfix))%iph kcs=mapline%meqrec%phr(abs(phfix))%ics ! exit 1 has same linefix as incomming line ------------------------ newnode%linehead(1)%linefixph%ixphase=iph newnode%linehead(1)%linefixph%compset=ics newnode%linehead(1)%linefix_phr=linefphr if(phfix.gt.0) then ! write(*,*)'allocated size of stableph 2: ',size(mapline%stableph) do jj=1,stabph newnode%linehead(1)%stableph(jj)%ixphase=& mapline%stableph(jj)%ixphase newnode%linehead(1)%stableph(jj)%compset=& mapline%stableph(jj)%compset newnode%linehead(1)%stablepham(jj)=mapline%stablepham(jj) newnode%linehead(1)%stable_phr(jj)=mapline%stable_phr(jj) enddo ! add phfix as stable phase jj=stabph+1 newnode%linehead(1)%stableph(jj)%ixphase=kph newnode%linehead(1)%stableph(jj)%compset=kcs newnode%linehead(1)%stablepham(jj)=zero newnode%linehead(1)%stable_phr(jj)=abs(phfix) ! UNFINISHED check why stable_phr and nodefxph same?? newnode%linehead(1)%nodfixph=abs(phfix) ! newnode%linehead(1)%nodfixtup=meqrec1%phr(abs(phfix))%phtupix newnode%linehead(1)%nstabph=jj else ! phfix is negative, a phase disappear kk=0 do jj=1,stabph-1 ! remove -phfix as stable phase if(mapline%stableph(jj)%ixphase.eq.kph .and.& mapline%stableph(jj)%compset.eq.kcs) then kk=jj+1 else kk=kk+1 endif newnode%linehead(1)%stableph(jj)%ixphase=& mapline%stableph(kk)%ixphase newnode%linehead(1)%stableph(jj)%compset=& mapline%stableph(kk)%compset newnode%linehead(1)%stablepham(jj)=mapline%stablepham(kk) newnode%linehead(1)%stable_phr(jj)=mapline%stable_phr(kk) enddo newnode%linehead(1)%nodfixph=abs(phfix) newnode%linehead(1)%nstabph=stabph-1 endif ! ! exit 2 has PHFIX as linefix ---------------------------------- newnode%linehead(2)%linefixph%ixphase=kph newnode%linehead(2)%linefixph%compset=kcs newnode%linehead(2)%linefix_phr=abs(phfix) if(phfix.gt.0) then do jj=1,stabph newnode%linehead(2)%stableph(jj)%ixphase=& mapline%stableph(jj)%ixphase newnode%linehead(2)%stableph(jj)%compset=& mapline%stableph(jj)%compset newnode%linehead(2)%stablepham(jj)=mapline%stablepham(jj) newnode%linehead(2)%stable_phr(jj)=mapline%stable_phr(jj) enddo ! add LFIX as stable phase jj=stabph+1 newnode%linehead(2)%stableph(jj)%ixphase=iph newnode%linehead(2)%stableph(jj)%compset=ics newnode%linehead(2)%stablepham(jj)=zero newnode%linehead(2)%stable_phr(jj)=lfix newnode%linehead(2)%nodfixph=lfix newnode%linehead(2)%nstabph=jj else kk=0 do jj=1,stabph-1 ! remove -phfix as stable phase if(mapline%stableph(jj)%ixphase.eq.kph .and.& mapline%stableph(jj)%compset.eq.kcs) then kk=jj+1 else kk=kk+1 endif newnode%linehead(2)%stableph(jj)%ixphase=& mapline%stableph(kk)%ixphase newnode%linehead(2)%stableph(jj)%compset=& mapline%stableph(kk)%compset newnode%linehead(2)%stable_phr(jj)=mapline%stable_phr(kk) enddo newnode%linehead(2)%nodfixph=lfix ! newnode%linehead(1)%nodfixtup=meqrec1%phr(lfix)%phtupix newnode%linehead(2)%nstabph=stabph-1 endif ! ! exit 3 has PHFIX as linefix ---------------------------------- newnode%linehead(3)%linefixph%ixphase=kph newnode%linehead(3)%linefixph%compset=kcs newnode%linehead(3)%linefix_phr=abs(phfix) do jj=1,stabph if(mapline%stableph(jj)%ixphase.eq.kph .and. & mapline%stableph(jj)%compset.eq.kcs) then ! exchange PHFIX for LFIX as stable phase newnode%linehead(3)%stableph(jj)%ixphase=iph newnode%linehead(3)%stableph(jj)%compset=ics newnode%linehead(3)%stablepham(jj)=zero newnode%linehead(3)%stable_phr(jj)=abs(phfix) else newnode%linehead(3)%stableph(jj)%ixphase=& mapline%stableph(jj)%ixphase newnode%linehead(3)%stableph(jj)%compset=& mapline%stableph(jj)%compset newnode%linehead(3)%stablepham(jj)=mapline%stablepham(jj) newnode%linehead(3)%stable_phr(jj)=mapline%stable_phr(jj) endif enddo newnode%linehead(3)%nodfixph=lfix newnode%linehead(3)%nstabph=stabph ! if(ocv()) then do jj=1,3 write(*,356)jj,newnode%seqx,& ! newnode%linehead(jj)%linefixph%phaseix,& newnode%linehead(jj)%linefixph%ixphase,& newnode%linehead(jj)%linefixph%compset,& newnode%linehead(jj)%nodfixph,& newnode%linehead(jj)%nstabph,& (newnode%linehead(jj)%stableph(kk)%ixphase,& newnode%linehead(jj)%stableph(kk)%compset,& kk=1,newnode%linehead(jj)%nstabph) enddo 356 format('Tie-line NOT in plane node exits: ',& i2,i3,i4,i2,i5,i3,10(i4,i2)) endif ! the fix and stable phases must be copied to meqrec1 when line is started ! write(*,*)'Created node with 2 exits: ',newnode%seqx,ceq%tpval(1) 390 continue !--------------------------------------------------------------- ! invariant isopleth, more than 3 exits case(4) ! isopleth invariants for isopleths, inveq ! number of stable phases equal to components+1 ! number of adjacent regions with "components" stable phases is "components+1" ! number of exit lines are 2*(components+1) ?? limit to 8 (minus 1 for entry) ! each line has a fix phase and one of the phases is stable at the invariant ! (set as not "nodefix"). The remaining phases are entered. ! Each phase is fix for two lines and "nodefix" for two others ! This is the way to generate the exit lines: ! - loop for all phases to set a phase fix (for two lines) ! - loop for the next two phases to set one phase not stable ! the remaining phases are set entered (amount?) generate a line startpoint ! take care of remobing line into the invariant ! ! How to know if the node is invariant? Gibbs phase rule, Degrees of freedom ! f = n + 2 - p ! where n is number of components, 2 if T and P variable, 1 if T or P variable, ! 0 if both T and P fixed, p is number of stable phases. ! write(*,*)'SMP2A Generating exits from isopleth invariant',newnode%lines ! Two crossing lines, one in and 3 exits ! this is probably redundant, fixph already reset ! phfix is the new stable phase! Must be positive ! mapline is the just finished line if(meqrec1%nfixph.gt.0) then ! write(*,*)'Invariant isopleth:',meqrec1%nfixph,phfix,mapline%nstabph meqrec1%fixph(1,meqrec1%nfixph)=0 meqrec1%fixph(2,meqrec1%nfixph)=0 meqrec1%phr(abs(phfix))%phasestatus=PHENTUNST meqrec1%nfixph=meqrec1%nfixph-1 endif ! determine LFIX, the phase which was fix along incomming line iph=mapline%linefixph(1)%ixphase ics=mapline%linefixph(1)%compset ! for use below I need to know the position of iph+ics in meqrec1%phr ... lfix=mapline%linefix_phr(1) flfix2: do jj=1,meqrec1%nstph ! this loop is only for stable phase it does not include the fix if(meqrec1%phr(jj)%iph.eq.iph .and. meqrec1%phr(jj)%ics.eq.ics) then lfix=jj meqrec1%phr(lfix)%phasestatus=PHENTUNST exit flfix2 endif enddo flfix2 if(lfix.eq.0) stop 'ERROR' ! this is total number of phases at each the invariant ! 1 fix and stabph-2 should be stable at each exit stabph=mapline%nstabph if(stabph.eq.0) then write(*,*)'Problems, no entered phase!' gx%bmperr=4242; goto 490 endif ! Collect all stable phases to be used as different exits. ! invph(1,jj) is iph,, invph(2,jj) is ics; invph(3,jj) is index in meqrec1%phr ! invph(4,jj) is to count number of times jj has been linefix ! invph(5,jj) is to count number of times jj has been nodefix ! invph(6,jj) is index to phase_varres allocate(invph(6,stabph+2)) invph=0 do jj=1,stabph ! stableph is a phase_tuple invph(1,jj)=mapline%stableph(jj)%ixphase invph(2,jj)=mapline%stableph(jj)%compset invph(3,jj)=mapline%stable_phr(jj) ! stable_phr is used to find the index in phr and index to phase_varres ! I DO NOT TRUST THE VALUE, "stable_phr" ! I SHOULD REORGANIZE PHE TO BE IN PHASE TUPLE ORDER. ! THERE ARE ALWAYS PROBLEM IS IF NEW COMPOSIION SETS ARE CREATED DURING MAPPING do zz=1,meqrec1%nphase if(meqrec1%phr(zz)%iph.eq.invph(1,jj) .and.& meqrec1%phr(zz)%ics.eq.invph(2,jj)) then invph(3,jj)=zz ! if(zz.ne.mapline%stable_phr(jj)) & ! write(*,*)'SMP correction: ',jj,zz,mapline%stable_phr(jj) endif enddo call get_phase_compset(invph(1,jj),invph(2,jj),lokph,lokcs) if(gx%bmperr.ne.0) goto 1000 invph(6,jj)=lokcs enddo ! at the end of loop jj=stabph+1; store phfix, the new fix phase, invph(1,jj)=meqrec1%phr(phfix)%iph invph(2,jj)=meqrec1%phr(phfix)%ics invph(3,jj)=phfix call get_phase_compset(invph(1,jj),invph(2,jj),lokph,lokcs) if(gx%bmperr.ne.0) goto 1000 invph(6,jj)=lokcs ! this is the phase fix at incomming line, only one exit line with this fix invph(1,jj+1)=iph invph(2,jj+1)=ics invph(3,jj+1)=lfix call get_phase_compset(invph(1,jj+1),invph(2,jj+1),lokph,lokcs) if(gx%bmperr.ne.0) goto 1000 invph(6,jj+1)=lokcs jlast=stabph+2 ! STABLE PHASES HAS TO BE IN PHR ORDER!! SORT invph ! do kk=1,stabph+2 ! write(*,'(a,i3,2x,i3,i2,4i4)')'SMP invph:',kk,(invph(zz,kk),zz=1,6) ! enddo ! second argument is first dimenstion of invph!! call sort_invph(jlast,6,invph) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'SMP sorted invph: ' ! do kk=1,stabph+2 ! write(*,'(a,i3,2x,i3,i2,4i4)')'SMP invph:',kk,(invph(zz,kk),zz=1,6) ! enddo do jj=1,jlast phases=' ' call get_phase_name(invph(1,jj),invph(2,jj),phases) ! keep track of the phase found at the invariant and the linefix phase ! nodein(1) is linefix if(invph(3,jj).eq.lfix) then nodein(1)=jj linefix=jj invph(4,nodein(1))=1 ! nodein(2) is nodefix elseif(invph(3,jj).eq.phfix) then nodein(2)=jj nodefix=jj invph(5,nodein(2))=1 endif enddo ! the entering line found at node, nodefix, mark it is used ! the entering line had this phase fix with zero amount ! write(*,'(a,5i4)')'SMP2: linefix and nodefix: ',& ! onlyone,lfix,notone,phfix ! all the others should be fixed one two exits !-------------- tmpceq=>newnode%nodeceq ! max 20 exit lines .... allocate(nodeout(2,10)) ! write(*,*)'SMP call to find all exits',tmpceq%tpval(1) call find_inv_exits(nexit,nodeout,nodein,stabph,invph,6,axarr,tmpceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,'(a,i3,5(i5,i3))')'SMP back from find_inv_exit: ',nexit,& ! nodein(1),nodein(2),(nodeout(1,jj),nodeout(2,jj),jj=1,nexit) ! stop 'SMP does it work? YES!' if(nexit.gt.2*mapline%nstabph) then write(*,*)'SMP too many exit lines: ',nexit,newnode%lines elseif(nexit.le.0) then write(*,*)'SMP no exits found?, just continue with one line' newnode%lines=1 else newnode%lines=2*nexit+1 endif ! There are nexit pairs of phases in nodeout for all exits, total number ! of exits are 2*nexit+1 (one exit eliminated because that was entering) ! !-------------- ! We have to generate newnode%lines exits!! jphr=mapline%nstabph jfix=1 ! set bit in mapnode! if(newnode%status.ne.0) write(*,*)'SMP2 nodestatus: ',newnode%status newnode%status=ibset(newnode%status,MAPINVARIANT) ! write(*,*)'SMP2 number of exit lines: ',newnode%lines,jphr allexit: do jj=1,newnode%lines ! initiate common data in map_line record in all exit lines newnode%linehead(jj)%number_of_equilibria=0 newnode%linehead(jj)%first=0 newnode%linehead(jj)%last=0 newnode%linehead(jj)%axchange=-1 newnode%linehead(jj)%done=1 newnode%linehead(jj)%status=0 newnode%linehead(jj)%more=1 newnode%linehead(jj)%termerr=0 newnode%linehead(jj)%axfact=1.0D-2 newnode%linehead(jj)%axandir=stepax ! this dimensioning is OK for two axis, if 3 axis it should be 2 etc. newnode%linehead(jj)%nfixphases=1 if(allocated(newnode%linehead(jj)%linefixph)) then write(*,*)'SMP2A line 5537: Strange allocated error in map17',& jj,jphr deallocate(newnode%linehead(jj)%linefixph) deallocate(newnode%linehead(jj)%linefix_phr) if(allocated(newnode%linehead(jj)%stableph)) then write(*,*)'SMP2A line 5537: skipping!' endif endif allocate(newnode%linehead(jj)%linefixph(1)) allocate(newnode%linehead(jj)%linefix_phr(1)) ! There will be the same number of stable phases in all lines allocate(newnode%linehead(jj)%stableph(jphr)) allocate(newnode%linehead(jj)%stablepham(jphr)) allocate(newnode%linehead(jj)%stable_phr(jphr)) ! a small first step in same axis as used to find the node ! We may have to change direction, in particular if the nodephase reappears ! evenvalue important only for STEP with one axis newnode%linehead(jj)%firstinc=axinc1*axarr(abs(stepax))%axinc newnode%linehead(jj)%evenvalue=zero ! links to node records at start and end of line newnode%linehead(jj)%start=>newnode nullify(newnode%linehead(jj)%end) ! number of stable phases along all lines. Additionally a fix and a forbidden newnode%linehead(jj)%nstabph=stabph ! possible problem with meqrec%status if(newnode%linehead(jj)%meqrec%status.ne.0) then write(*,*)'SMP zero meqrec%status for newnode%linehead',& newnode%linehead(jj)%meqrec%status newnode%linehead(jj)%meqrec%status=0 endif enddo allexit ! ! ------------------------ ISOPLETHAL INVARIANTS EXITS ----------- ! we have set LINEFIX and NODEFIX phases for each line ! We know the LINEFIX and NODEFIX phases for the line INTO THE INVARIAT ! For the first exit line we just swich these as they are at the same point ! with zero amount of both phases ! ! (C is ?) Cfix Afix Dfix Bfix (B is ?) ! \ ABCE.. \BCE./ BCDE.. / ! \ \ / / ! \____________\/_________/ ! ABDE.. !_________ ABCDE..______! CDE... ! / /\ \ ! / ABDE.. / \ ACDE.. \ ! / /ADE.\ \ ! Dfix Bfix Cfix Afix ! ! For the other exits FIND_INV_EXITS above have found all points along ! the invariant line that have two phases with zero amount. ! If next<0 just one exit will be generated with linefix/nodefix changed ! jj=1 phases=' ' ! write(*,717)newnode%nodeceq%tpval(1) 717 format(/' *************** invariant node at ',F10.2) ! now code to create correct combination of linefix and nodefix ! first a line with nodefix as linefix and vice versa ! and old linefix as nodefix phase (sorry very confusing for me too) newnode%linehead(jj)%linefixph%ixphase=invph(1,nodefix) newnode%linehead(jj)%linefixph%compset=invph(2,nodefix) newnode%linehead(jj)%linefix_phr=invph(3,nodefix) ! this is just to understand what is happening call get_phase_name(invph(1,nodefix),invph(2,nodefix),phases) zp=len_trim(phases)+3 phases(zp-1:zp-1)='(' ! write(*,*)'smp2: fix: ',trim(phases),onlyone,invph(3,onlyone) ! set linefix=LFIX as phase forbidden to become stable when line starts ! enclose the nodefix phase with ( .... ) newnode%linehead(jj)%nodfixph=invph(3,linefix) call get_phase_name(invph(1,linefix),invph(2,linefix),phases(zp:)) zp=len_trim(phases)+3 phases(zp-2:zp-2)=')' ! at this line we have switched nodefix/linefix; nodefix is fix along the line ! the incomming line had the same fix phases so set both 4 and 5 to 1 invph(4,nodefix)=1; invph(5,nodefix)=1 invph(4,linefix)=1; invph(5,linefix)=1 ! NOW add the stable phases excluding linefix and nodefix kk=0 names: do zz=1,stabph+2 if(zz.eq.linefix .or. zz.eq.nodefix) cycle names kk=kk+1 newnode%linehead(jj)%stableph(kk)%ixphase=invph(1,zz) newnode%linehead(jj)%stableph(kk)%compset=invph(2,zz) newnode%linehead(jj)%stablepham(kk)=1.0D-2 newnode%linehead(jj)%stable_phr(kk)=invph(3,zz) call get_phase_name(invph(1,zz),invph(2,zz),phases(zp:)) zp=len_trim(phases)+2 enddo names ! note again: nodefix here is fix along the line, linefix is stable at invarant ! write(*,430)jj,nodefix,linefix,trim(phases) write(*,430)jj,trim(phases) 430 format('SMP2A invexit ',i3,' >>> ',a) ! The code above is for the FIRST exit line ! Here we will create 2 exit lines using nodeout(1,jj) and nodeout(2,jj) ! with jj=1..nexit, repeat with switched linefix/nodefix do qq=1,nexit linefix=nodeout(1,qq) nodefix=nodeout(2,qq) doubline=0 392 continue jj=jj+1 newnode%linehead(jj)%linefixph%ixphase=invph(1,linefix) newnode%linehead(jj)%linefixph%compset=invph(2,linefix) newnode%linehead(jj)%linefix_phr=invph(3,linefix) invph(4,linefix)=invph(4,linefix)+1 call get_phase_name(invph(1,linefix),invph(2,linefix),phases) zp=len_trim(phases)+3 phases(zp-1:zp-1)='(' ! nodefix not always set correctly here, error in map16 running all macros newnode%linehead(jj)%nodfixph=invph(3,nodefix) invph(5,nodefix)=invph(5,nodefix)+1 call get_phase_name(invph(1,nodefix),invph(2,nodefix),phases(zp:)) zp=len_trim(phases)+3 phases(zp-2:zp-2)=')' kk=0 names2: do zz=1,stabph+2 if(zz.eq.linefix .or. zz.eq.nodefix) cycle names2 kk=kk+1 if(kk.le.stabph) then newnode%linehead(jj)%stableph(kk)%ixphase=invph(1,zz) newnode%linehead(jj)%stableph(kk)%compset=invph(2,zz) newnode%linehead(jj)%stablepham(kk)=1.0D-2 newnode%linehead(jj)%stable_phr(kk)=invph(3,zz) else write(*,'(a,10i5)')'SMP2 too many stable phases: ',jj,kk,zz,& invph(1,zz),invph(2,zz),linefix,nodefix endif call get_phase_name(invph(1,zz),invph(2,zz),phases(zp:)) zp=len_trim(phases)+2 enddo names2 write(*,430)jj,trim(phases) if(doubline.eq.0) then ! we have switch linefix and nodefis to create one more exit line doubline=linefix linefix=nodefix; nodefix=doubline phases=' ' goto 392 endif enddo 490 continue ! stop ' *** Unfinished invariant isopleth node exits *** ' end select exits !========================================================================= goto 1000 !------------------------------------------- ! we have found a node with same chemical potentials ! we should perhaps also check the set of phases ... ??? 800 continue if(ocv()) write(*,*)'This node already found',mapnode%seqx ! we set a link in the mapline record to this node and has finished! mapline%end=>mapnode if(ocv()) write(*,*)'Line: ',mapline%lineid,' ends in node: ',mapnode%seqx ! >>> We must also mark the "%done=-1" in the linehead record corresponding to ! the line we just followed. ! 1000 continue return end subroutine map_newnode ! redefined argument mecreq to mecreq1 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine sort_invph !\begin{verbatim} subroutine sort_invph(nitems,ndim,array) ! primitive sorting of array implicit none integer nitems,ndim,array(ndim,*) !\end{verbatim} ! sort array in acending order of value in array(3,*) integer ia,ib,ic,more more=nitems ia=1 do while(more.gt.0) more=0 do ia=2,nitems if(array(3,ia-1).gt.array(3,ia)) then more=more+1 do ic=1,ndim ib=array(ic,ia-1); array(ic,ia-1)=array(ic,ia); array(ic,ia)=ib enddo endif enddo enddo 1000 continue end subroutine sort_invph !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine find_inv_exits !\begin{verbatim} subroutine find_inv_exits(nexit,phut,phin,stabph,invph,dim1,axarr,thisceq) ! Find the phases to be linefix when nodefix with zero amount at the invariant ! NEW IDEA (N is numbe of elements) ! 1. extract the composition of all stable phases at invariant (N+1) ! 2. set up a system of linear equations M_j x_ij = c_i ! where x_ij is composition of component i in phase j, c_i is the condition ! for component i, (N-1 conditions) and M_j amount of phase j ! 3. The cases when his system has a solution represent exits! ! This also solves the problem with the number of exits! ! The conditions must be simple, such as x(cr)=0.05 ... ! Normal conditions are T, P, N and x, with N-1 x conditions. ! For 5 components, 6 phases at invariant, 4 mass balance conditions ! input/output: ! nexit is number of pairs that form two exit lines ! phut(1,*) and (2,*) are two phases with zero amount at the invariant ! phin is on enter the two phase with zero amount when the invariant is found ! stabph is number of stable phases along the lines, at node point 2 more stable ! invph is matrix with all phases at the node, dim1 is its first dim ! dim1 is first dimension of invph ! axarr has axis information (needed to maniplulate conditions) ! eqcopy1 is array with phase anounts and constitutions at new point (not used) ! linerec is a line record with all necessary data to calculate en equil implicit none integer nexit,phut(2,*),phin(2),stabph,dim1,invph(dim1,*),par(2) type(map_axis), dimension(*) :: axarr double precision, dimension(:), allocatable :: eqcopy1 type(gtp_equilibrium_data), pointer :: thisceq ! type(map_line), pointer :: linerec !\end{verbatim} double precision, allocatable, dimension(:) :: condval,rhs double precision, allocatable, dimension(:,:) :: phaseval,test type(gtp_condition), pointer :: lastcond,pcond,axcond type(gtp_state_variable), pointer :: statevar ! assume less than 20 components ... integer, parameter :: mcomp=20 character text*32,ch1*1 integer, allocatable, dimension(:) :: ipiv,jphase type(gtp_state_variable), dimension(mcomp), target :: stvarray ! integer ii,jj,kk,mm,ip,seqz,ncomp,ncomp1,info,ldb,zz ! dim is number of phases at the invariant, dim-1 is number of components ! For 5 components, 6 phases at invariant, select 4 phases to find exit ! x_ij is fraction of j in phase i ! x_11 + x_21 + x_31 N_1 C_1 ! ( x_12 + x_22 + x_32 ) ( N_2 ) = ( C_2 ) ! x_13 + x_23 + x_33 N_3 C_3 ! 1 1 1 N_4 1 ! to find N_i (which must be >0). The two excluded phases represet the exit ! ! 1. extract all condition values, skip the axis condition allocate(condval(stabph-1)) lastcond=>thisceq%lastcondition pcond=>lastcond%next ncomp=0 cloop: do while(.true.) cskip: if(pcond%active.eq.0) then ! this is an active condition, extract the state variable record statevar=>pcond%statvar(1) if(statevar%statevarid.ge.10 .and. statevar%argtyp.eq.1) then ! statevarid>=10 is extensive condition on a component seqz=pcond%seqz ! skip axis conditions if(seqz.eq.axarr(1)%seqz .or. seqz.eq.axarr(1)%seqz) exit cskip ! There must not be any terms if(pcond%noofterms.gt.1) cycle cloop ip=1 ncomp=ncomp+1 ! remember the state variable to be used extracting values from phases stvarray(ncomp)=statevar if(ncomp.gt.mcomp) stop 'SMP Too many components' condval(ncomp)=pcond%prescribed ! call get_one_condition(ip,text,seqz,thisceq) ! write(*,*)'SMP condition: ',trim(text),ncomp,condval(ncomp) endif endif cskip if(associated(pcond,lastcond)) exit cloop pcond=>pcond%next enddo cloop ! we must have extracted stabph-1 extensive conditions ... if(ncomp.ne.stabph-1) then write(*,*)'SMP too few conditions for invariants',ncomp,stabph-2 gx%bmperr=4399; goto 1000 endif ! 2. extract all phase compositions, for stabph+2 phases and ncomp compositions allocate(phaseval(ncomp,stabph+2)) do ii=1,stabph+2 do jj=1,ncomp ! insert phase index to get phase composition stvarray(jj)%argtyp=3 stvarray(jj)%phase=invph(1,ii) stvarray(jj)%compset=invph(2,ii) ! this subroutine uses character as argument ! call get_state_var_value(stvarray(jj),phaseval(jj,ii),text,thisceq) ! this subroutine uses state variable as argument statevar=>stvarray(jj) call state_variable_val(statevar,phaseval(jj,ii),thisceq) if(gx%bmperr.ne.0) then write(*,*)'SMP error extracting phase value',trim(text),ii,jj goto 1000 endif enddo enddo !---------------------------------- ! This is the invariant used to debug this !Output for equilibrium: 1, DEFAULT_EQUILIBRIUM 2020.04.28 !Conditions .................................................: ! 1:P=100000, 2:N=1, 3:W%(CR)=5, 4:W%(MO)=8, 5:W%(V)=1, 6:=0, ! 7:=0 ! Degrees of freedom are 0 ! !Some global data, reference state SER ......................: !T= 1232.69 K ( 959.54 C), P= 1.0000E+05 Pa, V= 6.4311E-06 m3 !N= 1.0000E+00 moles, B= 5.4289E+01 g, RT= 1.0249E+04 J/mol !G= -6.09563E+04 J, G/N=-6.0956E+04 J/mol, H= 3.4334E+04 J, S= 7.730E+01 J/K ! !Some data for components ...................................: !Component name Moles Mass-fr Chem.pot/RT Activities Ref.state !C 7.1177E-02 0.01575 -3.2298E+00 3.9566E-02 SER (default) !CR 5.2205E-02 0.05000 -7.7539E+00 4.2908E-04 SER (default) !FE 8.2069E-01 0.84425 -5.8469E+00 2.8888E-03 SER (default) !MO 4.5269E-02 0.08000 -8.0031E+00 3.3442E-04 SER (default) !V 1.0657E-02 0.01000 -1.4256E+01 6.4376E-07 SER (default) ! !Some data for phases .......................................: !Name Status Mass Volume Form.Units Cmp/FU dGm/RT Comp: !FCC_A1#1................ E 4.802E-02 6.36E-06 8.48E-01 1.03 0.00E+00 W: ! FE 9.34742E-01 MO 2.09038E-02 C 7.38762E-03 V 1.04403E-03 ! CR 3.59223E-02 ! !MC_FCC_A1#2............. E 7.219E-04 6.12E-09 9.35E-03 1.86 0.00E+00 W: ! MO 4.38724E-01 C 1.33163E-01 CR 4.68908E-02 FE 6.00860E-03 ! V 3.75214E-01 ! !HCP_A3.................. E 3.954E-03 6.74E-08 4.54E-02 1.50 0.00E+00 W: ! MO 7.20128E-01 FE 7.62966E-02 C 6.87569E-02 V 4.49350E-02 ! CR 8.98830E-02 ! !KSI_CARBIDE............. F 0.000E+00 0.00E+00 0.00E+00 4.00 0.00E+00 W: ! FE 4.58671E-01 CR 9.59266E-02 C 5.64977E-02 V 0.00000E+00 ! MO 3.88905E-01 ! !M23C6................... F 0.000E+00 0.00E+00 0.00E+00 29.00 0.00E+00 W: ! FE 5.94954E-01 MO 1.04967E-01 C 5.17714E-02 V 1.20517E-04 ! CR 2.48187E-01 ! !M7C3.................... E 1.590E-03 0.00E+00 3.67E-03 10.00 0.00E+00 W: ! FE 4.01696E-01 MO 1.09953E-01 C 8.31013E-02 V 2.77992E-02 ! CR 3.77451E-01 ! ! In alphabetical order of phases and components (mass percent) ! Phase Cr Mo V Mass of phase ?? ! FCC 3.59223 2.09038 0.1044 0.04802 ! MC_FCC 4.68908 43.8724 37.5214 0.0007219 ! HCP 8.98830 72.0128 4.4925 0.003954 ! KSI 9.59266 38.8905 0 0 ! M23 24.8187 10.4967 0.00012 0 ! M7 37.7451 10.9953 2.77992 0.001590 !----------------------------------- ! debug: ! do ii=1,stabph+2 ! write(*,88)'SMP all: ',ii,(phaseval(jj,ii),jj=1,ncomp) ! enddo 88 format(a,i3,6(1pe12.4)) ! The code gives: (in mass percent) ! 3.5822 2.0904 0.1044 etc ... ! ALL CORRECT!! WOW ! (missing in list result is mass %! I have only mass fraction) ! ! 3. select submatrix with dim-2 phases and solve for phase fractions. ! For solutions with phase phase fractions >0 the 2 excluded phases ! are exits. nexit=0 ncomp1=ncomp+1 allocate(test(ncomp1,ncomp1)) allocate(rhs(ncomp1)) allocate(ipiv(ncomp1)) ! I am not certain of this dimensioning ... allocate(jphase(ncomp1*(ncomp1+1))) ! allocate(lukas(ncomp1+1,ncomp1)) ! All possible ncomp x ncomp marices from phaseval are solved for phase amounts ! for the correct content of the components. One should find phin! ! This means we actually have 3 phases with zero amount at the lines?? ! The matrix phaseval has stabph+2 rows and columns ! We must copy this to test eliminating 3 rows ! THIS WAY OF GENERATING ALL COMBINATIONS OF ncomp x nacomp MATRICES IS ! involved but seems to work .... WoW do ii=1,ncomp1 jphase(ii)=ii enddo zz=0 kloop: do while(.true.) zz=zz+1 ! write(*,'(a,10i3)')'SMP subset ----------- ',zz,jphase ! test is destroyed when solving the system of linear equations ! and must be regenerated totally each time test=zero ! copy fractions from phaseval(P,*) represent fractions in phase P ! test(*,K) is fractions in all phases for component K do jj=1,ncomp1 do kk=1,ncomp test(kk,jj)=phaseval(kk,jphase(jj)) enddo enddo ! last line should be a row of 1.0 do kk=1,ncomp1 test(ncomp1,kk)=one enddo ! do jj=1,ncomp1 ! write(*,88)'SMP sub: ',zz,(test(jj,kk),kk=1,ncomp1) ! enddo !------------------------ ! this should be the solving ... ! LAPACK routine to L*U factorize A, the original A is destroyed ! call dgetrf(trans,n,nrhs,a,lda,ipiv,b,ldb,info) ! ipiv is array with N pivot ldb=ncomp1 call dgetrf(ncomp1,ncomp1,test,ldb,ipiv,info) if(info.ne.0) then write(*,*)'SMP error from dgetrf',info ! some combination of phases may not work, just skip goto 100 ! gx%bmperr=4399; goto 1000 endif ! solve the system of linear equations, X is overwritten by solution ! call dgetrs(trans,n,nrhs,a,lda,ipiv,b,ldb,info) do kk=1,ncomp rhs(kk)=condval(kk) enddo rhs(ncomp1)=one ! write(*,'(a,10(1pe10.2))')'SMP rhs: ',rhs call dgetrs('N',ncomp1,1,test,ldb,ipiv,rhs,ldb,info) if(info.ne.0) then ! some combination of phases may not work, just skip goto 100 ! write(*,*)'SMP error from dgetrs',info ! gx%bmperr=4399; goto 1000 endif 600 continue ! write(*,'(a,10(1pe10.2))')'SMP phase amounts: ',rhs ! check if all amounts greater than zero do kk=1,ncomp1 if(rhs(kk).le.zero) goto 100 enddo ! write(*,'(a,10(1pe11.3))')'SMP phase amounts: ',rhs ! Wow, now it works, but I must find which phases are excluded ! A very clumsy set to find which two phases that are excluded ... zz=0 ex1: do jj=1,stabph+2 do kk=1,stabph+2 if(jphase(kk).eq.jj) cycle ex1 enddo zz=zz+1; par(zz)=jj enddo ex1 ! write(*,'(a,20i3)')'SMP solution ',zz,jphase,0,phin,par ! write(*,'(a,20i3)')'SMP solution ',zz,phin,par ! we must have found 2 phases ... bug using map15 if(zz.ne.2) goto 100 ! check if solution equal to phin if((par(1).eq.phin(1) .or. par(1).eq.phin(2)) .and. & (par(2).eq.phin(1) .or. par(2).eq.phin(2))) then continue ! write(*,'(a,2i3,3x,2i2)')'SMP same as phin: ',par,phin else nexit=nexit+1 phut(1,nexit)=par(1) phut(2,nexit)=par(2) endif ! read(*,'(a)')ch1 ! here we have solved the system of linear equations !------------------------ 100 continue ! exclude a different phase in jphase ... jj=ncomp1 kk=0 jloop: do while(.true.) jphase(jj)=jphase(jj)+1 if(jphase(jj).gt.stabph+2-kk) then jj=jj-1 kk=kk+1 if(jj.ge.1) cycle jloop exit kloop else exit jloop endif ! increment all values in jphase after jj enddo jloop do kk=jj+1,ncomp1 jphase(kk)=jphase(kk-1)+1 enddo enddo kloop ! now we have found the all exits ... ! write(*,'(a,i3,5(i5,i3))')'SMP exits: ',nexit,& ! (phut(1,jj),phut(2,jj),jj=1,nexit) ! 1000 continue return end subroutine find_inv_exits !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine find_inv_nodephase !\begin{verbatim} subroutine find_inv_nodephase(phut,phin,stabph,invph,dim1,axarr,& eqcopy1,linerec) ! Find the phase to set as linefix when nodefix has zero amount ! phut will on exit be two phases with zero amount at the invariant ! phin is on enter the two phase with zero amount when the invariant is found ! stabph is number of stable phases along the lines, at node point 2 more stable ! invph is matrix with all phases at the node, dim1 is its first dim ! axarr has axis information (needed to manipulate conditions) ! eqcopy1 is array with phase anounts and constitutions at new point (not used) ! linerec is a line record with all necessary data to calculate en equil implicit none integer phut(2),phin(2),stabph,dim1,invph(dim1,*) type(map_axis), dimension(*) :: axarr double precision, dimension(:), allocatable :: eqcopy1 type(map_line), pointer :: linerec !\end{verbatim} ! linefix and nodefix is 2nd index in invph(5,*) type(gtp_condition), pointer :: lastcond,pcond,pcondx,pcondt ! type(gtp_equilibrium_data), target :: thisceq1 type(gtp_equilibrium_data), pointer :: thisceq integer linefix,nodefix,reset,ph1,ph2,lokcs1,lokcs2,onemoretry integer ii,jj,kk,nodeph,mapx,iadd,irem,iz,jax,mode,okcond,lokph,zeroam character*24 phname1,phname2,phname3,phname4 double precision, parameter :: mamfu=1.0D-6,mdgm=1.0D-4 double precision, dimension(:), allocatable :: eqcopy ! ! we must set the axis condition on T and ! remove the axis condition on the composition on the other axis !-------------------- copied from somewhere ................... ! write(*,10)phin,stabph,linerec%lineceq%tpval(1) 10 format(/'SMP find_inv exits from isopleth invariant: ',2i4,2x,i2,F10.2) reset=globaldata%status ! supress messages from calceq3 done inside find_inv globaldata%status=ibset(globaldata%status,GSSILENT) globaldata%status=ibclr(globaldata%status,GSSILENT) ! I wonder how much is copied when I use = ...? ! lineceq is an equilibrium record in eqlista ... thisceq=>linerec%lineceq write(*,*)'SMP exit equilibrum: ',thisceq%eqname ! constitution is OK here ! call list_conditions(kou,linerec%lineceq) ! call list_sorted_phases(kou,thisceq) ! write(*,*)'SMP constitution entering find_inv' ! suspend all phases not involved in the invariant, 1 means suspend call suspend_somephases(1,invph,6,stabph+2,thisceq) if(gx%bmperr.ne.0) then write(*,*)'SMP error calling suspend_somephases'; goto 1000 endif if(allocated(eqcopy)) deallocate(eqcopy) call save_phase_constitutions(0,thisceq,eqcopy) if(gx%bmperr.ne.0) goto 1000 ! loop both axis to extract condition pointer okcond=0 do jax=1,2 ! Set the condition on T and remember the condition on composition lastcond=>thisceq%lastcondition if(.not.associated(lastcond)) then write(*,*)'in find_inv, no conditions: ',jax gx%bmperr=4221; goto 1000 endif pcond=>lastcond 60 continue pcond=>pcond%next if(pcond%seqz.eq.axarr(jax)%seqz) goto 70 if(.not.associated(pcond,lastcond)) goto 60 write(*,*)'in find_inv the axis condition not found: ',jax gx%bmperr=4221; goto 1000 ! 70 continue if(pcond%statev.ge.10) then ! save pointer to extensive condition and remove it pcond%active=1 okcond=okcond+1 pcondx=>pcond elseif(pcond%statev.eq.1) then ! set condition on T as active okcond=okcond+1 pcondt=>pcond ! try setting two fix phases .... remove condition on T ! pcond%active=1 endif enddo if(okcond.ne.2) then write(*,*)'Conditions not T and X, quitting' gx%bmperr=4399 goto 1000 endif !----------------- end copy from somewhere................. ! most of these variables are just for debugging ph1=phin(1) ph2=phin(2) ! extract the name of the linefix and nodefix phases call get_phase_name(invph(1,ph1),invph(2,ph1),phname1) call get_phase_name(invph(1,ph2),invph(2,ph2),phname2) ! set small amounts of ph1 ?? ! call change_many_phase_status(phname1,PHENTSTAB,mamfu,thisceq) ! call change_many_phase_status(phname1,PHENTSTAB,zero,thisceq) ! if(gx%bmperr.ne.0) then ! write(*,*)'SMP error setting zero of line/nodefix' ! goto 1000 ! endif ! below we check the amounts and driving forces of both linefix and nodefix ! Note the phase_varres indices are the same in all equilibria! call get_phase_compset(invph(1,ph1),invph(2,ph1),lokph,lokcs1) call get_phase_compset(invph(1,ph2),invph(2,ph2),lokph,lokcs2) if(gx%bmperr.ne.0) then write(*,*)'SMP find_inv failed get phase_varres index' goto 1000 endif ! remove the condition on compostion and set fix T pcondx%active=1 pcondt%active=0 !------------------------------------------------------- ! ! the loop below tries set fix one phase at a time to discover an exit ! where one other phase is stable with zero amount ! Initial amounts of phases and constitutions are in eqcopy ! all calculations below are made at fixed T with different fix phases ! afterwards we check that the amount of nodefix is still zero (or very small) ! total number of phases at nodepoint is stabph+2 call list_sorted_phases(kou,0,thisceq) write(*,*)'SMP above listing for initial set of stable phases',gx%bmperr loop: do ii=1,stabph+2 unused: if(invph(4,ii).eq.0 .and. invph(5,ii).eq.0) then ! only test phases which has not already been used, extract its name call get_phase_name(invph(1,ii),invph(2,ii),phname3) onemoretry=0 ! jump back here to try with a small amount of phname1 or phname2 (no good) 50 continue ! restore inital amounts and constitutions 1 copies from eqcopy to thisceq call save_phase_constitutions(1,thisceq,eqcopy) call list_sorted_phases(kou,0,thisceq) write(*,76)trim(phname3),ii,thisceq%tpval(1),gx%bmperr 76 format(/'SMP find_inv ******** testing as fixed: ',a,i4,F10.2,i7) ! set ii fix with zero amount call change_many_phase_status(phname3,PHFIXED,zero,thisceq) ! debug listing call list_conditions(kou,thisceq) write(*,*)'SMP find_inv call calceq3:',gx%bmperr,onemoretry mode=0 call calceq3(mode,.FALSE.,thisceq) if(gx%bmperr.ne.0) then ! calculation error, remove phase ii as fix and try another write(*,*)'SMP find_inv error finding exit with fix: ',& trim(phname3),gx%bmperr gx%bmperr=0 call list_conditions(kou,thisceq) call list_sorted_phases(kou,0,thisceq) ! remove this phase as fix and continue loop goto 120 endif ! debug listing call list_conditions(kou,thisceq) call list_sorted_phases(kou,0,thisceq) write(*,*)'SMP find_inv: phases AFTER calculations',gx%bmperr jj=0 zeroam=0 zeroloop: do kk=1,stabph+2 ! At any exit all phases invph should have almost zero dgm if(abs(thisceq%phase_varres(invph(6,kk))%dgm).gt.mdgm) then write(*,*)'SMP too negative dgm: ',kk,& thisceq%phase_varres(invph(6,kk))%dgm ! exit unused endif if(thisceq%phase_varres(invph(6,kk))%amfu.lt.mamfu) then ! we have a phase with zero amount if(kk.ne.ii) then if(zeroam.eq.0) then zeroam=kk else write(*,*)'SMP two or more zero amount phases' endif endif else jj=jj+1 endif enddo zeroloop ! write(*,*)'SMP number of stable phases',jj,stabph ! call list_sorted_phases(kou,thisceq) if(jj.ne.stabph) then write(*,'(a,2i3,F10.2)')'SMP Skip wrong number of stable phases',& jj,stabph+2,thisceq%tpval(1) goto 120 endif write(*,'(a,3(i5,i3))')'SMP phin: ',jj,stabph,invph(4,phin(1)),& invph(5,phin(1)),invph(4,phin(2)),invph(5,phin(2)) ! select either phin(1) or phin(2) if free and zero amount with this phase if(invph(4,phin(1)).eq.1 .and.& thisceq%phase_varres(lokcs1)%amfu.lt.mamfu) then ! phase invph(*,ii) and invph(*,phin(1)) have zero amount, use as exit? ! ADD CHECK IF amfu for BOTH phin(1) and ph(2) are zero we must check dgm ... phut(1)=ii; phut(2)=phin(1) write(*,112)trim(phname3)//'+'//trim(phname1),phut(1),phut(2),& thisceq%tpval(1) 112 format('SMP find_inv **** success: ',a,2i4,F10.2) goto 200 elseif(invph(4,phin(2)).eq.1 .and. & thisceq%phase_varres(lokcs2)%amfu.lt.mamfu) then ! phase invph(*,ii) and invph(*,phin(1)) have zero amount, use this as exit phut(1)=ii; phut(2)=phin(2) write(*,112)trim(phname3)//'+'//trim(phname2),phut(1),phut(2),& thisceq%tpval(1) goto 200 elseif(invph(4,phin(1)).eq.1 .and. invph(4,phin(2)).eq.1) then ! This is first call to find_inv and we have found two new phases with ! zero amount. We do not need to find any more! call get_phase_name(invph(1,zeroam),invph(2,zeroam),phname4) ! Indicae this by setting it negative! phut(1)=ii; phut(2)=-zeroam write(*,114)trim(phname3)//'+'//trim(phname4),phut(1),-phut(2),& thisceq%tpval(1) 114 format('SMP find_inv **** success BUT IGNORED: ',a,2i4,F10.2) else call list_sorted_phases(kou,0,thisceq) write(*,113)trim(phname3),trim(phname1)//' nor '//trim(phname2) 113 format('SMP Skipping ',a,' as neither ',a,' has zero amount') endif 120 continue ! Failed but make two more tries. Constitutions restored above ! if(onemoretry.eq.0) then ! try once more ... ! write(*,*)'SMP try one more time with fix ',trim(phname3) ! call change_many_phase_status(phname1,PHENTSTAB,1.0D-2,thisceq) ! onemoretry=1 ! goto 50 ! elseif(onemoretry.eq.1) then ! try once more ... ! onemoretry=2 ! write(*,*)'SMP try one more time with fix ',trim(phname3) ! call change_many_phase_status(phname2,PHENTSTAB,1.0D-2,thisceq) ! goto 50 ! endif ! giv up on this fix phase endif unused ! try another fix phase ... call change_many_phase_status(phname3,PHENTERED,zero,thisceq) if(gx%bmperr.ne.0) goto 1000 enddo loop ! we have not found any set of phases for an exit line ! if we arrive here we should maybe try 2 fix phases and release T? write(*,*)'SMP find_inv failed to find two phases with zero amount' gx%bmperr=4399; goto 1000 200 continue ! we have a pair of phases in phut, reset phname3 as entered call change_many_phase_status(phname3,PHENTERED,zero,thisceq) ! copy constitution from thisceq to eqcopy, then copy to linerec%lineceq ! call save_phase_constitutions(1,thisceq,eqcopy) if(allocated(eqcopy)) deallocate(eqcopy) call save_phase_constitutions(0,thisceq,eqcopy) call save_phase_constitutions(1,linerec%lineceq,eqcopy) if(gx%bmperr.ne.0) write(*,*)'Problem to copy constitutions' !----------------------------- exit 1000 continue ii=gx%bmperr; gx%bmperr=0 ! restore axis conditions, set x condition and remove T condition pcondx%active=0 pcondt%active=1 ! If we have found an exit the phase set and constitution are in thisceq ! Restore phases earlier suspended, 0 menas restore call suspend_somephases(0,invph,6,stabph+2,thisceq) if(gx%bmperr.ne.0) then write(*,*)'SMP error calling suspend_somephases'; goto 1000 endif if(allocated(eqcopy)) deallocate(eqcopy) gx%bmperr=ii ! reset globaldata%status globaldata%status=reset return end subroutine find_inv_nodephase !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine reserve_saveceq !\begin{verbatim} subroutine reserve_saveceq(location,saveceq) ! must be THREADPROTECTED ! location index of reserved ceq record in saveceq implicit none integer location type(map_ceqresults), pointer :: saveceq !\end{verbatim} location=saveceq%free ! write(*,*)'SMP reserve record: ',location,saveceq%size ! write(*,*)'Reserve place for equilibrium: ',location,saveceq%size if(location.eq.saveceq%size-10) then ! indicate overflow with 5 places left if some emergency saving needed write(*,*)'Close to overflow in saveceq: ',saveceq%free gx%bmperr=4219; goto 1000 endif saveceq%free=location+1 ! end THREADPROTECT 1000 continue return end subroutine reserve_saveceq !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine map_findline !\begin{verbatim} subroutine map_findline(maptop,axarr,mapfix,mapline) ! must be THREADPROTECTED ! Searches all node records from maptop for a map_line record to be calculated ! ?? already been found and if so eliminate a line record ?? ! maptop map node record ! axarr array with axis records ! mapfix returned fixph record with phases to be ste as fixed for this line ! mapline returned mapline record for line to be calculated type(map_node), pointer :: maptop type(map_line), pointer :: mapline type(map_axis), dimension(*) :: axarr type(map_fixph), allocatable :: mapfix ! memory leak as mapfix is allocated below ... ! type(map_fixph), pointer :: mapfix !\end{verbatim} type(map_node), pointer :: mapnode type(gtp_condition), pointer :: pcond type(meq_setup), pointer :: meqrec type(gtp_equilibrium_data), pointer :: ceq2 type(gtp_state_variable), pointer :: svrrec,svr2 type(gtp_state_variable), target :: svrtarget integer nyline,jp,seqy,iph,ics,lokph,lokcs,ip,mapx integer mode,nofecond,jax,activax,irem1,iadd1,irem,iadd integer, parameter :: inmap=1 double precision finc,fixpham,xstab,xfix,xcorr,natpermol character eqname*24 ! sometimes there are many phases with long names ... character phaseset*512 logical hullerombuller ! mapnode=>maptop ! for the moment skip this for tie-lines not in the plane ! write(*,*)'In map_findline: ',mapnode%tieline_inplane 100 continue ! write(*,*)'Looking a lines exiting from all nodes:' ! write(*,*)'mapnode index: ',mapnode%seqx if(.not.allocated(mapnode%linehead)) then write(*,*)'ERROR found mapnode without exits' nullify(mapline) goto 1000 endif ! write(*,*)'map_findline: ',mapnode%lines do nyline=1,mapnode%lines ! if done is >=0 then this is a line to be calculated if(mapnode%linehead(nyline)%done.ge.0) then mapline=>mapnode%linehead(nyline) mapline%done=-1 goto 500 endif enddo ! write(*,*)'findline 1: ',mapnode%seqx mapnode=>mapnode%next ! write(*,*)'findline 2: ',mapnode%seqx if(.not.associated(mapnode,maptop)) goto 100 ! no more lines to calculate if(ocv()) write(*,*)'nullifying mapline as no more lines to calculate' nullify(mapline); goto 1000 ! jump here if we found a nyline !-------------------------------------------------------------------- 500 continue ! we must copy the equilibrium record ceq to the line record goto 503 !---------------------------------------------------------------------- ! code deleted !--------------------------------------------------------------------- 503 continue ! write(*,*)'At label 503',mapline%firstinc if(mapline%firstinc.ne.zero) then ! update the axis condition if mapline%firstinc is nonzero jp=abs(mapline%axandir) call locate_condition(axarr(jp)%seqz,pcond,mapline%lineceq) if(gx%bmperr.ne.0) goto 1000 ! Wow, here is the problem !!! pcond%prescribed=pcond%prescribed+mapline%firstinc finc=mapline%firstinc if(ocv()) write(*,501)'Selecting line and condition: ',& seqy,pcond%prescribed,finc 501 format(a,i3,2(1pe14.6)) ! if(pcond%active.ne.0) then ! write(*,*)'Error: axis condition not active!' ! pcond%active=0 ! endif endif ! check that correct axis condition is active, maybe I have not made sure ! that the map_line records are independent ... ! write(*,*)'axies ',maptop%number_ofaxis do jp=1,maptop%number_ofaxis call locate_condition(axarr(jp)%seqz,pcond,mapline%lineceq) ! write(*,*)'condition located',jp,axarr(jp)%seqz if(gx%bmperr.ne.0) goto 1000 if(pcond%active.ne.0) then if(jp.eq.abs(mapline%axandir)) then ! write(*,*)'Setting axis condition active!',jp,mapline%axandir pcond%active=0 ! write(*,*)'map_findline: ',jp,pcond%prescribed endif else if(jp.ne.abs(mapline%axandir)) then ! write(*,*)'Setting axis condition NOT active!',jp,mapline%axandir pcond%active=1 endif endif enddo ! we may have a set of stable phases in mapnode%stable_phases, maybe they ! should be set, at least when mapping. ! a meqrec record will be created by calceq7 at the first calculation ! for mapping set values in mapfix about which phases that should be fix ! or stable when calling calceq7, at present ingnore that !------------------------------------------------------------- ! write(*,*)'tielines: ',maptop%tieline_inplane if(maptop%tieline_inplane.lt.0) then ! ISOPLETH if(allocated(mapfix)) then deallocate(mapfix) endif allocate(mapfix) ! with only 2 axis we have just 1 fix phase for mapping, fixph is a tuple allocate(mapfix%fixph(1)) mapfix%status=0 mapfix%nfixph=1 mapfix%fixph=mapline%linefixph(1) ! we can have several stable phases when no tie-lines in plane ip=mapline%nstabph allocate(mapfix%stableph(ip)) allocate(mapfix%stablepham(ip)) allocate(mapfix%stable_phr(ip)) ! write(*,*)'Findline: Tie-lines not in plane: ',nyline,ip ! create a heading text for the line phaseset=' ' call get_phasetuple_name(mapfix%fixph(1),phaseset) if(gx%bmperr.ne.0) goto 1000 ip=len_trim(phaseset) phaseset(ip+1:ip+10)=', stable: ' ip=len_trim(phaseset)+2 if(mapnode%linehead(nyline)%nstabph.le.0) then write(*,*)'No stable phases for a line' write(*,*)'Error 14: ',nyline,mapnode%linehead(nyline)%nstabph,& mapnode%linehead(nyline)%stableph(1)%ixphase,& mapnode%linehead(nyline)%stableph(1)%compset mapfix%nstabph=0 gx%bmperr=4242; goto 1000 endif mapfix%nstabph=mapnode%linehead(nyline)%nstabph ! write(*,*)'Findline: stable phases: ',mapfix%nstabph do jp=1,mapfix%nstabph ! this is stored only for "real" nodes mapfix%stableph(jp)=mapnode%linehead(nyline)%stableph(jp) mapfix%stable_phr(jp)=mapnode%linehead(nyline)%stable_phr(jp) call get_phasetuple_name(mapfix%stableph(jp),phaseset(ip:)) if(gx%bmperr.ne.0) goto 1000 ! this values hould perhaps be in linehead?? ! mapfix%stablepham(jp)=mapnode%linehead(nyline)%stablepham(jp) mapfix%stablepham(jp)=one ! call get_phase_compset(mapfix%stableph(1)%phase,& ! mapfix%stableph(1)%compset,lokph,lokcs) ! mapline%lineceq%phase_varres(lokcs)%amfu=one ip=len_trim(phaseset)+2 enddo write(kou,520)mapline%lineid,mapline%lineceq%tpval(1),phaseset(1:ip) 520 format(/'Line ',i3,' T=',F8.2,' fix: ',a) !------------------------------------------------------------- elseif(maptop%tieline_inplane.gt.0) then ! TIE-LINES IN PLANE, NOTE: meqrec not allocated!! ! if(mapnode%nodefix%phase.gt.0) then ! write(*,*)'We have to set the fix phase along the line: ',& ! mapnode%nodefix%phase,mapnode%nodefix%compset ! phr no longer allocated ... ! iph=mapnode%meqrec%phr(mapnode%fixph)%iph ! ics=mapnode%meqrec%phr(mapnode%fixph)%ics ! call get_phase_compset(iph,ics,lokph,lokcs) ! write(*,*)'Setting phase status as fixed, phase_varres: ',lokcs ! mapline%lineceq%phase_varres(lokcs)%status2=& ! ibset(mapline%lineceq%phase_varres(lokcs)%status2,PHFIXED) ! endif ! mapline here should be identical to mapnode%linehead(nyline) ! if(ocv()) write(*,505)'In findline: add phase set for',& ! write(*,505)'In findline: add phase set for',& ! ' tie-lines in plane, node:',& ! mapnode%seqx,nyline,mapnode%linehead(nyline)%nstabph,nofecond !505 format(/a,a,10i4) if(allocated(mapfix)) then ! write(*,*)'Deallocating mapfix' deallocate(mapfix) endif allocate(mapfix) allocate(mapfix%fixph(1)) allocate(mapfix%stableph(1)) allocate(mapfix%stablepham(1)) allocate(mapfix%stable_phr(1)) mapfix%nfixph=1 mapfix%status=0 !......................................................... ! trying to impove mapping with two extensive axis variables nofecond=0 do jax=1,maptop%number_ofaxis call locate_condition(axarr(jax)%seqz,pcond,mapline%lineceq) if(gx%bmperr.ne.0) goto 1000 ! active condition means pcond%active=0 !! if(pcond%active.eq.0) activax=jax if(pcond%statev.gt.10) nofecond=nofecond+1 enddo ! default value fixpham=zero ! fix nonzero phase select!! ! if(nofecond.eq.2) then ! trying to have nonzero fix phase ... if(nofecond.eq.17) then ! skip trying to have nonzero fix phase ! ISOTHERMAL, two extensive axis variables ! test if we can have non-zero fix phase amount. Calculate the equilibrium ! set positive amount both in mapfix and in phase_varres ...?? write(*,47)activax,mapline%linefixph(1)%ixphase 47 format(/'*** Find_line nonzero fix phase',2i3,2(1pe12.4)) mapfix%fixph=mapline%linefixph(1) mapfix%stablepham(1)=one mapfix%stableph(1)=mapnode%linehead(nyline)%stableph(1) mapfix%stable_phr(1)=mapnode%linehead(nyline)%stable_phr(1) ! ceq2=>mapline%lineceq meqrec=>mapline%meqrec mapfix%nstabph=1 write(*,54)mapfix%fixph%ixphase,mapfix%fixph%compset 54 format('SMP fix phase: ',2i5,1pe12.4) write(*,55)mapfix%nstabph,mapfix%stableph%ixphase,& mapfix%stableph%compset,mapfix%stablepham 55 format('SMP stable phase: ',i2,2i5,1pe12.4) ! meqrec is allocated inside calceq7. mode=1 use gridminimizer ! mode=0 no gridminimizer; mode=-1 no grid and no deallocation of phr mode=-1 call calceq7(mode,meqrec,mapfix,mapline%lineceq) write(*,7)gx%bmperr,iadd,irem 7 format('Calculated equilibrium in map_findline',3i5) if(gx%bmperr.ne.0) then write(*,*)'SMP Failed calculate equilibrium try to adjust amounts' gx%bmperr=0 iadd1=0; irem1=0 ! write(*,*)'SMP2A calling meq_sameset from map_findline 1' call meq_sameset(irem1,iadd1,mapx,mapline%meqrec,& mapline%meqrec%phr,inmap,mapline%lineceq) write(*,*)'Check with meq_sameset: ',gx%bmperr,irem1,iadd1 if(gx%bmperr.ne.0) then goto 1000 elseif(iadd1.ne. 0 .or. irem1.ne.0) then write(*,*)'ignore nozero iadd or irem' endif endif ! try to change the amount of the fix phase by selecting a composition ! along the tieline with 30% of the fix phase ! Now we must change a condition ... call locate_condition(axarr(activax)%seqz,pcond,mapline%lineceq) ! write(*,*)'SMP2A Located condition',activax svrrec=>pcond%statvar(1) ! NOTE: If we change fix/entered phase we must change axvals/axvals2 svrtarget=svrrec svrtarget%argtyp=3 ! calculate composition of entered phase ! svrtarget%phase=meqrec%phr(sj)%iph ! svrtarget%compset=meqrec%phr(sj)%ics svrtarget%phase=mapfix%stableph(1)%ixphase svrtarget%compset=mapfix%stableph(1)%compset ! This extracts the composition of the entered phase for first new line ! we must use a pointer in state_variable_val svr2=>svrtarget call state_variable_val(svr2,xstab,mapline%lineceq) if(gx%bmperr.ne.0) goto 1000 svrtarget%phase=mapfix%fixph(1)%ixphase svrtarget%compset=mapfix%fixph(1)%compset ! This extracts the composition of the entered phase for first new line ! we must use a pointer in state_variable_val svr2=>svrtarget call state_variable_val(svr2,xfix,mapline%lineceq) if(gx%bmperr.ne.0) goto 1000 ! set fix phase amount to 0.3 as we may find a third phase along the line .. ! but we must take into account how many moles of atoms in fix phase ! natpermol=meqrec%phr(??fixphase)%curd%abnorm(1) iadd=mapfix%fixph(1)%ixphase write(*,*)'SMP Natpermol: ',iadd,meqrec%phr(iadd)%curd%abnorm(1) natpermol=one fixpham=0.3D0/natpermol xcorr=(one-fixpham)*xstab+fixpham*xfix write(*,71)fixpham,xstab,xfix,xcorr 71 format('Change: ',4(1pe16.8)) ! first argument 1 means to extract the value, 0 means to set the value call condition_value(0,pcond,xcorr,mapline%lineceq) if(gx%bmperr.ne.0) then write(*,*)'Cannot set axis condition' gx%bmperr=4399; goto 1000 endif ! Then call meq_sameset ignoring any new phases that tries to be stable iadd=0; irem=0 ! write(*,*)'SMP2A Calling meq_sameset from map_findline 2' call meq_sameset(irem,iadd,mapx,mapline%meqrec,& mapline%meqrec%phr,inmap,mapline%lineceq) if(gx%bmperr.ne.0) then gx%bmperr=0; goto 1000 elseif(irem.gt.0 .or. irem.gt.0) then write(*,*)'ignoring new phases: ',irem,iadd endif ! change the amount of the fix phase allocate(mapfix%fixphamap(1)) mapfix%fixphamap(1)=fixpham ! if hullerombuller true below then it will change fix and stable phase hullerombuller=.FALSE. mapfix%stablepham(1)=one-fixpham write(*,*)'find mapline conditions: ' call list_conditions(kou,mapline%lineceq) ! goto 1000 !.................................. else !----------------------------------------------------------------------- ! with a potential axis ? ! we should check that the not-fixed phase can vary composition ... ! write(*,*)'SMP2A using code with nofecond.ne.17 !!' ip=mapnode%linehead(nyline)%stableph(1)%ixphase ! fixedcomposition is a logical funtion in gtp3F.F90 if(fixedcomposition(ip)) then mapfix%fixph=mapnode%linehead(nyline)%stableph(1) hullerombuller=.TRUE. ! write(*,*)'Selecting other phase as fix',mapfix%fixph%ixphase,& ! mapfix%fixph%compset else ! write(*,*)'Changing fix phase: ',mapline%linefixph(1)%ixphase,& ! mapline%linefixph(1)%compset mapfix%fixph=mapline%linefixph(1) hullerombuller=.FALSE. endif endif ! create a heading text for the line phaseset=' ' call get_phasetuple_name(mapfix%fixph(1),phaseset) if(gx%bmperr.ne.0) goto 1000 ip=len_trim(phaseset)+4 phaseset(ip-2:ip-2)='+' ! It seems to be diffcult to reset tjis variable .... repeatederr=0 ! write(*,*)'Fixed phase: ',mapfix%nfixph,& ! mapfix%fixph%ixphase,mapfix%fixph%compset if(mapnode%linehead(nyline)%nstabph.gt.0) then ! this is stored only for "real" nodes mapfix%nstabph=1 if(hullerombuller) then mapfix%stableph(1)=mapline%linefixph(1) mapfix%stable_phr(1)=mapline%linefix_phr(1) else mapfix%stableph(1)=mapnode%linehead(nyline)%stableph(1) mapfix%stable_phr(1)=mapnode%linehead(nyline)%stable_phr(1) endif call get_phasetuple_name(mapfix%stableph(1),phaseset(ip:)) if(gx%bmperr.ne.0) goto 1000 ! set positive amount both in mapfix and in phase_varres ...?? mapfix%stablepham(1)=one-fixpham ip=len_trim(phaseset) if(ip.gt.1) then write(kou,516)mapline%lineid,& mapline%lineceq%tpval(1),phaseset(1:ip) 516 format(/'New line: ',i3,' T=',F8.2,' with: ',a) ! write(*,507)' *** Phase fix: ',mapfix%fixph(1)%ixphase,& ! mapfix%fixph(1)%compset,', entered: ',& ! mapfix%stableph(1)%ixphase,& ! mapfix%stableph(1)%compset,', old node: ',mapline%nodfixph 507 format(a,2i3,a,2i3,a,2i3) else write(kou,521) 521 format(/'Line with unknown phases, wow') endif else write(*,*)'No stable phase!! why??' write(*,*)'stable 4: ',nyline,mapnode%linehead(nyline)%nstabph,& mapnode%linehead(nyline)%stableph(1)%ixphase,& mapnode%linehead(nyline)%stableph(1)%compset mapfix%nstabph=0 endif ! write(*,*)'SMP looking for segmentation fault' !------------------------------------------------------------- else ! For STEP we should set a small positive amount of a new stable phase ! if(mapnode%nodefix%phaseix.gt.0) then if(mapnode%nodefix%ixphase.gt.0) then ! If the fix phase at the node was disappearing the phase index is negative ! write(*,*)'Add a small amount to the new stable phase: ',& ! mapnode%nodefix%phase,mapnode%nodefix%compset ! call get_phase_compset(abs(mapnode%nodefix%phaseix),& call get_phase_compset(abs(mapnode%nodefix%ixphase),& mapnode%nodefix%compset,lokph,lokcs) mapline%lineceq%phase_varres(lokcs)%amfu=1.0D-2 endif ! phaseset=' ' ip=1 do jp=1,mapnode%linehead(1)%nstabph call get_phasetuple_name(mapnode%linehead(1)%stableph(jp),& phaseset(ip:)) if(gx%bmperr.ne.0) goto 1000 ip=len_trim(phaseset)+2 enddo if(ip.gt.1) then ! just to get current value of axis condition call locate_condition(axarr(1)%seqz,pcond,mapline%lineceq) if(gx%bmperr.ne.0) goto 1000 call condition_value(1,pcond,finc,mapline%lineceq) if(gx%bmperr.ne.0) goto 1000 write(kou,522)mapline%lineid,finc,phaseset(1:ip) 522 format(/'Line ',i3,' from ',1pe14.6,' with: ',a) else write(*,*)'Line with unkonwn stable phases: ',& mapnode%linehead(1)%nstabph endif ! write(*,*)'SMP is mapfix allocated? ',allocated(mapfix) ! if(.not.allocated(mapfix)) then ! for STEP calculations mapfix was normally not allocated but I need the status ! but instead of adding this set a bit in the meqrec record after first ! call to calceq7 ! allocate(mapfix) ! mapfix%nfixph=0 ! mapfix%status=0 ! if(btest(mapnode%status,STEPINVARIANT)) then ! write(*,*)'SMP invarant step node',mapnode%status ! mapfix%status=ibset(mapfix%status,STEPINVARIANT) ! endif ! endif endif 1000 continue return end subroutine map_findline !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine create_saveceq !\begin{verbatim} subroutine create_saveceq(ceqres,size) ! creates an array of equilibrium records to save calculated lines for step ! and map. This can be very big type(map_ceqresults), pointer :: ceqres integer size !\end{verbatim} ! write(*,*)'In create saveceq',size integer errall allocate(ceqres) ceqres%size=size ceqres%free=1 allocate(ceqres%savedceq(size),stat=errall) if(errall.ne.0) then write(*,*)'SMP2A Allocation error 1: ',errall gx%bmperr=4370; goto 1000 endif 1000 continue return end subroutine create_saveceq !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine delete_mapresults !\begin{verbatim} subroutine delete_mapresults(maptop) ! delete all saved results created by step or map TYPE(map_node), pointer :: maptop !\end{verbatim} type(map_ceqresults), pointer :: saveceq TYPE(map_node), pointer :: current,nexttop,mapnode,delnode TYPE(map_line), pointer :: linehead TYPE(gtp_equilibrium_data), pointer :: ceq integer ieq,jj ! integer place,lastused ! if(.not.associated(maptop)) then write(*,*)'No step or map results to delete' goto 1000 endif ! write(*,*)'smp2A in delete_mapresults' current=>maptop ! deloop: do while(associated(current)) ! write(*,*)'smp2A maybe no saveceq?',associated(current%saveceq) ! if(associated(current%saveceq)) & ! write(*,*)'Saved equilibria:',current%saveceq%free-1 ! current=>current%plotlink ! enddo deloop ! write(*,*)'All equilibria saved in mapnodes listed' ! all mapnodes has a pointer to first where the saveceq is allocated current=>maptop do while(associated(current)) ! write(*,*)'smp2a current associated' if(associated(current%saveceq)) then if(allocated(current%saveceq%savedceq)) then write(*,*)'SMP: deleting saved step/map line equilibria: ',& current%saveceq%free-1 deallocate(current%saveceq%savedceq) endif endif ! adding this write avoided a segmentation fault ... no longer ... ! write(*,*)'SMP: are there more mapnode records?',& ! associated(current%plotlink),associated(current%next) nexttop=>current%plotlink mapnode=>current%next do while(.not.associated(mapnode,current)) ! write(*,*)'SMP: cleaning up more',mapnode%lines if(allocated(mapnode%linehead)) then ! write(*,*)'SMP: cleaning maplines: ',size(mapnode%linehead) do jj=1,mapnode%lines ! should these be deallocated explicitly?? linehead=>mapnode%linehead(jj) if(allocated(linehead%axvals)) deallocate(linehead%axvals) if(allocated(linehead%axvals2)) deallocate(linehead%axvals2) if(allocated(linehead%axvalx)) deallocate(linehead%axvalx) enddo deallocate(mapnode%linehead) endif delnode=>mapnode mapnode=>mapnode%next deallocate(delnode) enddo delnode=>current current=>nexttop ! deallocate the last mapnode if(associated(current)) deallocate(delnode) enddo write(*,*)'Deleting _MAPx equilibria' ceq=>firsteq call delete_equilibria('_MAP*',ceq) 1000 continue return end subroutine delete_mapresults !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable integer function tieline_inplane !\begin{verbatim} integer function tieline_inplane(nax,axarr,ceq) ! returns -1 if tielines are not in the plane (isopleth) ! 0 for step calculations (nax=1) ! 1 if tielines in the plane (binary T-X, ternary isopleths ! set if more than one extensive variable is not axis variables ! nax number of axis ! axarr array with axis records integer nax type(map_axis), dimension(nax) :: axarr type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} type(gtp_condition), pointer :: lastcond,pcond integer noc,inplane,nexv,iax ! inplane=0 if(nax.eq.1) goto 1000 lastcond=>ceq%lastcondition if(.not.associated(lastcond)) then write(*,*)'Whops, mapping with no conditions?' gx%bmperr=4243; goto 1000 endif nexv=0 pcond=>lastcond 100 continue pcond=>pcond%next if(pcond%statev.gt.9) then ! statev>10 means extensive variable, maximum one not axis variable ! For example binary T-X has extra conditions, P,N; ternary X-X isoterm T,P,N ! A fix chemical potential OK, a fix phase is the same as activity condition if(pcond%active.eq.0) then ! active=0 means it is an active condition do iax=1,nax if(axarr(iax)%seqz.eq.pcond%seqz) goto 200 enddo ! we have a condition on an extensive variable that is not an axis nexv=nexv+1 200 continue endif endif if(.not.associated(pcond,lastcond)) goto 100 inplane=-1 if(nexv.le.1) inplane=1 1000 continue tieline_inplane=inplane ! if(ocv()) write(*,*)'tie-line in plane return: ',inplane return end function tieline_inplane !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_map_equilibrium !\begin{verbatim} subroutine list_map_equilibrium(maptop,mapline,axarr,xxx,typ) ! output of all relevant infor for a failed equilibrium calculation ! maptop map node record ! mapline current line record ! axarr array with axis records ! xxx current active axis value that caused problems to calculate ! typ indicates the type of problem integer typ type(map_node), pointer :: maptop type(map_line), pointer :: mapline type(map_axis), dimension(*) :: axarr double precision xxx !\end{verbatim} type(gtp_equilibrium_data), pointer :: ceq integer jj,nph,lokph,lokcs,fixph,fixcs character name*24 double precision yyy ! list current conditions (indicate active axis variable) ! list stable phases ! write(*,*)'SMP map problems: ',typ,gx%bmperr,mapline%nodfixph ceq=>mapline%lineceq call list_conditions(kou,ceq) ! There is only one fix phase at all mapping at present !! jj=1 fixph=mapline%meqrec%fixph(1,jj) fixcs=mapline%meqrec%fixph(2,jj) ! ! nph=noofphasetuples() nph=nooftup() write(*,66,advance='no') 66 format('Phases: ') do jj=1,nph lokcs=phasetuple(jj)%lokvares if(ceq%phase_varres(lokcs)%phstate.eq.PHENTSTAB) then yyy=ceq%phase_varres(lokcs)%amfu call get_phase_name(phasetuple(jj)%ixphase,phasetuple(jj)%compset,& name) if(phasetuple(jj)%ixphase.eq.fixph .and. & phasetuple(jj)%compset.eq.fixcs) then write(*,67,advance='no')'*'//trim(name)//'=',yyy else write(*,67,advance='no')trim(name)//'=',yyy endif 67 format(a,F4.1,1x) elseif(ceq%phase_varres(lokcs)%phstate.eq.PHFIXED) then ! Ahhh, the fix phase is not set as condition in ceq!! call get_phase_name(phasetuple(jj)%ixphase,phasetuple(jj)%compset,& name) write(*,67,advance='no')'*'//trim(name)//' ' endif enddo write(*,77)'SMP: ',fixph,fixcs,mapline%axandir,xxx 77 format(/,a,3i3,1pe14.6) ! try for the AL-Cr-Ni case ... tuple 16, FCC_L12#2, should not be stable ... ! lokcs=phasetuple(16)%lokvares ! ceq%phase_varres(lokcs)%phstate=PHENTERED ! 15 is FCC_L12 is fix with 1 mole! try changing amounts ! ceq%phase_varres(14)%amfu=one ! ceq%phase_varres(15)%amfu=zero ! 15 is FCC_L12 is fix with 1 mole! try changing fix phase to 14 BCC ! I think meqrec is deallocated after this we have to change somewhere else ! jj=1 ! mapline%meqrec%fixph(1,jj)=14 ! mapline%meqrec%fixph(2,jj)=1 ! 1000 continue return end subroutine list_map_equilibrium !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine map_problems !\begin{verbatim} subroutine map_problems(maptop,mapline,axarr,xxx,typ) ! jump here for different problems ! maptop map node record ! mapline current line record ! axarr array with axis records ! xxx current active axis value that caused problems to calculate ! typ indicates the type of problem integer typ type(map_node), pointer :: maptop type(map_line), pointer :: mapline type(map_axis), dimension(*) :: axarr double precision xxx !\end{verbatim} character ch1*1 integer oldaxis double precision yyy ! skip debug output ! write(*,7)'In map_problem: ',typ,mapline%problems,mapline%lasterr,& ! mapline%axandir,mapline%nodfixph,maptop%number_ofaxis,xxx 7 format(a,6i4,6(1pe14.6)) ! we can list the current conditions here, ! note fix phases for mapping not included as condition here!! ! write(*,*)'Map problems 1' ! call list_conditions(kou,mapline%lineceq) ! call list_short_results(kou,mapline%lineceq) ! read(*,10)ch1 10 format(a) ! for debugging: ! call list_map_equilibrium(maptop,mapline,axarr,xxx,typ) ! if(mapline%problems.gt.5) then if(mapline%problems.gt.2) then if(mapline%nodfixph.gt.0) then ! call list_conditions(kou,mapline%lineceq) ! if(gx%bmperr.ne.0) then ! write(*,*)'Error listing conditions' ! gx%bmperr=0 ! endif write(*,11)mapline%lineid,trim(mapline%lineceq%eqname) 11 format('SMP2A giving up on this line',i3,': ',a) ! write(*,11)mapline%lineid,trim(mapline%lineceq%eqname),& ! mapline%meqrec%phr(mapline%nodfixph)%iph,& ! mapline%meqrec%phr(mapline%nodfixph)%ics !11 format('I give up on this line',i3,2x,a,' with fix phase ',2i4) ! else ! write(*,11)mapline%nodfixph,mapline%lineceq%eqname,0,0 endif gx%bmperr=4244; goto 1000 endif ! write(*,*)'Map problems 2' !--------------------------------------------- ! list current conditions ! call list_conditions(kou,mapline%lineceq) if(maptop%number_ofaxis.eq.1) then ! for step only take smaller steps or calculate with grid minimizer if(typ.eq.1) then ! take a smaller step ! current axis condition value is xxx, mapline%firstinc is the step taken xxx=xxx-0.999*mapline%firstinc else write(*,*)'Unknown problem ',typ gx%bmperr=4245 endif goto 1000 endif !======================================================= ! two or more axis select case(typ) case default write(*,*)'Unknown problem ',typ gx%bmperr=4245 !------------------------------------------------------ case(1) ! error at first step, for map opposite direction ! current axis condition value is xxx, mapline%firstinc is the step taken yyy=xxx ! write(*,*)'First increment: ',mapline%axandir,mapline%firstinc if(mapline%problems.eq.1) then ! first time here take the step in opposite direction ! xxx=yyy-0.99D0*mapline%firstinc !>> xxx=yyy-1.01D0*mapline%firstinc best tested value xxx=yyy-1.01D0*mapline%firstinc mapline%axandir=-mapline%axandir elseif(mapline%problems.eq.2) then ! second time take a small step in previous direction ! xxx=yyy-0.02D0*mapline%firstinc !>> xxx=yyy+0.02D0*mapline%firstinc best tested value xxx=yyy+0.02D0*mapline%firstinc mapline%axandir=-mapline%axandir elseif(mapline%problems.eq.3) then ! third time take small step in other axis ! write(*,*)'Changing active axis' ! we must extract axis value, change condition etc. assume only 2 axis ! oldaxis=mapline%axandir ! mapline%axandir=3-mapline%axandir ! call list_conditions(kou,mapline%lineceq) elseif(mapline%problems.eq.4) then ! fourth time take small step in opposite direction (of axis set with 3) ! xxx=yyy-0.02D0*mapline%firstinc ! mapline%axandir=-mapline%axandir endif mapline%axfact=1.0D-2 ! the returned value xxx will be set as condition ! call condition_value(0,pcond,xxx,ceq) ! if(gx%bmperr.ne.0) goto 1000 !------------------------------------------------------ end select 1000 continue return end subroutine map_problems !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine map_halfstep_bad !\begin{verbatim} subroutine map_halfstep_bad(halfstep,type,axvalok,mapline,axarr,ceq) ! THIS MADE MANY MAP macro FAIL: 3,6,7,8,12,13 and finally crash ... ! Used when an error calculating a normal step or a node point ! take back the last sucessfully calculated axis value and take smaller step ! possibly one should also restore the ceq record. ! halfstep number of times halfstep has been called for this problem ! axvalok last cucessfully calculated value of active axis ! mapline line record ! axarr array with axis records ! ceq equilibrium record implicit none integer halfstep,type double precision axvalok TYPE(gtp_equilibrium_data), pointer :: ceq TYPE(map_line), pointer :: mapline type(map_axis), dimension(*) :: axarr !\end{verbatim} type(gtp_condition), pointer :: pcond double precision value double precision :: sfact=1.0D-2 integer jax ! write(*,*)'In map_halfstep_bad',halfstep if(halfstep.eq.1) then sfact=0.5D0 else sfact=sfact*sfact endif halfstep=halfstep+1 if(type.eq.1 .and. (axvalok.eq.zero .or. halfstep.ge.3)) then ! write(*,*)'Two phases competing to appear/disappear',axvalok,halfstep gx%bmperr=4246 else ! Previous axis value should be axvalok, find current jax=abs(mapline%axandir) call locate_condition(axarr(jax)%seqz,pcond,ceq) if(gx%bmperr.ne.0) goto 1000 ! first argument 1 means to get the value call condition_value(1,pcond,value,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'Current active axis value: ',value ! at first call remember the original axis value if(halfstep.eq.1) then if(ocv()) write(*,67)'First call to map_half, value:',value,axvalok 67 format(a,2(1pe14.6)) mapline%evenvalue=value elseif(halfstep.gt.3) then ! write(*,*)'SMP2A Tried halfstep 3 times, giving up' gx%bmperr=4368 endif if(mapline%axfact.le.1.0D-6) then ! error initiallizing axfact ??? write(*,*)'Too small value of mapline%axfact: ',mapline%axfact mapline%axfact=1.0D-3 endif ! take a small step if(mapline%axandir.gt.0) then value=axvalok+sfact*mapline%axfact*axarr(jax)%axinc else value=axvalok-sfact*mapline%axfact*axarr(jax)%axinc endif write(*,97)'Halfstep axis value: ',mapline%axandir,value,axvalok,& mapline%axfact,axarr(jax)%axinc 97 format(a,i2,5(1pe14.6)) ! first argument 0 means to set the value call condition_value(0,pcond,value,ceq) if(gx%bmperr.ne.0) goto 1000 if(ocv()) write(*,*)'Taking a small step, new axis value: ',jax,value endif 1000 continue return end subroutine map_halfstep_bad !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine map_halfstep !\begin{verbatim} subroutine map_halfstep(halfstep,type,axvalok,mapline,axarr,ceq) ! Used when an error calculating a normal step or a node point ! take back the last sucessfully calculated axis value and take smaller step ! possibly one should also restore the ceq record. ! halfstep number of times halfstep has been called for this problem ! axvalok last cucessfully calculated value of active axis ! mapline line record ! axarr array with axis records ! ceq equilibrium record implicit none integer halfstep,type double precision axvalok TYPE(gtp_equilibrium_data), pointer :: ceq TYPE(map_line), pointer :: mapline type(map_axis), dimension(*) :: axarr !\end{verbatim} type(gtp_condition), pointer :: pcond double precision value double precision, parameter :: sfact=1.0D-2 integer jax repeatederr=repeatederr+1 ! write(*,*)'In map_halfstep',halfstep,repeatederr halfstep=halfstep+1 if(type.eq.1 .and. (axvalok.eq.zero .or. halfstep.ge.3)) then ! write(*,*)'Two phases competing to appear/disappear',axvalok,halfstep gx%bmperr=4246 else ! Previous axis value should be axvalok, find current jax=abs(mapline%axandir) call locate_condition(axarr(jax)%seqz,pcond,ceq) if(gx%bmperr.ne.0) goto 1000 ! first argument 1 means to get the value call condition_value(1,pcond,value,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'Current active axis value: ',value ! at first call remember the original axis value if(halfstep.eq.1) then if(ocv()) write(*,67)'First call to map_half, value:',value,axvalok 67 format(a,2(1pe14.6)) mapline%evenvalue=value elseif(halfstep.gt.3) then ! write(*,*)'SMP2A Tried halfstep 3 times, giving up' gx%bmperr=4368 endif if(mapline%axfact.le.1.0D-6) then ! error initiallizing axfact ??? write(*,*)'Too small value of mapline%axfact: ',mapline%axfact mapline%axfact=1.0D-3 endif ! take a small step if(mapline%axandir.gt.0) then value=axvalok+1.0D-1*mapline%axfact*axarr(jax)%axinc else value=axvalok-1.0D-1*mapline%axfact*axarr(jax)%axinc endif ! write(*,97)'Halfstep axis value: ',mapline%axandir,value,axvalok,& ! mapline%axfact,axarr(jax)%axinc 97 format(a,i2,5(1pe14.6)) ! first argument 0 means to set the value call condition_value(0,pcond,value,ceq) if(gx%bmperr.ne.0) goto 1000 if(ocv()) write(*,*)'Taking a small step, new axis value: ',jax,value endif 1000 continue return end subroutine map_halfstep !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine step_separate !\begin{verbatim} subroutine step_separate(maptop,noofaxis,axarr,seqxyz,starteq) ! calculates for each phase separately along an axis (like G curves) ! There can not be any changes of the stable phase ... ! maptop map node record ! noofaxis must be 1 ! axarr array of axis records ! seqxyz indices for map and line records ! starteq equilibrium record for starting implicit none integer noofaxis,seqxyz(*) type(map_axis), dimension(noofaxis) :: axarr TYPE(gtp_equilibrium_data), pointer :: starteq TYPE(map_node), pointer :: maptop !\end{verbatim} TYPE(gtp_equilibrium_data), pointer :: ceq integer ntup,itup,iph,ics,nystat,inactive(4),notop,seqy,mode,jk integer jj,seqz,iadd,irem,nv,saveq,lokcs,mapx type(gtp_phasetuple), dimension(:), allocatable :: entphcs integer, dimension(:), allocatable :: stsphcs type(map_line), pointer :: mapline type(map_fixph), allocatable :: mapfix ! type(map_fixph), pointer :: mapfix ! TYPE(map_node), pointer :: curtop type(meq_setup), pointer :: meqrec type(gtp_condition), pointer :: pcond type(gtp_state_variable), pointer :: svr type(meq_phase), pointer :: phr double precision val,xxx,yyy,axvalok logical firstline ! integer, parameter :: maxsavedceq=2000 ! decreased to 1800 as I sometimes run out of memeory integer, parameter :: maxsavedceq=1800 character name*24 ! turns off convergence control for T integer, parameter :: inmap=1 ! ! write(*,*)'In step_separate' if(noofaxis.ne.1) then write(kou,*)'Step separate only with one axis variable' goto 1000 endif ! this subroutine returnes the total number of phase and composition sets ! call sumofphcs(ntup,ceq) ! ntup=totalphcs(starteq) ! ntup=nonsusphcs(starteq) ntup=nooftup() allocate(entphcs(ntup)) allocate(stsphcs(ntup)) itup=0 ceq=>starteq ! collect all current phase status and set all phases suspended nystat=-3 val=zero do iph=1,noph() do ics=1,noofcs(iph) itup=itup+1 ! entphcs(itup)%phaseix=iph entphcs(itup)%ixphase=iph entphcs(itup)%compset=ics stsphcs(itup)=test_phase_status(iph,ics,val,ceq) ! write(*,*)'step-sep ',iph,noofcs(iph),ics,itup,stsphcs(itup) if(gx%bmperr.ne.0) goto 1000 ! phase status -1, 0 and 1 are all saved as 0 if(stsphcs(itup).ge.-1 .and. stsphcs(itup).le.1) stsphcs(itup)=0 ! do not change status of dormant phases ... if(stsphcs(itup).ne.-2) then call change_phase_status(iph,ics,nystat,val,ceq) if(gx%bmperr.ne.0) goto 1000 endif enddo enddo ! write(*,'(a,10i3)')'Suspended all phases',stsphcs ! indicator if maptop allocated ! nullify(curtop) notop=0 ! loop through all phases with stsphcs less than 3 ! nystat=0 !============================================================ phaseloop: do itup=1,ntup ! nystat:-4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fix ! write(*,*)'SS Phase ',itup,' status ',stsphcs(itup),ntup if(stsphcs(itup).gt.-2) then ! set default constitution, if none specified in the middle ! write(*,*)'loop for phase phase ',itup,' stable' iph=entphcs(itup)%ixphase call set_default_constitution(entphcs(itup)%ixphase,& entphcs(itup)%compset,ceq) if(gx%bmperr.ne.0) then write(*,*)'Failed setting default constitution' goto 500 endif ! set phase as entered ! write(*,*)'Trying to calculate line for phasetuple: ',itup call change_phase_status(entphcs(itup)%ixphase,& entphcs(itup)%compset,1,one,ceq) ! entphcs(itup)%compset,0,one,ceq) if(gx%bmperr.ne.0) then write(*,*)'Failed setting phase entered',gx%bmperr goto 500 endif ! debug listing of phase constitution to check ! call list_phase_model(entphcs(itup)%ixphase,entphcs(itup)%compset,& ! kou,ceq) ! here we should set the condition for overall composition to that of the phase ! Extract the current value of the axis state variable items using pcond ! write(*,*)'Extracting axis condition value ' seqz=axarr(1)%seqz ! write(*,*)'Locating condition ',seqz call locate_condition(seqz,pcond,ceq) if(gx%bmperr.ne.0) goto 500 ! if condition is a composition set it to be the current value with the ! default composition of the phase, 17 is mole fraction svr=>pcond%statvar(1) call get_phase_variance(entphcs(itup)%ixphase,nv) call get_phasetuple_name(entphcs(itup),name) ! write(*,*)'SMP2A axis condition type: ',svr%statevarid,nv ! skip phases with no variation of axis is not a potential if(nv.eq.0 .and. svr%statevarid.gt.5) then write(*,71)trim(name) 71 format('SMP2A ignoring phase ',a,' with fixed composition: ') goto 500 endif call state_variable_val(svr,val,ceq) if(gx%bmperr.ne.0) goto 500 ! 16=N, 17=X, 18=B, 19=W, 20=Y ! if(svr%statevarid.eq.17) then ! this call calculates the value of the axis condition with default composition ! call state_variable_val(svr,val,ceq) ! if(gx%bmperr.ne.0) goto 500 ! call get_phasetuple_name(entphcs(itup),name) ! axis variable is composition, skip phases with no variance ! call get_phase_variance(entphcs(itup)%ixphase,nv) ! if(nv.eq.0) then ! write(*,71)name(1:len_trim(name)),val !71 format(/'Ignoring phase with fixed composition: ',a,F10.6) !---------------- ! lokcs=phasetuple(iph)%lokvares ! write(*,*)'indices: ',iph,phasetuple(iph)%ixphase,lokcs ! goto 500 ! handle stoichiometric phases in step_separate .... ! we need to initiate a line with just one point ! special call to map_startpoint/map_findline for just one point ! inactive=0 ! call map_startpoint(maptop,noofaxis,axarr,seqxyz,inactive,ceq) ! if(gx%bmperr.ne.0) goto 500 ! call map_findline(maptop,axarr,mapfix,mapline) ! if(gx%bmperr.ne.0) goto 500 ! ceq=>mapline%lineceq ! meqrec=>mapline%meqrec ! this call gives error meqrec allready allocated ! ceq=>?? ! call calceq7(mode,meqrec,mapfix,ceq) ! if(gx%bmperr.ne.0) then ! write(*,*)'Error calculating stoichiometric phase',gx%bmperr ! endif ! store the value of G ! call map_store(mapline,axarr,maptop%number_ofaxis,& ! maptop%saveceq) ! if(gx%bmperr.ne.0) then ! write(*,*)'Error storing equilibrium',gx%bmperr ! goto 900 ! endif ! change the calculated value of G by adding 1.0D4 and store ! mapline%lineceq%phase_varres(lokcs)%gval(1,1)=& ! mapline%lineceq%phase_varres(lokcs)%gval(1,1)+1.0D3 ! call map_lineend(mapline,val,ceq) ! goto 500 !---------------- ! endif ! if(ocv()) write(*,73)name(1:len_trim(name)),val ! check if val is within axis limits if(val.lt.axarr(1)%axmin .or. val.gt.axarr(1)%axmax) then ! write adjusting startpoint to be inside limits val=axarr(1)%axmin+0.1D0*(axarr(1)%axmax-axarr(1)%axmin) endif write(*,73)trim(name),val 73 format(/'Setting start condition for ',a,f10.5) ! first argument 1 means to extract the value, 0 means to set the value call condition_value(0,pcond,val,ceq) if(gx%bmperr.ne.0) goto 500 mode=-1 ! if(notop.eq.0) then ! notop=-1 ! create maptop and things for storing results ! map_startpoint calculates the equilibrium and generates two start points ! write(*,*)'Creating start point',itup,notop inactive=0 call map_startpoint(maptop,noofaxis,axarr,seqxyz,inactive,ceq) if(gx%bmperr.ne.0) goto 500 ! write(*,*)'Start point created' ! create array of equilibrium records for saving results ! if larger than 500 I get segmentation fault ,,,, saveq=maxsavedceq call create_saveceq(maptop%saveceq,saveq) if(gx%bmperr.ne.0) goto 900 notop=-1 ! initiate line counter (redundant) ... maybe if several step separate? ! if(seqxyz(2).ne.0) then ! write(*,*)'step_separate seqy: ',seqxyz(2) ! endif else ! we generate a second or later startpoint for another phase ! note that maptop is allocated a new map_node linked from this ! write(*,*)'Creating next start point',itup,notop inactive=0 call map_startpoint(maptop,noofaxis,axarr,seqxyz,inactive,ceq) if(gx%bmperr.ne.0) then goto 500 endif endif firstline=.TRUE. ! find a stored line to calculate ! in this subroutine we have only one axis variable 200 continue ! write(*,*)'Calling findline:' call map_findline(maptop,axarr,mapfix,mapline) if(gx%bmperr.ne.0) goto 500 !lookingforbug ... never here write(*,*)'Back from map_findline in STEP',associated(mapline) ceq=>mapline%lineceq meqrec=>mapline%meqrec ! this is the first equilibrium along the line, create meqrec in step_separate 305 continue ! do jk=1,ntup ! if(stsphcs(jk).eq.-2) write(*,*)'SS phase ',jk,' dormant B' ! if(stsphcs(jk).ge.0) write(*,*)'SS phase ',jk,' stable B' ! enddo ! write(*,*)'smp2A calling calceq7 for first point' !lookingforbug ... never here call calceq7(mode,meqrec,mapfix,ceq) ! write(*,*)'smp2A back from calceq7',gx%bmperr if(gx%bmperr.ne.0) then ! error 4187 is to set T or P less than 0.1 if(gx%bmperr.eq.4187) then write(*,*)'We jump to 333' goto 333 endif if(mapline%number_of_equilibria.eq.0) then ! We can add/subtract a small amount of axis condition if error at first step write(*,*)'Error at first equilibrium: ',gx%bmperr,& mapline%axandir endif ! write(*,*)'SMP error: ',gx%bmperr ! if step turn on grid minimizer write(*,*)'Turn on grid minimizer' if(maptop%number_ofaxis.eq.1) then call calceq7(mode,meqrec,mapfix,ceq) if(gx%bmperr.ne.0) then write(kou,*)'Failed calling grid minimizer',gx%bmperr gx%bmperr=0 endif endif ! reset error code and take another line ! write(*,*)'SMP2 Generating mapline%meqrec failed 1: ',gx%bmperr gx%bmperr=0; goto 333 else ! calculation OK, do it again (why?) without creating meqrec, save and ! return here after taking a step using the same meqrec 380 continue iadd=0 irem=0 ! write(*,*)'SMP2A calling meq_sameset from step_separate' call meq_sameset(irem,iadd,mapx,mapline%meqrec,& mapline%meqrec%phr,inmap,ceq) if(gx%bmperr.ne.0) then ! write(*,*)'SMP2A Error calling meq_sameset',gx%bmperr goto 333 elseif(iadd.ne.0 .or. irem.ne.0) then write(*,*)'Change of phases not allowed! ',iadd,irem goto 333 endif ! store the result call map_store(mapline,axarr,maptop%number_ofaxis,maptop%saveceq) if(gx%bmperr.ne.0) then write(*,*)'Error storing equilibrium',gx%bmperr goto 900 endif ! do jk=1,ntup ! if(stsphcs(jk).eq.-2) write(*,*)'SS phase ',jk,' dormant C' ! if(stsphcs(jk).ge.0) write(*,*)'SS phase ',jk,' stable C' ! enddo call map_step(maptop,mapline,mapline%meqrec,mapline%meqrec%phr,& axvalok,noofaxis,axarr,ceq) ! write(*,*)'Back from map_step 2 ',mapline%more,& ! mapline%number_of_equilibria if(gx%bmperr.ne.0) then ! if error just terminate line write(*,*)'Error return from map_step 2: ',gx%bmperr mapline%more=-1 gx%bmperr=0; goto 333 endif if(mapline%more.ge.0) goto 380 endif 333 continue ! write(*,*)'Calling map_linend 2' call map_lineend(mapline,axarr(abs(mapline%axandir))%lastaxval,ceq) if(firstline) then ! follow the axis in the other direction if(gx%bmperr.ne.0) then write(*,*)'Reset error code',gx%bmperr endif firstline=.FALSE. goto 200 endif ! finished step in both directions 500 continue ! remove any error before calculating next phase if(gx%bmperr.ne.0) then write(*,*)'Reset error code to calculate next phase',gx%bmperr gx%bmperr=0 endif endif ! set current phase as suspended and calculate for next phase ! call change_phase_status(entphcs(itup)%phaseix,entphcs(itup)%compset,& call change_phase_status(entphcs(itup)%ixphase,entphcs(itup)%compset,& -3,zero,ceq) ! write(*,*)'At end of phase loop itup=',itup enddo phaseloop !============================================================ ! Terminate but restore all phase status, even if error above 900 continue val=zero ! write(*,*)'SMP Trying to restoring original phase status',ntup ! reset ceq to be starteq !! otherwise nothing is changed ceq=>starteq do itup=1,ntup ! write(*,910)itup,entphcs(itup)%ixphase,entphcs(itup)%compset,& ! stsphcs(itup) 910 format('Restoring all phase status: ',4i5) ! call change_phtup_status(itup,stsphcs(itup),val,ceq) call change_phase_status(entphcs(itup)%ixphase,& entphcs(itup)%compset,stsphcs(itup),val,ceq) if(gx%bmperr.ne.0) goto 1000 ! trying to set status entered ... ! write(*,911)'step_sep: restored? ',itup,entphcs(itup)%ixphase,& ! entphcs(itup)%compset,stsphcs(itup),val 911 format(a,3i4,i6,1pe12.4) enddo 1000 continue return end subroutine step_separate !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine step_special_setup !\begin{verbatim} subroutine step_special_setup(maptop,seqxyz,exits,starteq) ! create mapnode and tzero line and other special step commands ! maptop map node record ! seqxyz indices for map and line records ! exits is 1 or more depending on type of step implicit none integer seqxyz(*),exits TYPE(gtp_equilibrium_data), pointer :: starteq TYPE(map_node), pointer :: maptop !\end{verbatim} TYPE(gtp_equilibrium_data), pointer :: ceq,neweq integer jj,jp,seqz,iadd,irem,nv,saveq,lokcs,mapx,idir,seqx,seqy,kpos type(map_node), pointer :: mapnode type(map_line), pointer :: mapline type(map_fixph), allocatable :: mapfix type(meq_setup), pointer :: meqrec type(gtp_state_variable), pointer :: svr type(meq_phase), pointer :: phr type(gtp_condition), pointer :: pcond double precision xxx,yyy,zzz,fact ! logical firstline character eqname*24 integer, parameter :: maxsavedceq=1800 ! ! write(*,*)'In step_special_setup',exits !====================================================== ! create maptop, maplines and things for storing results ! we cannot use map_startpoint as we are not calculating equilibria ... ! we must allocate a maptop and its next and previous to point at itself allocate(maptop) mapnode=>maptop ! inititate status and links, maybe some of these change for other applications mapnode%status=0 mapnode%noofstph=2 mapnode%savednodeceq=-1 mapnode%next=>mapnode mapnode%previous=>mapnode mapnode%first=>mapnode mapnode%number_ofaxis=1 mapnode%nodefix%ixphase=0 mapnode%status=0 ! mapnone%lines incremented when created ?? mapnode%lines=0 ! %artxe nonzero if node with two stoichiometric phases with same composition mapnode%artxe=0 mapnode%globalcheckinterval=0 mapnode%seqx=seqxyz(1) mapnode%seqy=seqxyz(2) ! ! skip saving chemical potentials? mapnode%tpval=starteq%tpval mapnode%nodeceq=>starteq eqname='_MAPNODE_' jp=10 ! maptop%next is the the same mapnode !!! seqx=maptop%next%seqx+1 ! seqy=maptop%next%seq+1 ! seqy commented away but used later (some 50 lines below) ! I think it should probably be set here .../BoS 220220 seqy=maptop%next%seqy+1 maptop%next%seqx=seqx call wriint(eqname,jp,seqx) ! make a copy of ceq in a new equilibrium record with the pointer neweq ! This copy is a record in the array "eqlista" of equilibrium record, thus ! it will be updated if new composition sets are created in other threads. call copy_equilibrium(neweq,eqname,starteq) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'Created MAPNODE ',seqx ! set the tieline_inplane or not ! For step calculation, tieline_inplane=0 ! if there are more than one condition on an extensive_variable ! that is not an axis variable then no tielines in plane, tieline_inplane=-1 ! If there are tie_lines in plane then tieline_inplane=1 mapnode%tieline_inplane=0 ! forgetting to do this created a crash when plotting ... nullify(maptop%plotlink) ! we must store 1 or 2 (=exits) lineceq using starteq mapnode%lines=exits allocate(mapnode%linehead(mapnode%lines)) ! write(*,*)'step_special_setup',maptop%seqx,exits ! mapnode%type_of_node=0 idir=1 do jp=1,exits mapnode%linehead(jp)%axandir=idir idir=-1 mapnode%linehead(jp)%number_of_equilibria=0 mapnode%linehead(jp)%first=0 mapnode%linehead(jp)%last=0 mapnode%linehead(jp)%axchange=-1 mapnode%linehead(jp)%done=0 mapnode%linehead(jp)%status=0 mapnode%linehead(jp)%more=1 mapnode%linehead(jp)%termerr=0 mapnode%linehead(jp)%firstinc=zero ! saving equilibrium pointer in lineceq mapnode%linehead(jp)%lineceq=>starteq mapnode%linehead(jp)%start=>mapnode mapnode%linehead(jp)%axfact=1.0D-2 ! this is set to zero indicating the stable phases are saved in lineceq record mapnode%linehead(jp)%nstabph=0 mapnode%linehead(jp)%lineid=seqy mapnode%seqy=seqy+1 mapnode%linehead(jp)%nodfixph=0 ! %more is 1 while line is calculated, 0 means terminated at axis limit ! > 0 means error code <0 means exit removed ?? or is it %done ?? mapnode%linehead(jp)%more=1 mapnode%lines=exits nullify(mapnode%linehead(jp)%end) enddo ! ! create array of equilibrium records for saving results ! write(*,*)'step_special_setup create saveceq:',maxsavedceq saveq=maxsavedceq call create_saveceq(maptop%saveceq,saveq) if(gx%bmperr.ne.0) goto 1000 ! in this subroutine we have only one axis variable 1000 continue return end subroutine step_special_setup !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine step_tzero !\begin{verbatim} subroutine step_tzero(maptop,noofaxis,axarr,seqxyz,iph1,iph2,tzcond,starteq) ! calculates t for two phases where they have same Gibbs energy ! second version using step_special_setup ! There can not be any other phases ! maptop map node record ! noofaxis must be 1 ! axarr array of axis records ! seqxyz indices for map and line records ! iph1 and iph2 should be phase index (compset 1 in both) ! tzcond should be condition number for T implicit none integer noofaxis,seqxyz(*),iph1,iph2,tzcond type(map_axis), dimension(noofaxis) :: axarr TYPE(gtp_equilibrium_data), pointer :: starteq TYPE(map_node), pointer :: maptop !\end{verbatim} TYPE(gtp_equilibrium_data), pointer :: ceq,neweq integer jj,jp,seqz,iadd,irem,nv,saveq,lokcs,mapx,idir,seqx,seqy,kpos type(map_node), pointer :: mapnode type(map_line), pointer :: mapline type(map_fixph), allocatable :: mapfix type(meq_setup), pointer :: meqrec type(gtp_state_variable), pointer :: svr type(meq_phase), pointer :: phr type(gtp_condition), pointer :: pcond double precision xxx,yyy,zzz,fact ! logical firstline character eqname*24 integer, parameter :: maxsavedceq=1800 ! turns off convergence control for T integer, parameter :: inmap=1 ! ! write(*,*)'In step_tzero',iph1,iph2 if(noofaxis.ne.1) then write(kou,*)'Step tzero only with one axis variable' goto 1000 endif ! check that we have a tzero point ceq=>starteq ! call tzero(iph1,iph2,tzcond,yyy,ceq) if(gx%bmperr.ne.0) then write(*,*)'Start point is not on a tzero line' gx%bmperr=4399; goto 1000 endif ! extract axis condition value call locate_condition(axarr(1)%seqz,pcond,ceq) if(gx%bmperr.ne.0) goto 1000 ! first argument 1 means to get the value call condition_value(1,pcond,xxx,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,88)xxx,yyy 88 format('At x=',F10.6,' Tzero=',F10.2,10x,1pe12.4) !====================================================== call step_special_setup(maptop,seqxyz,2,starteq) if(gx%bmperr.ne.0) goto 1000 ! mapnode=>maptop ! write(*,*)'step_tzero creating maplines' tzstep: do jp=1,2 mapline=>mapnode%linehead(jp) eqname='_MAPLINE_' kpos=10 seqy=maptop%seqy+1 call wriint(eqname,kpos,seqy) call copy_equilibrium(mapnode%linehead(jp)%lineceq,eqname,& mapnode%nodeceq) if(gx%bmperr.ne.0) then write(*,*)'Error creating equilibrium: ',eqname goto 1000 endif ! write(*,*)'step_tzero created mapline ',seqy maptop%seqy=seqy mapnode%linehead(jp)%lineid=seqy mapnode%linehead(jp)%nodfixph=0 ! mapline%more is positive for line to be calculated, 0 means end at axis limit mapnode%linehead(jp)%more=1 ceq=>mapline%lineceq ! A very small first axis increment, extract axis condition value call locate_condition(axarr(1)%seqz,pcond,ceq) if(gx%bmperr.ne.0) goto 1000 ! first argument 1 means to get the value call condition_value(1,pcond,xxx,ceq) if(gx%bmperr.ne.0) goto 1000 fact=1.0D-2 idir=mapline%axandir ! write(*,*)'axis direction: ',idir,xxx tzlimits: do while(.TRUE.) xxx=xxx+fact*idir*axarr(1)%axinc if(xxx.lt.axarr(1)%axmin .or. xxx.gt.axarr(1)%axmax) exit tzlimits call condition_value(0,pcond,xxx,ceq) call tzero(iph1,iph2,tzcond,yyy,ceq) if(gx%bmperr.ne.0) then write(*,*)'TZERO step ',jp,' ended with error ',gx%bmperr gx%bmperr=0; cycle tzstep ! else ! write(*,88)xxx,yyy,fact endif call map_store(mapline,axarr,maptop%number_ofaxis,maptop%saveceq) if(gx%bmperr.ne.0) then write(*,*)'Error storing equilibrium',gx%bmperr gx%bmperr=0; cycle tzstep endif ! save missing ......... fact=min(2.0d0*fact,1.0d0) enddo tzlimits if(xxx.lt.axarr(1)%axmin) then xxx=max(axarr(1)%axmin,1.0D-6) call condition_value(0,pcond,xxx,ceq) call tzero(iph1,iph2,tzcond,yyy,ceq) elseif(xxx.gt.axarr(1)%axmax) then xxx=min(axarr(1)%axmax,0.999999D0) call condition_value(0,pcond,xxx,ceq) call tzero(iph1,iph2,tzcond,yyy,ceq) endif ! write(*,88)xxx,yyy call map_store(mapline,axarr,maptop%number_ofaxis,maptop%saveceq) if(gx%bmperr.ne.0) then write(*,*)'Error storing equilibrium',gx%bmperr gx%bmperr=0; cycle tzstep endif enddo tzstep ! 1000 continue return end subroutine step_tzero !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine step_eet !\begin{verbatim} subroutine step_eet(maptop,noofaxis,axarr,seqxyz,iph1,iph2,eetcond,starteq) ! COPY of step_tzero modified for STEP LIQUID_EET ! calculates t for two phases where they have same Gibbs energy ! second version using step_special_setup ! There can not be any other phases ! maptop map node record ! noofaxis must be 1 ! axarr array of axis records ! seqxyz indices for map and line records ! iph1 and iph2 should be phase index (compset 1 in both) ! eetcond should be condition number for T implicit none integer noofaxis,seqxyz(*),iph1,iph2,eetcond type(map_axis), dimension(noofaxis) :: axarr TYPE(gtp_equilibrium_data), pointer :: starteq TYPE(map_node), pointer :: maptop !\end{verbatim} TYPE(gtp_equilibrium_data), pointer :: ceq,neweq integer jj,jp,seqz,iadd,irem,nv,saveq,lokcs,mapx,idir,seqx,seqy,kpos type(map_node), pointer :: mapnode type(map_line), pointer :: mapline type(map_fixph), allocatable :: mapfix type(meq_setup), pointer :: meqrec type(gtp_state_variable), pointer :: svr type(meq_phase), pointer :: phr type(gtp_condition), pointer :: pcond double precision xxx,yyy,zzz,fact ! logical firstline character eqname*24 integer, parameter :: maxsavedceq=1800 ! turns off convergence control for T integer, parameter :: inmap=1 ! write(*,*)'step_eet not finished',iph1,iph2 goto 1000 if(noofaxis.ne.1) then write(kou,*)'Step tzero only with one axis variable' goto 1000 endif ! check that we have an eet point ceq=>starteq ! call liquid_eet(iph1,iph2,eetcond,yyy,ceq) if(gx%bmperr.ne.0) then write(*,*)'Start point is not on an EET line' gx%bmperr=4399; goto 1000 endif ! extract axis condition value call locate_condition(axarr(1)%seqz,pcond,ceq) if(gx%bmperr.ne.0) goto 1000 ! first argument 1 means to get the value call condition_value(1,pcond,xxx,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,88)xxx,yyy 88 format('At x=',F10.6,' Tzero=',F10.2,10x,1pe12.4) !====================================================== ! the penultima argument is number of exits from first eqquilibrium call step_special_setup(maptop,seqxyz,2,starteq) if(gx%bmperr.ne.0) goto 1000 ! mapnode=>maptop ! write(*,*)'step liquid_eet creating maplines' eetstep: do jp=1,2 mapline=>mapnode%linehead(jp) eqname='_MAPLINE_' kpos=10 seqy=maptop%seqy+1 call wriint(eqname,kpos,seqy) call copy_equilibrium(mapnode%linehead(jp)%lineceq,eqname,& mapnode%nodeceq) if(gx%bmperr.ne.0) then write(*,*)'Error creating equilibrium: ',eqname goto 1000 endif ! write(*,*)'step_tzero created mapline ',seqy maptop%seqy=seqy mapnode%linehead(jp)%lineid=seqy mapnode%linehead(jp)%nodfixph=0 ! mapline%more is positive for line to be calculated, 0 means end at axis limit mapnode%linehead(jp)%more=1 ceq=>mapline%lineceq ! A very small first axis increment, extract axis condition value call locate_condition(axarr(1)%seqz,pcond,ceq) if(gx%bmperr.ne.0) goto 1000 ! first argument 1 means to get the value call condition_value(1,pcond,xxx,ceq) if(gx%bmperr.ne.0) goto 1000 fact=1.0D-2 idir=mapline%axandir ! write(*,*)'axis direction: ',idir,xxx eetlimits: do while(.TRUE.) xxx=xxx+fact*idir*axarr(1)%axinc if(xxx.lt.axarr(1)%axmin .or. xxx.gt.axarr(1)%axmax) exit eetlimits call condition_value(0,pcond,xxx,ceq) ! call tzero(iph1,iph2,eetcond,yyy,ceq) call liquid_eet(iph1,iph2,eetcond,yyy,ceq) if(gx%bmperr.ne.0) then write(*,*)'TZERO step ',jp,' ended with error ',gx%bmperr gx%bmperr=0; cycle eetstep ! else ! write(*,88)xxx,yyy,fact endif call map_store(mapline,axarr,maptop%number_ofaxis,maptop%saveceq) if(gx%bmperr.ne.0) then write(*,*)'Error storing equilibrium',gx%bmperr gx%bmperr=0; cycle eetstep endif ! save missing ......... fact=min(2.0d0*fact,1.0d0) enddo eetlimits if(xxx.lt.axarr(1)%axmin) then xxx=max(axarr(1)%axmin,1.0D-6) call condition_value(0,pcond,xxx,ceq) call liquid_eet(iph1,iph2,eetcond,yyy,ceq) elseif(xxx.gt.axarr(1)%axmax) then xxx=min(axarr(1)%axmax,0.999999D0) call condition_value(0,pcond,xxx,ceq) call liquid_eet(iph1,iph2,eetcond,yyy,ceq) endif ! write(*,88)xxx,yyy call map_store(mapline,axarr,maptop%number_ofaxis,maptop%saveceq) if(gx%bmperr.ne.0) then write(*,*)'Error storing equilibrium',gx%bmperr gx%bmperr=0; cycle eetstep endif enddo eetstep ! 1000 continue return end subroutine step_eet !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine step_scheil !\begin{verbatim} subroutine step_scheil(maptop,noofaxis,axarr,seqxyz,starteq) ! calculates a Scheil-Gulliver solidification simulation ! maptop map node record ! noofaxis must be 1 ! axarr array of axis records ! seqxyz indices for map and line records ! starteq is an equilibrium with just liquid stable implicit none integer noofaxis,seqxyz(*) type(map_axis), dimension(noofaxis) :: axarr TYPE(gtp_equilibrium_data), pointer :: starteq TYPE(map_node), pointer :: maptop !\end{verbatim} TYPE(gtp_equilibrium_data), pointer :: ceq,neweq integer jj,jp,seqz,iadd,irem,nv,saveq,lokcs,mapx,idir,seqx,seqy,kpos integer inactive(4),mode,nc,nsch,liquid type(map_node), pointer :: mapnode type(map_line), pointer :: mapline type(map_fixph), allocatable :: mapfix type(meq_setup), pointer :: meqrec type(gtp_state_variable), pointer :: svr type(meq_phase), pointer :: phr type(gtp_condition), pointer :: pcond,firstcond,axcond double precision xxx,yyy,zzz,fact,fact1,axvalok,npliqval,liqfrac(20) character eqname*24,phname*24,npliq*24,encoded*72 integer, parameter :: maxsavedceq=1800 ! turns off convergence control for T integer, parameter :: inmap=1 logical solids ! needed to store links to condition values TYPE smp_scheil_condval ! these pointers must be updated for each new line (equilibrium) type(gtp_condition), pointer :: p1 end type smp_scheil_condval ! These two arrays keep track of conditions and liquid compositis ! the first is pointers to the condition record, the second is statevariable id type(smp_scheil_condval), dimension(20) :: scheilval TYPE(gtp_state_variable), target, dimension(20) :: scheilsvr ! write(*,*)'In step_scheil' if(noofaxis.ne.1) then write(kou,*)'Scheil simulations use one axis variable' goto 1000 endif ! axis condition must be T, extract its value call locate_condition(axarr(1)%seqz,pcond,starteq) if(gx%bmperr.ne.0) goto 1000 if(pcond%statev.ne.1) then ! pcond%statev=1 means T write(*,*)'Axis condition must be T' gx%bmperr=4399; goto 1000 endif ! first argument 1 means to get the value axcond=>pcond call condition_value(1,pcond,xxx,starteq) if(gx%bmperr.ne.0) goto 1000 ! write(*,'(a,F10.2)')'Scheil start T=',xxx ! inactive=0 ! inactive(1)=-1 means only one exit point with direcition -1 inactive(1)=-1 ! generate step/map datastructure needed for plotting and phase set changes. call map_startpoint(maptop,noofaxis,axarr,seqxyz,inactive,starteq) if(gx%bmperr.ne.0) goto 1000 ! There should be two maplines generated, the stable phase should be the liquid ! but do not be fuzzy, one may quech a two-phase mixture ! write(*,*)'Scheil step 1',allocated(maptop%linehead) ! write(*,*)'Scheil lineheads: ',size(maptop%linehead),& ! maptop%linehead(1)%axandir ! create array of equilibrium records for saving results seqy=maxsavedceq call create_saveceq(maptop%saveceq,seqy) if(gx%bmperr.ne.0) goto 1000 ! Mark this as a Scheil step maptop%type_of_node=3 ! ensure plotlink is nullified!! nullify(maptop%plotlink) ! initiate node counter done, line counter will be incremented if(maptop%seqx.gt.1) write(*,85)maptop%seqx,maptop%seqy+1 85 format('Previous step/map results saved'/& 'New mapnode/line equilibria indices will start from: ',i3,i5) ! take the first (only) line created by map_startpoint ! write(*,*)'Calling map_findline' call map_findline(maptop,axarr,mapfix,mapline) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'Back from map_findline in Scheil' ceq=>mapline%lineceq meqrec=>mapline%meqrec mode=-1 call calceq7(mode,meqrec,mapfix,ceq) if(gx%bmperr.ne.0) goto 1000 xxx=ceq%tpval(1) if(meqrec%nstph.gt.1) then write(*,*)'More than one phase stable at startpoint' gx%bmperr=4399; goto 1000 endif ! check stable phase is liquid call get_phasetup_name(meqrec%phr(meqrec%stphl(1))%phtupix,phname) if(gx%bmperr.ne.0) goto 1000 liquid=meqrec%phr(meqrec%stphl(1))%iph write(*,*)'Stable phase at start: ',trim(phname),liquid npliq='NP('//trim(phname)//') ' !======================================================= ! create special result array to save current fraction of liquid ! allocate(mapline%stepresultid(1)) ! mapline%stepresultid(1)=npliq ! extract relevant conditions and store in scheilval and scheilsvr firstcond=>ceq%lastcondition%next pcond=>firstcond nc=0 nsch=0 ploop: do while(.TRUE.) ! if %active nonzero the condition is not active if(pcond%active.ne.0) cycle ploop nc=nc+1 ! to prevent eternal loop if(nc.gt.20) exit ploop ! write(*,'(a,i3,a,i5)')'Condition ',nc,' type ',pcond%statev if(pcond%statev.lt.0) then write(*,*)'Fix phases not allowed as conditions' gx%bmperr=4399; goto 1000 endif svr=>pcond%statvar(1) ! write(*,*)'State variable id: ',svr%statevarid,svr%argtyp ! statvarid<10 means potential, allow and ignore if(svr%statevarid.le.10) goto 100 ! 11 <= statvarid <=15 are G, H etc, not allowed. Neither is Y if(svr%statevarid.le.15 .or. svr%statevarid.ge.20) then write(*,*)'Illegal condition for Scheil simulation',svr%statevarid gx%bmperr=4399; goto 1000 endif ! Allowed state variables are N, X, B and W without phase specification ! argtyp=0 means total such as N=1 if(svr%argtyp.eq.0) goto 100 ! argtyp=1 means component, >1 other means phase or compset specification if(svr%argtyp.gt.1) then write(*,*)'Condition has wrong type of arguments: ',svr%argtyp gx%bmperr=4399; goto 1000 endif if(pcond%symlink1.gt.0) then ! value must not be a symbol write(*,*)'Condition value must not be a symbol' gx%bmperr=4399; goto 1000 endif nsch=nsch+1 scheilval(nsch)%p1=>pcond ! save state variable but change it to include liquid phase index scheilsvr(nsch)=svr ! replace argtyp and add phase and compset scheilsvr(nsch)%argtyp=3 scheilsvr(nsch)%phase=liquid scheilsvr(nsch)%compset=1 ! write(*,'(a,i3,F10.6)')'Condition value: ',nsch,pcond%prescribed ! Puuuuuh, condition allowed, link to its current value 100 continue pcond=>pcond%next ! current value if(associated(pcond,firstcond)) exit ploop enddo ploop ! write(*,'(a,i3,a,i3)')'Found ',nc,' active conditions and saved ',nsch ! test that we can extract (and set) liquid conditions and state variable do nc=1,nsch svr=>scheilsvr(nc) call state_variable_val(svr,xxx,ceq) ! write(*,'(a,i3,2F10.6)')'Liquid initial conditions: ',& ! nc,scheilval(nc)%p1%prescribed,xxx enddo ! initial npliqval=one solids=.FALSE. ! Now find T when first solid phase will appear ! mapx does not seem to be used, inmap=1 turn off T convergence test(?) ! all data in meqrec was set calling calceq7 above ! axis conditio ! first argument 1 means to get the value call condition_value(1,axcond,xxx,ceq) if(gx%bmperr.ne.0) goto 1000 irem=0; iadd=0; nc=0 ! iadd=-1 turn on verbose in meq_sameset ! iadd=-1 ! large step before first solid appears fact1=1.0D1 axarr(1)%axinc=fact1*axarr(1)%axinc axvalok=xxx !==================================================== big loop node: do while(.TRUE.) ! follow axis including nodepoints with phase changes ! start with small steps ! fact=1.0D-2 line: do while(iadd.le.0 .and. irem.eq.0) ! follow line until a nodepoint ! axarr(1)%axval=axarr(1)%axval-axarr(1)%axinc if(solids) then ! update the liquid composition ! We have located the pcond records for each new line below ! write(*,*)'Update liquid composition at T=',ceq%tpval(1) do nc=1,nsch ! this call extract the liquid composition svr=>scheilsvr(nc) call state_variable_val(svr,liqfrac(nc),ceq) if(gx%bmperr.ne.0) then write(*,*)'Error extracting liquid composition' goto 1000 endif ! and this sets it as the overall composition call condition_value(0,scheilval(nc)%p1,liqfrac(nc),ceq) if(gx%bmperr.ne.0) then write(*,*)'Error setting new liquid composition' goto 1000 endif enddo call get_state_var_value(npliq,yyy,encoded,ceq) if(gx%bmperr.ne.0) gx%bmperr=0 npliqval=npliqval*yyy write(*,'(a,F7.2,"% ",F7.2,": ",10(1x,F8.4))')'Liquid:',& 1.0D2*npliqval,ceq%tpval(1),(liqfrac(nc),nc=1,nsch) ! turn on debug info in meq_sameset ! iadd=-1 endif ! take a step in the axis variable T call map_step2(maptop,mapline,meqrec,meqrec%phr,axvalok,1,axarr,ceq) if(gx%bmperr.ne.0) goto 1000 if(ceq%tpval(1).lt.axarr(1)%axmin) then write(*,*)'At low T limit ',axarr(1)%axmin goto 900 endif ! calculate until a phase change ! write(*,*)'Calling meq_sameset',ceq%tpval(1),npliqval call meq_sameset(irem,iadd,mapx,mapline%meqrec,mapline%meqrec%phr,& inmap,ceq) ! write(*,*)'Back from meq_sameset',ceq%tpval(1),gx%bmperr if(iadd.eq.0 .and. irem.eq.0) then ! Store the equilibrium along the line call map_store(mapline,axarr,1,maptop%saveceq) ! write(*,*)'Stored calculated equilibrium' if(gx%bmperr.ne.0) then write(*,*)'Error storing equilibria',gx%bmperr goto 1000 endif endif enddo line ! exit line loop when iadd or irem nonzero, i.e. new set of phases if(.not.solids) then ! if solids FALSE set it TRUE solids=.TRUE. axarr(1)%axinc=axarr(1)%axinc/fact1 fact1=1.0D0 endif ! Maybe not store here because the T is not correct ! call map_store(mapline,axarr,1,maptop%saveceq) ! write(*,*)'Stored calculated equilibrium' if(gx%bmperr.ne.0) then write(*,*)'Error storing equilibria',gx%bmperr goto 1000 endif ! use map_calcnode to create new mapnode and mapline. ! We should not set any fix phases, just continue along the axis ! as with a step command with different sets of stable phases call map_calcnode(irem,iadd,maptop,mapline,meqrec,axarr,ceq) ! in map_calcnode a new _MAPNODE and _MAPLINE is created with the new set ! of phases. Store the end point of the line nullify(maptop%plotlink) ! Terminate the current line, must be after calcnode ... call map_lineend(mapline,axarr(1)%lastaxval,ceq) if(gx%bmperr.ne.0) then write(*,*)'Rest error ',gx%bmperr gx%bmperr=0 endif write(*,*)'Per cent liquid and T',1.0D2*npliqval,ceq%tpval(1) if(.not.(npliqval.gt.0.01)) then ! terminate if npliqval<0.01 BUT IT DOES NOT WORK ??? write(*,*)'Terminating as liquid fraction less than 1%' goto 900 ! else ! if(npliqval.gt.0.01) then ! write(*,*)'Terminating as liquid fraction less than 1%' ! goto 900 ! endif endif ! The Scheil simulation continue along the same axis with new set of phases. call map_findline(maptop,axarr,mapfix,mapline) if(gx%bmperr.ne.0) then write(*,*)'Error return from map_findline, terminating' goto 1000 endif ceq=>mapline%lineceq ! write(*,*)'SMP2A calling calceq7 after findline,',allocated(mapfix),mode ! Evidently we have to call calceq7 to initiate meqrec ?? meqrec=>mapline%meqrec call calceq7(mode,meqrec,mapfix,ceq) if(gx%bmperr.ne.0) then write(*,*)'Failed calling calceq7',gx%bmperr goto 1000 endif ! check if zero fraction of liquid here call get_state_var_value(npliq,yyy,encoded,ceq) write(*,*)'SMP2A Scheil liquid fraction: ',yyy if(yyy.lt.0.03) then ! Terminate the current line call map_lineend(mapline,axarr(1)%lastaxval,ceq) goto 900 endif ! we have to locate the condition records for the liquid comp in the new ceq firstcond=>ceq%lastcondition%next pcond=>firstcond ploop2: do while(.TRUE.) if(pcond%active.ne.0) cycle ploop2 svr=>pcond%statvar(1) do nc=1,nsch if(svr%statevarid.eq.scheilsvr(nc)%statevarid .and. & svr%argtyp.eq.1 .and.& svr%component.eq.scheilsvr(nc)%component) then scheilval(nc)%p1=>pcond ! write(*,*)'Found scheil condition in new ceq: ',nc endif enddo pcond=>pcond%next if(associated(pcond,firstcond)) exit ploop2 ! write(*,*)'Looping conditions in new ceq' enddo ploop2 ! write(*,*)'Node T=',ceq%tpval(1) enddo node write(*,*)'Never here!' ! !=========================================== ! exit here if no liquid left of at low T limit 900 continue ! maybe clean up? 1000 continue return end subroutine step_scheil !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine step_scheil2 !\begin{verbatim} subroutine step_scheil2(maptop,noofaxis,axarr,seqxyz,fast,starteq) ! calculates a Scheil-Gulliver solidification simulation with fast elements ! maptop map node record ! noofaxis must be 1 ! axarr array of axis records ! seqxyz indices for map and line records ! fast is array with names of fast diffusing elements, fast(i)=' ' for last ! starteq is an equilibrium with just liquid stable implicit none integer noofaxis,seqxyz(*) character*2 fast(*) type(map_axis), dimension(noofaxis) :: axarr TYPE(gtp_equilibrium_data), pointer :: starteq TYPE(map_node), pointer :: maptop !\end{verbatim} ! max number of components and fast diffusing elements integer, parameter :: mscheil=20,mfast=3 TYPE(gtp_equilibrium_data), pointer :: ceq,neweq integer jj,jp,seqz,iadd,irem,nv,saveq,lokcs,mapx,idir,seqx,seqy,kpos integer inactive(4),mode,nc,nsch,liquid,jfast,nfast,fastix(mfast),iel ! notremove is a phase which just became stable, do not remove integer slice,slices,offset,notremove,keep type(map_node), pointer :: mapnode type(map_line), pointer :: mapline type(map_fixph), allocatable :: mapfix type(meq_setup), pointer :: meqrec type(gtp_state_variable), pointer :: svr type(meq_phase), pointer :: phr type(gtp_condition), pointer :: pcond,firstcond,axcond double precision xxx,yyy,zzz,fact,fact1,axvalok,npliqval,liqconst(20) double precision sameact(mfast) double precision slicefrac(1000) character eqname*24,phname*24,npliq*24,encoded*72,mucondition*24 integer, parameter :: maxsavedceq=1800 ! turns off convergence control for T integer, parameter :: inmap=1 logical solids ! needed to store links to condition values TYPE smp_scheil_condval ! these pointers must be updated for each new line (equilibrium) type(gtp_condition), pointer :: p1 integer fcond end type smp_scheil_condval ! These two arrays keep track of conditions and liquid compositions ! the first is pointers to the condition record, the second is statevariable id type(smp_scheil_condval), dimension(mscheil) :: scheilval type(smp_scheil_condval), dimension(mfast) :: mucond TYPE(gtp_state_variable), target, dimension(mscheil) :: scheilsvr ! ! write(*,*)'In step_scheil' if(noofaxis.ne.1) then write(kou,*)'Scheil simulations use one axis variable' goto 1000 endif ! axis condition must be T, extract its value call locate_condition(axarr(1)%seqz,pcond,starteq) if(gx%bmperr.ne.0) goto 1000 if(pcond%statev.ne.1) then ! pcond%statev=1 means T write(*,*)'Axis condition must be T' gx%bmperr=4399; goto 1000 endif ! first argument 1 means to get the value axcond=>pcond call condition_value(1,pcond,xxx,starteq) if(gx%bmperr.ne.0) goto 1000 ! write(*,'(a,F10.2)')'Scheil start T=',xxx ! inactive=0 ! inactive(1)=-1 means only one exit point with direcition -1 inactive(1)=-1 ! generate step/map datastructure needed for plotting and phase set changes. call map_startpoint(maptop,noofaxis,axarr,seqxyz,inactive,starteq) if(gx%bmperr.ne.0) goto 1000 ! There should be two maplines generated, the stable phase should be the liquid ! but do not be fuzzy, one may quech a two-phase mixture ! write(*,*)'Scheil step 1',allocated(maptop%linehead) ! write(*,*)'Scheil lineheads: ',size(maptop%linehead),& ! maptop%linehead(1)%axandir ! create array of equilibrium records for saving results seqy=maxsavedceq call create_saveceq(maptop%saveceq,seqy) if(gx%bmperr.ne.0) goto 1000 ! Mark this as a Scheil step maptop%type_of_node=3 ! ensure plotlink is nullified!! nullify(maptop%plotlink) ! initiate node counter done, line counter will be incremented if(maptop%seqx.gt.1) write(*,85)maptop%seqx,maptop%seqy+1 85 format('Previous step/map results saved'/& 'New mapnode/line equilibria indices will start from: ',i3,i5) ! take the first (only) line created by map_startpoint ! write(*,*)'Calling map_findline' call map_findline(maptop,axarr,mapfix,mapline) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'Back from map_findline in Scheil' ceq=>mapline%lineceq meqrec=>mapline%meqrec mode=-1 call calceq7(mode,meqrec,mapfix,ceq) if(gx%bmperr.ne.0) goto 1000 xxx=ceq%tpval(1) if(meqrec%nstph.gt.1) then write(*,*)'More than one phase stable at startpoint' gx%bmperr=4399; goto 1000 endif ! check stable phase is liquid call get_phasetup_name(meqrec%phr(meqrec%stphl(1))%phtupix,phname) if(gx%bmperr.ne.0) goto 1000 liquid=meqrec%phr(meqrec%stphl(1))%iph write(*,*)'Stable phase at start: ',trim(phname),liquid npliq='NP('//trim(phname)//') ' !======================================================= ! check number of fast diffusion elements (can be zero ...) nfast=1 do while(fast(nfast).ne.' ') ! write(*,*)'SMP2A fast diffusing elements: "',fast(nfast),'"' call find_element_by_name(fast(nfast),fastix(nfast)) if(gx%bmperr.ne.0) goto 1000 nfast=nfast+1 if(nfast.gt.mfast) then write(*,*)'SMP2A too many fast diffusing elements',nfast gx%bmperr=4399; goto 1000 endif enddo ! OK if nfast is 0 here, this routine should work anyway ... (replace original) nfast=nfast-1 if(nfast.gt.0) then write(*,*)'SMP2A number of fast diffusing elements: ',nfast jfast=1 else write(*,*)'SMP2A No fast diffusing elements' jfast=0 endif !========================================================= ! extract relevant conditions and store in scheilval and scheilsvr firstcond=>ceq%lastcondition%next pcond=>firstcond nc=0 nsch=0 ploop: do while(.TRUE.) ! skip condition if %active nonzero (the condition is not active) ! write(*,*)'SMP2A inside ploop',pcond%active,& ! pcond%statvar(1)%statevarid,pcond%statvar(1)%component if(pcond%active.ne.0) goto 100 nc=nc+1 ! to prevent eternal loop if(nc.gt.20) exit ploop ! write(*,'(a,i3,a,i5)')'Condition ',nc,' type ',pcond%statev if(pcond%statev.lt.0) then write(*,*)'Fix phases not allowed as conditions' gx%bmperr=4399; goto 1000 endif svr=>pcond%statvar(1) ! write(*,*)'State variable id: ',svr%statevarid,svr%argtyp ! statvarid<10 means potential, allow and ignore if(svr%statevarid.le.10) goto 100 ! 11 <= statvarid <=15 are G, H etc, not allowed. Neither is Y if(svr%statevarid.le.15 .or. svr%statevarid.ge.20) then write(*,*)'Illegal condition for Scheil simulation',svr%statevarid gx%bmperr=4399; goto 1000 endif ! Allowed state variables are N, X, B and W without phase specification ! argtyp=0 means total such as N=1 if(svr%argtyp.eq.0) goto 100 ! argtyp=1 means component, >1 other means phase or compset specification if(svr%argtyp.gt.1) then write(*,*)'Condition has wrong type of arguments: ',svr%argtyp gx%bmperr=4399; goto 1000 endif if(pcond%symlink1.gt.0) then ! value must not be a symbol write(*,*)'Condition value must not be a symbol' gx%bmperr=4399; goto 1000 endif nsch=nsch+1 scheilval(nsch)%p1=>pcond scheilval(nsch)%fcond=0 ! save state variable but change it to include liquid phase index scheilsvr(nsch)=svr ! replace argtyp and add phase and compset scheilsvr(nsch)%argtyp=3 scheilsvr(nsch)%phase=liquid scheilsvr(nsch)%compset=1 if(jfast.gt.0) then if(svr%component.eq.fastix(jfast)) then ! is this element fast diffusing? ! we should add a condition on the chemical potential of this component ! Set current value of the chemical potential ... mucondition='MU('//trim(fast(jfast))//') ' ! ok write(*,*)'SMP2A Fast diffusing element: ',trim(mucondition) call get_state_var_value(mucondition,xxx,encoded,ceq) if(gx%bmperr.ne.0) goto 1000 nv=len_trim(mucondition)+1 write(mucondition(nv:),666)xxx 666 format('= ',F14.6) ! this condition should be set as last ... I hope nv=0 ! this condition should be added last ! write(*,*)'SMP2A mucondition: ',trim(mucondition),nv call set_condition(mucondition,nv,ceq) if(gx%bmperr.ne.0) goto 1000 ! check that this is the last condition, MU=3 mucond(jfast)%p1=>ceq%lastcondition mucond%fcond=nsch scheilval(nsch)%fcond=jfast ! write(*,*)'SMP2A set condition: ',trim(mucondition),nsch,jfast svr=>mucond(jfast)%p1%statvar(1) ! deactivate MU condition ceq%lastcondition%active=1 jfast=jfast+1 if(jfast.gt.nfast) jfast=0 ! write(*,*)'SMP2A new condition: ',svr%statevarid,svr%component endif endif ! Puuuuuh, condition allowed, link to its current value 100 continue pcond=>pcond%next ! current value ! write(*,*)'SMP2A next condition: ',pcond%statev,pcond%active if(associated(pcond,firstcond)) exit ploop enddo ploop ! write(*,*)'SMP2A have exited ploop' ! call list_conditions(kou,ceq) ! if(nfast.gt.0) then ! write(*,*)'Unfinished' ! goto 1000 ! endif !----------------------------- ! write(*,'(a,i3,a,i3)')'Found ',nc,' active conditions and saved ',nsch ! test that we can extract (and set) liquid conditions and state variable do nc=1,nsch svr=>scheilsvr(nc) call state_variable_val(svr,xxx,ceq) ! write(*,'(a,i3,2F10.6)')'Liquid initial conditions: ',& ! nc,scheilval(nc)%p1%prescribed,xxx enddo ! initial npliqval=one solids=.FALSE. slices=-1 ! this is number of initial equilibria to be skipped ! It may include one extra per new line, I am not sure ... offset=2 ! Now find T when first solid phase will appear ! mapx does not seem to be used, inmap=1 turn off T convergence test(?) ! all data in meqrec was set calling calceq7 above ! axis conditio ! first argument 1 means to get the value call condition_value(1,axcond,xxx,ceq) if(gx%bmperr.ne.0) goto 1000 irem=0; iadd=0; nc=0; notremove=0; keep=-1 ! iadd=-1 turn on verbose in meq_sameset ! iadd=-1 ! large step before first solid appears fact1=1.0D1 axarr(1)%axinc=fact1*axarr(1)%axinc axvalok=xxx !==================================================== big loop node: do while(.TRUE.) ! follow axis including nodepoints with phase changes line: do while(iadd.le.0 .and. irem.eq.0) if(solids) then ! write(*,*)'SMP2A inside line loop',ceq%tpval(1),slices ! update the liquid composition ! We have located the pcond records for each new line below ! write(*,*)'Update liquid composition at T=',ceq%tpval(1) ! If slices>0 then change conditions of fast diffusing elements to MU ! if(slices.ge.0) then ! write(*,*)'SMP2A slices: ',slices,mapline%last ! endif do nc=1,nsch ! this call extract the liquid composition if(scheilval(nc)%fcond.gt.0) then ! this is a fast diffusing element, use mucond write(*,*)'SMP2A to set MU condition',& scheilval(nc)%fcond,slices endif ! else svr=>scheilsvr(nc) call state_variable_val(svr,liqconst(nc),ceq) if(gx%bmperr.ne.0) then write(*,*)'Error extracting liquid composition' goto 1000 endif ! and this sets it as the overall composition call condition_value(0,scheilval(nc)%p1,liqconst(nc),ceq) if(gx%bmperr.ne.0) then write(*,*)'Error setting new liquid composition' goto 1000 endif ! endif enddo ! calculate fraction of liquid remaining and slicefrac call get_state_var_value(npliq,yyy,encoded,ceq) if(gx%bmperr.ne.0) gx%bmperr=0 ! slicefrac is fraction of solid at this timestep (slices) if(slices.gt.1000) then write(*,*)'SMP2A exit after 1000 solidification steps' gx%bmperr=4399; goto 1000 endif if(slices.eq.0) slices=1 slicefrac(slices)=(one-yyy)*npliqval npliqval=npliqval*yyy write(*,670)ceq%tpval(1),1.0D2*npliqval,1.0D2*slicefrac(slices),& slices,nsch,(liqconst(nc),nc=1,nsch) 670 format('SMP2A T=',F8.2,'K, liq ',2F7.2,'% ',2i3,10(1x,F7.4)) ! turn on debug info in meq_sameset ! iadd=-1 endif ! take a step in the axis variable T call map_step2(maptop,mapline,meqrec,meqrec%phr,axvalok,1,axarr,ceq) if(gx%bmperr.ne.0) goto 1000 if(ceq%tpval(1).lt.axarr(1)%axmin) then write(*,*)'At low T limit ',axarr(1)%axmin goto 900 endif ! write(*,*)'Calling meq_sameset',ceq%tpval(1),npliqval allslices: do while(.TRUE.) ! If fast diffusing element we calculate simultaneously the equilibrium ! with liquid and all saved equilibria with a MU condition. ! write(*,*)'SMP2A inside allslices: ',ceq%tpval(1),slices call meq_sameset(irem,iadd,mapx,mapline%meqrec,mapline%meqrec%phr,& inmap,ceq) if(gx%bmperr.ne.0) then write(*,*)'Scheil2 error return from meq_sameset',gx%bmperr goto 1000 endif ! if irem is equal to notremove at first step ignore ... if(irem.gt.0 .and. irem.eq.notremove) then write(*,*)'SMP2A do not remove',irem,ceq%tpval(1) keep=3 irem=0 endif ! if set of phases change extit line if(iadd.ne.0 .or. irem.ne.0) exit line ! if no fast diffusing element we have calculated a new equilibrium if(nfast.eq.0 .or. slices.lt.0) exit allslices ! calculate equilibria in all previous slices and sum amount of fast elements ! and loop allslices until total amount of fast diffusing element correct write(*,*)'calling calc_allslices',slices if(calc_allslices(maptop,mapline,slices,offset,fastix,& slicefrac)) then ! if calc_allslices is .TRUE. we calculated a new equilibrium slices=slices+1 write(*,*)'Back from calc_allslices: ',slices exit allslices endif enddo allslices ! clear noremove after 3 steps to avoid a second phase change keep=keep-1 if(keep.eq.0) notremove=0 ! offset is incremented for all equilibria until first solid if(slices.lt.0) then offset=offset+1 else ! change the condition in mapline%lineceq on faset diffusing element to be MU ! write(*,*)'SMP2A store: ',mapline%lineceq%tpval(1),ceq%tpval(1) endif ! Store the equilibrium and step in T call map_store(mapline,axarr,1,maptop%saveceq) if(gx%bmperr.ne.0) then write(*,*)'Scheil2 error storing equilibria',gx%bmperr goto 1000 endif enddo line ! exit line loop when iadd or irem nonzero, i.e. new set of phases if(.not.solids) then ! if solids FALSE set it TRUE, this is first solid appearing solids=.TRUE. axarr(1)%axinc=axarr(1)%axinc/fact1 fact1=1.0D0 ! This is first solid appearing, change fast elements to MU conditions do jfast=1,nfast iel=mucond(jfast)%p1%statvar(1)%component mucondition='MU('//trim(fast(iel))//')' call get_state_var_value(mucondition,xxx,encoded,ceq) if(gx%bmperr.ne.0) goto 1000 write(*,*)'SMP2A first solid, ',trim(mucondition),xxx,iadd enddo ! initiate slices to count how many slices of solids we have slices=0 endif ! save value of iadd, not allowed to be removed by calc_node notremove=iadd write(*,*)'SMP2A Found new phase',iadd,irem,slices ! use map_calcnode to create new mapnode and mapline. ! We should not set any fix phases, just continue along the axis ! as with a step command with different sets of stable phases call map_calcnode(irem,iadd,maptop,mapline,meqrec,axarr,ceq) ! in map_calcnode a new _MAPNODE and _MAPLINE is created with the new set ! of phases. Store the end point of the line if(gx%bmperr.ne.0) then write(*,*)'Error return from map_calcnode',gx%bmperr goto 1000 endif nullify(maptop%plotlink) ! Terminate the current line, must be after calcnode ... call map_lineend(mapline,axarr(1)%lastaxval,ceq) if(gx%bmperr.ne.0) then write(*,*)'Reset error ',gx%bmperr gx%bmperr=0 endif write(*,665)ceq%tpval(1),1.0D2*npliqval,slices,iadd,irem 665 format('SMP2A T=',F7.2,' K and liquid ',F7.2,'%',3i5) if(.not.(npliqval.gt.0.01)) then ! terminate if npliqval<0.01 BUT IT DOES NOT WORK ??? write(*,*)'Terminating as liquid fraction less than 1%' goto 900 endif ! The Scheil simulation continue along the same axis with new set of phases. write(*,*)'SMP2A calling map_findline' call map_findline(maptop,axarr,mapfix,mapline) if(gx%bmperr.ne.0) then write(*,*)'Error return from map_findline, terminating' goto 1000 endif ! write(*,*)'SMP2A back from map_findline' ! write(*,*)'SMP2A back from map_findline',associated(mapline) ! write(*,*)'SMP2A back from map_findline',associated(mapline%lineceq) ceq=>mapline%lineceq if(slices.lt.0) slices=0 ! write(*,*)'SMP2A calling calceq7 after findline,',slices ! Evidently we have to call calceq7 to initiate meqrec ?? meqrec=>mapline%meqrec call calceq7(mode,meqrec,mapfix,ceq) if(gx%bmperr.ne.0) then if(gx%bmperr.eq.4222 .or. gx%bmperr.eq.4210) then write(*,*)'Scheil cannot handle invariant equilibrium',gx%bmperr else write(*,*)'Failed caculating start of new line',gx%bmperr endif goto 1000 endif ! check if zero fraction of liquid here call get_state_var_value(npliq,yyy,encoded,ceq) ! write(*,*)'SMP2A Scheil liquid fraction: ',yyy,slices if(yyy.lt.0.01D0) then ! Terminate the current line call map_lineend(mapline,axarr(1)%lastaxval,ceq) goto 900 endif ! we have to locate the condition records for the liquid comp in the new ceq ! write(*,*)'SMP2A locating conditions' firstcond=>ceq%lastcondition%next pcond=>firstcond nv=0 ! write(*,*)'SMP2A entering ploop2',nsch ploop2: do while(.TRUE.) ! eternal loop? ! write(*,*)'SMP2A locating Scheil conditions in new ceq',nv if(pcond%active.eq.0) then ! condition is active svr=>pcond%statvar(1) do nc=1,nsch if(svr%statevarid.eq.scheilsvr(nc)%statevarid .and. & svr%argtyp.eq.1 .and.& svr%component.eq.scheilsvr(nc)%component) then if(scheilval(nc)%fcond.gt.0) then ! mucond(jfast)%p1=>ceq%lastcondition ! mucond%fcond=nsch ! write(*,*)'SMP2A found MU condition' mucond(scheilval(nc)%fcond)%p1=>pcond ! temporarily MU condition not implemented scheilval(nc)%p1=>pcond else scheilval(nc)%p1=>pcond ! write(*,*)'Found scheil condition in new ceq: ',nc endif endif enddo endif pcond=>pcond%next nv=nv+1 if(associated(pcond,firstcond)) exit ploop2 enddo ploop2 ! write(*,*)'Node T=',ceq%tpval(1) iadd=0; irem=0 enddo node write(*,*)'Never here!' ! !=========================================== ! exit here if no liquid left at low T limit 900 continue ! maybe clean up? 1000 continue return end subroutine step_scheil2 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable logical function calc_allslices !\begin{verbatim} logical function calc_allslices(maptop,mapline,slices,& offset,fastix,slicefrac) ! calculates all equilibria in saveceq and sums amount of fast element ! maptop map node record ! slices is number of equilibria in saveceq ! offset are the number of equilibria saved before first solid ! fast are fast diffusing elements ! slicefrac is fraction of total for each slice ! implicit none integer slices,fastix(*),offset double precision slicefrac(*) TYPE(map_node), pointer :: maptop type(map_line), pointer :: mapline !\end{verbatim} integer ieq,iel,iph,ics,nv,nofel integer, parameter :: mode=-1 type(map_fixph), allocatable :: mapfix TYPE(gtp_equilibrium_data), pointer :: ceq type(meq_setup), pointer :: meqrec double precision sxmol(20),smass(20),stotmol,totmass,sumslices double precision cxmol(20),xmol(20),wmass(20),totmol,amount logical converged ! write(*,*)'SMP2A in calc_allslices to calculate ',mapline%last,slices,offset converged=.FALSE. if(slices.eq.1) then write(*,*)'SMP2A initiating sliceq' sliceq=mapline%lineceq sliceq%nexteq=0 converged=.TRUE. goto 1000 endif nofel=noel() if(nofel.gt.20) then write(*,*)'SMP2A max 20 elements for Scheil with fast elements' gx%bmperr=4399; goto 1000 endif ! Change conditions to use MU of fast diffusing elements and current T ! calculate equilibria in all slices for current MU and T sumslices=zero do ieq=1,slices sumslices=sumslices+slicefrac(ieq) ! set of stable phases may change, for example delta-ferrite tranform to fcc ! DISCOVERY HERE, conditions were still pointing to mapline%lineceq !!! ! Now the list of conditions not saved, only local and allocated data ! We have to extract phase amounts and constitutions, ignoring liquid ! and calculate new equilibria with current T and MU of fast diffusing element ! using sliceq if(ieq.eq.slices-1) then ceq=>maptop%saveceq%savedceq(offset+ieq) ! Sum amounts of diffusing components, is liquid included? YES ! call calc_molmass(sxmol,smass,stotmol,totmass,ceq) ! if(gx%bmperr.ne.0) goto 1000 cxmol=zero ics=1 sumx: do iph=1,noph() ! skip liquid and unstable phases if(ceq%phase_varres(1)%amfu.ge.1.0D-1 .or.& ceq%phase_varres(1)%amfu.eq.zero) cycle sumx call calc_phase_molmass(iph,ics,xmol,wmass,& totmol,totmass,amount,ceq) if(gx%bmperr.ne.0) goto 1000 ! totmol is total number of moles of phase, xmol(iel) is mole fraction of iel do iel=1,nofel cxmol(iel)=cxmol(iel)+totmol*xmol(iel) enddo write(*,10)'allslices1: ',iph,amount,& (cxmol(nv),nv=1,nofel) 10 format(a,i3,1pe12.4,10(0pF6.3)) enddo sumx ! slicefrac(ieq) is fracion of this slice of solid write(*,10)'allslices2: ',0,slicefrac(ieq),& (sxmol(nv),nv=1,nofel) meqrec=>mapline%meqrec ! set amounts as conditions together with MU including T, P and N=1 ! call calceq7(mode,meqrec,mapfix,ceq) ! if(gx%bmperr.ne.0) then ! write(*,*)'Error slice ',ieq,gx%bmperr ! gx%bmperr=0; ! endif ! write(*,*)'SMP2A slice and T: ',ieq+offset,ceq%tpval(1) ! call list_conditions(kou,ceq) endif enddo write(*,*)'Sum slicefracs: ',sumslices ! sum up amount of fast element(s) in all slices, multiply with the ! size of the slice and return. Several calculations with ! different values of MU mab be needed. converged=.TRUE. 1000 continue calc_allslices=converged return end function calc_allslices !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine step_paraequil !\begin{verbatim} subroutine step_paraequil(maptop,noofaxis,axarr,seqxyz,tupix,fastelno,starteq) ! calculates a paraequilibrium diagram ! maptop map node record ! noofaxis must be 1 ! axarr array of axis records ! seqxyz indices for map and line records ! starteq is an equilibrium with just two phases stable ! tupix are phasetuple indices of two phases ! fastelno fast diffusing component index ! ! TO BE MODIFIED ! ! we will use the same overall conditions except for the carbon implicit none integer noofaxis,seqxyz(*),tupix(*),fastelno type(map_axis), dimension(noofaxis) :: axarr TYPE(gtp_equilibrium_data), pointer :: starteq TYPE(map_node), pointer :: maptop !\end{verbatim} TYPE(gtp_equilibrium_data), pointer :: ceq,neweq integer jj,jp,seqz,iadd,irem,nv,saveq,lokcs,mapx,idir,seqx,seqy,kpos integer inactive(4),mode,nc,npara,liquid,errall type(map_node), pointer :: mapnode type(map_line), pointer :: mapline type(map_fixph), allocatable :: mapfix ! we have to choose between meqrec or meqrec1 .... normal step use meqrec1 type(meq_setup), pointer :: meqrec type(meq_setup), allocatable, target :: meqrec1 type(gtp_state_variable), target :: fastxsvr,fastmusvr type(gtp_state_variable), target :: matrixsvr,growxsvr type(gtp_state_variable), pointer :: svr type(meq_phase), pointer :: phr type(gtp_condition), pointer :: pcond,axcond double precision xxx,yyy,zzz,fact,fact1,axvalok character eqname*24,phname*24,npliq*24,encoded*72,setmucond*64 integer, parameter :: maxsavedceq=1800 ! temporary storage of results double precision xpara(2) ! turns off convergence control for T integer, parameter :: inmap=1 ! needed to store links to condition values TYPE smp_paraequil_condval ! these pointers must be updated for each new line (equilibrium) type(gtp_condition), pointer :: p1 end type smp_paraequil_condval ! These two arrays keep track of conditions and liquid compositis ! the first is pointers to the condition record, the second is statevariable id ! type(smp_paraequil_condval), dimension(20) :: paraval ! TYPE(gtp_state_variable), target, dimension(20) :: parasvr ! ! write(*,*)'SMP2A In step_paraequil',tupix(1),tupix(2),fastelno if(noofaxis.ne.1) then write(kou,*)'Paraequilibrium simulations one axis variable' goto 1000 endif ! ceq=>starteq jp=1 findxcond: do while(.true.) ! find the condition on the amount of the fast diffusing element ! ?? does this loop through all conditions number 1..n? YES call locate_condition(jp,pcond,starteq) if(gx%bmperr.eq.4295) then ! this error code means no more conditions gx%bmperr=0; exit findxcond endif if(gx%bmperr.ne.0) goto 1000 ! skip conditions not active if(pcond%active.ne.0) cycle findxcond svr=>pcond%statvar(1) ! write(*,*)'findcond: ',jp,svr%statevarid,svr%argtyp,svr%component if(svr%component.eq.fastelno) then if(svr%argtyp.ne.1) then write(*,*)'Problem, condition not on overall fraction' stop 'paraeq 3' endif ! fastxcondno=jp ! here it should be assigned, not a pointer fastxsvr=svr endif ! avoid eternal loop? jp=jp+1 if(jp.gt.20) stop 'eternal loop in step_paraeq' enddo findxcond if(allocated(meqrec1)) deallocate(meqrec1) allocate(meqrec1,stat=errall) if(errall.ne.0) then write(*,*)'MM Allocation error 19: ',errall gx%bmperr=4370; goto 1000 endif meqrec=>meqrec1 ! write(*,*)'Calling calc_paraeq first time',tupix(1),tupix(2),fastelno ! check we can calculate a paraequilibrium call calc_paraeq(tupix,fastelno,xpara,meqrec,meqrec1,starteq) if(gx%bmperr.ne.0) then write(*,*)'Sorry, cannot calculate an initial paraequilibrium',gx%bmperr goto 1000 endif ! write(*,'(a,2F10.6)')'first paraeq:',xpara(1),xpara(2) ! ! gx%bmperr=4399; goto 1000 ! ================================================================= inactive=0 ! inactive(1)=-1 is used when only one exit point with direcition -1 ! generate step/map datastructure needed for plotting and phase set changes. ! in map_startpoint an equilibrium will be calculated and maplines created call map_startpoint(maptop,noofaxis,axarr,seqxyz,inactive,starteq) if(gx%bmperr.ne.0) goto 1000 ! create storage area for results ! write(*,*)'Back from map_startpoint' call create_saveceq(maptop%saveceq,maxsavedceq) if(gx%bmperr.ne.0) goto 1000 ! Mark this as a paraequil step maptop%type_of_node=4 ! ensure plotlink is nullified!! nullify(maptop%plotlink) ! write(*,*)'Taking the first line' ! take the first line created by map_startpoint call map_findline(maptop,axarr,mapfix,mapline) if(gx%bmperr.ne.0) goto 1000 ceq=>mapline%lineceq mode=-1 call locate_condition(axarr(1)%seqz,axcond,ceq) if(gx%bmperr.ne.0) goto 1000 !----------------------------------------------- line loop jp=0 lineloop: do while(.TRUE.) ! there will be no phase changes during the STEP command, no new nodes jp=jp+1 ! write(*,*)'SMP2A Calculating paraequilibrium',jp call calc_paraeq(tupix,fastelno,xpara,meqrec,meqrec1,ceq) if(gx%bmperr.ne.0) then ! terminate the line and check if more lines goto 500 endif ! if(jp.eq.0) then ! We need the meqrec below ... ! maptop%meqrec=meqrec ! endif ! first argument 1 means to get the value call condition_value(1,axcond,xxx,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,'(a,F12.6,": ",2F10.6)')'SMP2A paraeq:',xxx,xpara(1),xpara(2) ! calculation OK, save it call map_store(mapline,axarr,1,maptop%saveceq) ! write(*,*)'Stored calculated equilibrium' if(gx%bmperr.ne.0) then write(*,*)'Error storing equilibria',gx%bmperr goto 1000 endif ! take a step, at second line the step is zero ... why?? ! write(*,*)'SMP2A Calling map_step2',size(meqrec%phr) ! call map_step2(maptop,mapline,meqrec,meqrec%phr,axvalok,1,axarr,ceq) ! in call to map_step2 meqrec is not a pointer !! call map_step2(maptop,mapline,meqrec1,meqrec%phr,axvalok,1,axarr,ceq) if(gx%bmperr.ne.0) goto 500 ! when outside limits aapline%more is negative if(mapline%more.lt.0) then ! this indicate outside axis limits, call map_findline or finish call map_lineend(mapline,axarr(abs(mapline%axandir))%lastaxval,ceq) goto 510 endif cycle lineloop ! treating problems 500 continue if(gx%bmperr.ne.0) then write(*,*)'SMP2A error in step_paraequil',gx%bmperr ! terminate the line, error code cleared call map_lineend(mapline,axarr(mapline%axandir)%lastaxval,ceq) ! some errors maybe fatal endif 510 continue ! take another line created by map_startpoint call map_findline(maptop,axarr,mapfix,mapline) if(gx%bmperr.ne.0) goto 1000 if(.not.associated(mapline)) then ! write(*,*)'SMP2A no more lines' ! call list_conditions(kou,ceq) exit lineloop endif ceq=>mapline%lineceq ! axcond changed because ceq changed!! ! write(*,*)'New line, change axis condition record' ! call list_conditions(kou,ceq) call locate_condition(axarr(1)%seqz,axcond,ceq) if(gx%bmperr.ne.0) goto 1000 ! Wow, forgot > svr=>axcond%statvar(1) call state_variable_val(svr,xxx,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'Next line start at: ',xxx ! call list_conditions(kou,ceq) ! first argument 0 means to set the value NOT ALWAYS T BEWARE ! call condition_value(0,axcond,xxx,ceq) ! if(gx%bmperr.ne.0) goto 1000 ! call list_conditions(kou,ceq) ! meqrec contain information from the calculated equilibrium meqrec=>mapline%meqrec enddo lineloop !=========================================== ! exit here when followed the line in both directions remove all axcond 900 continue ! maybe clean up? ! Allow plotting tie-lines maptop%tieline_inplane=1 1000 continue ! write(*,*)'Finished step_paraequil, list condition?' ! call list_conditions(kou,ceq) return end subroutine step_paraequil !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine auto_startpoints !\begin{verbatim} subroutine auto_startpoints(maptop,noofaxis,axarr,seqxyz,starteqs) ! Calculates 5 equilibria and store them as start points for mapping ! maptop map node record ! noofaxis must be 2 ! axarr array of axis records ! seqxyz indices for map and line records ! starteq equilibrium record for starting implicit none integer noofaxis,seqxyz(*) type(map_axis), dimension(noofaxis) :: axarr ! TYPE(gtp_equilibrium_data), pointer :: starteq TYPE(starteqlista), dimension(*) :: starteqs TYPE(map_node), pointer :: maptop !\end{verbatim} ! genrate one startpoint in each corner and one in the center ! For the corner add one directions along each axis ! For the center add 4 directions, totally 12 lines ! For isothermal sections one corner startpoint will be lost ! startpoint 0.02x, 0.02y; direction +x and +y ! startpoint 0.94x, 0.02y; direction -x and +y ! startpoint 0.94x, 0.94y; direction -x and -y (lost in isothermal section) ! startpoint 0.02x, 0.94y; direction +x and -y ! startpoint 0.3x, 0.3y; all 4 directions (should work also in isothermal) integer seqz1,seqz2,j1,j2,mode,nss double precision xx1,xx2 TYPE(gtp_equilibrium_data), pointer :: ceq,neweq,starteq type(gtp_condition), pointer :: pcond1,pcond2 double precision, dimension(2), parameter :: x1=[0.02,0.92] double precision, dimension(2), parameter :: x2=[0.02,0.92] character*24 eqname ! if(noofaxis.ne.2 .or. & btest(globaldata%status,GSNOAUTOSP)) goto 1000 ! goto 1000 ! the rest here works but not converting the startpoint to lines. write(*,*)'SMP *** in auto_startpoints' ceq=>starteqs(1)%p1 ! added assignment to started as used below starteq=>ceq mode=1 eqname='_STARTEQ_00' nss=0 ! loop for corners 100 continue cycle1: do j1=1,2 !----------- xx2=axarr(2)%axmin+x2(j2)*(axarr(2)%axmax-axarr(2)%axmin) seqz2=axarr(2)%seqz call locate_condition(seqz2,pcond2,ceq) if(gx%bmperr.ne.0) then write(*,*)'SMP failed find 2nd condition ',j1,j2 gx%bmperr=0 cycle cycle1 endif ! first argument 1 means get value, 0 means set value call condition_value(0,pcond2,xx2,ceq) if(gx%bmperr.ne.0) then write(*,*)'Error setting start point condition',gx%bmperr gx%bmperr=0; cycle cycle1 endif cycle2: do j2=1,2 write(*,*)'SMP auto ',j1,j2 nss=nss+1 xx1=axarr(1)%axmin+x1(j1)*(axarr(1)%axmax-axarr(1)%axmin) seqz1=axarr(1)%seqz call locate_condition(seqz1,pcond1,ceq) if(gx%bmperr.ne.0) then write(*,*)'SMP failed find first condition ',j1,j2 gx%bmperr=0 cycle cycle2 endif ! first argument 1 means get value, 0 means set value call condition_value(0,pcond1,xx1,ceq) if(gx%bmperr.ne.0) then write(*,*)'Error setting start point condition',gx%bmperr gx%bmperr=0; cycle cycle2 endif ! calculate equilibrium ! write(*,130)'SMP startpoint: ',nss,xx1,xx2 130 format(a,i3,2(1pe14.4)) ! call list_conditions(kou,ceq) call calceq2(mode,ceq) if(gx%bmperr.ne.0) then write(*,*)'SMP failed calculate startpoint' gx%bmperr=0 else ! enter a start equilibrum with two directions write(*,*)'SMP eqname: ',eqname call incunique(eqname(10:11)) write(*,*)'SMP eqname: ',eqname call copy_equilibrium(neweq,eqname,ceq) if(gx%bmperr.ne.0) then write(*,*)'Failed to store starteq: ',trim(eqname),gx%bmperr gx%bmperr=0; cycle cycle2 endif write(*,*)'SMP Created equilibrium: ',trim(eqname),neweq%eqno neweq%multiuse=20+nss ! create the list, ceq is always same equilibrium as starteq neweq%nexteq=ceq%nexteq ! starteq not assigned here ... set to ceq above /BoS 20200220 starteq%nexteq=neweq%eqno endif enddo cycle2 enddo cycle1 ! a start point in the middle 500 continue xx1=0.7*axarr(1)%axmin+0.3*axarr(1)%axmax seqz1=axarr(1)%seqz call locate_condition(seqz1,pcond1,ceq) if(gx%bmperr.ne.0) then write(*,*)'SMP failed find first condition',3,3 gx%bmperr=0 goto 1000 endif ! first argument 1 means get value, 0 means set value call condition_value(0,pcond1,xx1,ceq) if(gx%bmperr.ne.0) then write(*,*)'Error setting first central point condition',gx%bmperr gx%bmperr=0; goto 1000 endif xx2=0.6*axarr(2)%axmin+0.4*axarr(2)%axmax seqz2=axarr(2)%seqz call locate_condition(seqz2,pcond2,ceq) if(gx%bmperr.ne.0) then write(*,*)'SMP failed find 2nd condition ',j1,j2 gx%bmperr=0 goto 1000 endif ! first argument 1 means get value, 0 means set value call condition_value(0,pcond2,xx2,ceq) if(gx%bmperr.ne.0) then write(*,*)'Error setting second central point condition',gx%bmperr gx%bmperr=0; goto 1000 endif ! calculate equilibrium ! write(*,130)'SMP startpoint: ',5,xx1,xx2 ! call list_conditions(kou,ceq) call calceq2(mode,ceq) if(gx%bmperr.ne.0) then write(*,*)'SMP failed calculate startpoint' gx%bmperr=0 else ! enter a start equilibrum with two directions call incunique(eqname(10:11)) call copy_equilibrium(neweq,eqname,ceq) if(gx%bmperr.ne.0) then write(*,*)'Failed to store start equilibrium',gx%bmperr gx%bmperr=0; goto 1000 endif neweq%multiuse=30 neweq%nexteq=starteq%nexteq starteq%nexteq=neweq%eqno endif 1000 continue write(*,*)'SMP *** leaving auto_startpoint' return end subroutine auto_startpoints !\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine reset_plotoptions !\begin{verbatim} subroutine reset_plotoptions(graphopt,plotfile,textlabel) ! if new axis then reset default plot options ! plot ranges and their defaults character plotfile*(*) type(graphics_options) :: graphopt type(graphics_textlabel), pointer :: textlabel !\end{verbatim} integer savebit graphopt%gibbstriangle=.FALSE. graphopt%rangedefaults=0 ! axistype 0 is linear, 1 is logarithmic graphopt%axistype=0 ! labeldefaults(1) is the title!!! graphopt%labeldefaults=0 graphopt%tielines=0 graphopt%plotmin=zero graphopt%dfltmin=zero graphopt%plotmax=one graphopt%scalefact=one graphopt%dfltmax=one graphopt%appendfile=' ' ! do not reset font! ! graphopt%font='Arial' ! This is confused ... GRWIN=0 if WIndows, GRWIN=1 if not windows ... SUCK ! if(btest(graphopt%status,GRWIN)) savebit=1 ! if the bit GRKEEP is set it should remain set ! savebit=0 ! if(btest(graphopt%status,GRKEEP)) savebit=1 ! if(savebit.ne.0) graphopt%status=ibset(graphopt%status,GRKEEP) ! remove all texts ... loosing some memory ... nullify(graphopt%firsttextlabel) graphopt%labelkey='top right font "'//trim(graphopt%font)//',12" ' nullify(graphopt%firsttextlabel) nullify(textlabel) plotfile='ocgnu' ! reset status but by default spawn plots graphopt%status=0 graphopt%status=ibset(graphopt%status,GRKEEP) ! lowerleftcorner graphopt%lowerleftcorner=' ' ! default plot terminal graphopt%gnutermsel=1 ! plot linetype default 1 graphopt%linetype=1 ! no plot symbols graphopt%linewp=0 ! axis tics size etc graphopt%textonaxis=0 ! setgrid graphopt%setgrid=0 ! do not reset plotend if set ! plotend=plotenddefault ! write(*,*)'Plot options reset' return end subroutine reset_plotoptions !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ ================================================ FILE: src/stepmapplot/smp2B.F90 ================================================ ! included in smp2.F90. Generating graphics using GNUPLOT !\addtotable subroutine ocplot2 !\begin{verbatim} subroutine ocplot2(ndx,maptop,axarr,graphopt,version,ceq) ! subroutine ocplot2(ndx,pltax,filename,maptop,axarr,graphopt,pform,& ! version,ceq) ! Main plotting routine, generates a GNUPLOT data file for a step/map calc ! NOTE for isothermal section ocplot3 is used (when 2 axis with wildcards) ! ndx is mumber of plot axis, ! - pltax is text with plotaxis variables ! - filename is the name of the GNUPLOT file ! maptop is map_node record with all results ! axarr is array of axis records ! graphopt is graphical option record ! NOT USED: pform is type of output (screen/acrobat/postscript/gif) ! ceq is equilibrium record implicit none integer ndx ! character pltax(*)*(*),filename*(*),pform*(*) character version*(*) type(map_axis), dimension(*) :: axarr type(map_node), pointer :: maptop type(graphics_options) :: graphopt TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ ! local variables set from graphopt ! character pltax(2)*64,filename*64,pform*32 character pltax(2)*64,filename*128 ! type(map_ceqresults), pointer :: results TYPE(gtp_equilibrium_data), pointer :: curceq type(map_node), pointer :: mapnode,invar,localtop type(map_line), pointer :: mapline logical wildcard,hashtag character ch1*1,gnuplotline*256,pfd*128,pfc*256 character pfh*128,dummy*24 double precision, dimension(:,:), allocatable :: anp double precision, dimension(:), allocatable :: xax,yyy ! save isopleth invariants in special array, max 50 invariants double precision xyinv(4,50) integer ninv ! Too big?? ! integer, parameter :: maxval=10000 ! plotting isothermal section Cr-Fe-Mo required more than 2000 integer, parameter :: maxval=4000 integer, dimension(:), allocatable :: nonzero,linzero,linesep ! integer, dimension(:), allocatable :: linesep ! encoded2 stores returned text from get_many ... 2048 is too short ... ! selphase used when plotting data just for a selected phase like y(fcc,*) character statevar*64,encoded1*1024,encoded2*4096,selphase*24,funsym*24 character*128, dimension(:), allocatable :: phaseline integer i,ic,jj,k3,kk,kkk,lokcs,nnp,np,nrv,nv,nzp,ip,nstep,nnv,nofapl integer nr,line,next,seqx,nlinesep,ksep,iax,anpax,notanp,appfil,errall double precision xmax,xmin,ymax,ymin,value,anpmin,anpmax ! used for Scheil double precision npflval logical scheilorder ! lhpos is last used position in lineheader integer giveup,nax,ikol,maxanp,lcolor,lhpos,repeat,anpdim,qp integer nix,stoichfix,invlines,invnode,nrett,mfix integer, allocatable, dimension(:) :: ixpos ! setting color on isopleth lines? Dimension is max different fix phases integer, allocatable, dimension(:,:) :: phamfu integer fixphasecolor ! trying to understand integer ttunodeid,ttuheads,ttutoplines,ttuline,ttuplotline,haha character date*8,mdate*12,title*128,backslash*2,lineheader*1024 character deftitle*128,labelkey*64 logical overflow,first,last,novalues,selectph,varofun,moretops,isopleth logical, allocatable, dimension(:) :: nevernone ! dot derivatives should not be calcuated at first point of a range logical skipdotder ! textlabels type(graphics_textlabel), pointer :: textlabel ! line identification (title) character*16, dimension(:), allocatable :: lid ! character*32, dimension(:), allocatable :: lid ! ! write(*,*)'In ocplot2 graphopt%status: ',maptop%status,MAPINVARIANT ! transfer from graphics record to local variables ! initiate lines_excluded lines_excluded=0 scheilorder=.FALSE. ! create the terminal plot_line record allocate(lastplotline) nullify(lastplotline%nextline) lastplotline%type=-1 plotline1=>lastplotline ! when creating a new plotline: ?? ! 1: allocate(plotline%nextline) ! 2: plotline%nextline%nextline=>plotline1 ! 3: ploline1=>plotline1%nextline ! transfer from graphics record to local variables pltax(1)=graphopt%pltax(1) pltax(2)=graphopt%pltax(2) isopleth=btest(graphopt%status,GRISOPLETH) ! write(*,*)'ocplot2 wildcard: ',trim(pltax(1)),' & ',trim(pltax(2)) ! if(index(pltax(1),'*').gt.0 .or. index(pltax(2),'*').gt.0) then ! fixed in PMON6 ! allow plotting phase compositions also for isopleths ... ! isopleth=.FALSE. ! endif if(isopleth) write(*,*)'smp2b plotting isopleth' filename=graphopt%filename funsym=' ' ! for isopleths this value determine the line color fixphasecolor=1 ! If wildcard on two axis use ocplot3 to extract data (tie-lines in plane) if(index(pltax(1),'*').gt.0 .and. index(pltax(2),'*').gt.0) then ! write(*,*)'Using ocplot3' call ocplot3(ndx,pltax,filename,maptop,axarr,graphopt,& version,ceq) goto 1000 endif ! for tzero lines there is no meqrec record, meqrec%phr not allocated ! write(*,*)'In ocplot2: ',maptop%lines,allocated(maptop%linehead) moretops=.FALSE. seqx=0 call date_and_time(date) mdate=" "//date(1:4)//'-'//date(5:6)//'-'//date(7:8)//" " deftitle='OpenCalphad '//version//': '//mdate//': with GNUPLOT' if(graphopt%labeldefaults(1).eq.0) then title=deftitle else ! alwas inlcude open calphad and date, add user title at the end ! 123456789.123456789.123456789 ! 'Open Calphad 3.0 2015-03-16 : with GNUPLOT' jj=len_trim(deftitle) title=deftitle(1:jj+1)//graphopt%plotlabels(1) endif ! if(.not.associated(maptop)) then write(kou,*)'In ocplot2 but nothing to plot' gx%bmperr=4247; goto 1000 endif ! write(*,*)'Entering OC plot version 2: ',& ! pltax(1)(1:len_trim(pltax(1))),', ',pltax(2)(1:len_trim(pltax(2))),& ! maptop%next%seqx if(graphopt%rangedefaults(1).ne.0) then write(*,11)'x',graphopt%plotmin(1),graphopt%plotmax(1) 11 format('SMP limits set by user for ',a,': ',2(1pe14.6)) endif if(graphopt%rangedefaults(2).ne.0) then write(*,11)'y',graphopt%plotmin(2),graphopt%plotmax(2) endif ! allocate as many items in linesep as there are mapnodes. ! Hm, if merging plots the number of separators needed can be any value jj=100+10*maptop%next%seqx+1 ! write(*,*)'SMP: Allocating linesep: ',jj allocate(linesep(jj),stat=errall) if(errall.ne.0) then write(*,*)'SMP2B Allocation error 1: ',errall gx%bmperr=4370; goto 1000 endif nax=maptop%number_ofaxis linesep=0 ! allocate texts to identify the lines on the gnuplot file ! write(*,*)'SMP: Allocating phaseline: ',jj allocate(phaseline(jj),stat=errall) allocate(phamfu(2,jj),stat=errall) if(errall.ne.0) then write(*,*)'SMP2B Allocation error 2: ',errall gx%bmperr=4370; goto 1000 endif ! sometimes phaseline used containing rubbish ... phaseline=' ' ! zero array fr isopleth fix phase phamfu=0 ! if(maptop%number_ofaxis.gt.1) then ! write(*,*)'Warning: may not not handle map graphics correctly',jj ! endif ! giveup=0 nrv=maxval ! write(*,*)'SMP: allocating xax: ',nrv allocate(xax(nrv),stat=errall) if(errall.ne.0) then write(*,*)'SMP2B Allocation error 3: ',errall gx%bmperr=4370; goto 1000 endif ! to insert MOVE at axis terminations nlinesep=1 phaseline(1)=' ' phaseline(2)=' ' ! nv is number of values to plot nv=0 ! min and max not used by gnuplot but may be useful if plotpackage change ! or for manual scaling. xmin=1.0D20 xmax=-1.0D20 ymin=1.0D20 ymax=-1.0D20 maxanp=1000 np=maxanp qp=1 ninv=0 wildcard=.FALSE. selectph=.FALSE. hashtag=.FALSE. selphase=' ' graphopt%specialdiagram=0 if(maptop%type_of_node.eq.3) then ! this change the order of plotting the lines, maybe needed only for PFL/PFS ?? scheilorder=.TRUE. endif do iax=1,2 ! write(*,*)'Allocating for axis: ',iax call capson(pltax(iax)) if(pltax(iax)(1:4).eq.'PFL ' .or. pltax(iax)(1:4).eq.'PFS ') then if(maptop%type_of_node.eq.3) then ! this is a function only used for plotting phase fraction liquid or solids ! in Scheil simulations. npflval=one ! this indicates to ocplot2B that one must use plot "-" ...etc ! to have different colors and labels on different lines ! write(*,*)'ocplot2: Setting graphopt%specialdiagram=2' graphopt%specialdiagram=2 else write(*,*)'Plot axis PFL/PFS are reserved for Scheil simulations' gx%bmperr=4399; goto 1000 endif endif ! wildcard1: if(index(pltax(iax),'*').gt.0) then wildcard1: if(index(pltax(iax),'*').gt.0 .or. & index(pltax(iax),'(#)').gt.0) then ! searching for (#) avoids problem when # is used for comp. sets or sublattatice i=index(pltax(iax),'#') if(i.gt.0 .and.& (pltax(iax)(i+1:i+1).eq.')'.or.pltax(iax)(i+1:i+1).eq.',')) then ! this means the phase name is #, indicating all phases including dormant ! Note that # is used to indicate composition sets, thus ignore #2 etc hashtag=.TRUE. ! write(*,*)'SMP2B hastag set true',trim(pltax(iax)),i endif if(wildcard) then write(*,*)'in OCPLOT2 one axis variable with wildcard allowed' goto 1000 endif ! wildcards allowed only on one axis, we do not know how many columns needed ! allocate as many array elements as columns anpdim=np ! write(*,*)'SMP: allocating anp1: ',np*nrv allocate(anp(np,nrv),stat=errall) ! write(*,*)'SMP: allocating anp2: ',np ! nonzero indicates for each column if there is any nonzero value ! columns with only zero values will be eliminated before plotting allocate(nonzero(np),stat=errall) ! write(*,*)'SMP: allocating nonzero: ',np ! linzero indicate for the present block of equilibria for each column ! if this column contain nonzero values allocate(linzero(np)) ! write(*,*)'SMP: allocating yyy: ',np allocate(yyy(np),stat=errall) if(errall.ne.0) then write(*,*)'SMP2B Allocation error 5: ',errall gx%bmperr=4370; goto 1000 endif nzp=np ! nzp should be dimension of yyy, np returns the number of values in yyy ! yyy is to extract state variable values for the column with wildcard ! NOTE binary phase diagrams are plotted with wildcard axis like x(*,cr) vs T ! nevernone is an attempt to remove columns that are zero by the value NaN allocate(nevernone(np),stat=errall) if(errall.ne.0) then write(*,*)'SMP2B Allocation error 6: ',errall gx%bmperr=4370; goto 1000 endif nevernone=.FALSE. nonzero=0 wildcard=.TRUE. anpax=iax ! we can have wildcards as np(*), w(fcc,*) or w(*,cr) or y(gas,*) ! IT IS NOT ALLOWED TO HAVE y(*,*) ... only one wildcard ! when we plot things like y(fcc,*) we should only select equilibria ! with fcc stable. Check if * is before or after a , ! NOTE that a single * without , can be phase or component: ! MU(*) is for a component, HM(*) is for a phase ! For MQMQA one sometimes plot N(*,component) when phase have zero amount ikol=index(pltax(iax),',') ! write(*,*)'smp2b selectph: ',trim(pltax(iax)),ikol if(ikol.gt.0) then ! if the * is after the , then extract the phase name before ! and set selecrph to TRUE if(pltax(iax)(ikol+1:ikol+1).eq.'*') then nrv=index(pltax(iax),'(') if(nrv.lt.ikol) then selphase=pltax(iax)(nrv+1:ikol-1) ! write(*,*)'SMP2B wildcard selected phase: ',trim(selphase) selectph=.TRUE. endif ! else ! we can also have N(*,constituent) plotting MQMQA diagrams? Never here ! write(*,*)'SMP2B plotting: ',trim(pltax(iax)) endif ! else ! this is perfectly possible, for example NP(*) ! write(*,*)'SMP2B: Wildcard without ,!' endif endif wildcard1 enddo if(.not.wildcard) then anpdim=1 allocate(anp(anpdim,nrv),stat=errall) if(errall.ne.0) then write(*,*)'SMP2B Allocation error 7: ',errall gx%bmperr=4370; goto 1000 endif wildcard=.FALSE. nnp=1 anpax=2 endif ! zero anp, maybe waste of time but ... anp=zero ! if anpax is 1, notanp is 2, if anpax is 2, notanp is 1 notanp=3-anpax localtop=>maptop ! write(*,*)'In ocplot2, looking for segmentation fault 2' !------------- ! come back here if there is another localtop in plotlink! 77 continue ! change all "done" marks in mapnodes to zero ! write(*,*)'SMP2B ocplot2 at label 77A: ',localtop%lines ikol=0 do nrv=1,localtop%lines if(allocated(localtop%linehead)) localtop%linehead(nrv)%done=0 enddo ! we sometimes have a segmentation fault when several maptops ... if(associated(localtop%next)) then mapnode=>localtop%next invnode=0 if(btest(mapnode%status,MAPINVARIANT)) then invnode=size(mapnode%linehead) ! write(*,*)'ocplot2 invariant node 1',invnode endif else write(*,*)'Mapnode next link missing 1' goto 79 endif ! write(*,*)'SMP2B ocplot2 at label 77B: ',localtop%lines thisloop: do while(.not.associated(mapnode,localtop)) do nrv=1,mapnode%lines mapnode%linehead(nrv)%done=0 enddo if(.not.associated(mapnode%next)) then write(*,*)'Mapnode next link missing 2' exit thisloop endif mapnode=>mapnode%next enddo thisloop !----------- 79 continue if(.not.associated(localtop%saveceq)) then write(*,*)'Plot data structure has no results to plot' gx%bmperr=4399; goto 1000 endif results=>localtop%saveceq mapnode=>localtop line=1 ! looking for segmentation fault running map11.OCM as part of all.OCM in oc4P ! This error may be due to having created (or not created) composition sets ... ! write(*,*)'SMP2B ocplot2 after label 79' ! extract the names of stable phases for this lone ! write(*,*)'mapnode index: ',mapnode%seqx ! write(*,*)'Before label 100: ',results%free !------------------------------------------- begin loop 100 ! loop back here from ?? 100 continue ! write(*,*)'SMP2B ocplot2 at label 100',localtop%seqx,line,& ! size(localtop%linehead) mapline=>localtop%linehead(line) ! TRYING TO UNDERSTAND WHAT IS HAPPENING HERE .... ttunodeid=localtop%seqx ttuheads=size(localtop%linehead) ttutoplines=localtop%lines ttuline=line ttuplotline=nv ! write(*,101)'At 100',ttunodeid,ttuheads,ttutoplines,ttuline,ttuplotline 101 format('Line selected: ',a,': nodeid ',i3,', heads/lines: ',2i2,& ' index: ',i2,', plotline: ',2i4) ! initiate novalues to false for each line novalues=.false. ! skip first point if dot derivative skipdotder=.TRUE. ! We have a segmentation fault sfter this in oc4P when running map11.OCM ! at the end of running all macros. ! write(*,*)'In ocplot2, looking for segmentation fault 3' ! skip line if EXCLUDEDLINE set if(btest(mapline%status,EXCLUDEDLINE)) then ! write(*,*)'Skipping a line 3' lines_excluded=lines_excluded+1 if(line.lt.mapnode%lines) then line=line+1 goto 100 else goto 500 endif endif ! We jump here from where?? ... several places 110 continue ! mark line is plotted ! write(*,*)'Values from mapline ',mapline%lineid ! loop for all calculated equilibria, phases and composition sets ! write(*,*)'Before label 150: ',mapline%lineid !150 continue nr=mapline%first if(mapline%done.ne.0) goto 220 mapline%done=-1 ! if(ocv()) write(*,*)'Plotting line: ',& ! write(*,*)'Plotting line: ',& ! mapline%lineid,mapline%number_of_equilibria,mapline%termerr !-------------- ttunodeid=localtop%seqx ttuheads=size(localtop%linehead) ttutoplines=localtop%lines ttuline=line ttuplotline=nv ! write(*,101)'at 110',ttunodeid,ttuheads,ttutoplines,ttuline,& ! ttuplotline !-------------- if(mapline%lineid.le.0) then write(*,*)'Skipping line with id less or equal to zero' goto 500 elseif(mapline%number_of_equilibria.le.0) then ! write(*,*)'Skipping line with no equilibria.' goto 500 endif first=.TRUE. ! last set true when we reach the last equilibrium on the line last=.FALSE. ! we may have empty lines due to bugs ... ! write(*,*)'Axis with wildcard and not: ',anpax,notanp !200 continue ! this is the loop for all equilibria in the line ! write(*,*)'SMP2: nr and nv: ',nr,nv ! Possibly skip last if mapline%termerr not zero ! if(mapline%termerr.ne.0) write(*,*)'SMP2B termerr:',mapline%termerr nrett=nv+1 plot1: do while(nr.gt.0) ! nr is index to stored equilibrium if(last.and. mapline%termerr.ne.0) then ! skip this equilibrium!! nr=0 ! write(*,*)'Skipping last point of a line in the plot' ! same as cycle plot1 but maybe safer?? goto 220 ! cycle plot1 endif nv=nv+1 if(nv.ge.maxval) then write(*,*)'Too many points to plot',maxval goto 600 endif curceq=>results%savedceq(nr) ! write(*,201)'SMP2B Current: ',nr,nv,curceq%tpval(1) if(ocv()) write(*,201)'Current equilibrium: ',nr,nv,curceq%tpval(1) 201 format(a,2i5,F8.2,1pe14.6) ! extract the names of stable phases to phaseline from the first equilibrium ! Note that the information of the fix phases have not been saved if(first) then ! segmentation fault after here ! write(*,*)'In ocplot2, looking for segmentation fault 4A' first=.false. kk=1 ! leave space to write fixphasecolor index first if(isopleth) kk=5 ! if(selectph) novalues=.TRUE. phloop: do jj=1,noph() ! write(*,*)'In ocplot2, segmentation fault 4Ax',jj,noofcs(jj) do ic=1,noofcs(jj) k3=test_phase_status(jj,ic,value,curceq) if(gx%bmperr.ne.0) goto 1000 stableph1: if(k3.gt.0) then ! this phase is stable or fix call get_phase_name(jj,ic,dummy) if(gx%bmperr.ne.0) goto 1000 if(selectph) then ! this is an attempt to remove lines from irrelevant equilibria when plotting ! data for a specific phase like y(fcc#4,*) which is not stable?? if(abbr_phname_same(dummy,trim(selphase))) then novalues=.FALSE. ! write(*,217)'SMP2B novalues set FALSE',& ! mapline%lineid,trim(dummy),trim(selphase) 217 format(a,i5,2x,a,2x,a) exit phloop else novalues=.TRUE. ! write(*,*)'SMP2B novalues set TRUE',mapline%lineid endif endif if(.not.novalues) then ! I think this phaseline is no longer used ?? YES it is ! write(*,*)'SMP addto phaseline 1: ',trim(dummy),& ! nlinesep phaseline(nlinesep)(kk:)=dummy kk=len_trim(phaseline(nlinesep))+2 endif linecolor: if(isopleth .and. value.eq.zero) then ! attempt to have the same color for all lines with same fix phase kkk=10*jj+ic do mfix=1,nlinesep if(kkk.eq.phamfu(1,mfix)) then phamfu(1,nlinesep)=kkk phamfu(2,nlinesep)=phamfu(2,mfix) ! write(*,*)'smp2b same: ',kkk,phamfu(1,mfix) exit linecolor endif enddo if(mfix.gt.nlinesep) then phamfu(1,nlinesep)=kkk phamfu(2,nlinesep)=fixphasecolor fixphasecolor=fixphasecolor+1 ! save phase names in lid for KET, how many phases? if(.not.allocated(lid)) then allocate(lid(20)) lid=' ' endif lid(fixphasecolor-1)=dummy endif ! write(*,'(a,7i5)')'smp2b phasecolor: ',nlinesep,mfix,& ! kkk,jj,fixphasecolor endif linecolor endif stableph1 enddo enddo phloop ! finding place to change color of line in Scheil simulations ! write(*,'(a,i3,2x,a)')'ocplot2 extract stable phases ',& ! nlinesep,trim(phaseline(nlinesep)) ! do kkk=1,nlinesep ! write(*,'(a,i3,3i5)')'smp2b color: ',nlinesep,& ! kkk,phamfu(1,kkk),phamfu(2,kkk) ! enddo ! This destroyed phaseline for map with tie-lines in plasne ... if(isopleth) & write(phaseline(nlinesep)(1:3),'(i3)')phamfu(2,nlinesep) ! write(*,117)'smp2b phaseline: ',nlinesep,phamfu(2,nlinesep),& ! trim(phaseline(nlinesep)) 117 format(a,2i5,2x,a) ! the segmentation fault was that linzero not always allocated .... if(allocated(linzero)) linzero=0 endif ! no wildcards allowed on this axis statevar=pltax(notanp) ! write(*,'(a,a,3i4,1pe12.4)')'In ocplot2, segmentation fault 4Ay1: ',& ! trim(statevar),nr,nv,notanp,curceq%tpval(1) if(skipdotder) then ! If skipdotder and this is a dot derivative return error code to skip value ! write(*,*)'smp2B skipping point A: ',trim(statevar),nv ! skipdotder=.FALSE.; special_circumstances=1 special_circumstances=1 endif if(statevar(1:4).eq.'PFL ' .or. statevar(1:4).eq.'PFS ') then call meq_get_state_varorfun_value('NPM(LIQUID) ',& value,encoded1,curceq) value=npflval*value npflval=value if(statevar(1:4).eq.'PFS ') value=one-value else call meq_get_state_varorfun_value(statevar,value,encoded1,curceq) ! write(*,*)'SMP axis variable 1: ',trim(encoded1),value,gx%bmperr if(gx%bmperr.ne.0) then ! this error should not prevent plotting the other points FIRST SKIPPING write(*,212)'SMP skipping a point 1, error evaluating: ',& statevar(1:10),curceq%tpval(1),nv,nr,gx%bmperr 212 format(a,a,f10.2,3i5) ! buperr resets putfun error gx%bmperr=0; buperr=0 nv=nv-1; goto 215 endif endif xax(nv)=value ! write(*,201)'at 202: ',nr,nv,curceq%tpval(1),value ! xax(nv)=curceq%tpval(1) ! macro step1 run in parallel plotting cp has segm fault after this line ! write(*,*)'After label 200: ',mapline%lineid,nr,nv if(xax(nv).lt.xmin) xmin=xax(nv) if(xax(nv).gt.xmax) xmax=xax(nv) ! second axis statevar=pltax(anpax) ! varofun=.FALSE. ! write(*,*)'In ocplot2: wildcard, selectph and novalues:',& ! wildcard,selectph,novalues if(wildcard) then ! NEW ignore data for this equilibrium if NOVALUES is TRUE ! because "selphase" not equal to the stable phase found above if(novalues) then ! write(*,*)'Ignoring equilibria without ',trim(selphase) yyy=zero ! np=1 ! skip this equilibrium, nv=nv-1, and take next equilibrium, increement nr!! nv=nv-1 goto 199 else ! write(*,*)'SMP2B wildcard value 1: ',nr,trim(statevar) ! write(*,*)'In ocplot2, segmentation fault after 4C1: ',& ! trim(statevar),nooftup() ! segmentation fault is inside this call for map11.OCM ! probably because new composition set created ! write(*,*)'SMP2B get_many ',trim(statevar),nzp,selectph,hashtag ! nzp is dimentsion of yyy, np is number of values ! write(*,*)'SMP2B calling get_many_svar: ',trim(statevar) call get_many_svar(statevar,yyy,nzp,np,encoded2,curceq) ! write(*,*)'In ocplot2, segmentation fault search: ' if(gx%bmperr.ne.0) then write(*,*)'Error return from "get_many_svar',gx%bmperr goto 1000 endif ! write(*,223)'SMP2B values: ',np,(yyy(i),i=1,np) ! problem that part of encoded2 desctroyed in late calls, it is OK here ! write(*,737)len_trim(encoded2),trim(encoded2) 737 format('smp2b: debug encoded2 ',i5/a/) ! write(*,738)(yyy(qp),qp=1,np) 738 format('SMP mm: ',(10F7.3)) ! compiling without -finit-local-zero gives a segmentation fault here ! running the MAP11 macro qp=np ! write(*,*)'SMP2B wildcard value 2: ',nr,trim(statevar) ! write(*,223)'SMP2B Values: ',np,(yyy(i),i=1,np) ! if(selectph) then ! write(*,*)'SMP2B: number of values: ',trim(selphase),np,nv 223 format(a,i3,20F8.4) ! endif nix=np ! we must allocate the array to indicate which values that should e plotted if(allocated(ixpos)) deallocate(ixpos) allocate(ixpos(nix),stat=errall) if(errall.ne.0) then write(*,*)'SMP2B Allocation error 8: ',errall gx%bmperr=4370; goto 1000 endif ! This quite complicated IF is to handle the case when the wildcard is ! is a phase or component/constituent ! write(*,*)'SMP2B stvarix: ',trim(statevar),selectph if(statevar(1:2).EQ.'MU' .or. & statevar(1:2).EQ.'AC' .or. statevar(1:4).EQ.'LNAC' .or. & selectph.and.(& statevar(1:2).EQ.'N(' .or. statevar(1:2).EQ.'B(' .or. & statevar(1:2).EQ.'X(' .or. statevar(1:2).EQ.'X%' .or. & statevar(1:2).EQ.'W(' .or. statevar(1:2).EQ.'W%')) then ! for the state variables MU(*), AC(*), LNAC(*), N(*), X(*), W(*) the * ! means component, not phase, set selectph=.FALSE. ! write(*,*)'SMP Wildcard means component! ',trim(statevar),np ! not calling stvarix, all values should be included ! Allocation should be number of components ixpos=1 elseif(.not.selectph .and. .not.hashtag) then ! elseif(selectph) then ! this routine supress values for phases that are not relevant ... ! IT SHOULD NOT BE USED FOR CASES LIKE Y(GAS,*) ! write(*,737)len_trim(encoded2),trim(encoded2) ! allocation should be number of phases ! if ! write(*,'(a,a/a,2i5)')'SMP2B stvarix1: ',trim(statevar),& ! trim(encoded2),nlinesep,nix call stvarix(statevar,phaseline(nlinesep),& encoded2,nix,ixpos) if(gx%bmperr.ne.0) then write(*,*)'SMP2B yaxis error: "',trim(statevar),'"' goto 1000 endif else ! here we may have hashtag TRUE ! write(*,*)'SMP2B Hashtag: ',hashtag ! We should supress values for suspended phases !!! if(hashtag) then call hashtag_susphix(statevar,phaseline(nlinesep),& encoded2,nix,ixpos,curceq) if(gx%bmperr.ne.0) then write(*,*)'SMP2B failed handle hashtag' goto 1000 endif else ixpos=1 endif endif endif ! if(hashtag) then ! all values are used ! ixpos=1 ! endif ! write(*,*)'On ocplot2, segmentation fault 4D1' ! write(*,213)trim(encoded2),np,(yyy(ic),ic=1,np) 213 format('WILDCARD: ',a,i3/6(1pe12.4)) ! write(*,214)np,(ixpos(ic),ic=1,np) 214 format('ixpos: ',12i3) ! write(*,16)'val: ',kp,nr,gx%bmperr,(yyy(i),i=1,np) 16 format(a,2i3,i5,/6(1pe11.3/)) anpmin=1.0D20 anpmax=-1.0D20 lcolor=0 ! write(*,'(a,90i3)')'SMP ixpos: ',(ixpos(jj),jj=1,np) ! write(*,*)'On ocplot2, segmentation fault before 4D2',np ! this is a loop for all values for this equilibria ! Here we may try to replace zero values by RNONE ??? ! write(*,*)'SMP2B RNONE: ',RNONE do jj=1,np if(last) then if(linzero(jj).ne.0) then ! in last equilibria we may have a value from the new phase at the node anp(jj,nv)=yyy(jj) ! elseif(yyy(jj).ne.zero) then ! write(*,*)'SMP skipping a value for line ',nlinesep endif else ! trying to avoid plotting a line at zero for unstable/unused state variables ! now we have used stvarix to identify the relevant phases if(yyy(jj).eq.zero) then if(ixpos(jj).eq.0) then ! for STEP calculations try to make the ending a property at zero ! for MAP calculations just ignore the point ... also for STEP ... anp(jj,nv)=rnone else anp(jj,nv)=zero endif else ! Hm, jumps from zero to finite values in step1, fig 3 plotting w(phase,cr) .. ! if(nv.gt.1 .and. anp(jj,nv-1).eq.rnone) then ! anp(jj,nv-1)=zero ! endif anp(jj,nv)=yyy(jj) endif ! difficult ... if(yyy(jj).ne.rnone .and. ixpos(jj).ne.0) then ! ths is the trick to supress lines for phases that are never stable nonzero(jj)=1 linzero(jj)=1 ! save the first column with nonzero for use with invariants if(ikol.eq.0) ikol=jj if(anp(jj,nv).gt.anpmax) anpmax=anp(jj,nv) if(anp(jj,nv).ne.rnone .and. & anp(jj,nv).lt.anpmin) anpmin=anp(jj,nv) ! extract state variable jj used for table headings and key if(.not.allocated(lid)) then allocate(lid(np+5),stat=errall) if(errall.ne.0) then write(*,*)'SMP2B Allocation error 9: ',errall gx%bmperr=4370; goto 1000 endif endif if(.not.isopleth) then ! if not isopleth save variable symbol in lid for headings (KEY) ! getext( , ,2, , , ) returns next text item up to a space call getext(encoded2,lcolor,2,encoded1,'x',lhpos) lid(jj)=encoded1 ! lid is 16 characters kk=len_trim(encoded1) if(kk.gt.len(lid(jj))) then ! lid(jj)(7:)='..'//encoded1(kk-6:kk) ! proposal by Chunhui, modified by 2 positions ! 12 12345 lid(jj)(10:)='..'//encoded1(kk-4:kk) endif endif else ! skip state variable call getext(encoded2,lcolor,2,encoded1,'x ',lhpos) endif endif enddo ! write(*,*)'OK Point: ',nr,nv,xax(nv) else ! A single state variable or function value like CP ! I HAVE HAD PROBLEMS WITH NEGATIVE CP HERE ! try skipping this value (below) if last equilibrium on the line ! varofun=.TRUE. ! segmentation fault if I plot Cp after shifting to a NEW MAPTOP record ! write(*,'(a,F8.2,a,a)')'SMP meq_get_state_varofun 7: T=',& ! curceq%tpval(1),' axis: ',trim(statevar) ! encoded1 not set correctly for dot derivative !! ! encoded1='dummy' ! there is a segmentation fault in this call ! segmentation fault if maptop changed (several map/step commands) if(skipdotder) then ! return error code if calculating a derivative at first point of line ! write(*,*)'smp2B skipping point B: ',trim(statevar),nv skipdotder=.FALSE.; special_circumstances=1 endif ! special Scheil simulation if(statevar(1:4).eq.'PFL ' .or. statevar(1:4).eq.'PFS ') then call meq_get_state_varorfun_value('NPM(LIQUID) ',& value,encoded1,curceq) value=npflval*value npflval=value if(statevar(1:4).eq.'PFS ') value=one-value encoded1=statevar else ! end special Scheil, evaluate function normally call meq_get_state_varorfun_value(statevar,value,& encoded1,curceq) ! encoded1 here is wrong?? not Cp when it should be, also when no error ! write(*,*)'SMP axis value 7: ',trim(encoded1),value,gx%bmperr if(gx%bmperr.ne.0) then ! SECOND Skipping if(gx%bmperr.ne.4373) & write(*,212)'SMP Skipping a point 2,error evaluating: ',& statevar(1:10),curceq%tpval(1),nv,nr,gx%bmperr nv=nv-1; goto 215 endif endif ! save to use in lid if not allocated funsym=encoded1 if(results%savedceq(nr)%nexteq.eq.0) then ! THIRD ?? Skipping ! write(*,212)'SMP skip last evaluated symbol: ',& ! trim(statevar),curceq%tpval(1),nv,nr,gx%bmperr if(trim(statevar).ne.trim(encoded1)) then ! If "statevar" not equal to "encoded1" skip last point ! This is a clumsy way to avoid negative CP=H.T values at end of lines ... nv=nv-1; goto 215 endif endif ! if(gx%bmperr.ne.0) goto 1000 anp(1,nv)=value ! macro test step1 run in parallel has segme fault plotting cp before this line ! write(*,201)'at 19: ',nr,nv,curceq%tpval(1),value ! write(*,19)'Bug: ',nr,nv,seqx,xax(nv),anp(1,nv) 19 format(a,3i4,2(1pe12.4)) anpmin=anp(1,nv) anpmax=anp(1,nv) endif if(anpmin.lt.ymin) ymin=anpmin if(anpmax.gt.ymax) ymax=anpmax 215 continue ! reset any previous error code if(gx%bmperr.ne.0) then ! write(*,*)'SMP reset error code ',gx%bmperr gx%bmperr=0 endif 199 continue nr=curceq%nexteq if(nr.gt.0) then if(results%savedceq(nr)%nexteq.eq.0) then ! write(*,*)'We have found last equilibria along the line: ',nr last=.TRUE. ! skipdotder=TRUE means skip dot derivatives at first equilibrium in next line skipdotder=.TRUE. endif endif !>>>>>>>>>>>>>>>>>>>>>>>>>> starting a line ! write(*,*)'Next equilibrium: ',nr,nv,xax(nv) ! read(*,17)ch1 17 format(a) enddo plot1 220 continue ! finished one line ! write(*,*)'SMP2B at 220: nr and nv: ',nr,nv invariant_lines: if(nax.gt.1) then !--------------------------------------------------------------- !------------------ special for invariant lines ?? and others !--------------------------------------------------------------- ! for phase diagram always move to the new line map1: if(nlinesep.ge.1) then newsep: if(linesep(nlinesep).lt.nv) then ! we should never have several linesep for the same value of nv! nlinesep=nlinesep+1 linesep(nlinesep)=nv ! names of phases on new line phaseline(nlinesep+1)=' ' ! write(*,*)'adding empty line 1',nlinesep,linesep(nlinesep) inv: if(localtop%tieline_inplane.gt.0 .and. & associated(mapline%end)) then ! write(*,*)'Tie-lines in plane, an invariant equil here' ! extract values for invariant equilibrium invar=>mapline%end if(ocv()) write(*,*)'Invariant eq: ',& invar%seqx,invar%savednodeceq if(invar%savednodeceq.lt.0) then write(*,*)'SMP equilibrium not saved, skipping' goto 222 endif ! This is a check for node with 2 stoichiometric phases, if so skip first line ! if(invar%artxe.eq.1) then ! write(*,*)'Found node with 2 stoichiomeric phases' ! endif curceq=>results%savedceq(invar%savednodeceq) !------------------- ! get the names of stable phases from the node equilibrium record kk=1 stoichfix=0 extractphnames: do jj=1,noph() do ic=1,noofcs(jj) ! value is amount of phase? k3=test_phase_status(jj,ic,value,curceq) if(k3.gt.0) then ! this phase is stable or fix ! write(*,*)'SMP addto phaseline 2: ',trim(dummy),& ! nlinesep call get_phase_name(jj,ic,dummy) if(kk.lt.100) phaseline(nlinesep)(kk:)=dummy kk=len_trim(phaseline(nlinesep))+2 stoichfix=stoichfix+1 endif enddo enddo extractphnames ! invariant write(*,*)'SMP2 phases: ',trim(phaseline(nlinesep)),nlinesep if(stoichfix.gt.3) then write(*,*)'SMP2B too many stable phases at invariant',& stoichfix stoichfix=3 endif !------------------- ! axis without wildcard statevar=pltax(notanp) if(skipdotder) then ! skip calculating a derivative if this is first point of a region ! write(*,*)'smp2B skipping point C: ',trim(statevar),nv skipdotder=.FALSE.; special_circumstances=1 endif call meq_get_state_varorfun_value(statevar,value,& encoded1,curceq) ! write(*,*)'SMP axis variable 3: ',encoded1(1:3),value if(gx%bmperr.ne.0) then ! THIRD skipping write(*,212)'SMP skipping a point 3, error evaluating ',& statevar,curceq%tpval(1),nv,0,gx%bmperr goto 222 endif ! save symbol name if lid not allocated funsym=encoded1 ! This is tielines inplane, normally 3 lines to generate ! but when 2 stoichiometric phass with same composition one is not set stable ! nv=nv+3 ! NOTE if not wildcard nv is decremented in next "else" statement nv=nv+stoichfix if(nv.ge.maxval) then write(*,*)'Too many points to plot 2',maxval goto 600 endif do invlines=0,stoichfix-1 xax(nv-invlines)=value enddo ! write(*,335)'New line: ',nlinesep,nv,linesep(nlinesep),& ! statevar(1:5),value 335 format(a,3i4,' <',a,'> ',3(1pe14.6)) ! axis with possible wildcard statevar=pltax(anpax) ! write(*,*)'In ocplot2, segmentation fault 4H' wild2: if(wildcard) then ! this cannot be a state variable derivative ! write(*,*)'SMP2B wildcard value 3: ',nr,statevar(1:20) call get_many_svar(statevar,yyy,nzp,np,encoded2,curceq) if(gx%bmperr.ne.0) goto 1000 ! we have to handle axis values that are zero what is np here??? nix=np ! to supress suspended phases ! write(*,'(a,a/a,2i5)')'SMP2B stvarix2: ',trim(statevar),& ! trim(encoded2),nlinesep,nix call stvarix(statevar,phaseline(nlinesep),& encoded2,nix,ixpos) if(gx%bmperr.ne.0) goto 1000 ! save one non-zero value per line, 3 lines ic=0 do jj=1,np ! np is the number of values retrieved by get_many_svar ! only those with nonzero values in ixpos should be used, one per line. if(ixpos(jj).ne.0) then anp(ikol,nv-ic)=yyy(jj) ic=ic+1 endif enddo ! for RNONE = NaN add empty line after invariant ... if(linesep(nlinesep).lt.nv) then ! we should never have several linesep for the same value of nv! nlinesep=nlinesep+1 linesep(nlinesep)=nv ! write(*,*)'Empty line after invariant: ',nlinesep,nv endif else ! if no wildcard extract the phase with zero amount nv=nv-stoichfix goto 225 endif wild2 222 continue ! else ! write(*,*)'SMP no else link ...' endif inv endif newsep endif map1 ! jump here if no wildcard 225 continue endif invariant_lines ! if(invnode.ne.0) then ! write(*,'(a,3i4,2(1pe12.4))')'ocplot2 Invariant isopleth node: ',& ! invnode,ninv,nrett,xax(nrett),anp(1,nrett) if(ninv.eq.0) then ! the first invariant isopleth ninv=ninv+1 xyinv(1,1)=xax(nrett); xyinv(2,1)=anp(1,nrett) xyinv(3,1)=xax(nrett); xyinv(4,1)=anp(1,nrett) else ! check if anp value same as already saved invariant cinv: do kk=1,ninv if(abs(anp(1,nrett)-xyinv(2,kk)).lt.1.0D-4) then ! same ... check if x values lesser than xyinv(1,kk) or greater than xyinv(3,kk) if(xax(nrett).lt.xyinv(1,kk)) xyinv(1,kk)=xax(nrett) if(xax(nrett).gt.xyinv(3,kk)) xyinv(3,kk)=xax(nrett) goto 227 endif enddo cinv ! this is a new invariant, do not accept zero values if(abs(xax(nrett)).gt.1.0D-6.and.abs(anp(1,nrett)).gt.1.0D-6) then ninv=ninv+1 xyinv(1,ninv)=xax(nrett); xyinv(2,ninv)=anp(1,nrett) xyinv(3,ninv)=xax(nrett); xyinv(4,ninv)=anp(1,nrett) ! write(*,*)'New invariant:',ninv,xyinv(1,ninv),xyinv(2,ninv) ! else ! write(*,*)'Invariant with zero values ignored' endif 227 continue endif endif !---- take next node along the same line ! Then jump back to label 100 and plot other lines ... a bit stupid ... 230 continue ! write(*,*)'SMP2B at 230: nr and nv: ',nr,nv kk=seqx if(associated(mapline%end)) then seqx=mapline%end%seqx else seqx=0 endif 240 continue ! write(*,'(a,5i5,l2)')'ocplot2 next node: ',seqx,nlinesep,& ! linesep(nlinesep),nv,line,scheilorder if(seqx.eq.0) then if(nlinesep.gt.0) then if(linesep(nlinesep).lt.nv) then ! we should never have several linesep for the same value of nv! nlinesep=nlinesep+1 linesep(nlinesep)=nv ! write(*,*)'adding empty line 2',nlinesep,linesep(nlinesep) endif endif ! Hm, this was not designed for multicomponent isopleths .... if(line.eq.2) then ! write(*,*)'ocplot2 jump to label 500',line goto 500 endif if(scheilorder) then ! The mapnodes must be followed in numeric order ! ane they have just one line each. line=1 ! write(*,*)'SMP2B scheilorder',localtop%seqx,& ! localtop%next%seqx,localtop%previous%seqx localtop=>localtop%previous mapline=>localtop%linehead(1) ! write(*,*)'ocplot2 newline ',nlinesep,linesep(nlinesep) goto 110 endif line=2 ! jump back to label 100 for next line ! write(*,*)'ocplot2 jump to label 100 for line 2' goto 100 else if(kk.eq.seqx) then if(giveup.gt.3) then write(*,*)'infinite loop ?' seqx=0 goto 240 endif giveup=giveup+1 endif mapnode=>localtop%next invnode=0 if(btest(mapnode%status,MAPINVARIANT)) then invnode=size(mapnode%linehead) ! write(*,*)'ocplot2 invariant node 2',invnode endif ! loop through all mapnodes 250 continue ! write(*,*)'ocplot2, at label 250: ',mapnode%seqx,seqx ! if(mapnode%seqx.eq.seqx) then ! If just for STEP then check number of axis for calculation if(graphopt%noofcalcax.eq.1 .and. mapnode%seqx.eq.seqx) then ! >>> this is just for step, for map one must find line connected do haha=1,size(mapnode%linehead) mapline=>mapnode%linehead(haha) if(mapline%done.eq.0) then if(.not.btest(mapline%status,EXCLUDEDLINE)) then ! write(*,*)'ocplot2 jump to label 110',& ! seqx,mapline%number_of_equilibria goto 110 else lines_excluded=lines_excluded+1 endif endif enddo endif ! write(*,*)'ocplot2 associated? ',associated(mapnode,localtop),& ! mapnode%seqx,seqx if(.not.associated(mapnode,localtop)) then mapnode=>mapnode%next invnode=0 if(btest(mapnode%status,MAPINVARIANT)) then invnode=size(mapnode%linehead) ! Does all invariant nodes have the same number of stable phases YES! ! But they can have different number of line exits ! write(*,*)'ocplot2 invariant node 3',invnode,mapnode%seqx endif goto 250 else ! we have gone through all mapnodes without finding one with index seqx!! ! write(*,*)'Cannot find node: ',seqx ! this seems not to be a problem .... probably already found. seqx=0; goto 240 endif endif !------------------------------------------- end loop 100 ! check if we can find any lines not starting from localtop to be plotted 500 continue ! write(*,*)'ocplot2 at 500 ',seqx ! write(*,*)'In ocplot2, looking for segmentation fault 5' ! mapnode=>localtop%next ! when we have several plots localtop is the important one!! mapnode=>localtop invnode=0 if(btest(mapnode%status,MAPINVARIANT)) then invnode=size(mapnode%linehead) ! if(invnode.ne.mapnode%lines) write(*,*)'SMP2B check invnodes 1!' ! write(*,*)'ocplot2 invariant node 4',invnode endif ! Check for unplotted lines anymoretoplot: do while(.TRUE.) ! write(*,*)'>>>>>Checking unplotted lines at node: ',mapnode%seqx jjline: do jj=1,mapnode%lines if(mapnode%linehead(jj)%done.eq.0) then if(ocv()) write(*,*)'Found a line in node: ',mapnode%seqx,jj line=jj if(nlinesep.gt.0) then if(linesep(nlinesep).lt.nv) then ! we should never have several linesep for the same value of nv! nlinesep=nlinesep+1 linesep(nlinesep)=nv ! write(*,*)'adding empty line:',nlinesep,linesep(nlinesep) endif endif mapline=>mapnode%linehead(line) ! skip line if EXCLUDEDLINE set if(btest(mapline%status,EXCLUDEDLINE)) then cycle jjline endif ! write(*,*)'SMP2B jump to 110 for line ',jj,& ! ' in mapnode ',mapnode%seqx ! %done=-1 means already plotted ... ! mapnode%linehead(jj)%done=-1 goto 110 endif enddo jjline mapnode=>mapnode%next invnode=0 if(btest(mapnode%status,MAPINVARIANT)) then invnode=size(mapnode%linehead) ! if(invnode.ne.mapnode%lines) write(*,*)'SMP2B check invnodes 2!' ! write(*,*)'ocplot2 invariant node 5',invnode endif if(associated(mapnode,localtop)) exit anymoretoplot enddo anymoretoplot !-------------------------------------------- ! end extracting data 600 continue overflow=.FALSE. ! but we may have another maptop !! if(associated(localtop%plotlink) .and. .not.scheilorder) then if(.not.moretops) then write(*,*)'More than one maptop record' moretops=.true. endif localtop=>localtop%plotlink goto 77 endif ! write(*,*)'Number of points: ',nv if(.not.wildcard) then np=1; nrv=nv ! write(*,*)'Extracted values: ',nrv goto 800 endif !============================================================ ! remove columns that are only zeroes ! write(*,*)'Now remove colums with just zeros',nv,nrv ! read(*,17)ch1 ic=0 ! if a selected phase has been plotten np and qp may be different ! select the largest! nnp=max(np,qp) ! write(*,651)'SMP wildcard, np=, qp, nnp, ic: ',wildcard,np,qp,nnp,ic 651 format(a,l2,10i5) !------------------------------------------ begin loop 650 650 ic=ic+1 660 continue if(ic.gt.nnp) goto 690 ! nonzero(ic) is a column with nonzero value to plot ... redundant?? if(nonzero(ic).eq.0) then ! shift all values from ic+1 to np if(nnp.gt.maxanp) then write(kou,*)'Too many points in anp array 1',maxanp,nv,nnp overflow=.TRUE. nnp=maxanp endif if(nv.gt.maxval) then write(kou,*)'Too many points in anp array 2',maxval,nv overflow=.TRUE. nv=maxval endif if(.not.allocated(lid)) then ! write(*,*)'SMP allocating lid 3: ',np allocate(lid(np+5),stat=errall) if(errall.ne.0) then write(*,*)'SMP2B Allocation error 10: ',errall gx%bmperr=4370; goto 1000 endif endif do jj=ic,nnp-1 do nnv=1,nv anp(jj,nnv)=anp(jj+1,nnv) enddo nonzero(jj)=nonzero(jj+1) ! also shift label lid(jj)=lid(jj+1) enddo nnp=nnp-1 goto 660 endif ! there is no more space in arrays to plot if(overflow) then write(*,*)'plot data overflow',nv,nnp goto 690 endif goto 650 !------------------------------------------ end loop 650 ! nnp is the number of columns to plot ! nv is the number of separate lines 690 continue ! write(*,651)'SMP at 690: ',wildcard,np,qp,nnp,ic nrv=nv np=nnp ! goto 800 !============================================ generate gnuplot file 800 continue ! are there any isopleth invariants? if(ninv.gt.0) then do kk=1,ninv ! nlinesep is last line with data, linesep(nlinsesp) is index of last data line ! write(*,'("Isoinv: ",3i4,4(1pe12.4))')nlinesep,linesep(nlinesep),& ! kk,(xyinv(jj,kk),jj=1,4) ! add these to lines to be plotted kkk=nlinesep if(len_trim(phaseline(kkk)).gt.0) then write(*,*)'smp2b phaseline: "',trim(phaseline(kkk)),'"',kkk endif phaseline(kkk)='100 invariant equilibrium' phaseline(kkk+1)=' ' ! write(*,*)'smp2b isoinv: "',trim(phaseline(kkk)),'"',kkk jj=linesep(kkk) nlinesep=nlinesep+1 ! the line nlinesep contain 2 points, beginning and end of invariant line linesep(nlinesep)=jj+2 xax(jj+1)=xyinv(1,kk); anp(1,jj+1)=xyinv(2,kk) xax(jj+2)=xyinv(3,kk); anp(1,jj+2)=xyinv(4,kk) nrv=nrv+2 enddo endif ! add the invariant lines to be plotted ! two points for each invariants (X and Y) ! ! write(*,808)np,nv,nlinesep,maxanp,maxval ! write(*,'(a,(16i4))')'SMP pp: ',(linesep(kk),kk=1,nlinesep) 808 format('plot data used: ',3i7,' out of ',2i7) if(np.eq.0) then write(kou,*)'No data to plot',np write(*,*)'SMP2B axis 1: ',trim(pltax(1)),', 2:',trim(pltax(2)) gx%bmperr=4248 goto 1000 endif !------------------------------------------------------------ if(.not.allocated(lid)) then ! lid is "LineIdenifier and changes color for each line with different meaning ! if(np.ge.1) then ! lid should always be allocated if np>1, but ... one never knows ! write(*,*)'ocplot2 allocate lid 4: ',np,nlinesep ! if(scheilorder) then ! for Scheil simulations phaseline(1..nlinesep) are phase names ! allocate(lid(nlinesep-1),stat=errall) ! do i=1,nlinesep-1 ! jj=len_trim(phaseline(i)) ! if(jj.le.32) then ! lid(i)=phaseline(i) ! else ! Too long list, replace the middle by ... ! lid(i)=phaseline(i)(1:22)//'...'//phaseline(i)(jj-6:jj) ! endif ! write(*,*)'ocplot2 phaseline: ',trim(lid(i)) ! enddo ! Wow, set np=nlinesep-1 to have separate colors of Scheil lines ! write(*,*)'ocplot2 change np to nphaseline: ' ! np=nlinesep-1 ! else ! normally np=1 if we come here, plotting a single value ! write(*,*)'Allocating lid: ',trim(encoded1),':',trim(funsym),np allocate(lid(np),stat=errall) if(errall.ne.0) then write(*,*)'SMP2B Allocation error 11: ',errall gx%bmperr=4370; goto 1000 endif do i=1,np lid(i)=funsym enddo endif ! endif !------------------------------------------------------------ 2000 continue ! write(*,*)'We are at 2000 ' !---------------------------------------------------------------------- ! call get_plot_conditions(encoded1,maptop%number_ofaxis,axarr,ceq) ! ! option to create a CSV table if(btest(graphopt%status,GRCSVTABLE)) then call list_csv(np,nrv,nlinesep,linesep,pltax,xax,anpax,anpdim,anp,lid,& phaseline,title,filename,version,encoded1) else ! NOW pltax should be the the axis labels if set manually if(graphopt%labeldefaults(2).ne.0) pltax(1)=graphopt%plotlabels(2) if(graphopt%labeldefaults(3).ne.0) pltax(2)=graphopt%plotlabels(3) ! write(*,*)' >>>>>>>>**>>> plot file: ',trim(filename) call ocplot2B(np,nrv,nlinesep,linesep,pltax,xax,anpax,anpdim,anp,lid,& phaseline,title,filename,graphopt,version,encoded1,fixphasecolor) ! title,filename,graphopt,pform,version,encoded1) ! goto 900 endif ! deallocate, not really needed for local arrays ?? deallocate(anp) deallocate(xax) deallocate(linesep) if(allocated(yyy)) then deallocate(yyy) deallocate(nonzero) endif 1000 continue return end subroutine ocplot2 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine ocplot2B !\begin{verbatim} %- subroutine ocplot2B(np,nrv,nlinesep,linesep,pltax,xax,anpax,anpdim,anp,lid,& phaseline,title,filename,graphopt,version,conditions,fixphasecolor) ! called from ocplot2 to generate the GNUPLOT file after extracting data ! np is number of columns (separate lines), if 1 no labelkey ! nrv is number of values to plot ! nlinesep is the number of separate lines (index to linesep) ! linesep is the row index when a line to be plotted finishes (1..nlinesep) ! pltax are axis labels ! xax array of values for single valued axis (T or mu etc) ! anpax=2 if axis with single value is column 2 and (multiple) values in ! columns 3 and higher ! anp array of values for axis with multiple values (can be single values also) ! lid array with a label for the different lines ! title Title of the plot ! filename GNUPLOT file name, (also used for pdf/ps/gif file) ! graphopt is graphical option record ! conditions is a character with the conditions for the diagram ! fixphasecolor is used for isopleths to know how many columns are needed implicit none integer np,anpax,nlinesep,fixphasecolor integer ndx,nrv,linesep(*),anpdim,npx character pltax(*)*(*),filename*(*),lid(*)*(*),title*(*) character conditions*(*),version*(*),phaseline(*)*(*) type(graphics_options) :: graphopt double precision xax(*),anp(anpdim,*) double precision scale1,scalem type(graphics_textlabel), pointer :: textlabel !\end{verbatim} !---------------------------------------------------------------------- ! internal integer ii,jj,kk,lcolor,appfil,nnv,ic,repeat,ksep,nv,k3,kkk,nofapl,iz integer, parameter :: mofapl=100 integer, parameter :: maxmultiplotlines=100 ! ltf1 is a LineTypeoFfset for current plot when appending a plot, 0 default ! linewp is plotting with points along the line integer appfiletyp,lz,ltf1,linewp ! appending an multiplot in ocplot2B ! sleep time in microseconds integer, parameter :: us=500000 integer multibuffline character multibuffer(maxmultiplotlines)*128 logical appendmultiplot ! other things ... character pfc*128,pfh*128,backslash*2,appline*128,inline*8,colord*5 character applines(mofapl)*128,gnuplotline*256,labelkey*64,rotate*16 character labelfont*32,linespoints*12,tablename*16,year*16,hour*16 ! for handling appended plots use $Appendx character datablock*8,applot*13 logical isoplethplot ! write the gnuplot command file with data appended ! ! write(*,10)'in ocplot2B: ',np,anpax,nrv,nlinesep,trim(title),& ! (linesep(kk),kk=1,nlinesep) ! write(*,*)'smp2b isoplethplot 2: ',btest(graphopt%status,GRISOPLETH) 10 format(a,4i5,a/(15i4)) ! graphopt%specialdiagram=2 is a Scheil plot phase amount/vs T ! if(graphopt%specialdiagram.eq.2) then ! write(*,*)'In ocplot2B scheil: ',graphopt%specialdiagram ! just check all is OK ! do kk=1,nlinesep-1 ! write(*,*)'phaseline: ',kk,': ',trim(phaseline(kk)) ! enddo ! endif multibuffline=0 nofapl=0 appendmultiplot=.FALSE. ltf1=0 if(graphopt%appendfile(1:1).ne.' ') ltf1=10 if(index(filename,'.plt ').le.0) then kk=len_trim(filename) pfc=filename(1:kk)//'.'//'plt ' kkk=kk+4 else pfc=filename kk=index(pfc,'.')-1 kkk=len_trim(filename)+1 endif write(*,*)'SMP2B writing gnuplot file: ',trim(pfc) open(21,file=pfc,access='sequential',status='unknown') write(21,1600)trim(title) 1600 format('# GNUPLOT file generated by OpenCalphad'/'# ',a/& '# subroutine ocplot2B') ! if there is just one curve do not write any key. May be overriiden later .. if(graphopt%gnutermsel.lt.1 .or. & graphopt%gnutermsel.gt.graphopt%gnutermax) then write(*,*)'Unknown graphics terminal: ',graphopt%gnutermsel goto 1000 elseif(graphopt%gnutermsel.gt.1) then ! terminal 1 is screen without any output file pfh=filename(1:kk)//'.'//graphopt%filext(graphopt%gnutermsel) ! set the screen as a comment ... write(21,840)trim(graphopt%gnuterminal(1)),& trim(graphopt%gnuterminal(graphopt%gnutermsel)),trim(pfh) 840 format('#set terminal ',a/'set terminal ',a/'set output "',a,'"') else ! terminal 1 is screen without any output file, add PDF as comment write(21,841)trim(graphopt%gnuterminal(graphopt%gnutermsel)),& trim(graphopt%gnuterminal(3)) 841 format('set terminal ',a/'#set terminal ',a/'#set output "ocgnu.pdf"') !841 format('set terminal ',a) endif ! for isopleths we will generate one column for each phase even if there ! are just a single value in anpax. To handle this we need different ! values of "np" for these columns isoplethplot=btest(graphopt%status,GRISOPLETH) npx=np if(isoplethplot) then ! This is the number of columns with phases in the isopleth incl. invariant npx=fixphasecolor endif ! this part is independent of which axis is a single value !------------------ some GNUPLOT colors: ! colors are black: #000000, red: #ff000, web-green: #00C000, web-blue: #0080FF ! dark-yellow: #C8C800, royal-blue: #4169E1, steel-blue #306080, ! gray: #C0C0C0, cyan: #00FFFF, orchid4: #804080, chartreuse: 7CFF40 ! if just one line set key off for that line. if(graphopt%specialdiagram.eq.2) then ! for Scheil labelkey=' on font "Arial,12" ' elseif(npx.eq.1 .and. graphopt%appendfile(1:1).eq.' ') then labelkey=' off' else labelkey=graphopt%labelkey endif call date_and_time(year,hour) ! write(*,*)'"',year,'" "',hour,'"' tablename='OCT'//year(3:8)//hour(1:6) ! write(*,*)'Plot heading 2? ',btest(graphopt%status,GRNOTITLE) call replace_uwh(conditions) if(btest(graphopt%status,GRNOTITLE)) then write(21,858)trim(title),trim(conditions),trim(graphopt%font) else write(21,859)trim(title),trim(conditions),trim(graphopt%font) endif 858 format('#set title "',a,' \n #',a,'" font "',a,',10" ') 859 format('set title "',a,' \n ',a,'" font "',a,',10" ') lz=graphopt%linetype ! replace _ and & in axis texts by "\_" and "\&" ! write(*,*)'Replacing _ and &: ',trim(pltax(2)) call replace_uwh(pltax(1)) call replace_uwh(pltax(2)) ! write(*,*)'Debug: "',graphopt%logofont,'"' if(isoplethplot) then write(21,8601)graphopt%xsize,graphopt%ysize,& trim(pltax(1)),trim(pltax(2)),graphopt%logofont,trim(labelkey),& ltf1+1,ltf1+2,ltf1+3,ltf1+4,ltf1+5,& ltf1+6,ltf1+7,ltf1+8,ltf1+9,ltf1+10 ! add information of any scaling factors for the axis "xf" or "yf" ! if(graphopt%scalefact(1).ne.one) xf=graphopt%scalefact(1) ! if(graphopt%scalefact(2).ne.one) yf=graphopt%scalefact(2) 8601 format('set origin 0.0, 0.0 '/& 'set size ',F8.4,', ',F8.4/& 'set xlabel "',a,'"'/'set ylabel "',a,'"'/& ! the compiler did not detect the missing , between 4' in ... F8.4', ' .... !8601 format('set origin 0.0, 0.0 '/& ! 'set size ',F8.4', ',F8.4/& ! 'set xlabel "',a,'"'/'set ylabel "',a,'"'/& ! Help with stackoverflow to fix nice logo independent of plot size! ! 'set label "~O{.0 C}" at screen 0.02, 0.03 font "Garamond Bold,20"'/& ! the logofont depend on OS, MacOS does not provide Garamond 'set label "~O{.0 C}" at screen 0.02, 0.03 font "',a,'"'/& 'set key ',a/& 'set linetype ',i2,' lc rgb "#000000" lw 2 pt 10'/& 'set linetype ',i2,' lc rgb "#4169E1" lw 2 pt 6'/& 'set linetype ',i2,' lc rgb "#00C000" lw 2 pt 3'/& 'set linetype ',i2,' lc rgb "#FF0000" lw 2 pt 2'/& 'set linetype ',i2,' lc rgb "#FF00FF" lw 2 pt 4'/& 'set linetype ',i2,' lc rgb "#C8C800" lw 2 pt 5'/& 'set linetype ',i2,' lc rgb "#C0C0C0" lw 2 pt 7'/& 'set linetype ',i2,' lc rgb "#00FFFF" lw 2 pt 8'/& 'set linetype ',i2,' lc rgb "#804080" lw 2 pt 9'/& 'set linetype ',i2,' lc rgb "#7CFF40" lw 2 pt 1'/& '# for invariants, orange'/& 'set linetype 100 lc rgb "#FFC000" lw 3 pt 1') else write(21,860)graphopt%xsize,graphopt%ysize,& trim(pltax(1)),trim(pltax(2)),graphopt%logofont,trim(labelkey),& ! trim(pltax(1)),trim(pltax(2)),trim(labelkey),& ltf1+1,lz,ltf1+2,lz,ltf1+3,lz,ltf1+4,lz,ltf1+5,lz,& ltf1+6,lz,ltf1+7,lz,ltf1+8,lz,ltf1+9,lz,ltf1+10,lz 860 format('set origin 0.0, 0.0 '/& 'set size ',F8.4,', ',F8.4/& 'set xlabel "',a,'"'/'set ylabel "',a,'"'/& ! Help with stackoverflow to fix nice logo independent of plot size! ! 'set label "~O{.0 C}" at graph -0.1, -0.1 font "Garamond Bold,20"'/& ! 'set label "~O{.0 C}" at screen 0.02, 0.03 font "Garamond Bold,20"'/& 'set label "~O{.0 C}" at screen 0.02, 0.03 font "',a,'"'/& 'set key ',a/& 'set style line ',i2,' lt ',i2,' lc rgb "#000000" lw 2 pt 10'/& 'set style line ',i2,' lt ',i2,' lc rgb "#4169E1" lw 2 pt 6'/& 'set style line ',i2,' lt ',i2,' lc rgb "#00C000" lw 2 pt 3'/& 'set style line ',i2,' lt ',i2,' lc rgb "#FF0000" lw 2 pt 2'/& 'set style line ',i2,' lt ',i2,' lc rgb "#FF00FF" lw 2 pt 4'/& 'set style line ',i2,' lt ',i2,' lc rgb "#C8C800" lw 2 pt 5'/& 'set style line ',i2,' lt ',i2,' lc rgb "#C0C0C0" lw 2 pt 7'/& 'set style line ',i2,' lt ',i2,' lc rgb "#00FFFF" lw 2 pt 8'/& 'set style line ',i2,' lt ',i2,' lc rgb "#804080" lw 2 pt 9'/& 'set style line ',i2,' lt ',i2,' lc rgb "#7CFF40" lw 2 pt 1'/& '# for invariants, faded read'/& 'set style line 100 lt 1 lc rgb "#FF3333" lw 3 pt 1') endif ! Plot grid? if(graphopt%setgrid.eq.1) write(21,777) 777 format('set grid') ! add some useful things for maniplulation of graph write(21,8000) 8000 format(/'# Some useful GNUPLOT commands for editing the figure'/& '# ** THIS IS A DASHED LINE (on pdf/wxt):'/& '# set style line 15 lt 0 lc rgb "#C8C800" lw 2 pt 2'//& '# set pointsize 0.6'/& '# set label "text" at 0.5, 0.5 rotate by 60 font "arial,12"'/& '# set xrange [0.5 : 0.7] '/& '# ** ADDING MANUALLY A LINE AND KEEP SCALING:'/& '# set arrow from x0, y0 to x1,y1 nohead linestyle 1'/& '# ** ADD A RED DOT AT 0.1,1000:'/& '# set obj 1 circle fc rgb "#FF0000" fs sol size 0.02 noclip at 1,1'/& '# ** MODIFY THE PLOTTED VALUE ON AN AXIS:'/& '# plot for [i=] ... using (2*column(i)/(1-2*column(i))):2 with ...'/& '# ** PLOTTING SYMBOLS INSTEAD OF LINE:'/& '# ... using 2:i with points pt 7 ps 3 '/& '# ** OVERLAY PLOTS: '/& '# set multiplot'/& '# set xrange [] writeback'/& '# ... plot someting'/& '# set xrange restore'/& '# ... plot more using same axis scaling '/& '# unset multiplot'/) ! if(graphopt%rangedefaults(1).ne.0) then ! user defined ranges for x axis write(21,870)'x',graphopt%plotmin(1),graphopt%plotmax(1) 870 format('set ',a1,'range [',1pe12.4,':',1pe12.4,'] ') endif if(graphopt%rangedefaults(2).ne.0) then ! user defined ranges for y axis write(21,870)'y',graphopt%plotmin(2),graphopt%plotmax(2) endif !---------------------- ! logarithmic axis if(graphopt%axistype(1).eq.1) then write(21,151)'x' 151 format('set logscale ',a) endif if(graphopt%axistype(2).eq.1) then write(21,151)'y' endif !------------------------------------------------------------ ! set labels (user added text in diagram) textlabel=>graphopt%firsttextlabel do while(associated(textlabel)) rotate=' ' if(textlabel%angle.ne.0) write(rotate,177)textlabel%angle 177 format(' rotate by ',i5) labelfont=' ' ! write(*,*)'textfontscale: ',textlabel%textfontscale if(textlabel%textfontscale.ne.one) then ! write(labelfont,178)int(10*textlabel%textfontscale) !178 format(' font "Sans,',i2,'" ') ! write(*,1178)trim(graphopt%font),int(10*textlabel%textfontscale) !1178 format(' SMP2B font "',a,',',i2,'" ') write(labelfont,178)trim(graphopt%font),& int(10*textlabel%textfontscale) 178 format(' font "',a,',',i2,'" ') endif ! if(textlabel%angle.eq.0) then write(21,1505)trim(textlabel%textline),textlabel%xpos,textlabel%ypos,& trim(labelfont),trim(rotate) 1505 format('set label "',a,'" at ',1pe12.4,', ',1pe12.4,a,a) ! else ! write(21,1506)trim(textlabel%textline),textlabel%xpos,textlabel%ypos,& ! textlabel%angle !1506 format('set label "',a,'" at ',1pe12.4,', ',1pe12.4,& ! ' rotate by ',i5) ! endif textlabel=>textlabel%nexttextlabel enddo !--------------------------------------------------------------- ! handle appended files here .... ! ! write(*,*)'ocplot2B append?',trim(graphopt%appendfile) appfildata: if(graphopt%appendfile(1:1).eq.' ') then appfil=0 else appfil=23 write(kou,*)'Appending data from: ',trim(graphopt%appendfile) open(appfil,file=graphopt%appendfile,status='old',& access='sequential',err=1750) ! write(21,1719)trim(graphopt%appendfile) 1719 format(//78('#')/'# APPENDED from ',a) ! copy all lines up to "plot" to new graphics file nnv=0 1710 continue read(appfil,1720,end=1750)appline 1720 format(a) ! note if append file is GIBBSTRIANGLE if(appline(1:10).eq.'# GIBBSTRI') then write(*,*)'Warning: appended file is in Gibbstriangle format,',& ' plot will be strange!' goto 1710 endif ! skip other comment lines if(appline(1:1).eq.'#') goto 1710 ! save lines between "set multiplot" and "unset multiplot" to a buffer ! appending a file which contains an already appended part ! copy all lines to a buffer if(appline(1:14).eq.'set multiplot ') then ! write(*,*)'ocplot2B Found multiplot in appended file' if(multibuffline.gt.0) then write(*,*)'smp2B appending twice, will probably fail',multibuffline else multibuffline=1 ! write(*,*)'ocplot2B appending a "set multiplot"' endif appendmultiplot=.TRUE. goto 1710 endif if(appline(1:16).eq.'unset multiplot ') then ! write(*,*)'ocplot2B found "unset multiplot", saved ',& ! multibuffline,' lines' appendmultiplot=.FALSE. ! do iz=1,multibuffline-1 ! write(*,*)'ocplot2B: 'trim(multibuffer(iz)) ! enddo ! pause mouse ?? exit appfildata ! goto 1710 endif if(appendmultiplot) then if(multibuffline.gt.maxmultiplotlines) then write(*,*)'Too many appendbuffer lines',multibuffline else multibuffer(multibuffline)=appline multibuffline=multibuffline+1 endif goto 1710 endif !------------------------------------------------------------------ ! ignore some lines with "set" in the append file ! set title ! set xlabel ! set ylabel ! set xrange ! set yrange ! set terminal ! set origin ! set size ! set key if(appline(1:10).eq.'set title ' .or.& appline(1:11).eq.'set xlabel ' .or.& appline(1:11).eq.'set ylabel ' .or.& appline(1:11).eq.'set xrange ' .or.& appline(1:11).eq.'set yrange ' .or.& appline(1:11).eq.'set output ' .or.& appline(1:13).eq.'set terminal ' .or.& appline(1:11).eq.'set origin ' .or.& appline(1: 9).eq.'set size ' .or.& appline(1: 8).eq.'set key ') then ! write(*,*)'ignoring append line ',trim(appline) goto 1710 endif !------------------------------------------------------------------ ! changes here in the new subroutine ocplot2B ! write(*,*)'SMP: appline1: ',trim(appline) ii=index(appline,'plot "-"') if(ii.gt.0) then applines(1)=appline appfiletyp=1 else ! modify to dataplot inside multiplot ii=index(appline,"plot '-'") if(ii.gt.0) then applines(1)=appline appfiletyp=1 else ! we can also have a "plot for ... " do not change applines(1) ii=index(appline,"plot for ") if(ii.le.0) then ! just copy the file to ocgnu.plt write(21,'(a)')trim(appline) goto 1710 else ! this is a "plot for" appfile using a table that has already been copied applines(1)=appline appfiletyp=2 endif endif endif ! we have now found the plot command in the append file. There can be more write(*,*)'SMP appfiletyp: ',appfiletyp ! here we save the actual plot commands from the appendfile!! applines(1)=appline ! write(*,*)'SMP appline1: ',trim(applines(1)) ic=1 1730 continue ! if line ends with \ then read more ii=len_trim(appline) ! write(*,*)'There are more? ',appline(i:ii),ii,ic if(appline(ii:ii).eq.'\') then ! if(appline(ii:ii).eq.' ') then ! continuation lines !! NOTE EACH plot expected at the beginning of the line read(appfil,1720,end=1750)appline ic=ic+1 if(ic.ge.mofapl) then write(*,*)'Too many header lines in append file',ic else applines(ic)=appline endif goto 1730 endif nofapl=ic write(*,*)'Read applines header lines: ',nofapl ! debug output of saved plot command ! nofapl=ic ! write(*,*)(trim(applines(jj)),jj=1,nofapl) ! write(*,*)'appline: ',trim(appline),ic ! close(appfil) ! appfil=0 goto 1770 ! endif ! write(*,*)'SMP appline1B: ',trim(appline) write(21,1720)trim(appline) nnv=nnv+1 goto 1710 ! error oppening append file 1750 continue write(21,1719)'# end of append',multibuffline ! write(*,1719)' end of append',multibuffline write(kou,*)'Error opening or reading the append file, skipping it' close(appfil) appfil=0 1770 continue endif appfildata ! end of appendfile special !----------------------------------------------- ! text in lower left corner ii=len_trim(graphopt%lowerleftcorner) if(ii.gt.0) then ! in square diagram below figure ! write(21,209)trim(graphopt%lowerleftcorner) !209 format('set label "',a,'" at graph -0.10, -0.08 ') write(21,209)trim(graphopt%lowerleftcorner) 209 format('set label "',a,'" at graph -0.05, -0.05 ') endif ! if lowerleftcorner is empty ignore it !--------------------------------------------------------------- ! this is new subroutine ocplot2B !--------------------------------------------------------------- !========================================= begin using plot for ! ANPAX is axis with multiple values if(anpax.ne.0) then scalem=graphopt%scalefact(anpax) scale1=graphopt%scalefact(3-anpax) else scalem=graphopt%scalefact(1) scale1=graphopt%scalefact(2) endif if(graphopt%specialdiagram.eq.2) then !============================================== start Scheil ! Handle Scheil diagram with color changes along a single line ! ONLY if one axis is PFL or PFS!!! NOT if one plot composition of a phase ! write(*,*)'ocplot2B special for Scheil with PFL or PFS',nlinesep ! if there is an appended file we must set multiplot here ... if(appfil.gt.0) then write(*,*)'ocplot2B adding set multiplot' write(21,3828) endif backslash=',\' ! All lines to plot, colord can be 2:3 or 3:2 depending what is on the axis colord=' 2:3 ' ! no need to change, evidently xax and anp are already shifted ... suck ! write(*,'(a,a,2F12.6)')'ocplot2B colord: ',colord,xax(1),anp(1,1) ! ! this should be written AFTER entering the data part, what about several datablock='$Append1' ! applot='plot '//datablock ! do kk=1,nlinesep-1 ! call replace_uwh(phaseline(kk)) ! write(21,1999)applot,colord,kk,trim(phaseline(kk)),backslash !1999 format('# ',a,' using 'a,' with lines ls ',i2,' title "',a,'"',a) ! applot='""' ! if(kk.eq.nlinesep-2) backslash=' ' ! enddo ! write(*,*) ! the loop below the initial one, removed after testing backslash=',\' inline='plot "-"' ! commented away and using new datablock inside multiplot do kk=1,nlinesep-1 call replace_uwh(phaseline(kk)) write(21,2000)inline,colord,kk,trim(phaseline(kk)),backslash 2000 format('# ',a,' using ',a,' with lines ls ',i2,' title "',a,'"',a) inline='""' if(kk.eq.nlinesep-2) backslash=' ' enddo ! Then all data with an empty line and a line with a single "e" ! between each line. ! nlinesep is number of separate lines to plot (with different sets of phases) ! linesep(1..nlinesep) is number of lines of data for each line to plot ! nrv is total lines with lines with data to write ! write(*,*)'ocplot2B linesep: ',(linesep(jj),jj=1,nlinesep) ! begin datablock write(21,'(a," << EOD ")')datablock write(21,'(a)')'# Line 1, phases: '//trim(phaseline(1)) jj=2 ltw: do nv=1,nrv ! write(*,'(3i4,1pe12.4)')'ocgnu2B data: ',jj,nv,linesep(jj),xax(nv) if(nv.eq.linesep(jj)) then ! a new line start if(jj.eq.nlinesep) exit ltw write(21,'(i4,2F12.6)')nv,xax(nv),anp(1,nv) write(21,2100)jj,trim(phaseline(jj)) 2100 format(/'e'/'# Line ',i3,' phases ',a) jj=jj+1 endif write(21,'(i4,2F12.6)')nv,xax(nv),anp(1,nv) enddo ltw write(21,2110) 2110 format(/'e'/) ! end of appended data? write(21,'(a)')'EOD end of appended data' ! We should add the datablock plot command here applot='plot '//datablock backslash=',\' do kk=1,nlinesep-1 call replace_uwh(phaseline(kk)) write(21,1999)applot,colord,kk,trim(phaseline(kk)),backslash 1999 format(a,' using ',a,' with lines ls ',i2,' title "',a,'"',a) applot='""' ! remove backslash at last line if(kk.eq.nlinesep-2) backslash=' ' enddo ! !2110 format(/'e'/'pause mouse') ! close(21) ! Finished writing plot file ! stop 'test' goto 4000 !============================================== end Scheil endif ! now write all data once as a table ended with EOD write(21,3000)nrv,trim(tablename) 3000 format(//'# begin of data with lines',i7/'$',a,' << EOD') ! ! A digit before the first phase gives number of columns to plot ! write(*,*)'smp2b: isopleth? ',isoplethplot,np,npx if(isoplethplot) read(phaseline(1),'(i3)')fixphasecolor ! write(*,*)'SMP2B replace _ in keys: ',npx do jj=1,npx ! remove _ in keys call replace_uwh(lid(jj)) enddo if(graphopt%tielines.gt.0) then write(*,*)'ocplot2 does not plot tielines,',& ' they are perpendicular to the potential axis' endif ! columnheaders used as keys if(isoplethplot) then ! This column headin is not set before lid(npx)='Invariant' ! write(*,3100)'KEYS: ',trim(pltax(3-anpax)),(trim(lid(jj)),jj=1,npx) write(21,3100)'KEYS: ',trim(pltax(3-anpax)),(trim(lid(jj)),jj=1,npx) !2900 format(a,i3,2x,10(a,2x)) else ! write(*,*)'SMP2B mqmqa plot?' write(21,3100)'KEYS: ',trim(pltax(3-anpax)),(trim(lid(jj)),jj=1,np) 3100 format(a,' ',100(a,' ')) endif ksep=2 write(21,*)'# First line: ',trim(phaseline(1)) ! write(*,*)'smp2b isoplethplot 3: ',isoplethplot,& ! btest(graphopt%status,GRISOPLETH),fixphasecolor do nv=1,nrv !--------------------------------------------------------------- ! values written multiplied with graphopt%scalefact, ! first value is single valued axis (can be X or Y axis) multiplied with scale1 ! remaining values multiplied scalem write(21,'(i4,1pe16.6)',advance='no')nv,scale1*xax(nv) ! note that isopletpots have np=1 do jj=1,np-1 ! second and later columns represent Y axis if(anp(jj,nv).ne.rnone) then write(21,2821,advance='no')scalem*anp(jj,nv) else write(21,'(a)',advance='no')' NaN ' endif enddo if(isoplethplot) then ! fixphasecolor 100 means invariant if(fixphasecolor.lt.100) then ! dummy column values up to fixphasecolor do jj=1,fixphasecolor-1 write(21,'(" NaN ")',advance='no') enddo ! This column has real value, then maybe additional columns with dummy values ! note only anp(1,nv) has any value!! write(21,2821,advance='no')scalem*anp(1,nv) do jj=1,npx-fixphasecolor-1 write(21,'(" NaN ")',advance='no') enddo ! The last colum is for invariants which are written seperatey below write(21,'(" NaN ")') else ! this is an invariant, last column has values. There may be no invariant! do jj=1,npx-1 write(21,'(" NaN ")',advance='no') enddo write(21,2821)scalem*anp(1,nv) endif elseif(anp(jj,nv).ne.rnone) then write(21,2821)scalem*anp(jj,nv) else write(21,'(a)')' NaN ' endif !2820 format(i4,1pe16.6) 2821 format(1pe16.6) !2822 format(' NaN ') !--------------------------------------------------------------- ! here we shift to another line and color if(nv.eq.linesep(ksep)) then ! an empty line in the plot file means a MOVE to the next point. if(nv.lt.nrv) then ! write(21,3819)ksep-1,trim(phaseline(ksep-1)),trim(phaseline(ksep)) !3819 format('# shift of line ',i3,2x,a//'# new line ',a) ! sometimes phaseline is empty ... and not needed anyway and create stray lines write(21,3819)ksep-1 3819 format('# shift of line ',i3//) ! write(*,*)'SMP2B readfixcolor: ',trim(phaseline(ksep)),ksep if(isoplethplot) read(phaseline(ksep),'(i3)')fixphasecolor else ! try to avoid rubbish ! write(21,3821)ksep-1,trim(phaseline(ksep-1)) !3821 format('# end of line ',i3,2x,a//) write(21,3821)ksep-1 3821 format('# end of line ',i3//) endif ! test of uninitiallized variable, ksep must not exceed nlinesep ksep=min(ksep+1,nlinesep) endif enddo write(21,3823) 3823 format('EOD'//) if(appfil.gt.0) then ! if there is an appendfile add set multiplot write(*,*)'ocplot2B trying to include appfile ...' ! The "writeback" is important for uniform scaling of multiplots ! NOTE this is also used for Scheil above write(21,3828) 3828 format('set multiplot'/& 'set xrange [] writeback'/'set yrange [] writeback') endif ! If no file appended the line types are (i-2) ! if a file appended then line types are (i-2+ltf1(=10)) ! if anpax is axis with single value (1=x, 2=y) ! if(isoplethplot) then ! write(21,3800)trim(tablename) !3800 format('plot $',a,' using 2:3:4 with lines lc variable notitle') ! elseif(anpax.eq.1) then ! here we use npx for both isopleths and others! if(graphopt%linewp.le.1) then if(anpax.eq.1) then ! linewp=0 is dashed and =1 is line without point write(21,3900)npx+2,trim(tablename),ltf1 3900 format('plot for [i=3:',i2,'] $',a,' using i:2',& ' with lines ls (i-2+',i2,') title columnheader(i)') else write(21,3910)npx+2,trim(tablename),ltf1 3910 format('plot for [i=3:',i2,'] $',a,' using 2:i',& ' with lines ls (i-2+',i2,') title columnheader(i)') endif else ! plot line with points at every linewp-1 calculated point if(anpax.eq.1) then write(21,3600)npx+2,trim(tablename),ltf1,graphopt%linewp-1 3600 format('plot for [i=3:',i2,'] $',a,' using i:2',& ' with lp ls (i-2+',i2,') pi ',i3,' title columnheader(i)') else write(21,3610)npx+2,trim(tablename),ltf1,graphopt%linewp-1 3610 format('plot for [i=3:',i2,'] $',a,' using 2:i',& ' with lp ls (i-2+',i2,') pi ',i3,' title columnheader(i)') endif endif ! write(*,*)'SMP2 linespoint increment 1:',graphopt%linewp-1 !================================================================= ! we come here after plotting a Scheil diagram above, try including appfiles 4000 continue !================================================================= ! plot command from appfil if(appfil.gt.0) then ! write(*,*)'ocplot2B appending a file at label 3912' ! try to avoid overlapping keys ... ! The "restore" for x/yrange means the scaling from the "plot for" ! will be used also for the appended data write(21,3912)trim(graphopt%font) 3912 format('set key bottom right font "',a,',12"'/& 'set xrange restore'/'set yrange restore') if(appfiletyp.eq.2) then ! just one line with plot for ... ! the data to append is already copied as a table write(21,'(a)')trim(applines(1)) ! if applines>0 write those lines before "unset" if(multibuffline.gt.0) then do iz=1,multibuffline-1 write(21,'(a)')trim(multibuffer(iz)) enddo endif multibuffline=0 write(21,'(a)')'unset multiplot #appfiletype 2' ! write(21,'(a)')'unset multiplot' close(appfil) appfil=0 elseif(multibuffline.gt.0) then ! these are "plot "-" ... lines, not connected to "set multiplot" write(21,'(a,2i7)')'# not appfiletype 2, multibufline, nofapl',& multibuffline,nofapl do iz=1,multibuffline-1 write(21,'(a)')trim(multibuffer(iz)) enddo multibuffline=0 do jj=1,nofapl write(21,'(a)')trim(applines(jj)) enddo write(21,'(a)')'unset multiplot #appfiletype 1' close(appfil) appfil=0 endif endif ! if the plot command is "plot '-' ... then ! copy the data from the append file, it should be correctly formatted ! as I understand appfil muste always be 0 here ... no if(appfil.gt.0) then if(multibuffline.gt.0) then write(*,*)' *** ocplot2B appending multiplot',multibuffline do iz=1,multibuffline-1 write(21,'(a)')trim(multibuffer(iz)) enddo multibuffline=0 ! write(21,'(a)')'unset multiplot # closing appfil' endif ! appfile header lines write(*,*)'Appfile header lines: ',nofapl ic=0 write(21,'(a)')'# Copying appfile data' ! these line contain the 'plot "-" ..." do jj=1,nofapl write(21,'(a)')trim(applines(jj)) enddo 1900 continue ! this is copying the actual data to plot from the append file. ! write(*,*)'Copying appfile data' read(appfil,884,end=1910)appline 884 format(a) ic=ic+1 ! skip pause mouse if(appline(1:12).eq.'pause mouse ') goto 1900 write(21,884)trim(appline) goto 1900 ! end of copying appfile data 1910 continue write(*,*)'Appended ',ic,' data lines' ! if(multibuffline.gt.0) then ! ocplot2B add multiple plot "multplot" commands .... ! write(*,*)'ocplot2B adding prevous multplot ...',multibuffline ! do iz=1,multibuffline-1 ! write(21,884)trim(multibuffer(iz)) ! enddo ! endif ! write(21,'(a)')'unset multiplot' write(21,'(a)')'unset multiplot # closing appfil 3' close(appfil) appfil=0 endif !------------------------------------------------------ ! write(*,*)'In OCPLOT2B finished 1 "',pform(1:1),'"' if(graphopt%gnutermsel.eq.1) then ! if not hardcopy pause gnuplot. Mouse means clicking in the graphics window ! will close it. I would like to have an option to keep the graphics window... write(21,990)trim(graphopt%plotend) !990 format('pause mouse') 990 format(a) endif close(21) ! write(*,*)'In OCPLOT2B closed ',trim(pfc),kkk if(appfil.ne.0) close(appfil) appfil=0 !------------------------------------------------------------------- ! execute the GNUPLOT command file gnuplotline='gnuplot '//pfc(1:kkk)//' & ' ! Uncomment the following line for OS having gnuplot5 and ! comment the above line with gnuplotline='gnuplot '//pfc(1:kkk)//' & ' ! gnuplotline='gnuplot5 '//pfc(1:kkk)//' & ' ! Reason - Choose the gnuplot command as per the Operating System's ! existing command "gnuplot", "gnuplot5"etc.. ! Or, give the path of the gnuplot file as described below: ! if gnuplot cannot be started with gnuplot give normal path ... ! gnuplotline='"c:\program files\gnuplot\bin\wgnuplot.exe" '//pfc(1:kkk)//' ' k3=len_trim(gnuplotline)+1 ! write(kou,*)'Gnuplot command file: ',pfc(1:kk+4) if(graphopt%gnutermsel.ne.1) then write(kou,*)'Graphics output file: ',pfh(1:kk+4) endif ! plotonwin is set by compiler option, if 1 we are running microspft windows if(lines_excluded.gt.0) write(kou,11)lines_excluded 11 format('SMP Some calculated lines are excluded from the plot',i5) if(plotonwin.eq.1) then ! call system without initial "gnuplot " keeps the window !!! if(btest(graphopt%status,GRKEEP)) then ! write(*,*)'plot command: "',gnuplotline(9:k3),'"' ! write(*,*)'Trying to spawn: ',trim(gnuplotline) ! call system(gnuplotline(9:k3)) ! spawn plot on Windows ?? NOT ISO-TERMAL DIAGRAM ! write(*,*)'executing command: "start /B '//trim(gnuplotline) ! call execute_command_line('start /B '//gnuplotline(9:k3)) write(*,*)'SMP2B executing command: "start /B '//trim(gnuplotline)//'"' call execute_command_line('start /B '//trim(gnuplotline)) ! sleep 500 miliseconds call usleep(us) ! WORKS WITH OCPLOT3B ! call execute_command_line('start /B '//trim(gnuplotline)) else ! write(*,*)'plot command: "',gnuplotline(1:k3),'"' ! call system(gnuplotline) write(*,*)'SMP2B executing command: "'//trim(gnuplotline)//'"' call execute_command_line(gnuplotline) ! sleep 500 miliseconds call usleep(us) endif else ! plot on non-windows system without "start /B ... ! how to implement GRKEEP? write(*,*)'SMP2B executing command: '//trim(gnuplotline) call execute_command_line(gnuplotline) ! sleep 500 miliseconds call usleep(us) endif 1000 continue return end subroutine ocplot2B !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine ocplot3 !\begin{verbatim} ! subroutine ocplot3(ndx,pltax,filename,maptop,axarr,graphopt,pform,& subroutine ocplot3(ndx,pltax,filename,mastertop,axarr,graphopt,& version,ceq) ! special to plot isothermal sections (two columns like x(*,cr) x(*,ni)) ! or other diagrams with two extensive variable on the axis ! ndx is mumber of plot axis, ! pltax is text with plotaxis variables ! filename is intermediary file (maybe not needed) ! mastertop is the map_node record with all results ! axarr are axis records ! graphopt is graphics record (should be extended to include more) ! pform is graphics form ! NOT USED: pform is type of output (screen or postscript or gif) implicit none integer ndx character pltax(*)*(*),filename*(*),version*(*) type(map_axis), dimension(*) :: axarr type(map_node), pointer :: mastertop type(graphics_options) :: graphopt TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} %+ integer, parameter :: maxsame=200 type(map_node), pointer :: plottop,curtop,endnode,maptop type(map_line), pointer :: curline type(gtp_equilibrium_data), pointer :: curceq type(map_ceqresults), pointer :: results integer ii,jj,point,plotp,lines,eqindex,lasteq,nooftups,lokcs,jph,same,kk integer, parameter :: maxval=4000,mazval=100 double precision, allocatable :: xval(:,:),yval(:,:),zval(:,:),tieline(:,:) integer offset,nofeq,sumpp,last,nofinv,ntieline,mtieline,noftielineblocks double precision xxx,yyy character*64, dimension(:), allocatable :: phaseline ! TO BE REPLACED BY GNUTERMSEL: pform ! character pform*8 integer, allocatable :: plotkod(:),lineends(:) character xax1*8,xax2*24,yax1*8,yax2*24,axis1*32,axisx(2)*32,axisy(2)*32 character phname*32,encoded*1024,axis*32 character lid(2,maxsame)*24 integer nooflineends,ephl,invnode double precision xmin, xmax, ymin, ymax ! ! do not change mastertop! maptop=>mastertop ! xval and yval and ccordinates to plot, ! points on one line is xval(1,jj),yval(1,jj) ! points on the other line is xval(2,jj),yval(2,jj) ! zval is an occational point zval(1,kk),zval(2,kk) at line ends (invariants) ! plotkod is a specific code for each point ! normal point just the index, -1 means point should be suppressed ! -100 or -101 is a tieline; -1000 an invariant ! lineends is the index in xval/yval for an end of line if(.not.associated(maptop)) then write(*,*)'No data to plot' goto 1000 endif allocate(xval(2,maxval)) allocate(yval(2,maxval)) allocate(plotkod(maxval)) allocate(zval(2,maxsame)) allocate(lineends(maxsame)) ! phaseline is the name of the phases stable along a line allocate(phaseline(maxsame)) nooflineends=0 ! write(*,17) 17 format(//'Using ocplot3') ! extract the axis variables jph=index(pltax(1),'*') xax1=pltax(1)(1:jph-1) xax2=pltax(1)(jph+1:) jph=index(pltax(2),'*') yax1=pltax(2)(1:jph-1) yax2=pltax(2)(jph+1:) ! ! initiate loop to extract values point=0 plotp=0 nofinv=0 xmin=zero; xmax=zero; ymin=zero; ymax=zero ! if graphopt%tielines not zero check if the tielines are in plane ... ! %tieline_tieline_inplane <0 means step, 0 means isopleth if(graphopt%tielines.gt.0) then if(maptop%tieline_inplane.le.0) then write(kou,*)' Warning, tie-lines may be wrong' ! graphopt%tielines=0 endif endif ! same is incremented for each line same=0 sumpp=0 plottop=>maptop curtop=>plottop nooftups=nooftup() ! nooftup=noofphasetuples() 100 continue if(.not.allocated(curtop%linehead)) goto 500 lines=size(curtop%linehead) results=>plottop%saveceq invnode=0 if(btest(plottop%status,MAPINVARIANT)) then invnode=size(plottop%linehead) write(*,*)'ocplot3 invariant node 1',invnode endif noftielineblocks=0 ! write(*,*)'SMP Number of lines: ',lines node: do ii=1,lines ! up to version 5.014: (june 2018) ! curline=>curtop%linehead(ii) ! because crash plotting a ternary with 2 start points I changed ! curline=>plottop%linehead(ii) ! BUT the line above does not work for map10 and map3 (last plot of H) ! so until further investigations I keep: curline=>curtop%linehead(ii) if(btest(curline%status,EXCLUDEDLINE)) then write(*,*)'Excluded line: ',ii,curline%lineid,lines cycle node endif eqindex=curline%first lasteq=curline%last if(eqindex.le.0 .or. eqindex.gt.lasteq) cycle node last=same same=same+1 if(same.gt.maxsame) then write(*,*)'Too many lines to plot ',maxsame cycle node endif nofeq=lasteq+1-eqindex axisx=' ' axisy=' ' ntieline=0 ! write(*,*)'Plotting tie-lines: ',graphopt%tielines if(graphopt%tielines.gt.0) then ! estimate the number of tie-lines to extract mtieline=nofeq/graphopt%tielines ! write(*,*)'Number of tie-lines: ',mtieline allocate(tieline(4,mtieline+5)) ! write(*,*)'Allocating for tielines: ',mtieline+1 ! UNFINISHED: try to have equal number of equilibria at the beginning and end endif line: do eqindex=eqindex,lasteq ! extract for each stable phase the state variable in pltax point=point+1 curceq=>results%savedceq(eqindex) if(.not.associated(curceq)) then write(*,*)'SMP error, equilibrium missing?: ',& curtop%seqx,curline%lineid,eqindex cycle line endif ! find the stable phases (max 3) plotp=plotp+1 if(plotp.gt.maxval) then write(*,*)'Too many points to plot ',maxval cycle node endif jj=1 ephl=1 equil: do jph=1,nooftups lokcs=phasetuple(jph)%lokvares call get_phasetup_name(jph,phname) ! crash as lokcs not valid ... the 3rd of 4th time plotted ... ! write(*,321)'SMP bug? ',curtop%seqx,curline%lineid,eqindex,& ! jph,lokcs,trim(phname) 321 format(a,2i4,i5,2i4,' : ',a) ! crash next line in alcrni-1200 mapping ... if(curceq%phase_varres(lokcs)%phstate.ge.PHENTSTAB) then if(jj.ge.3) then if(eqindex.eq.lasteq) then ! skip this point if it is the last plotp=plotp-1 ! write(*,*)'ocplot3 indexing error, skipping last point' endif cycle equil endif ! the generation of the axis state variable is needed just once for all points ! if we save the axis text ... plotkod(plotp)=same call get_phasetup_name(jph,phname) phaseline(same)(ephl:)=phname ephl=min(len_trim(phaseline(same))+2,62) if(same.gt.last) then lid(jj,same)=phname endif ! !>>>>>>> here we should allow a wildcard axis like ac(*) !>>>>>>> without any phase label!! ! if(axisx(1)(1:1).eq.' ') then axisx(1)=trim(xax1)//trim(phname)//trim(xax2) axisy(1)=trim(yax1)//trim(phname)//trim(yax2) elseif(axisx(2)(1:1).eq.' ') then axisx(2)=trim(xax1)//trim(phname)//trim(xax2) axisy(2)=trim(yax1)//trim(phname)//trim(yax2) endif ! write(*,*)'We are here 1X: ',trim(axisx(jj)) call meq_get_state_varorfun_value(axisx(jj),xxx,encoded,curceq) xval(jj,plotp)=xxx if(xxx.lt.xmin) then xmin=xxx elseif(xxx.gt.xmax) then xmax=xxx endif ! write(*,*)'We are here 1Y: ',trim(axisy(jj)) call meq_get_state_varorfun_value(axisy(jj),xxx,encoded,curceq) yval(jj,plotp)=xxx if(xxx.lt.ymin) then ymin=xxx elseif(xxx.gt.ymax) then ymax=xxx endif ! write(*,19)'X/Y axis variable: ',plotp,trim(axis),& ! xval(jj,plotp),xxx,point !19 format(a,i5,2x,a,2F10.6,2i5) jj=jj+1 endif enddo equil if(graphopt%tielines.gt.0) then ! exact coordinates for tielines each ntieline equilibria ! write(*,*)'saving tieline?',eqindex,& ! mod(eqindex,graphopt%tielines),ntieline,plotp if(mod(eqindex,graphopt%tielines).eq.0) then ntieline=ntieline+1 tieline(1,ntieline)=xval(1,plotp) tieline(2,ntieline)=yval(1,plotp) tieline(3,ntieline)=xval(2,plotp) tieline(4,ntieline)=yval(2,plotp) endif endif ! write(*,23)'phase line: ',same,last,trim(lid(1,same)),& ! trim(lid(2,same)) last=same ! write(*,21)xval(1,plotp),yval(1,plotp),& ! xval(2,plotp),yval(2,plotp),plotp !21 format('phase 1: ',2F10.7,10x,'phase 2: ',2F10.7,i7) lineends(same)=plotp enddo line ! check if line ends in a node and add its coordinates for the same phases endnode=>curline%end if(associated(endnode)) then ! there is a node at the end, extracts its ceq record curceq=>endnode%nodeceq plotp=plotp+1 if(plotp.gt.maxval) then write(*,*)'Too many points to plot 1:',maxval gx%bmperr=4399; goto 1000 endif do jj=1,2 ! write(*,*)'We are here 2:',trim(axisx(jj)) call meq_get_state_varorfun_value(axisx(jj),xxx,encoded,curceq) if(gx%bmperr.ne.0) then write(*,*)'Error extracting end points' goto 1000 endif xval(jj,plotp)=xxx call meq_get_state_varorfun_value(axisy(jj),yyy,encoded,curceq) if(gx%bmperr.ne.0) goto 1000 yval(jj,plotp)=yyy enddo ! write(*,*)'Endnode x,y: ',plotp,xxx,yyy ! correct lineends!! lineends(same)=plotp endif ! write(*,23)'phase line: ',same,plotp,trim(lid(1,same)),trim(lid(2,same)) 23 format(a,2i5,3x,a,' and ',a) noftielineblocks=noftielineblocks+1 if(ntieline.gt.0) then ! All tielines on the same line with a space in between same=same+1 phaseline(same)='tie-line' do eqindex=1,ntieline plotp=plotp+1 if(plotp.gt.maxval) then write(*,*)'Too many points to plot 2:',maxval gx%bmperr=4399; goto 1000 endif xval(1,plotp)=tieline(1,eqindex) yval(1,plotp)=tieline(2,eqindex) ! this means the tie-lines will be plotted twice ... but why not?? xval(2,plotp)=tieline(1,eqindex) yval(2,plotp)=tieline(2,eqindex) plotkod(plotp)=-100 plotp=plotp+1 if(plotp.gt.maxval) then write(*,*)'Too many points to plot 3:',maxval gx%bmperr=4399; goto 1000 endif xval(1,plotp)=tieline(3,eqindex) yval(1,plotp)=tieline(4,eqindex) xval(2,plotp)=tieline(3,eqindex) yval(2,plotp)=tieline(4,eqindex) lineends(same)=plotp plotkod(plotp)=-101 enddo lid(1,same)='tieline' lid(2,same)='tieline' endif ! no longer any use of tieline if(allocated(tieline)) deallocate(tieline) enddo node !---------------------------------------------------------------------- ! finished all lines in this curtop, take next ! but first generate the monovariant (not invariant) curtop=>curtop%next if(.not.associated(curtop,maptop)) then ! write(*,*)'Extracting data from node' curceq=>curtop%nodeceq if(associated(curceq)) then ! write(*,*)'Extracting data from node equilibrium' plotp=plotp+1 if(plotp.gt.maxval) then write(*,*)'Too many points to plot 4:',maxval gx%bmperr=4399; goto 1000 endif jj=1 same=same+1 ephl=1 nodeequil: do jph=1,nooftups lokcs=phasetuple(jph)%lokvares if(curceq%phase_varres(lokcs)%phstate.ge.PHENTSTAB) then ! plotkod set to -1 to indicate monovariant (not invariant) plotkod(plotp)=-1 call get_phasetup_name(jph,phname) phaseline(same)(ephl:)=phname ephl=min(len_trim(phaseline(same))+2,62) ! write(*,*)'Stable phase ',trim(phname),jj ! if(jj.lt.3) lid(jj,same)='invariant' if(jj.lt.3) lid(jj,same)='monovariant' axis=trim(xax1)//trim(phname)//trim(xax2) ! write(*,*)'We are here 3: ',trim(axis) call meq_get_state_varorfun_value(axis,xxx,encoded,curceq) if(jj.ge.3) then nofinv=nofinv+1 zval(1,nofinv)=xxx else xval(jj,plotp)=xxx endif axis=trim(yax1)//trim(phname)//trim(yax2) call meq_get_state_varorfun_value(axis,xxx,encoded,curceq) if(jj.ge.3) then zval(2,nofinv)=xxx else yval(jj,plotp)=xxx endif jj=jj+1 endif enddo nodeequil lineends(same)=plotp endif ! jump back to label 100 goto 100 endif ! do jj=1,same ! write(*,23)'phases: ',same,jj,trim(lid(1,jj)),trim(lid(2,jj)) ! enddo !------------------------------------------------ ! Jump here if there is a line with illegal lineid 772 continue ! there can be more maptops linked via plotlink if(associated(plottop%plotlink)) then jj=plottop%seqx plottop=>plottop%plotlink write(*,*)'ocplot3B current and next maptop: ',jj,plottop%seqx ! this added 180918 to plot results from several MAP commands curtop=>plottop maptop=>plottop ! write(*,*)'Current number of lines: ',same,plotp,& ! allocated(curtop%linehead) goto 100 endif !======================================================== call get_plot_conditions(encoded,maptop%number_ofaxis,axarr,ceq) ! now we should have all data to plot in xval and yval arrays 500 continue write(*,808)same,plotp,maxsame,maxval 808 format('plot data used: ',2i7,' out of ',2i7) ! write(*,*)'found lines/points to plot: ',same,plotp,nofinv ! write(*,502)(lineends(ii),ii=1,same) 502 format(10i5) ! set default xmin, xmax etc ... graphopt%dfltmin(1)=xmin graphopt%dfltmin(2)=ymin graphopt%dfltmax(1)=xmax graphopt%dfltmax(2)=ymax ! NOW pltax should be the the axis labels if set manually if(graphopt%labeldefaults(2).ne.0) pltax(1)=graphopt%plotlabels(2) if(graphopt%labeldefaults(3).ne.0) pltax(2)=graphopt%plotlabels(3) call ocplot3B(same,nofinv,lineends,2,xval,2,yval,2,zval,plotkod,pltax,& lid,phaseline,filename,graphopt,version,encoded) deallocate(xval) deallocate(yval) deallocate(plotkod) 1000 continue return end subroutine ocplot3 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\begin{verbatim} %- subroutine ocplot3B(same,nofinv,lineends,nx1,xval,ny1,yval,nz1,zval,plotkod,& pltax,lid,phaseline,filename,graphopt,version,conditions) ! called by ocplot3 to write the GNUPLOT file for two wildcard columns ! same is the number of lines to plot ! nofinv number of monovariants (not invariants) ! lineends array with row numbers where each line ends ! nx1 first dimension of xval ! xval 2D matrix with values to plot on x axis ! ny1 first dimension of yval ! yval 2D matrix with values to plot on y axis ! nz1 first dimension of zval ! zval 2D matrix with third point of monovariant (not invariant) triangles ! plotkod integer array indicating the type of line (-1 skip line) ! pltax text for axis ! lid array with GNUPLOT line types ! phaseline is phase names of phase stable along the line ! filename is intermediary file (maybe not needed) ! graphopt is graphics option record ! maptop is map_node record with all results ! REPLACED BY gnutermsel pform is type of output (screen/acrobat/postscript/gir) ! conditions is a text with conditions for the calculation implicit none ! character pltax(*)*(*),filename*(*),pform*(*),lid(nx1,*)*(*),conditions*(*) character pltax(*)*(*),filename*(*),lid(nx1,*)*(*),conditions*(*) character version*(*) character phaseline(*)*(*) type(graphics_options) :: graphopt integer same,plotkod(*),nx1,ny1,nz1,nofinv integer lineends(*) double precision xval(nx1,*),yval(ny1,*),zval(nz1,*) !\end{verbatim} integer, parameter :: maxcolor=200,mofapl=100 integer ii,jj,kk,jph,offset,n1,nofapl,ltf2 type(graphics_textlabel), pointer :: textlabel character gnuplotline*256,date*12,mdate*12,title*128 character deftitle*64,backslash*2 ! pointincremet emergy fix character piincrement*8 character labelkey*64,applines(mofapl)*128,appline*128,pfc*128,pfh*128 integer sumpp,np,appfil,ic,nnv,kkk,lcolor(maxcolor),iz,again integer done(maxcolor),foundinv,fcolor,k3 character color(maxcolor)*24,rotate*16,labelfont*32,linespoints*12 integer naptitle,apptitles(maxcolor) ! we plot monovariant twice, once with border once with filledcurves!! ! integer noofmono,jjj,monovariant2(100) integer, parameter :: monovariantborder=11 integer xtieline,xmonovariant,lz integer, parameter :: us=500000 ! now a global variable ! character monovariant*6 ! Gibbs triangle variables logical plotgt,appgt double precision sqrt3,xxx,yyy,xmax,ymax,ltic,xf,yf,xmin,ymin ! write(*,*)'Using the rudimentary graphics in ocplot3B!',graphopt%linett ! light green 'fc "#B0FFB0" notitle ',a) ! very faint green 'fc "#F0FFF0" notitle ',a) ! yellow 'fc "#FFFF00" notitle ',a) ! goldenrod 'fc "#DAA520" notitle ',a) ! dark green monovariant='50FF50' ! monovariant='00FFFF' ! write(*,*)'Filename: ',trim(ocgnu) ! ltf2=0 call date_and_time(date) mdate=" "//date(1:4)//'-'//date(5:6)//'-'//date(7:8)//" " deftitle='OpenCalphad '//version//': '//mdate//': with GNUPLOT' if(graphopt%labeldefaults(1).eq.0) then title=deftitle else ! default inlcude open calphad and date, add user title at the end title=trim(deftitle)//' '//graphopt%plotlabels(1) endif ! np should be the number of different lines to be plotted ! if there is just one line do not write any key. May be overriiden later .. np=same write(*,*)'ocplot3B append?',trim(graphopt%appendfile(1:1)) if(np.eq.1 .and. graphopt%appendfile(1:1).eq.' ') then labelkey=' off' else labelkey=graphopt%labelkey endif ! problems with identifying monovariants (not invariants) and tie-lines lines lcolor=0 ! if(index(filename,'.plt ').le.0) then kk=len_trim(filename) pfc=filename(1:kk)//'.'//'plt ' kkk=kk+4 else pfc=filename endif ! write(kou,*)'SMP2B filename: ',trim(pfc) ! write(kou,*)'Graphics format: ',graphopt%gnutermsel open(21,file=pfc,access='sequential',status='unknown') write(21,110)trim(title) 110 format('# GNUPLOT file generated by OpenCalphad'/'# ',a/& '# subroutine ocplot3B') if(graphopt%gnutermsel.lt.1 .or. & graphopt%gnutermsel.gt.graphopt%gnutermax) then write(*,*)'Unknown graphics terminal: ',graphopt%gnutermsel goto 1000 elseif(graphopt%gnutermsel.gt.1) then ! terminal 1 is screen without any output file pfh=filename(1:kk)//'.'//graphopt%filext(graphopt%gnutermsel) ! set the screen as a comment ... write(21,840)trim(graphopt%gnuterminal(1)),& trim(graphopt%gnuterminal(graphopt%gnutermsel)),trim(pfh) 840 format('#set terminal ',a/'set terminal ',a/'set output "',a,'"') ! 840 format('set terminal ',a/'set output "',a,'"') else ! terminal 1 is screen without any output file, add PDF as comment write(21,841)trim(graphopt%gnuterminal(graphopt%gnutermsel)),& trim(graphopt%gnuterminal(3)) 841 format('set terminal ',a/'#set terminal ',a/'#set output "ocgnu.pdf"') !841 format('set terminal ',a) endif if(graphopt%gibbstriangle) then ! write(*,*)'Gibbs triangle diagrams are under development!' ! xmax should be the largest scale value of x and y axis (same length!!) xmax=one plotgt=.true. if(graphopt%rangedefaults(1).ne.0) then xmax=min(xmax,graphopt%plotmax(1)) endif if(graphopt%rangedefaults(2).ne.0) then xmax=min(xmax,graphopt%plotmax(2)) endif ! graphopt%plotmin(1) etc are user defined ! graphopt%dfltmin(1..3) and dfltmax(1..3) are generated above ! write(*,*)'SMP2B xmin,ymin: ',graphopt%dfltmin(1),graphopt%dfltmin(2) ! write(*,*)'SMP2B xmax,ymax: ',graphopt%dfltmax(1),graphopt%dfltmax(2) ltic=0.01*xmax sqrt3=0.5D0*sqrt(3.0D0) write(21,844)sqrt3*xmax,xmax ! These maybe not necessary ... 0.866 is 0.5*sqrt(3) 844 format('# GIBBSTRIANGLE '/& 'set bmargin 3'/'set lmargin 3'/'set rmargin 3'/'set tmargin 3'/& 'set origin 0.0, 0.0 '/& 'set size ratio 0.866'/& 'set yrange [0:',F10.6,']'/'set xrange [0:',F10.6,']'/& 'set noborder'/'set noxtics'/'set noytics') ! This replaces axis without tics, only a tic in the middle write(21,845)xmax, xmax, 0.5*xmax, sqrt3*xmax, 0.5*xmax, sqrt3*xmax,& ! next 3 values are value and position for max values of Y axis ! xmax, 0.343*xmax, sqrt3*(xmax+0.15d0), & xmax, 0.39, sqrt3*(one+0.17d0), & ! next 3 values are value and positions of max values for X axis ! xmax, 0.92, -5.0*ltic, & xmax, 0.95, -3.0*ltic, & ! next 6 values are min values for X and Y axis xmin , -0.04, -0.03, ymin , -0.1, 0.01, & ! these are rudimentary ticmarks, now going inside triangle !!! 0.25*xmax, 0.5*sqrt3*xmax, 0.25*xmax+2*ltic, 0.5*sqrt3*xmax, & 0.25*xmax, 0.5*sqrt3*xmax, 0.25*xmax+ltic, 0.5*sqrt3*xmax-1.5*ltic,& 0.75*xmax, 0.5*sqrt3*xmax, 0.75*xmax-2*ltic, 0.5*sqrt3*xmax, & 0.75*xmax, 0.5*sqrt3*xmax, 0.75*xmax-ltic, 0.5*sqrt3*xmax-1.5*ltic,& 0.5*xmax,0.0,0.5*xmax,1.5*ltic 845 format('set style line 90 lt 1 lw 1 pt -1 ps 1'/& 'set style line 91 lt 1 lw 1 pt -1 ps 1'/& 'set arrow 1 from 0,0 to ',F8.4,', 0.0 nohead linestyle 90'/& 'set arrow 2 from ',F8.4,', 0 to ',F8.4,',',F8.4,& ' nohead linestyle 90'/& 'set arrow 3 from ',F8.4,',',F8.4,' to 0,0 nohead linestyle 90'/& '# axis max values ...'/& 'set label "',F6.2,'" at graph ',F8.4,',',F8.4/& 'set label "',F6.2,'" at graph ',F8.4,',',F8.4/& '# axis min values ...'/& 'set label "',F6.2,'" at graph ',F8.4,',',F8.4/& 'set label "',F6.2,'" at graph ',F8.4,',',F8.4/& '# tickmarks ...'/& 'set arrow 4 from ',F8.4,',',F8.4,' to ',F8.4,',',F8.4,& ' nohead linestyle 91'/& 'set arrow 5 from ',F8.4,',',F8.4,' to ',F8.4,',',F8.4,& ' nohead linestyle 91'/& 'set arrow 6 from ',F8.4,',',F8.4,' to ',F8.4,',',F8.4,& ' nohead linestyle 91'/& 'set arrow 7 from ',F8.4,',',F8.4,' to ',F8.4,',',F8.4,& ' nohead linestyle 91'/& 'set arrow 8 from ',F8.4,',',F8.4,' to ',F8.4,',',F8.4,& ' nohead linestyle 91'/& '# end most of special Gibbs triangle') else plotgt=.false. endif ! ! write(*,*)'Plot heading 3? ',btest(graphopt%status,GRNOTITLE) if(btest(graphopt%status,GRNOTITLE)) then write(21,128)trim(title),trim(conditions),trim(graphopt%font) else call replace_uwh(conditions) write(21,129)trim(title),trim(conditions),trim(graphopt%font) endif call replace_uwh(pltax(1)) ! Plot grid? if(graphopt%setgrid.eq.1) write(21,777) 777 format('set grid') ! add information of any scaling factors for the axis "xf" or "yf" ! if(graphopt%scalefact(1).ne.one) xf=graphopt%scalefact(1) ! if(graphopt%scalefact(2).ne.one) yf=graphopt%scalefact(2) write(21,130)graphopt%xsize,graphopt%ysize,& trim(pltax(1)),trim(labelkey) 128 format('#set title "',a,' \n #',a,'" font "',a,',10"') 129 format('set title "',a,' \n ',a,'" font "',a,',10"') 130 format('set origin 0.0, 0.0 '/& 'set size ',F8.4,', ',F8.4/& 'set xlabel "',a,'"'/& 'set key ',a) call replace_uwh(pltax(2)) if(plotgt) then ! OC logo added by Catalina Pineda ! when Gibbs triangle the ylabel and logo must be placed carefully ! THIS IS THE Y-AXIS WITH 60 degrees angle write(21,131)trim(pltax(2)), 0.15*xmax, 0.37*xmax,graphopt%logofont 131 format('set label "',a,'" at ',F8.4,',',F8.4,' rotate by 60 '/& ! Help with stackoverflow to fix nice logo independent of plot size! 'set label "~O{.0 C}" at screen 0.02, 0.03 font "',a,'"') ! 'set label "~O{.0 C}" at screen 0.02, 0.03 font "Garamond Bold,20"') ! 'set label "~O{.0 C}" at graph -0.1, -0.1 font "Garamond Bold,20"') ! we should also enforce same length of X and Y axis !!! else ! SQUARE DIAGRAM write(21,132)trim(pltax(2)),graphopt%logofont 132 format('set ylabel "',a,'"'/& ! Help with stackoverflow to fix nice logo independent of plot size! 'set label "~O{.0 C}" at screen 0.02, 0.03 font "',a,'"') ! 'set label "~O{.0 C}" at screen 0.02, 0.03 font "Garamond Bold,20"') ! 'set label "~O{.0 C}" at graph -0.1, -0.1 font "Garamond Bold,20"') endif lz=graphopt%linetype write(21,133)lz,lz,lz,lz,lz,lz,lz,lz,lz,lz 133 format('# if the value after solid is 0 the monovariants are transparent'/& 'set style fill transparent solid 1'/& 'set style line 1 lt ',i2,' lc rgb "#000000" lw 2 pt 10'/& 'set style line 2 lt ',i2,' lc rgb "#00C000" lw 2 pt 2'/& 'set style line 3 lt ',i2,' lc rgb "#4169E1" lw 2 pt 7'/& 'set style line 4 lt ',i2,' lc rgb "#FF0000" lw 2 pt 3'/& 'set style line 5 lt ',i2,' lc rgb "#00FFFF" lw 2 pt 10'/& 'set style line 6 lt ',i2,' lc rgb "#FF00FF" lw 2 pt 5'/& 'set style line 7 lt ',i2,' lc rgb "#804080" lw 2 pt 6'/& 'set style line 8 lt ',i2,' lc rgb "#00C000" lw 2 pt 8'/& 'set style line 9 lt ',i2,' lc rgb "#C0C0C0" lw 2 pt 1'/& 'set style line 10 lt ',i2,' lc rgb "#DAA520" lw 2 pt 4') ! add some useful things for manual maniplulation of graph write(21,8000) 8000 format(/'# Some useful GNUPLOT commands for editing the figure'/& '# *** THIS IS A DASHED LINE (on pdf/wxt):'/& '# set style line 15 lt 0 lc rgb "#C8C800" lw 2 pt 2'//& '# set pointsize 0.6'/& '# set label "text" at 0.5, 0.5 rotate by 60 font "Arial,12"'/& '# set xrange [0.5 : 0.7] '/& '# *** ADDING MANUALLY A LINE AND KEEP SCALING:'/& '# set arrow from x0, y0 to x1,y1 nohead linestyle 1'/& '# *** ADD A RED DOT AT 1,100:'/& '# set obj 1 circle fc rgb "#FF0000" fs sol size 0.02 noclip at 1,1'/& '# *** PLOTTING SYMBOLS INSTEAD OF LINE:'/& '# ... using 2:i with points pt 7 ps 3'/& '# ** MODIFY THE AXIS VALUE:'/& '# plot for [i=] ... using (2*column(i)/(1-2*column(i))):2 with ...'/& '# ** OVERLAY PLOTS: '/& '# set multiplot'/& '# set xrange [] writeback'/& '# ... plot someting'/& '# set xrange restore'/& '# ... plot more using same axis scaling '/& '# set nomultiplot'/) ! ! 'set style line 10 lt 2 lc rgb "#00FFFF" lw 2 pt 10'/& ! orange is #FF4500 ! goldenrod hex: DAA520" ! line style 11 is monovariant (not invariant), 12 tieline ! 'set style line 11 lt 2 lc rgb "goldenrod" lw 3'/& ! 'set style line 11 lt 2 lc rgb "#DAA520" lw 3'/& ! 'set style line 12 lt 2 lc rgb "goldenrod" lw 1') ! 'set style line 11 lt 2 lc rgb "#804080" lw 3'/& ! 'set style line 12 lt 2 lc rgb "#804080" lw 1') ! 'set style line 11 lt 2 lc rgb "#7CFF40" lw 3'/& ! for monovariants use filledcurves fc "#xxxxxx" AND linestyle 11 write(21,134)tielinecolor,tielinecolor ! line style 11 is for the limits of the monovariants, 12 for tie-lines 134 format('set style line 11 lt 2 lc rgb "#',a,'" lw 3'/& 'set style line 12 lt 2 lc rgb "#',a,'" lw 1') ! 'set style line 12 lt 2 lc rgb "#7CFF40" lw 1') ! The last two styles (11 and 12) are for monovariants (not invariants) ! and tielines ! ! ranges for x and y if(graphopt%rangedefaults(1).ne.0) then ! user defined ranges for x axis write(21,150)'x',graphopt%plotmin(1),graphopt%plotmax(1) 150 format('set ',a1,'range [',1pe12.4,':',1pe12.4,'] ') endif if(graphopt%rangedefaults(2).ne.0) then ! user defined ranges for y axis write(21,150)'y',graphopt%plotmin(2),graphopt%plotmax(2) endif !---------------------- ! logarithmic axis if(graphopt%axistype(1).eq.1) then write(21,151)'x' 151 format('set logscale ',a) endif if(graphopt%axistype(2).eq.1) then write(21,151)'y' endif !---------------------- ! line labels ! set labels textlabel=>graphopt%firsttextlabel do while(associated(textlabel)) if(plotgt) then xxx=textlabel%xpos+0.5D0*textlabel%ypos ! sqrt3=0.5D0*sqrt(3.0D0) yyy=sqrt3*textlabel%ypos else xxx=textlabel%xpos yyy=textlabel%ypos endif ! write(*,*)'SMP text: ',textlabel%textline,textlabel%xpos,xxx,plotgt !----------------------- new rotate=' ' if(textlabel%angle.ne.0) write(rotate,177)textlabel%angle 177 format(' rotate by ',i5) labelfont=' ' ! write(*,*)'textfontscale: ',textlabel%textfontscale if(textlabel%textfontscale.ne.one) then ! write(labelfont,178)int(10*textlabel%textfontscale) !178 format(' font "Sans,',i2,'" ') write(labelfont,178)trim(graphopt%font),& int(10*textlabel%textfontscale) 178 format(' font "',a,',',i2,'" ') endif ! if(textlabel%angle.eq.0) then ! write(21,1505)trim(textlabel%textline),textlabel%xpos,textlabel%ypos,& write(21,1505)trim(textlabel%textline),xxx,yyy,& trim(labelfont),trim(rotate) 1505 format('set label "',a,'" at ',1pe12.4,', ',1pe12.4,a,a) ! else ! write(21,1506)trim(textlabel%textline),textlabel%xpos,textlabel%ypos,& ! textlabel%angle !1506 format('set label "',a,'" at ',1pe12.4,', ',1pe12.4,& ! ' rotate by ',i5) ! endif ! textlabel=>textlabel%nexttextlabel ! OLD below ! if(textlabel%angle.eq.0) then ! write(21,160)trim(textlabel%textline),xxx,yyy,& !160 format('set label "',a,'" at ',1pe14.6,', ',1pe14.6) ! else ! write(21,161)trim(textlabel%textline),xxx,yyy,textlabel%angle !161 format('set label "',a,'" at ',1pe14.6,', ',1pe14.6,& ! ' rotate by ',i5) ! endif jj=len_trim(textlabel%textline) textlabel=>textlabel%nexttextlabel enddo !--------------------------------------------------------------- ! handle heading of appended files here .... ! if(graphopt%appendfile(1:1).eq.' ') then appfil=0 else appfil=23 write(kou,*)'Appending data from: ',trim(graphopt%appendfile) open(appfil,file=graphopt%appendfile,status='old',& access='sequential',err=280) ! write(21,210)'# APPENDED from '//trim(graphopt%appendfile) appgt=.false. ! copy all lines up to "plot" to new graphics file nnv=0 200 continue read(appfil,210,end=290)appline 210 format(a) ! if(appline(1:1).eq.'#') then ! write(*,*)'input: ',trim(appline),appgt ! endif if(appline(1:15).eq.'# GIBBSTRIANGLE') then appgt=.true. if(.not.plotgt) then write(*,*)'Append file is in Gibbstriangle format' goto 280 endif endif ! skip other comment lines if(appline(1:1).eq.'#') goto 200 !------------------------------------------------------------------ ! ignore some lines with "set" in the append file ! set title ! set xlabel ! set ylabel ! set xrange ! set yrange ! set output ! set terminal ! set size ! set key if(appline(1:10).eq.'set title ' .or.& appline(1:11).eq.'set xlabel ' .or.& appline(1:11).eq.'set ylabel ' .or.& appline(1:11).eq.'set xrange ' .or.& appline(1:11).eq.'set yrange ' .or.& appline(1:11).eq.'set output ' .or.& appline(1:13).eq.'set terminal ' .or.& appline(1:11).eq.'set origin ' .or.& appline(1: 9).eq.'set size ' .or.& appline(1: 8).eq.'set key ') then ! write(*,*)'ignoring append file line ',trim(appline) goto 200 endif !------------------------------------------------------------------ if(index(appline,'plot "-"').gt.0 .or. & index(appline,"plot '-'").gt.0 .or. & index(appline,"plot for ").gt.0) then ! this is ocplot3B, reading plot command lines if(plotgt) then ! check if append file has square or triangular coordinates ... if(.not.appgt) then ! If GIBBSTRIANGLE they must be converted unless already a triangle .... write(*,*)'Please use append file with Gibbs triangle' goto 280 endif elseif(appgt) then ! a triangular append file must be transformed to square ... write(*,*)'Please use append file with square coordinates' goto 280 endif applines(1)=appline ic=1 230 continue ! if line ends with \ then read more ii=len_trim(appline) ! write(*,*)'There are more? ',appline(i:ii),ii,ic if(appline(ii:ii).eq.'\') then ! continuation lines read(appfil,210,end=290)appline ic=ic+1 if(ic.ge.mofapl) then write(*,*)'Too many head lines in append file',ic else applines(ic)=appline endif goto 230 endif nofapl=ic goto 290 else ! ignore all lines until "plot "-" ... goto 200 endif ! These are coordinate lines write(21,210)trim(appline) nnv=nnv+1 goto 200 ! error oppening append file 280 continue write(kou,*)' *** Cannot open or read the append file, skipping it' close(appfil) appfil=0 290 continue ! do not close the append file, we have to read the data also! ! write(*,*)'Finished reading appendfile head: ',nofapl,ic endif ! coordinate the content of lid with the colors ! do ii=1,same ! write(*,*)'phases: ',ii,trim(lid(1,ii)),' ',trim(lid(2,ii)) ! enddo nnv=0 iz=0 ! color(1)=' ' color=' ' ! if(2*same.gt.maxcolor) then ! write(*,*)'Number of lines: ',2*same,maxcolor ! endif pair: do jj=1,2 ! maybe same must be incremented with the number of tieline blocks?? ! and ivariants?? They have separate plot commands ... point: do ii=1,same iz=iz+1 ! plotkod -1 negative means ignore ! plotkod -100 and -101 used for tie-lines if(jj.eq.2 .and. plotkod(iz).eq.-1) then write(*,*)'SMPB: Ignoring this line ',jj,iz,plotkod(iz) ! cycle pair cycle point endif do ic=1,nnv if(trim(lid(jj,ii)).eq.trim(color(ic))) then if(iz.gt.maxcolor) then write(kou,*)'lcolor dimension overflow',iz else lcolor(iz)=ic endif goto 295 endif enddo ! no match, increment nnv and assign that color to lcolor ! skip colors 11 and 12, reserved for monovariants and tielines nnv=nnv+1 lcolor(iz)=nnv color(nnv)=lid(jj,ii) ! write(*,293)'color select: ',nnv,jj,ii,iz,trim(color(nnv)) 293 format(a,4i5,' "',a,'"') 295 continue enddo point enddo pair ! write(*,*)'Finished assigning colors',iz ! replace _ by - (in phase names). nnv is number of titles do kk=1,nnv 297 continue jj=index(color(kk),'_') if(jj.gt.0) then color(kk)(jj:jj)='-' goto 297 endif enddo !--------------------------------------------------------------- ! check for monovariants (not invariant) and tieline and replace color! do ii=1,2*same if(lcolor(ii).le.0) then write(*,*)'missing color in ',ii,' out of ',2*same,' set to 9' lcolor(ii)=9 ! else ! write(*,*)'original: ',ii,lcolor(ii),trim(color(lcolor(ii))) endif enddo lcolor1: do ii=1,2*same jj=lcolor(ii) if(trim(color(jj)).eq.'invariant') then write(*,*)' *** wrong: invariant color ',jj,trim(color(jj)) endif if(trim(color(jj)).eq.'monovariant') then ! write(*,*)'found monovariant ',ii,jj,2*same lcolor(ii)=11 ! color(11)='invariant' color(11)='monovariant' do kk=ii+1,2*same if(lcolor(kk).eq.jj) then ! write(*,*)'subsequent: ',kk,lcolor(kk),jj,11 lcolor(kk)=11 endif enddo ! why exit? ! exit lcolor1 endif enddo lcolor1 lcolor2: do ii=1,2*same jj=lcolor(ii) if(jj.le.0 .or. jj.gt.maxcolor) then ! this is a line that should not be plotted ... write(*,*)'smp2B: problem: ',ii,jj lcolor(ii)=11 cycle lcolor2 endif if(trim(color(jj)).eq.'tieline') then ! write(*,*)'found tie-line ',ii,jj lcolor(ii)=12 color(12)='tie-line' do kk=ii+1,2*same if(lcolor(kk).eq.jj) lcolor(kk)=12 enddo ! why exit? ! exit lcolor2 endif enddo lcolor2 ! do ii=1,2*same ! write(*,*)'Final: ',ii,lcolor(ii),trim(color(lcolor(ii))) ! enddo !---------------------------------------------------------------- if(plotgt) then ! convert all coordinates to a Gibbs trangle, ax and ay are the square coordin ! x = ax + 0.5*ay ! y = 0.5*sqrt(3)*ay ! ! As the 3rd point of the monovariant is connected to the xval/yval I must ! make the same loop as below when plotting ... ! write(*,*)'Converting coordinates to Gibbs Triangle',same,lineends(1) foundinv=0 ! sqrt3=0.5D0*sqrt(3.0D0) sumpp=0 do jj=1,same if(sumpp+1.eq.lineends(jj)) then foundinv=foundinv+1 ! write(*,*)'Monovariant at ',foundinv,sumpp sumpp=sumpp+1 xval(1,sumpp)=xval(1,sumpp)+5.0D-1*yval(1,sumpp) xval(2,sumpp)=xval(2,sumpp)+5.0D-1*yval(2,sumpp) zval(1,foundinv)=zval(1,foundinv)+5.0D-1*zval(2,foundinv) zval(2,foundinv)=sqrt3*zval(2,foundinv) yval(1,sumpp)=sqrt3*yval(1,sumpp) yval(2,sumpp)=sqrt3*yval(2,sumpp) else do while(sumpp.lt.lineends(jj)) sumpp=sumpp+1 xval(1,sumpp)=xval(1,sumpp)+5.0D-1*yval(1,sumpp) xval(2,sumpp)=xval(2,sumpp)+5.0D-1*yval(2,sumpp) yval(1,sumpp)=sqrt3*yval(1,sumpp) yval(2,sumpp)=sqrt3*yval(2,sumpp) enddo endif enddo endif !---------------------------------------------------------------- ! text in lower left corner ii=len_trim(graphopt%lowerleftcorner) if(graphopt%gibbstriangle) then if(ii.gt.3) then ! write(21,208)trim(graphopt%lowerleftcorner),-0.14 !208 format('set label "',a,'" at graph ',F10.4,', -0.05 ') write(21,208)trim(graphopt%lowerleftcorner),-0.05 208 format('set label "',a,'" at graph ',F10.4,', -0.03 ') elseif(ii.gt.0) then write(21,208)trim(graphopt%lowerleftcorner),-0.08 endif elseif(ii.gt.0) then ! in square diagram below figure write(21,209)trim(graphopt%lowerleftcorner) 209 format('set label "',a,'" at graph -0.10, -0.08 ') endif ! if lowerleftcorner is empty ignore it !---------------------------------------------------------------- !---------------------------------------------------------------- ! Finished all options, now deal with the data to plot! ! this is subroutine ocplot3B for two extensive axis !---------------------------------------------------------------- ! Here we generate the datafile with coordinates to plot ! if nx1 or ny1 is 1 plot all on other axis versus single axis coordinate ! if nx1=ny1 plot the pairs xval(1..nx1,jj) yval(1..ny1,jj) !---------------------- backslash=',\' ! empty line before the plot command write(21,*) ! here we should start from the value in graphopt%linett ii=0 kk=graphopt%linett-1 if(kk.ne.0) then write(*,*)'SMP2B: Ignoring manipulation of line colors' endif ! if graphopt%linestyle=0 use lines, otherwise linespoints ! this never worked ... ! if(graphopt%linestyle.eq.0) then linespoints='lines ls' piincrement=' ' if(graphopt%linewp.gt.1) then ! this should add a symbol at each calculated line but it does not work (yet) ! linespoints='lp lt ' linespoints='lp ls ' write(piincrement,'(" pi ",i3,1x)')graphopt%linewp-1 endif ! write(*,*)'smp2B linesplot increment 2: "',piincrement,'"',graphopt%linewp ! write(*,*)'SMP2B plotting lines: ',trim(linespoints),graphopt%linewp done=0 ! noofmono=0 ! Here we write all plot "-" using ... and subsequent "" using ... naptitle=0 xtieline=0 xmonovariant=0 kkloop: do kk=1,2 jjloop: do jj=1,same ii=ii+1 if(ii.eq.1) then if(lcolor(ii).eq.11) then ! this is monovariant! ! this is the first plot command, ii=1 so kk must be 1!! if(kk.eq.1) then write(21,306)monovariant,backslash 306 format('plot "-" using 1:2 with filledcurves ',& 'fc "#',a,'" notitle ',a) xmonovariant=jj ! write(*,*)'SMP monovariant 1: ',xmonovariant else ! this else branch is impossible, when ii=1 then kk=1 !!! but ... write(21,307)monovariant,trim(color(lcolor(ii))),backslash 307 format('plot "-" using 1:2 with filledcurves ',& 'fc "#',a,'" title "',a,'"',a) ! light green 'fc "#B0FFB0" title "',a,'"',a) ! very faint green 'fc "#F0FFF0" title "',a,'"',a) ! faint yellow 'fc "#EEFFCC" title "',a,'"',a) endif elseif(lcolor(ii).eq.12) then ! tie-line write(21,308)'lines',lcolor(ii),& trim(color(lcolor(ii))),backslash xtieline=jj ! write(*,*)'SMP xtieline 1: ',xtieline 308 format('plot "-" using 1:2 with ',a,' ls ',i2,' notitle ',a) else ! normal line with label ! SUDDENLY lcolor(ii) is not set null !! ! write(*,*)'SMP2B ocplot3B 1: ',ii,'"',linespoints,'"' ! write(*,*)'SMP2B ocplot3B 2: ',lcolor(ii),color(lcolor(ii)) write(21,309)trim(linespoints),lcolor(ii),& trim(piincrement),trim(color(lcolor(ii))),backslash endif naptitle=naptitle+1 apptitles(naptitle)=lcolor(ii) !309 format('plot "-" using 1:2 with ',a,' ls ',i2,' title "',a,'"',a) 309 format('plot "-" using 1:2 with ',a,1x,i2,1x,a,' title "',a,'"',a) done(lcolor(1))=1 else ! all lines except the first plotted here ! the last line for the plot command has no backslash --- except if append file if(ii.eq.2*same .and. appfil.eq.0) backslash=' ' ! we can only use linestyles 1 to 10 except for monovariants and tie-lines fcolor=lcolor(ii) if(fcolor.gt.12) then fcolor=mod(fcolor,10) if(fcolor.eq.0) fcolor=10 ! fixed Nath MoNiRe isotherm at 1500 K had some lines with no lcolor assignment! elseif(fcolor.le.0) then lcolor(ii)=1 fcolor=1 endif cone: if(done(lcolor(ii)).eq.1) then ! we have already a title for this line ... except tie-lines and monovariant if(lcolor(ii).eq.11) then if(kk.eq.1) then ! first time plotting an invariant use thick lines write(21,320)'lines ls',monovariantborder,' ',backslash ! save the index of the last monovariant to add title! xmonovariant=jj ! write(*,*)'SMP monovariant 2: ',xmonovariant else ! if kk=2 check if this is last monovariant, if so add title if(jj.eq.xmonovariant) then write(21,318)monovariant,trim(color(11)),backslash 318 format('"" using 1:2 with filledcurves ',& 'fc "#',a,'" title "',a,'" ',a) ! write(*,*)'SMP monovariant 5: ',xmonovariant,jj else write(21,319)monovariant,backslash 319 format('"" using 1:2 with filledcurves ',& 'fc "#',a,'" notitle ',a) endif endif elseif(lcolor(ii).eq.12) then ! tie-line, if kk==2 and xtieline==jj add label if(kk.eq.1) then write(21,320)'lines ls',fcolor,' ',backslash xtieline=jj ! write(*,*)'SMP xtieline 2: ',xtieline elseif(xtieline.ne.jj) then write(21,320)'lines ls',fcolor,' ',backslash else write(21,299)'lines',fcolor,trim(color(12)),backslash 299 format('"" using 1:2 with ',a,' ls ',i2,& ' title "',a,'" ',a) ! write(*,*)'SMP xtieline 5:',jj,xtieline endif else ! normal line with no title ! write(*,320)trim(linespoints),fcolor,backslash write(21,320)trim(linespoints),fcolor,& trim(piincrement),backslash endif !320 format('"" using 1:2 with ',a,' ls ',i2,' notitle ',a) 320 format('"" using 1:2 with ',a,1x,i2,1x,a,' notitle ',a) else ! we have a new line withou title if(fcolor.eq.11) then if(kk.eq.1) then ! first time plotting a monovariant use thick lines write(21,320)'lines ls',monovariantborder,' ',backslash xmonovariant=jj ! write(*,*)'SMP monovariant 3: ',xmonovariant else if(jj.eq.xmonovariant) then ! this is the last monovariant, add title write(21,321)monovariant,& trim(color(lcolor(ii))),backslash 321 format('"" using 1:2 with filledcurves ',& 'fc "#',a,'" title "',a,'"',a) ! write(*,*)'SMP monovariant 4: ',xmonovariant,jj else ! not the last monovariant, notitle write(21,325)monovariant,backslash 325 format('"" using 1:2 with filledcurves ',& 'fc "#',a,'" notitle ',a) endif endif elseif(fcolor.eq.12) then ! this is a tie-line without title if(kk.eq.1) then ! if kk=1 no not add title, just keep track of last tie-line write(21,320)'lines ls',fcolor,' ',backslash xtieline=jj ! write(*,*)'SMP xtieline 3: ',xtieline else ! if kk=2 add title if xtieline=jj if(jj.eq.xtieline) then write(21,331)'lines ls',fcolor,& trim(color(lcolor(ii))),backslash ! write(*,*)'SMP xtieline 4:',jj,xtieline else write(21,320)'lines ls',fcolor,' ',backslash endif endif else ! any normal line add title write(21,331)trim(linespoints),fcolor,& trim(piincrement),trim(color(lcolor(ii))),backslash endif naptitle=naptitle+1 apptitles(naptitle)=lcolor(ii) !331 format('"" using 1:2 with ',a,' ls ',i2,' title "',a,'"',a) 331 format('"" using 1:2 with ',a,1x,i2,1x,a,' title "',a,'"',a) done(lcolor(ii))=1 endif cone endif enddo jjloop enddo kkloop ! if we have an append file we must add the plotcommands in applines(1:nofapl) ! we made sure a few lines above that there is a backslash at last line above if(appfil.gt.0) then ! match the titles of all applines with those used above in lcolor ! and make sure the line with the same title has the same color ! note there is only one color for monovariants ... problem with lcolor ... ! call ocappfixlabels(nofapl,applines,same,color,lcolor,nnv) call ocappfixlabels(nofapl,applines,same,color,apptitles,nnv) ! replace the 'plot "-" ' by just '"" ' applines(1)='"" '//applines(1)(9:) ! write(*,*)'from append file',nofapl,trim(applines(1)) do ii=1,nofapl write(21,'(a)')trim(applines(ii)) enddo endif ! goto 500 ! we have to include the scaling factors graphopt%scalefact(1,2) xf=one; yf=one if(graphopt%scalefact(1).ne.one) xf=graphopt%scalefact(1) if(graphopt%scalefact(2).ne.one) yf=graphopt%scalefact(2) ! write(*,*)'SMP2B x/y factors: ',xf,yf ! loop for all line coordinates ! sumpp=0 do kk=1,2 ! again=sumpp foundinv=0 sumpp=0 do jj=1,same ! handle monovariants, just one point, just once ! the monovariants (not invariants) will be plotted twice ... if(sumpp+1.eq.lineends(jj)) then foundinv=foundinv+1 sumpp=sumpp+1 ! write(*,*)'Assumed to be an monovariant!',foundinv,kk write(21,600)jj,lcolor(jj) 600 format('# Line ',2i5,' representing a monovariant') write(21,549)xf*xval(1,sumpp),yf*yval(1,sumpp) write(21,549)xf*xval(2,sumpp),yf*yval(2,sumpp) write(21,549)xf*zval(1,foundinv),yf*zval(2,foundinv) write(21,549)xf*xval(1,sumpp),yf*yval(1,sumpp) ! we are at the end of a line, write a blank line write(21,548)jj,trim(phaseline(jj)) ! write(21,548)jj 548 format('e '//'# end of monovariant',i5,2x,a/) else ! this is the beginning of a line to be plotted if(lcolor(jj).eq.12) then write(21,605)jj,lcolor(jj) 605 format('# Line ',2i5,' representing tielines') else write(21,610)jj,lcolor(jj),trim(color(lcolor(jj))) 610 format('# Line ',2i5,' representing phase: ',a) endif do while(sumpp.lt.lineends(jj)) sumpp=sumpp+1 write(21,549)xf*xval(kk,sumpp),yf*yval(kk,sumpp) !549 format(2e15.6,4i7) 549 format(2(1pe16.6),4i7) ! plotkod -101 means tieline ! UNFINISHED: VALGRIND indicates plotkod(sumpp) is uninitiallized?? if(plotkod(sumpp).eq.-101) write(21,552) 552 format(1x) enddo ! we are at the end of a line, write a blank line write(21,551)jj,trim(phaseline(jj)) ! write(21,551)jj 551 format('e '//'# end of line',i5,2x,a/) endif enddo enddo !------------------------------------------------------------------------ ! finally copy the data from the append file, it should be correctly formatted if(appfil.gt.0) then ic=0 1900 continue read(appfil,884,end=1910)appline 884 format(a) ic=ic+1 if(appline(1:12).eq.'pause mouse ') then write(*,*)'reading appendfile ends at "puase mouse"' goto 1910 else write(21,884)trim(appline) goto 1900 endif 1910 continue write(*,*)'Appended ',ic,' data lines' close(appfil) appfil=0 endif !------------------------------------------------------ ! if(pform(1:1).eq.' ') then if(graphopt%gnutermsel.eq.1) then ! if not hardcopy pause gnuplot. Mouse means clicking in the graphics window ! will close it. I would like to have an option to spawn the graphics window... ! so it is kept while continuing the program. write(21,990)trim(graphopt%plotend) 990 format(a) !990 format('pause mouse') !990 format('e'//'pause mouse') else ! add pause mouse as comment write(21,991) 991 format('# pause mouse') endif close(21) if(appfil.ne.0) close(appfil) appfil=0 ! write(21,565) !565 format('e'//'pause mouse'/) ! close(21) ! ! gnuplotline='gnuplot ocgnu.plt ' gnuplotline='gnuplot '//trim(pfc)//' & ' ! if gnuplot cannot be started with gnuplot give normal path ... ! gnuplotline='"c:\program files\gnuplot\bin\wgnuplot.exe" '//pfc(1:kkk)//' ' k3=len_trim(gnuplotline)+1 write(*,*)'Gnuplot command line: ',trim(gnuplotline) ! if(pform(1:1).ne.' ') then if(graphopt%gnutermsel.ne.1) then write(*,*)'Graphics output file: ',trim(pfh) endif if(lines_excluded.gt.0) write(kou,11)lines_excluded 11 format('SMP Some calculated lines excluded from the plot',i5) ! plotonwin set by compiler option, 1 means windows if(plotonwin.eq.1) then if(btest(graphopt%status,GRKEEP)) then ! this is a TERNARY PLOT with 2 extensive axis ! write(*,*)'executing command '//trim(gnuplotline(9:)) ! call system(gnuplotline(9:)) write(*,*)'SMP2B executing Command: "start /B '//trim(gnuplotline)//'"' ! WORKS WITH OCPLOT3B call execute_command_line('start /B '//trim(gnuplotline)) ! sleep 500 miliseconds call usleep(us) else write(*,*)'SMP2B executing command '//trim(gnuplotline) call execute_command_line(gnuplotline) ! sleep 500 miliseconds call usleep(us) endif else ! plot on non-windows system ! how to implement GRKEEP? write(*,*)'SMP2B executing command '//trim(gnuplotline) call execute_command_line(gnuplotline) ! sleep 500 miliseconds call usleep(us) endif !900 continue 1000 continue return end subroutine ocplot3B !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine calc_diagram_point !\begin{verbatim} subroutine calc_diagram_point(axarr,pltax,xxx,xxy,line,ceq) ! calculates the equilibrium for axis coordinates xxx,xxy ! to obtain the set of stable phases ! axarr specifies calculation axis, ! pltax plot axis ! xxx and xxy are axis coordinates for calculating a point ! line is a character where the stable phases at the point is returned ! ceq is the current equilibrium, should be the default with axis conditions ! ONLY COORDINATES FOR CALCULATION AXIS ALLOWED implicit none type(map_axis), dimension(*) :: axarr double precision xxx,xxy character line*(*),pltax(*)*(*) TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer jax,nax,kk,jj,ic,k3 type(gtp_condition), pointer :: pcond type(gtp_state_variable), pointer :: svrrec double precision value character dummy*24 ! ! write(*,*)'Not implemented yet' ! goto 1000 ! ! We should check if plotaxis are the same as those used for calculation!!! ! x-axis dummy=' ' if(xxx.lt.axarr(1)%axmin .or. xxx.gt.axarr(1)%axmax) then write(*,11)'X value outside axis limits',xxx,& axarr(1)%axmin,axarr(1)%axmax 11 format(a,3(1pe14.5)) gx%bmperr=4399; goto 1000 endif call locate_condition(axarr(1)%seqz,pcond,ceq) if(gx%bmperr.ne.0) goto 1000 ! first argument 1 means to extract the value, 0 means to set the value call condition_value(0,pcond,xxx,ceq) if(gx%bmperr.ne.0) goto 1000 if(pcond%active.ne.0) then ! active=0 means condition is active pcond%active=0 ! we must indicate if T or P are now fixed ... ! if(pcond%statev.eq.1) then ! mapline%meqrec%tpindep(1)=.FALSE. ! elseif(pcond%statev.eq.2) then ! mapline%meqrec%tpindep(1)=.FALSE. ! endif endif ! y-axis if(xxy.lt.axarr(2)%axmin .or. xxy.gt.axarr(2)%axmax) then write(*,11)'Y value outside axis limits',xxy,& axarr(2)%axmin,axarr(2)%axmax gx%bmperr=4399; goto 1000 endif call locate_condition(axarr(2)%seqz,pcond,ceq) if(gx%bmperr.ne.0) goto 1000 call condition_value(0,pcond,xxy,ceq) if(gx%bmperr.ne.0) goto 1000 if(pcond%active.ne.0) then ! active=0 means condition is active pcond%active=0 ! we must indicate if T or P are now fixed ... ?? ! if(pcond%statev.eq.1) then ! mapline%meqrec%tpindep(1)=.FALSE. ! elseif(pcond%statev.eq.2) then ! mapline%meqrec%tpindep(1)=.FALSE. ! endif endif ! calculate the equilibrium without global minimization ! call list_conditions(kou,ceq) call calceq3(0,.FALSE.,ceq)! if(gx%bmperr.ne.0) then write(*,*)'Calculation failed' goto 1000 endif ! extract the names of the stable phases kk=1 do jj=1,noph() do ic=1,noofcs(jj) k3=test_phase_status(jj,ic,value,ceq) if(k3.gt.0) then ! this phase is stable or fix call get_phase_name(jj,ic,dummy) line(kk:)=dummy kk=len_trim(line)+2 ! write(*,*)'Stable phases ',trim(line) endif enddo enddo ! replace _ with - in phase names 100 continue kk=index(line,'_') if(kk.gt.0) then line(kk:kk)='-' goto 100 endif 1000 continue return end subroutine calc_diagram_point !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable logical function abbr_phname_same !\begin{verbatim} logical function abbr_phname_same(full,short) ! return TRUE if short is a correct abbreviation of full ! This is used in macro step4 to plot fractions in different composition sets implicit none character*(*) full,short !\end{verbatim} logical same integer k1,k2 character*1 ch1,ch2 ! write(*,*)'Comparing ',trim(full)//' : '//trim(short) same=.false. ! unequal if full has no # or different index after k1=index(short,'#') if(k1.gt.0) then k2=index(full,'#') if(k2.le.0) then ! full has no compset ! if short has #1 then the full phase without # should be accepted ! write(*,*)'full has no compset: ',short(k1+1:k1+1),k2 if(short(k1+1:k1+1).eq.'1') then same=.true. goto 1000 endif else ! the character after # must be the same if(short(k1+1:k1+1).eq.full(k2+1:k2+1)) then same=.true. goto 1000 endif endif endif ! if short is without # then all compsets match if(compare_abbrev(short,full)) then same=.true. endif 1000 continue ! write(*,*)'Comparing ',trim(short)//' with '//trim(full),' is ',same abbr_phname_same=same return end function abbr_phname_same !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine get_plot_conditions !\begin{verbatim} subroutine get_plot_conditions(text,ndx,axarr,ceq) ! extracts the conditions from ceq and replaces those that are axis variables implicit none character text*(*) integer ndx type(map_axis), dimension(*) :: axarr type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer jj,seqz,ip,jp,kp character symbol*24 type(gtp_condition), pointer :: pcond type(gtp_state_variable), pointer :: svrrec,svr2 logical ok1 ! ! get all conditions call get_all_conditions(text,-1,ceq) ! write(*,*)'PC1: ',trim(text),ndx replace: do jj=1,ndx ! replace the conditions that are X or Y axis seqz=axarr(jj)%seqz call locate_condition(seqz,pcond,ceq) if(gx%bmperr.ne.0) goto 1000 svrrec=>pcond%statvar(1) symbol=' ' ip=1 call encode_state_variable(symbol,ip,svrrec,ceq) if(gx%bmperr.ne.0) goto 1000 ! write(*,*)'SMP2B debug: "',trim(text),'" "',symbol(1:ip-1),'"' jp=index(trim(text),symbol(1:ip-1)) 77 continue ! strange bug because index does not find match with T as first condition if(jp.eq.0 .and. text(1:1).eq.symbol(1:1)) then jp=1 ! write(*,*)'SMP2B attempt to fix problem creates infinite loop?',jp endif if(jp.gt.0) then ! minor error here when conditons are N(A)+N(B)=1 and N(B)=axis. One should ! skip matches with N(A) or N(B), not preceeded by ' ' and followd by '=' ! write(*,*)'SMP2B: "',trim(text),'" ',jp ok1=.false. if(jp.eq.1) then ok1=.true. else ! fortran can test conditions in any order, ! if jp=1 one must not test text(jp-1:jp-1) if(jp.gt.1 .and. text(jp-1:jp-1).eq.' ') ok1=.true. endif if(ok1 .and. text(jp+ip-1:jp+ip-1).eq.'=') then seqz=jp+index(text(jp:),'=')-1 ip=jp+index(text(jp:),' ')-1 if(jj.eq.1) then text(seqz:)='=X, '//text(ip:) else text(seqz:)='=Y, '//text(ip:) endif else ! search the text following ! write(*,*)'PC2: "',text(jp-1:jp-1),'" "',& ! text(jp+ip-1:jp+ip-1),'"' kp=jp+1 jp=index(text(kp:),symbol(1:ip-1)) if(jp.gt.0) jp=kp+jp-1 goto 77 endif else write(*,*)'SMP2B Cannot find: "',symbol(1:ip-1),'" in ',trim(text) endif enddo replace ! if line too long (>200) divide in middle jj=len_trim(text) if(jj.gt.250) then ! text 1:ip ip=jj/3 call find_space_in_text(text,ip,10) text(ip+4:)=text(ip:) text(ip:ip+3)=' \n ' ! maybe some character get lost ... no one will notice ! text ip+4:2*ip+8 jp=2*ip+4 call find_space_in_text(text,jp,10) text(jp+4:)=text(jp:) text(jp:jp+3)=' \n ' ! write(*,*)'Dividing condition text 3 parts',ip,jp,jj elseif(jj.gt.100) then ! write(*,*)'Dividing condition text in the middle',jj jj=jj/2 call find_space_in_text(text,jj,10) text(jj+4:)=text(jj:) text(jj:jj+3)=' \n ' endif 1000 continue return end subroutine get_plot_conditions !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine find_space_in_text !\begin{verbatim} subroutine find_space_in_text(text,jp,maxc) ! moves jp max +/-maxc charactres to find a space (? or , or : or ) ! If none found do not change jp implicit none character text*(*) integer jp,maxc !\end{verbatim} integer ap ap=jp add: do ap=jp,jp+maxc if(text(ap:ap).eq.' ') goto 900 enddo add sub: do ap=jp-1,jp-maxc,-1 if(text(ap:ap).eq.' ') goto 900 enddo sub ! no space found ap=jp 900 continue ! write(*,*)'SMP2B: ',text(jp-maxc:jp+maxc),jp,ap jp=ap return end subroutine find_space_in_text !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable double precision function get_axis_phase_value !\begin{verbatim} double precision function get_axis_phase_value(phase,axis,axarr,ceq) ! extacts the condition for one axis and if is something like X(A) ! it changes to x(phase,A) and extracts and returns that value !! ! if it is a potential like T it just returns its value implicit none character phase*(*) integer axis type(map_axis), dimension(*) :: axarr type(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} integer seqz,ip character symbol*64,dummy*64 double precision value type(gtp_condition), pointer :: pcond type(gtp_state_variable), pointer :: svrrec,svr2 ! value=zero ! find the condition for axis "axis" seqz=axarr(axis)%seqz call locate_condition(seqz,pcond,ceq) if(gx%bmperr.ne.0) goto 1000 svrrec=>pcond%statvar(1) ! write(*,*)'Value of axis',axis,' for phase ',trim(phase),svrrec%statevarid if(svrrec%statevarid.le.9) then ! it is a potential, extract its current value symbol=' ' ip=1 call encode_state_variable(symbol,ip,svrrec,ceq) if(gx%bmperr.ne.0) goto 1000 call get_state_var_value(symbol,value,dummy,ceq) elseif(svrrec%argtyp.eq.1) then ! it is an extensive variable (%statevarid>=10) for a component such as X(A) ! A smarter way is to modify svrrec to insert phase/compset index ... ! edit the phase into the symbol symbol=' ' ip=1 call encode_state_variable(symbol,ip,svrrec,ceq) if(gx%bmperr.ne.0) goto 1000 ip=index(symbol,'(') dummy=symbol(ip+1:) symbol(ip+1:)=trim(phase)//',' ip=len_trim(symbol) symbol=symbol(1:ip)//dummy ! write(*,*)'SMP2B value of: ',trim(symbol) ! call get_stable_state_var_value(symbol,value,dummy,ceq) call get_state_var_value(symbol,value,dummy,ceq) if(gx%bmperr.ne.0) goto 1000 else write(*,*)'Illegal axis type: ',svrrec%statevarid,svrrec%argtyp gx%bmperr=4399 endif 1000 continue ! write(*,*)'SMP2B value of: ',trim(symbol),value get_axis_phase_value=value return end function get_axis_phase_value !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_stored_equilibria !\begin{verbatim} subroutine list_stored_equilibria(kou,axarr,maptop) ! list all nodes and lines from step/map ! use amed to exclude/include lines ! kou output unit ! axarr array with axis records ! maptop map node record integer kou type(map_node), pointer :: maptop type(map_axis), dimension(*) :: axarr !\end{verbatim} %+ type(map_ceqresults), pointer :: results type(map_node), pointer :: mapnode,localtop type(gtp_equilibrium_data), pointer :: thisceq type(gtp_condition), pointer :: pcond type(meq_setup), pointer :: lineeq integer kl,ll,jax,nax,jj,jk,phtupix double precision, dimension(:), allocatable :: axxx type(gtp_state_variable), pointer :: svrrec logical once character*100 phases ! if(.not.associated(maptop)) then write(kou,*)'No stored equilibria' goto 1000 endif if(associated(maptop%plotlink)) then write(*,*)'The plotlink is set !!! ' endif results=>maptop%saveceq if(.not.associated(results)) then write(kou,*)'No stored equilibria' goto 900 endif nax=maptop%number_ofaxis allocate(axxx(nax)) write(kou,90) 90 format('List of all stored equilibria') ! if there has been several STEP/MAP there can be several localtop localtop=>maptop ! ! return here if there has been several step/map commands 99 continue mapnode=>localtop ! list all mapnodes for this step/map command 100 continue ! mapnode=>localtop write(kou,101)mapnode%seqx,mapnode%nodeceq%tpval(1),mapnode%noofstph,& mapnode%savednodeceq,mapnode%lines ! mapnode%savednodeceq,mapnode%status,mapnode%lines 101 format(' Mapnode: ',i3,' at T=',F10.2,', ',i2,' phases, ceq saved ',& i5,', exting lines: ',i2) do kl=1,mapnode%lines if(.not.associated(mapnode%linehead(kl)%end)) then if(mapnode%linehead(kl)%termerr.gt.0) then write(kou,105)kl,mapnode%linehead(kl)%lineid,& mapnode%linehead(kl)%number_of_equilibria,& mapnode%linehead(kl)%termerr 105 format(' Line ',i3,', id: ',i3,' with ',i5,& ' equilibria ended with error: ',i6) else write(kou,110)kl,mapnode%linehead(kl)%lineid,& mapnode%linehead(kl)%number_of_equilibria 110 format(' Line ',i3,', id: ',i3,' with ',i5,& ' equilibria ending at axis limit') endif else ll=mapnode%linehead(kl)%end%seqx write(kou,120)kl,mapnode%linehead(kl)%lineid,& mapnode%linehead(kl)%number_of_equilibria,ll 120 format(' Line ',i3,', id: ',i3,' with ',i5,& ' equilibria ending at node ',i3) endif if(btest(mapnode%linehead(kl)%status,EXCLUDEDLINE)) then write(*,*)'Line excluded' cycle endif ll=mapnode%linehead(kl)%first ! write(*,*)'SMP2B allcrach 1: ',ll ! BOS 191224 add phase names ! tzero lines has no meqrec%phr allocated NOTE kl is K-EL not K-ETT ! for tzero lines it is listed line 3 and 4 although there are only 2 ???? if(ll.gt.0 .and. allocated(mapnode%linehead(kl)%meqrec%phr)) then ! only if there is an link to a linehead lineeq=>mapnode%linehead(kl)%meqrec phases=' ' jk=1 do jj=1,lineeq%nstph ! write(*,*)'SMP2B allcrach 2: ',jj,lineeq%stphl(jj),& ! lineeq%phr(lineeq%stphl(jj))%phtupix phtupix=lineeq%phr(lineeq%stphl(jj))%phtupix if(jk.lt.72) then call get_phasetup_name(phtupix,phases(jk:)) jk=len_trim(phases)+2 else phases(jk:)=' ... more' endif enddo write(*,*)'Phases: ',trim(phases) ! BOS 191224 end add phase names ! write(*,*)'list first equilibrium ',ll ! write(*,*)'axis: ',mapnode%number_ofaxis if(.not.allocated(results%savedceq)) then write(*,*)'Cannot find link to saved equilibria! ' else once=.true. write(kou,140) 140 format('Saved ceq link T X') ceqloop: do while(ll.gt.0) thisceq=>results%savedceq(ll) do jax=1,nax call locate_condition(axarr(jax)%seqz,pcond,thisceq) if(gx%bmperr.ne.0) goto 300 svrrec=>pcond%statvar(1) call state_variable_val(svrrec,axxx(jax),thisceq) if(gx%bmperr.ne.0)then if(once) then write(*,*)' *** Error ',gx%bmperr,& ' reset, data may be missing' once=.false. endif gx%bmperr=0 endif enddo write(kou,150)ll,thisceq%nexteq,thisceq%tpval(1),axxx 150 format(2i9,f9.2,5(1pe13.5)) ll=thisceq%nexteq enddo ceqloop endif endif 300 continue if(gx%bmperr.ne.0) then write(*,*)' *** Error ',gx%bmperr,' reset, data maybe missing' gx%bmperr=0 endif enddo ! write(kou,160)mapnode%seqx,mapnode%previous%seqx 160 format('Current node: ',i2,' followed by: ',i2) mapnode=>mapnode%previous ! localtop=>localtop%previous if(.not.associated(mapnode,localtop)) goto 100 ! plotlink needed if there has been several step/map commands 900 continue if(associated(localtop%plotlink)) then write(lut,910) 910 format(/'Results from a previous step/map command,',& ' equilibrium numbers will overlap') localtop=>localtop%plotlink write(*,*)'Setting result link' results=>localtop%saveceq if(.not.associated(results)) then write(kou,*)'No stored equilibria' goto 900 endif goto 99 endif ! write(kou,*)'That is all' 1000 continue return end subroutine list_stored_equilibria !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine amend_stored_equilibria !\begin{verbatim} %- subroutine amend_stored_equilibria(axarr,maptop) ! allows amending inactive/acive status of all lines from step/map type(map_node), pointer :: maptop type(map_axis), dimension(*) :: axarr !\end{verbatim} character cline*12,status*8,ch1*1,phline*78 type(map_ceqresults), pointer :: results type(map_node), pointer :: mapnode,localtop,testnode type(gtp_equilibrium_data), pointer :: thisceq type(gtp_condition), pointer :: pcond integer kl,ll,jax,last,nax double precision, dimension(:), allocatable :: axxx type(gtp_state_variable), pointer :: svrrec logical all ! if(.not.associated(maptop)) then write(kou,*)'No stored equilibria' goto 1000 endif if(associated(maptop%plotlink)) then write(*,*)'There is more than one maptop record' endif localtop=>maptop ! if(associated(localtop,maptop)) write(*,*)'maptop same as localtop' nax=localtop%number_ofaxis allocate(axxx(nax)) write(kou,90) nullify(results) 90 format('Amend all stored equilibria ... from several maptops') ! ! return here if %plotlink is not empty ! each plotlink has its own results link to saveceq 99 continue last=len(cline) call gparcdx('Only excluded? ',cline,last,1,ch1,'Y','?PLOT options') if(ch1.eq.'Y' .or. ch1.eq.'y') then all=.FALSE. else all=.TRUE. endif ! there can be lines associated with several maptops ! but I have trouble finding them. They should be linked by plotlink mapnode=>localtop results=>mapnode%saveceq 100 continue ! mapnode=>maptop if(associated(localtop,mapnode)) write(*,*)'mapnode same as localtop' if(.not.associated(results)) then write(kou,*)'No stored equilibria' goto 900 endif status=' ' write(kou,102)mapnode%seqx,mapnode%nodeceq%tpval(1),& mapnode%noofstph,mapnode%savednodeceq 102 format(' Mapnode: ',i5,' at T=',F10.2,' with ',i2,& ' stable phases, ceq saved in ',i5) write(*,*)'Number of exit lines: ',mapnode%lines lineloop: do kl=1,mapnode%lines if(mapnode%linehead(kl)%number_of_equilibria.eq.0) then write(*,*)'Skipping empty line >>>' cycle lineloop endif if(btest(mapnode%linehead(kl)%status,EXCLUDEDLINE)) then status='EXCLUDED' else status='INCLUDED' endif call line_with_phases_withdgm0(phline,mapnode%linehead(kl)%lineceq) if(gx%bmperr.ne.0) then phline='Sorry cannot list stable phases' gx%bmperr=0 endif if(.not.associated(mapnode%linehead(kl)%end)) then if(mapnode%linehead(kl)%termerr.gt.0) then write(kou,105)kl,mapnode%linehead(kl)%lineid,& mapnode%linehead(kl)%number_of_equilibria,& mapnode%linehead(kl)%termerr,status,trim(phline) 105 format(' Line ',i3,', id: ',i3,' with ',i5,& ' equilibria ended with error: ',i6,2x,a/' with phases: ',a) else write(kou,110)kl,mapnode%linehead(kl)%lineid,& mapnode%linehead(kl)%number_of_equilibria,status,trim(phline) 110 format(' Line ',i3,', id: ',i3,' with ',i5,& ' equilibria ending at axis limit.',2x,a/' with phases: ',a) endif else ll=mapnode%linehead(kl)%end%seqx write(kou,120)kl,mapnode%linehead(kl)%lineid,& mapnode%linehead(kl)%number_of_equilibria,ll,status,trim(phline) 120 format(' Line ',i3,', id: ',i3,' with ',& i5,' equilibria ending at node ',i3,2x,a/' with phases: ',a) endif ll=mapnode%linehead(kl)%first ! if deleted ask for Restore, else ask for Keep or Delete last=len(cline) if(btest(mapnode%linehead(kl)%status,EXCLUDEDLINE)) then call gparcdx(' *** Include this line? ',cline,last,1,ch1,'N',& '?PLOT options') elseif(all) then call gparcdx('Exclude this line? ',cline,last,1,ch1,'N',& '?PLOT options') else cycle lineloop endif if(biglet(ch1).eq.'Y') then if(btest(mapnode%linehead(kl)%status,EXCLUDEDLINE)) then mapnode%linehead(kl)%status=& ibclr(mapnode%linehead(kl)%status,EXCLUDEDLINE) write(kou,*)'Line activated' else mapnode%linehead(kl)%status=& ibset(mapnode%linehead(kl)%status,EXCLUDEDLINE) write(kou,*)'Line inactivated' endif elseif(biglet(ch1).eq.'Q') then goto 1000 endif enddo lineloop mapnode=>mapnode%previous if(.not.associated(mapnode,localtop)) then goto 100 endif 900 continue ! plotlink needed if there has been several step/map commands if(associated(localtop%plotlink)) then write(lut,910) 910 format(/'Results from a previous step/map command,',& ' equilibrium numbers will overlap') localtop=>localtop%plotlink goto 99 endif write(kou,*)'That is all' 1000 continue return end subroutine amend_stored_equilibria !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine list_csv_table !\begin{verbatim} % subroutine list_csv(np,nrv,nlinesep,linesep,pltax,xax,anpax,anpdim,anp,lid,& phaseline,title,filename,version,encoded1) ! list results from a STEP as an CSV (Comma Separated Values) table ! called from ocplot2 when all values extraced ! np number of regions ! nrv total number of lines with calculated values ! nlinesep number of lines for each region ! linesep(j..nlinesep) is index of last line for region j ! pltax are heading of table columns, each region separate headings ! xax values on single value axis ! anpax not used ! anpdim first dimension of anp ! anp values of axis with (possibly) multiple values ! lid column headings for each region ? ! phaseline ?? ! title of plot ! filename output file ! graphopt record ! version of OC ! encoded1 all conditions ! ! use ov integer np,nrv,nlinesep,anpax,anpdim integer linesep(*) character filename*(*),title*(*),version*(*),encoded1*(*) character pltax(*)*(*),phaseline(*)*(*),lid(*)*(*) double precision xax(*),anp(anpdim,*) ! not needed? ! character lid(*)*(*) !\end{verbatim} integer jj,kk ! ! write(*,'(a,10i5)')'SMP2B: in list_csv',np,nrv,nlinesep,anpax,anpdim ! write(*,'(a,a,a,i3,1pe12.4)')'SMP2B: plotfile: "',trim(filename),'"',& ! len_trim(filename),rnone write(*,*)'SMP2B writing csv file: ',trim(filename) if(filename(1:1).ne.' ') then open(22,file=filename,access='sequential',status='unknown',err=1100) lut=22 else lut=kou endif ! header if(np.eq.1) then write(lut,100)trim(pltax(1)),trim(lid(np)) elseif(np.le.100) then write(lut,101,advance='no')trim(pltax(1)),(trim(lid(jj)),jj=1,np-1) write(lut,102)trim(lid(np)) else write(*,*)'Cannot tablulate when more than 100 variables ...' endif 100 format('"',a,'", "',a,'"') 101 format('"',a,'"',100(',"',a,'"')) 102 format(a,'"') ! loop for lines do jj=1,nrv write(lut,200,advance='no')xax(jj) 200 format(1PE13.5) 201 format(',',1PE13.5) 202 format(',') ! loop for columns except first and last value do kk=1,np-1 if(anp(kk,jj).ne.rnone) then write(lut,201,advance='no')anp(kk,jj) else write(lut,202,advance='no') endif enddo if(anp(np,jj).ne.rnone) then write(lut,201)anp(np,jj) else write(lut,202) endif enddo if(lut.ne.kou) close(lut) 1000 continue return ! failed open output file 1100 continue write(*,*)'Cannot open file: ',trim(filename) goto 1000 end subroutine list_csv !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine ocappfixlabels !\begin{verbatim} subroutine ocappfixlabels(nofapl,applines,same,color,appcol,nnv) ! check if there are the same labels in applines. They are normally phase ! names and should be the same !! use the same color for the same phase!! ! if we find a title matching we must change all lines with the same ls x ! to the value of x in the new file !! ! nofapl: number of lines to plot in appfile ! applines: the plot command lines from appfile ! same: number of lines to plot in the current calculation ! color: the titles in the current calculation ! appcol: the linestyle for color in the current calculation ! clast: the last used linestyle in the current calculation implicit none integer nofapl,same,nnv character*(*) applines(nofapl),color(*) integer appcol(*) !\end{verbatim} integer i1,j1,k1,nols,ip,jp,found,oldls,newls integer, parameter :: mofapl=100 integer nyttls(nofapl) character endofline*(2),title*24 integer changels(2,nofapl) ! the line label is color(lcolor(jj)) ... suck. Use the index of color as nyls ! write(*,*)'ocappfixlabels: ',nofapl,same,nnv ! do j1=1,same ! if(color(j1)(1:1).ne.' ') write(*,'(i3,2x,a,i4)')j1,trim(color(j1)),& ! appcol(j1) ! enddo ! do i1=1,nofapl ! write(*,'(i3,2x,a)')i1,trim(applines(i1)) ! enddo ! we have to check if there are new phases in the appfile. They should ! be given color/labels that start from nnv ! unique for the appfile. They should be given colors nnv and higher! ! ! still problem for CHI with the bef-500-gibbs testfile ! ! The applines look like: ! "" using 1:2 with filledcurves fc "#EEFFCC" title "monovariant",\ ! "" using 1:2 with lines ls 4 title "BCC-A2",\ ! "" using 1:2 with lines ls 12 title "tie-line",\ ! "" using 1:2 with lines ls 4 notitle ,\ ! each title (in color) is associated with a ls value (in lcolor) ! if we find a matching title in applines change the ls value to lcolor ! for all lines with the ls value ! for titles in applines with no title in color use last free ls endofline=',\' found=0 newls=nnv loop1: do j1=1,nofapl if(j1.eq.nofapl) endofline=' ' ! check if the line has a title ip=index(applines(j1),' title ') if(ip.gt.0) then ! write(*,*)' *** Found title: ',trim(applines(j1)),j1 title=applines(j1)(ip+8:) jp=index(title,'"') if(jp.eq.0) then write(*,*)'Missing ": ',trim(applines(j1)),j1 stop else title(jp:)=' ' endif if(trim(title).eq.'tie-line' .or.& trim(title).eq.'monovariant') then ! titles "tie-line" and "monovariant" are just replaced by notitle applines(j1)(ip:)=' notitle'//endofline ! write(*,*)'removed tie/mono: ',trim(applines(j1)),j1 cycle loop1 endif ! compare with color(1..same) ! write(*,*)'Comparing with old labels' loop2: do i1=1,same if(color(i1)(1:1).eq.' ') cycle loop2 if(trim(color(i1)).eq.trim(title)) then ! we have found the applines title in current labels ! write(*,*)'Found title: ',trim(title) applines(j1)(ip:)=' notitle'//endofline ! write(*,*)'removed: ',trim(applines(j1)),j1 ! we must also save the value after ' line ls ' to change other lines ! "" using 1:2 with lines ls 4 title "BCC-A2",\ ip=index(applines(j1),' lines ls ') if(ip.gt.0) then jp=ip+9 ip=ip+10 call getint(applines(j1),jp,oldls) if(buperr.ne.0) then write(*,*)'No ls number: ',trim(applines(j1)) stop endif found=found+1 changels(1,found)=oldls changels(2,found)=i1 write(applines(j1)(ip:ip+1),'(i2)')i1 ! write(*,69)'Changing ls: ',trim(applines(j1)),oldls,i1,found 69 format(a,a,5i4) else write(*,*)'missing "lines ls" in: ',trim(applines(j1)) stop endif cycle loop1 endif ! write(*,*)'No match: ',trim(title),' ',trim(color(i1)),i1,same enddo loop2 ! if we come here we have a new title in the appfiles, ! that should be assigned newls ip=index(applines(j1),' lines ls ')+10 if(ip.le.0) then write(*,*)'Old color in appfile: ',trim(applines(j1)) stop else ! reuse the same color for something else ! changing like this created problems below ... try reuse old color ! write(applines(j1)(ip:ip+1),'(i2)')same+1 applines(j1)(ip:ip+1)='01' write(*,*)'New color in appfile: ',trim(applines(j1)) endif else ! this is a line without title but we may have to change number after "line ls" ip=index(applines(j1),' lines ls ') if(ip.gt.0) then ! write(*,'(a,10(i4,i3))')'changels: ',& ! (changels(1,k1),changels(2,k1),k1=1,found) jp=ip+9 ip=ip+10 call getint(applines(j1),jp,oldls) if(buperr.ne.0) then write(*,*)'Cannot find ls number: ',trim(applines(j1)),found stop endif ! write(*,*)'Found ls number: ',oldls ! ignore 11 and 12 as they are tie-lines or monovariant if(oldls.eq.11 .or. oldls.eq.12) cycle loop1 ! seach for replacement getls: do k1=1,found ! if(changels(1,k1).ne.oldls) cycle getls if(changels(1,k1).eq.oldls) goto 100 enddo getls ! if k1>found then we have not found oldls if(k1.gt.found) then write(*,79)'Cannot find old ls: ',oldls,k1,found,j1,& trim(applines(j1)) 79 format(a,4i3,' in ',a) write(*,'(10(i2,i3))')(changels(1,k1),changels(2,k1),k1=1,found) ! replace colow with 01 ip=index(applines(j1),' lines ls ') applines(j1)(ip+10:ip+11)='01' ! stop endif ! write the new ls number in applines(j1) 100 continue ! write(applines(j1)(ip:ip+1),'(i2)')changels(2,k1) ! line above must be wrong, changed to that below 2021.03.08/BoS, then removed ! write(applines(j1)(ip+10:ip+11),'(i2)')changels(2,k1) ! write(*,*)'Changed ls: ',trim(applines(j1)) ! else ! write(*,*)'skipping: ',trim(applines(j1)) endif endif enddo loop1 ! write(*,*)'New applines' ! do j1=1,nofapl ! write(*,*)j1,trim(applines(j1)) ! enddo 1000 continue return end subroutine ocappfixlabels !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine stvarix !\begin{verbatim} subroutine stvarix(statevar,phaseline,encoded,nix,ixpos) ! extract the indices of corresponding wildcard state variables ! For example X(*,O) replace "*" with phase names in phline ! and search which index correspond to X(C1_MO2#2,O) in encoded ... suck ! statevar: with ONE wildcard (for a phase) ! phaseline: phase names separated by a space ! encoded: state variables returned by get_many(...) separated by a space ! nix: number of state variables in encoded ! ixpos: integer array with corresponding index for values ! NOTE is there is a # in the statevar then ALL values should be included implicit none integer nix,ixpos(*) character*(*) statevar, phaseline, encoded !\end{verbatim} character sstring*48,phase*32,prefix*24,suffix*24,cha*1 integer ip,jp,kp,lp,pix,vix ! write(*,*)'stvarix: ',trim(statevar) ! write(*,*)'phases: "',trim(phaseline),'"' ! write(*,*)'encoded: "',trim(encoded),'"' ! initiate ipos to zero ! write(*,8)1,trim(statevar),len_trim(encoded),trim(encoded) !8 format('smp2B: ',i1,' searching for "',a,'" in encoded with length ',i5/a/) ! ixpos(1:nix)=0 ip=index(statevar,'*') ! if no wildcard skip if(ip.le.0) goto 1000 ! debug check search string: ! write(*,8)2,trim(statevar),len_trim(encoded),trim(encoded) prefix=statevar(1:ip-1) suffix=statevar(ip+1:) ! ip=1 jp=index(phaseline,' ') outside: do while(jp.gt.ip) ! create search string with phase name replacing wildcard sstring=trim(prefix)//phaseline(ip:jp-1)//trim(suffix) ! write(*,*)'Seach for: "',trim(sstring),'"',jp pix=0 kp=1 lp=index(encoded,' ') ! write(*,*)'encoded item: ',trim(encoded(kp:lp-1)),kp,lp-1 inside: do while(lp.gt.kp) pix=pix+1 ! write(*,*)'Same? ',trim(sstring),' and ',trim(encoded(kp:lp-1)),pix ! read(*,10)cha 10 format(a) if(trim(sstring).eq.trim(encoded(kp:lp-1))) then ! vix=vix+1 ! it seems simpler to indicate for each possible value that it is relevent ixpos(pix)=1 ! than to return an array with the relevant values ... ! ixpos(vix)=pix ! write(*,*)'Found: ',trim(sstring),vix,ixpos(vix) ! select next phase name ip=jp+1 jp=jp+index(phaseline(jp+1:),' ') cycle outside endif ! compare with next item in encoded kp=lp+1 lp=lp+index(encoded(lp+1:),' ') ! write(*,*)'Next encoded item: ',trim(encoded(kp:lp-1)),kp,lp-1 ! read(*,10)cha enddo inside write(*,*)'SMP2B: Cannot find: ',trim(sstring) gx%bmperr=4399; goto 1000 enddo outside ! write(*,70)nix,(ixpos(vix),vix=1,nix) 70 format('SMP nix: ',i3,30i2) ! write(*,*)'vix mm: ',vix,(ixpos(vix),vix=1,nix) 1000 continue return end subroutine stvarix !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine hashtag_susphix !\begin{verbatim} subroutine hashtag_susphix(statevar,phaseline,encoded,nix,ixpos,ceq) ! replace # with non-suspended phase names in DGM(#) ! statevar: DGM(#) wildcard (for a phase) ! phaseline: phase names separated by a space ! encoded: state variables returned by get_many(...) separated by a space ! nix: number of state variables in encoded ! ixpos: integer array with corresponding index for values implicit none integer nix,ixpos(*) character*(*) statevar, phaseline, encoded TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} character sstring*48,phase*32,prefix*24,suffix*24,cha*1 integer ip,jp,kp,lp,pix,lpre,lenc,iph,ics double precision amfu ! write(*,*)'SMP2B hastag_suspix: ',trim(statevar),nix ! write(*,*)'phases: "',trim(phaseline),'"' ! write(*,*)'encoded: "',trim(encoded),'"' ! initiate ipos to zero ! write(*,8)1,trim(statevar),len_trim(encoded),trim(encoded) !8 format('smp2B: ',i1,' searching for "',a,'" in encoded with length ',i5/a/) ! lenc=len_trim(encoded) ! write(*,*)'SMP2B in hashtag_susphix: ',trim(statevar) ! write(*,'(a,a)')'SMP2B phaseline: ',trim(phaseline) ! write(*,'(a,a)')'SMP2B encoded: ',lenc ! ixpos(1:nix)=0 ip=index(statevar,'#') ! if no hashtag skip if(ip.le.0) goto 1000 ! if hashtag not followed ) or , it indicate a composition set, skip if(.not.(statevar(ip+1:ip+1).eq.')' .or. statevar(ip+1:ip+1).eq.',')) & goto 1000 ! debug check search string: ! write(*,8)2,trim(statevar),len_trim(encoded),trim(encoded) prefix=statevar(1:ip-1) lpre=len_trim(prefix) ! write(*,*)'SMP2B hastag1: "',prefix(1:lpre),'"',len(encoded) ! ip=1 pix=0 ixpos(1:nix)=0 ! we can ignore phaseline and we skip all phases in encoded that are suspended do while(ip.lt.lenc) jp=index(encoded(ip:),prefix(1:lpre)) kp=index(encoded(ip:),' ') phase=encoded(ip+jp+lpre-1:ip+kp-3) ! write(*,'(a,a,a,3i5)')'SMP2B hashtag 2: "',trim(phase),'"',ip,jp,kp ! update ip for next phase ip=ip+kp ! write(*,*)'SMP2B rest: ',trim(encoded(ip:)) ! find phase number/set ! call find_phase_by_name_exact(phase,iph,ics) call find_phase_by_name(phase,iph,ics) if(gx%bmperr.ne.0) then write(*,*)'SMP2B hashtag found nonexisting phase name: ',phase endif pix=pix+1 if(test_phase_status(iph,ics,amfu,ceq).ge.PHDORM) then ! this phase is not suspended, it should be included ! it seems simpler to indicate for each possible value that it is relevent ixpos(pix)=1 ! than to return an array with the relevant values ... ! write(*,*)'not suspended: ',trim(phase),pix,ixpos(pix) ! else ! write(*,*)'suspended: ',trim(phase) endif enddo 1000 continue return end subroutine hashtag_susphix !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine replace_UWH !\begin{verbatim} subroutine replace_uwh(text) ! replaces underscore by a hyphen for texts used in GNUPLOT ! replaces ampersand, &, by @ implicit none character*(*) text !\end{verbatim} integer jj ! replace _ by - in lid jj=-1 do while(jj.ne.0) ! replace _ by - in lid because _ is interpreted as subscript (as LaTeX) if(jj.gt.0) text(jj:jj)='-' jj=index(text,'_') enddo jj=-1 do while(jj.ne.0) ! replace & by z in lid because & is treated strangely by GNUPLOT if(jj.gt.0) text(jj:jj)='%' jj=index(text,'&') enddo ! write(*,*)'SMP2B text without "_": ',trim(text) return end subroutine replace_uwh !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ ================================================ FILE: src/userif/pmon6.F90 ================================================ ! MODULE cmon1oc ! ! Copyright 2012-2025, Bo Sundman, France ! ! This program is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 2 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this program; if not, write to the Free Software ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! Contact persion: Bo.Sundman@gmail.com ! !------------------------------------------------------------------ ! !***************************** ! command line monitor for OC !***************************** ! use ocsmp use liboceqplus ! ! parallel processing, set in gtp3.F90 !$ use omp_lib ! implicit none ! ! option record TYPE ocoptions ! unit for listing, default is kou (screen) integer lut end TYPE ocoptions type(ocoptions) :: optionsset ! contains ! subroutine oc_command_monitor(version,linkdate,narg,argline) ! command monitor implicit none ! ! linkdat is date when program was linked ! argline and narg are inline arguments character linkdate*(*),version*(*),argline(*)*(*) integer narg ! various symbols and texts, version 6 character :: ocprompt*8='--->OC6:' character name1*24,name2*24,name3*24,dummy*24,line*80,model*72,chshort*1 integer, parameter :: ocmonversion=75 ! for the on-line help, at present turn off by default, if a HTML file set TRUE character*128 browser,latexfile,htmlfile,unformfile,xtdbdef logical :: htmlhelp=.FALSE. ! logical :: htmlhelp=.TRUE. ! element symbol and array of element symbols for database use character elsym*2,ellist(maxel)*2,elbase(maxel)*2,parael*2 ! more texts for various purposes character text*72,string*256,ch1*1,chz*1,selection*27,funstring*1024 character axplot(2)*24,axplotdef(2)*24,quest*20 ! character longstring*2048,optres*40 character longstring*5000,optres*40 ! measure calculate carefully double precision finish2,start2 integer endoftime,startoftime ! separate file names for remembering and providing a default character ocmfile*128,ocufile*128,tdbfile*128,xtdbfile*128 character ocdfile*128,filename*128 character zext*8,mqmqass*60 ! home for OC and default directory for databases ! character ochome*64,ocbase*64, change suggested by Chunhui character ochome*128,ocbase*128 ! prefix and suffix for composition sets character prefix*4,suffix*4 ! element mass double precision mass ! constituent fractions of a phase double precision, dimension(maxconst) :: yarr ! stoichiometry of a specis and sublattice sites of a phase double precision, dimension(maxsubl) :: stoik ! calculated vaules of a function (G, G.T, G.P, G.T.T; G.T.P and G.P.P) double precision val(6) ! estimated chemical potentials after a grid minimization and TP for ref states double precision cmu(maxel),tpa(2) ! the beginning of a sequential list of all ternary methods ! cpu time measurements double precision ending,starting !>>>> has to be reorganized ------------------------------------ ! axis variables and limits ! default values used for axis variables double precision dinc,dmin,dmax ! graphics record for plot ranges, texts and defaults type(graphics_options) :: graphopt integer grunit ! species for ternary extrapolation method character xspecies(3)*24,tkmode*6 ! path to start directory declared inside metlib!! ! character macropath*128 ! plot texts ! type(graphics_textlabel), allocatable, target :: textlabel type(graphics_textlabel), pointer :: textlabel type(graphics_textlabel), pointer :: labelp ! axis data structures type(map_axis), dimension(5) :: axarr ! if more than one start equilibrium these are linked using the ceq%next index ! type(gtp_equilibrium_data), pointer :: starteq ! type(starteq_lista), dimension(20) :: starteqs ! for map results type(map_node), pointer :: maptop,mapnode,maptopsave,maptopcheck ! type(map_line) :: mapline ! seqxyz has initial values of seqx, seqy and seqz ! integer noofaxis,noofstarteq,seqxyz(3) integer noofaxis,seqxyz(3) ! csv file converion integer ioc,ip ! this should be removed ! TYPE(ssm_node), pointer :: resultlist ! for paraequilibrium meqrec is needed also here TYPE(meq_setup), pointer :: meqrec TYPE(meq_setup), allocatable, target :: meqrec1 !<<<<<<<-------------------------------------------------------------- ! used for element data and R*T double precision h298,s298,rgast ! temporary reals double precision xxx,xxy,xxz,totam,cpham,xpara(2),gms ! input data for grid minimizer double precision, dimension(maxel) :: xknown,aphl ! arrays for grid minimization results integer, dimension(maxel) :: iphl,icsl,nyphl ! selected kommand and subcommands integer kom,kom2,kom3,kom4 ! selected output mode for results and the default, list output unit lut integer listresopt,lrodef,lut,afo ! integers used for elements, phases, composition sets, equilibria, defaults integer iel,iph,ics,ieq,idef,iph2,tupix(2),icond ! for gradients in MU and interdiffusivities integer nend ! for mqmqanend, a negative value needed att first call to mqmqa_species ! it is declared in gt3_dd2.F90 ! integer :: mqmqanend=-100 ! dimension of mugrad for 16x16 matrix !CCI double precision, allocatable, dimension(:) :: mugrad,mobilities double precision, allocatable, dimension(:) :: nsites integer, allocatable, dimension(:) :: nkl integer nsub !CCI !------------------- ! selection of minimizer and optimizer integer minimizer,optimizer ! plot unit for experimental data used in enter many_equilibria integer :: plotdataunit(9)=0,plotunit0=0 ! temporary integer variables in loops etc integer i1,i2,j4,j5,j2,iax,threads,modelx,jquad ! more temporary integers integer jp,kl,svss,language,last,leak,j3,tzcond,eetcond ! and more temporary integers integer ll,lokcs,lokph,lokres,loksp,lrot,maxax ! and more temporary integers integer mode,ndl,neqdef,noelx,nofc,nopl,nops,nv,nystat,times,fromeq ! temporary matrix ! double precision latpos(3,3) ! used to call init_gtp for the NEW command integer intv(10) double precision dblv(10) ! debugging mqmqma_data%const lines ... lines 5236 ff integer ik,ij,kp,s1,thiscon ! ceq%phase_varres(lokcs)%mqmqaf%compvar(j4)%vk_ij, ! type(gtp_mqmqa_var), pointer :: mqmqavar type(gtp_phase_varres), pointer :: mqmqavar !------------------- ! variables for lmdif ! integer, parameter :: lwam=2500 integer :: lwam=2500,nfev integer :: nopt1=100, mexp=0,nvcoeff=0,nopt,iflag,mexpdone=0,nvcoeffdone=0 integer, allocatable, dimension(:) :: iwam double precision, allocatable, dimension(:) :: wam ! tccovar is the covariance matrix used to calculate RSD as in Thermo-Calc double precision, allocatable, dimension(:,:) :: fjac,cov1,cormat,tccovar double precision :: optacc=1.0D-3 logical :: updatemexp=.true. ! saved parameters for analyze double precision, allocatable, dimension(:,:) :: savedcoeff double precision savesumerr,delta integer analyze,cormatix,nvcoeffsave,mexpsave,iz,jz,ztyp ! this is least square error from using LMDIF ! 1: previous value, 2 new value, 3 normalized error (divided by m-n) double precision err0(3) ! occational segmentation fault when deallocating www .... ! double precision, dimension(maxw) :: www ! double precision, dimension(:), allocatable :: www double precision, dimension(:), allocatable :: errs double precision, dimension(:), allocatable :: coefs ! external new_assessment_calfun ! external calfun !------------------- ! loop variable when entering constituents of a phase integer icon,flc ! array with constituents in sublattices when entering a phase ! only used for interactive entering the mqmqa_constituent character, dimension(25) :: const*24 ! This is for species in the mqmqa model which may contain commas "," character mqmqacon*24 ! mqmqa quadbonds double precision quadbonds(4) ! for macro and logfile and repeating questions logical logok,stop_on_error,once,wildcard,twice,startupmacro,temporary logical listzero,maptopbug ! default plot axis for some STEP command: ! 1 for SEPARATE, 2 SCHEIL, 3 TZERO, 4 PARAEQUIL, 5 LIQUID_EET logical stepspecial(5) ! fast elements for Scheil, max 3 character*2 fast(3) ! unit for logfile input, 0 means no logfile integer logfil ! remember default for calculate phase integer defcp ! for state variables as conditions integer istv double precision coeffs(10),textfontscale TYPE(gtp_state_variable), target :: stvrvar TYPE(gtp_state_variable), pointer :: stvr ! TYPE(gtp_state_variable), dimension(10) :: stvarr TYPE(gtp_condition), pointer :: pcond,firstc ! current equilibrium records TYPE(gtp_equilibrium_data), pointer :: ceq,neweq TYPE(gtp_phase_varres), pointer :: parres ! addition record used for listing calculated values type(gtp_phase_add), pointer :: addrec ! character actual_arg(2)*16 ! character cline*128,option*80,aline*128,plotfile*256,eqname*24 character cline*256,option*80,aline*128,plotfile*256,eqname*24,aux*4 ! variable phase tuple type(gtp_phasetuple), pointer :: phtup ! MQMQA asymmetry ! character*3 new_asymmetry integer asymter,new_toop !CCI integer :: indexPrecond, indexSplitsolver, typeOfChange !CCI !---------------------------------------------------------------- ! here are all commands and subcommands ! character (len=64), dimension(6) :: oplist integer, parameter :: ncbas=30,nclist=27,ncalc=18,ncent=21,ncread=9 integer, parameter :: ncam1=18,ncset=27,ncadv=18,ncstat=6,ncdebug=12 integer, parameter :: nselect=6,nlform=6,noptopt=9,mqmqacc=6,nsetbit=6 integer, parameter :: ncamph=18,naddph=12,nclph=6,nccph=6,nrej=9,nsetph=6 integer, parameter :: nsetphbits=15,ncsave=6,nplt=15,nstepop=9 integer, parameter :: nplt2=18 integer, parameter :: ninf=15 ! basic commands character (len=16), dimension(ncbas), parameter :: cbas=& ['AMEND ','CALCULATE ','SET ',& 'ENTER ','EXIT ','LIST ',& 'QUIT ','READ ','SAVE ',& 'HELP ','INFORMATION ','BACK ',& 'NEW ','MACRO ','ABOUT ',& 'DEBUG ','SELECT ','DELETE ',& 'STEP ','MAP ','PLOT ',& 'HPCALC ','FIN ','OPTIMIZE ',& 'SHOW ',' ',' ',& ' ',' ',' '] ! in French ! 'MODIFIEZ ','CALCULEZ ','REGLEZ ',& ! 'ENTREZ ','EXIT ','AFFICHER ',& ! 'QUIT ','LIRE ','SAUVGARDE ',& ! 'AIDEZ ','INFORMATION ','RETURNEZ ',& ! 'NOUVEAU ','MACRO ','ABOUT ',& ! 'DEBUG ','SELECTIONEZ ','EFFACEZ ',& ! 'STEP ','MAP ','DESSINEZ ',& ! 'HPCALC ','FIN ',' '] ! NOTE a command line can contain options preceded by / ! for example "list /out=myfile.dat all_data" or !------------------- ! subcommands to LIST character (len=16), dimension(nclist) :: clist=& ['DATA ','SHORT ','PHASE ',& 'STATE_VARIABLES ','BIBLIOGRAPHY ','MODEL_PARAM_ID ',& 'AXIS ','TPFUN_SYMBOLS ','QUIT ',& 'PARAMETER ','EQUILIBRIA ','RESULTS ',& 'CONDITIONS ','SYMBOLS ','LINE_EQUILIBRIA ',& 'OPTIMIZATION ','MODEL_PARAM_VAL ','ERROR_MESSAGE ',& 'ACTIVE_EQUILIBR ','ELEMENTS ','EXCELL_CSV_FILE ',& 'MQMQA_SPECIAL ','ESTIMAT_ACCURACY','WORKING_DIRECTOR',& ' ',' ',' '] !------------------- ! subsubcommands to LIST DATA character (len=16), dimension(nlform) :: llform=& ['SCREEN ',' ','MACRO ',& ' ',' ',' '] !------------------- ! subsubcommands to LIST PHASE character (len=16), dimension(nclph) :: clph=& ['DATA ','CONSTITUTION ','MODEL ',& ' ',' ',' '] !------------------- ! subsubcommands to LIST OPTIMIZE results character (len=16), dimension(noptopt) :: optopt=& ['SHORT ','LONG ','COEFFICIENTS ',& 'GRAPHICS ','DEBUG ','MACRO ',& 'EXPERIMENTS ','CORRELATION_MTRX','TC_RSD '] !------------------- ! subsubcommands to LIST MQMQA_SPECIALS character (len=16), dimension(mqmqacc) :: mqmqalist=& ['QUADS ','ASYMMETRIES ','DEBUG ',& 'EXCESS ','AMEND_VARKAPPA ',' '] !------------------- subcommands to CALCULATE character (len=16), dimension(ncalc) :: ccalc=& ['TPFUN_SYMBOLS ','PHASE ','NO_GLOBAL ',& 'TRANSITION ','QUIT ','GLOBAL_GRIDMIN ',& 'SYMBOL ','EQUILIBRIUM ','ALL_EQUILIBRIA ',& 'WITH_CHECK_AFTER','TZERO_POINT ','CAREFULLY ',& 'ONLY_GRIDMIN ','BOSSES_METHOD ','PARAEQUILIBRIUM ',& 'LIQUID_EET ',' ',' '] !------------------- ! subcommands to CALCULATE PHASE character (len=16), dimension(nccph) :: ccph=& ['ONLY_G ','G_AND_DGDY ','ALL_DERIVATIVES ',& 'CONSTITUTION_ADJ','DIFFUSION_COEFF ','QUIT '] !------------------- ! subcommands to ENTER character (len=16), dimension(ncent) :: center=& ['TPFUN_SYMBOL ','ELEMENT ','SPECIES ',& 'PHASE ','PARAMETER ','BIBLIOGRAPHY ',& 'CONSTITUTION ','EXPERIMENT ','QUIT ',& 'EQUILIBRIUM ','SYMBOL ','OPTIMIZE_COEFF ',& 'COPY_OF_EQUILIB ','COMMENT ','MANY_EQUILIBRIA ',& 'MATERIAL ','PLOT_DATA ','GNUPLOT_TERMINAL',& ' ',' ',' '] !------------------- ! subcommands to READ character (len=16), dimension(ncread) :: cread=& ['UNFORMATTED ','TDB ','QUIT ',& 'DIRECT ','XTDB ','SELECTED_PHASES ',& 'ENCRYPTED ',' ',' '] !------------------- ! subcommands to SAVE ! note SAVE TDB, MACRO, LATEX part of LIST DATA !! character (len=16), dimension(ncsave) :: csave=& ['TDB ',' ','QUIT ',& 'DIRECT ','UNFORMATTED ','XTDB '] !------------------- ! subcommands to AMEND first level ! many of these should be subcommands to PHASE character (len=16), dimension(ncam1) :: cam1=& ['SYMBOL ','ELEMENT ','SPECIES ',& 'PHASE ','PARAMETER ','BIBLIOGRAPHY ',& 'TPFUN_SYMBOL ','CONSTITUTION ','QUIT ',& 'COMPONENTS ','GENERAL ','ASSESSMENT_RESLT',& 'OPTIMIZING_COEFS','EQUILIBRIUM ','REDUNDANT_SETS ',& 'LINES ','START_CONSTIT ',' '] !------------------- ! subsubcommands to AMEND PHASE ! the UNIQUAC model specified when entering the phase character (len=16), dimension(ncamph) :: camph=& ['ADDITION ','COMPOSITION_SET ','DISORDERED_FRACS',& ' ','DIFFUSION ','DEFAULT_CONSTIT ',& 'TERNARY_EXTRAPOL','FCC_PERMUTATIONS','BCC_PERMUTATIONS',& 'REMOVE_COMPSETS ','ASYMMETRIES ','AQUEUS_MODEL ',& 'QUASICHEM_MODEL ','FCC_CVM_TETRAHDR',' ',& ' ',' ','QUIT '] !------------------- ! subsubsubcommands to PHASE ADDITION character (len=16), dimension(naddph) :: caddph=& ['MAGNETIC_CONTRIB','QUIT ','GADDITION ',& 'TWOSTATE_LIQUID ','SCHOTTKY_ANOMALY','VOLUME_MODEL1 ',& 'LOWT_CP_MODEL ','LIQUID_2STATE ',' ',& 'ELASTIC_MODEL_1 ',' ','SMOOTH_CP_STEP '] !------------------- ! subcommands to SET character (len=16), dimension(ncset) :: cset=& ['CONDITION ','STATUS ','ADVANCED ',& ' ','INTERACTIVE ','REFERENCE_STATE ',& 'QUIT ','ECHO ','PHASE ',& 'UNITS ','LOG_FILE ','WEIGHT ',& 'NUMERIC_OPTIONS ','AXIS ','INPUT_AMOUNTS ',& 'VERBOSE ','AS_START_EQUILIB','BIT ',& 'OPTCOEFF_VARIABL','OPTCOEFF_SCALED ','LMDIF_ACCURACY ',& 'RANGE_EXPER_EQU ','OPTCOEFF_FIXED ','SYSTEM_VARIABLE ',& 'INITIAL_T_AND_P ','LINEAR_SYSTEM ','GRID_GENERATOR '] ! subsubcommands to SET STATUS character (len=16), dimension(ncstat) :: cstatus=& ['ELEMENT ','SPECIES ','PHASE ',& 'CONSTITUENT ',' ',' '] ! 123456789.123456---123456789.123456---123456789.123456 ! subsubcommands to SET ADVANCED character (len=16), dimension(ncadv) :: cadv=& ['EQUILIB_TRANSFER','QUIT ','SYMBOL ',& 'GRID_DENSITY ','SMALL_GRID_ONOFF','MAP_SPECIALS ',& 'GLOBAL_MIN_ONOFF','OPEN_POPUP_OFF ','WORKING_DIRECTRY',& 'HELP_POPUP_OFF ','EEC_METHOD ','LEVEL ',& 'NO_MACRO_STOP ','PROTECTION ','IGNORE_MACRO_ERR',& 'XTDB_DEFAULTS ',' ',' '] ! 123456789.123456---123456789.123456---123456789.123456 ! subsubcommands to SET BITS character (len=16), dimension(nsetbit) :: csetbit=& ['EQUILIBRIUM ','GLOBAL ','PHASE ',& ' ',' ',' '] ! 123456789.123456---123456789.123456---123456789.123456 ! subsubcommands to SET PHASE character (len=16), dimension(nsetph) :: csetph=& ['QUIT ','STATUS ','DEFAULT_CONSTIT ',& 'AMOUNT ','BITS ','CONSTITUTION '] ! 123456789.123456---123456789.123456---123456789.123456 !------------------- ! subsubsubcommands to SET PHASE BITS ! Some bits can still be set here by numbers but the text is no longer shown ! most bits are set by AMEND PHASE command character (len=16), dimension(nsetphbits) :: csetphbits=& [' ',' ',' ',& ' ',' ',' ',& ' ','NO_AUTO_COMP_SET','QUIT ',& 'EXTRA_DENSE_GRID',' ',' ',& ' ',' ',' '] ! 123456789.123456---123456789.123456---123456789.123456 !------------------- ! subcommands to STEP character (len=16), dimension(nstepop) :: cstepop=& ['NORMAL ','SEPARATE ','QUIT ',& 'CONDITIONAL ','TZERO ','LIQUID_EET ',& 'SCHEIL_GULLIVER ','PARAEQUILIBRIUM ','FAST '] ! 123456789.123456---123456789.123456---123456789.123456 !------------------- ! subcommands to DEBUG character (len=16), dimension(ncdebug) :: cdebug=& ['FREE_LISTS ','STOP_ON_ERROR ','PARAMETER_STRUCT',& 'SPECIES ','TPFUN ','BROWSER ',& 'TRACE ','SYMBOL_VALUE ','MAP_STARTPOINTS ',& 'GRID ','TERNARY_MQMQA ','BOMBMATTA '] !------------------- ! subcommands to SELECT, maybe some should be CUSTOMMIZE ?? character (len=16), dimension(nselect) :: cselect=& ['EQUILIBRIUM ','MINIMIZER ','GRAPHICS ',& 'LANGUAGE ','OPTIMIZER ',' '] !------------------- ! subcommands to DELETE character (len=16), dimension(nrej) :: crej=& ['ELEMENTS ','SPECIES ','PHASE ',& 'QUIT ','COMPOSITION_SET ','EQUILIBRIUM ',& 'STEP_MAP_RESULTS',' ',' '] !------------------- ! subcommands to INFORMATION character (len=16), dimension(ninf) :: cinf=& ['ELEMENTS ','SPECIES ','PHASES ',& 'QUIT_INFO ','COMPOSITION_SET ','EQUILIBRIUM ',& 'HELP_SYSTEM ','CONDITIONS ','DATABASES ',& 'CHANGES ','PHASE_DIAGRAM ','PROPERTY_DIAGRAM',& 'STATE_VARIABLES ',' ',' '] !------------------- ! subcommands to PLOT OPTIONS/ GRAPHICS OPTIONS ! Now there are two levels (using EXTRA) but still a mess character (len=16), dimension(nplt) :: cplot=& ['RENDER ','SCALE_RANGES ','FONT ',& 'AXIS_LABELS ',' ','TITLE ',& 'GRAPHICS_FORMAT ','OUTPUT_FILE ',' ',& 'QUIT ','POSITION_OF_KEYS','APPEND ',& 'TEXT_LABEL ',' ','EXTRA '] ! subsubcommands to PLOT EXTRA character (len=16), dimension(nplt2) :: cplot2=& ['COLOR ','LOGSCALE ','RATIOS_XY ',& 'LINE_TYPE ','MANIPULATE_LINES','PAUSE_OPTION ',& 'LOWER_LEFT_TEXT ','TIE_LINES ','GIBBS_TRIANGLE ',& 'QUIT ','SPAWN ','NO_HEADING ',& 'AXIS_FACTOR ','GRID ',' ',& ' ',' ',' '] !------------------- ! 123456789.123456---123456789.123456---123456789.123456 ! minimizers character (len=16), dimension(2) :: minimizers=& ['LUKAS_HILLERT ','SUNDMAN_HILLERT '] !------------------------------------------------------------------------ ! optimizers character (len=16), dimension(2) :: optimizers=& ['LMDIF ','VA05AD '] !------------------------------------------------------------------------ ! ! before we come here gtp_init has been called in the main program ! some defaults ! write(*,*)'Start of OC command line monitor' language=1 logfil=0 defcp=1 seqxyz=0 ! ceq has no value here!!! Moved this to gtp3A: initialize_global_parameters ! ceq%gmindif=default_mingridmin ! defaults for several step special stepspecial=.FALSE. ! save the working directory (where OC is started?) call getcwd(workingdir) ! write(*,*)'Working directory is: ',trim(workingdir) ! this is used to save the path to any directory where a macro is started ! macropath=' ' ! initiate command line history myhistory%hpos=0 ! defaults for optimizer, number of variable coefficients nvcoeff=0 ! present the software write(kou,10)version,trim(linkdate),ocmonversion,gtpversion,hmsversion,& smpversion 10 format(/'Open Calphad (OC) software version ',a,', linked ',a,/& 'with command line monitor version ',i3//& 'This program is available with a GNU General Public License.'/& 'either version 2 of the License, or any later version.'/& 'It includes the General Thermodynamic Package, version ',A,','/& "Hillert's equilibrium calculation algorithm version ",A,','/& 'step/map/plot software version ',A,' using GNUPLOT 5.2 graphics.'/& 'Numerical routines are extracted from LAPACK and BLAS and'/& 'the assessment procedure uses LMDIF from ANL.'/) ! ! lines starting with !$ will be included when compiling with -fopenmp !$ write(kou,11) 11 format('Linked with OpenMp for parallel execution') ! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> ! Default gnuterminals, edit these as they may not be same on your systems graphopt%gnutermid=' ' ! graphopt%status=0 initiated to zero ! Screen is terminal 1 graphopt%gnutermid(1)='SCREEN ' ! default font, not reinitiated if set explicitly graphopt%font='Arial ' ! MAX 80 characters to set terminal .... HERE FONT AND SIZE IS SET ! test compilation ... ! #ifdef aqplt ! Aqua plot screen on some Mac systems graphopt%gnuterminal(1)='aqua size 600,500 font "'//& trim(graphopt%font)//',16"' ! it should be #elif not #elseif .... suck #elif qtplt ! Qt plot screen on some LINUX systems graphopt%gnuterminal(1)='qt size 600,500 font "'//& trim(graphopt%font)//',16"' ! graphopt%gnuterminal(1)='qt size 600,500 font "arial,16"' #elif x11 ! x11 plot screen on other LINUX systems graphopt%gnuterminal(1)='x11 size 840,700 font "'//& trim(graphopt%font)//',16"' ! graphopt%gnuterminal(1)='x11 size 840,700 font "arial,16"' #else ! wxt default plot screen (used on most Window systems) ! graphopt%gnuterminal(1)='wxt size 940,700 font "'//& graphopt%gnuterminal(1)='wxt size 840,700 font "'//& trim(graphopt%font)//',16"' ! write(*,*)'pmon: "',trim(graphopt%gnuterminal(1)),'"' ! graphopt%gnuterminal(1)='wxt size 840,700 font "arial,16"' ! This uses 'start /B ' in front of plot command to spawn plot windows ! graphopt%status=ibset(graphopt%status,GRKEEP) ! graphopt%gnuterminal(1)='wxt size 900,600 font "arial,16"' #endif graphopt%filext(1)=' ' ! NOTE THAT THE SCREEN PLOT WINDOW ALLOWS YOU TO SELECT FILE OUTPUT ! Postscript i1=2 graphopt%gnutermid(i1)='PS ' graphopt%gnuterminal(i1)='postscript color solid fontscale 1.2' graphopt%filext(i1)='ps ' ! Adobe Portable Document Format (PDF) i1=3 graphopt%gnutermid(i1)='PDF ' !--------- #ifdef qtplt ! On LINUX ?? ! graphopt%gnuterminal(i1)='pdfcairo ' !----------#else ! NOTE size is in inch ! graphopt%gnuterminal(i1)='pdf color solid size 6,5 enhanced font "arial,16"' graphopt%gnuterminal(i1)='pdf color solid size 6,5 enhanced font "'//& trim(graphopt%font)//',16"' !----------#endif graphopt%filext(i1)='pdf ' ! Graphics Interchange Format (GIF) i1=4 graphopt%gnutermid(i1)='GIF ' graphopt%gnuterminal(i1)='gif enhanced fontscale 0.7' graphopt%filext(i1)='gif ' graphopt%gnutermax=i1 ! Portable graphics format (PNG) i1=5 graphopt%gnutermid(i1)='PNG ' graphopt%gnuterminal(i1)='png enhanced fontscale 0.7' graphopt%filext(i1)='png ' graphopt%gnutermax=i1 ! by default spawn plots graphopt%status=ibset(graphopt%status,GRKEEP) ! if winhlp set also GRKEEP #ifdef winhlp ! write(*,*)'UI: Setting windows bit 2: ',GRKEEP ! This uses 'start /B ' in front of plot command to spawn plot windows graphopt%status=ibset(graphopt%status,GRKEEP) #endif !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> ! jump here after NEW to reinitiallize all local variables also 20 continue ! clear file names ocmfile=' '; ocufile=' '; tdbfile=' '; xtdbfile=' ' ! clear some other variables dummy=' '; name1=' '; name2=' '; name3=' ' tzcond=0 eetcond=0 parael=' ' ! initiating the equence of mqmqaquads, declared in models/gtp3_dd2.F90 mqmqanend=-100 ! initiallize ploted, it is not done in reset_plotoptions graphopt%plotend='pause mouse' ! reset plot ranges and their defaults call reset_plotoptions(graphopt,plotfile,textlabel) axplotdef=' ' ! default list unit optionsset%lut=kou lut=kou ! default for list short chshort='A' ! set default minimizer, 2 is matsmin, 1 does not work ... minimizer=2 ! set default optimimzer, 1 is LMDIF, 2 is VA05AD (no longer available) optimizer=1 ! by default no stop on error and no logfile stop_on_error=.false. logfil=0 buperr=0 ! initiate the limit on number of equilibria saved during step/map totalsavedceq=0 ! ! nopenpopup is declared in metlib3.F90 and dis/allow open popup windows ! it is initiated to FALSE, if user change it will not be reinitiated here ! nopenpopup=.FALSE. ! in init_gtp the first equilibrium record is created and ! firsteq has been set to that ! !25 continue ! default values of T and P. NOTE these are not set as conditions firsteq%tpval(1)=1.0D3 firsteq%tpval(2)=1.0D5 ! ! default list result option lrodef=1 ! default axis limits set to be 0 and 1 maxax=5 noofaxis=0 ! state variable for plot axis (only 2) do j4=1,2 axplotdef(j4)=' ' enddo ! remove any results from step and map nullify(maptop) nullify(mapnode) nullify(maptopsave) ! entered start equilibria nullify(starteqs(1)%p1) noofstarteq=0 ! set default fractions when entering composition xknown=one ! set default equilibrium to 1 and current equilibrium (CEQ) to firsteq neqdef=1 ceq=>firsteq ! >>> we should remove all equilibria !! ?? ! here one should read a user initialisation file as a macro ! file can be at current directory or at home directory ! initiate on-line help ! local environment: please create OCHOME as an environment variable ochome=' ' call get_environment_variable('OCHOME ',ochome) startupmacro=.FALSE. ! if help is not set then set these filenames as blanks browser=' ' latexfile=' ' htmlfile=' ' #ifdef winhlp ! BROWSER FOR WINDOWS ! browser='C:\PROGRA~1\INTERN~1\iexplore.exe ' browser='C:\"Program Files\Mozilla Firefox"\firefox.exe ' #elif lixhlp ! BROWSER FOR LINUX browser='/usr/bin/firefox ' ! browser='firefox ' #elif machlp ! BROWSER FOR MAC browser='/Applications/Firefox.app/Contents/MacOS/firefox ' ! browser='firefox ' #endif noochome: if(ochome(1:1).eq.' ') then ! there is no OCHOME environment variable, maybe a local ochelp.html? inquire(file='ochelp.html ',exist=logok) if(.not.logok) then write(*,*)'Warning, no environment variable OCHOME and no help file' htmlfile=' ' htmlhelp=.FALSE. else write(*,*)'Warning, no environment variable OCHOME but local help file' htmlfile='ochelp.html' htmlhelp=.TRUE. endif call init_help(browser,htmlfile) else ! there is a OCHOME environment variable ! both LINUX and WINDOWS accept / as separator between directory and file names write(*,*)'Found OC home directory (OCHOME): ',trim(ochome) #ifdef winhlp ! HTML FILE FOR WINDOWS ! normal tex/html help files htmlfile=trim(OCHOME)//'\'//'ochelp.html' #elif lixhlp ! HTML FILE FOR LINUX htmlfile=trim(OCHOME)//'/'//'ochelp.html' #elif machlp ! HTML FILE FOR MAC htmlfile=trim(OCHOME)//'/'//'ochelp.html' #endif call init_help(browser,htmlfile) if(.not.ochelp%htmlhelp) then write(kou,*)'Warning, no file "ochelp.html" at OCHOME or no browser' write(kou,*)trim(browser) write(kou,*)trim(htmlfile) htmlhelp=.FALSE. else write(kou,*)'Online help by '//trim(browser)//& ' and ochelp.html' endif ! default directory for databases ocbase=trim(ochome)//'/databases' cline=trim(ochome)//'/start.OCM ' inquire(file=cline,exist=logok) if(logok) then write(*,*)'Reading your startup macro: ',trim(cline) last=0 ! This just open the file and sets input unit to file call macbeg(cline,last,logok) startupmacro=.TRUE. endif endif noochome ! initiate XML defaults lowTdef='298.15 '; hightdef='6000 '; bibrefdef='U.N. Known'; eldef='VA /-'; unary1991=.TRUE.; includemodels=.FALSE. ! running a initial macro file write(*,*)'Working directory is: ',trim(workingdir) ! ! finished initiallization ! ! !============================================================ ! return here for next command 100 continue if(gx%bmperr.ne.0) goto 990 if(buperr.ne.0) goto 990 ! turn off any options set call ocmon_reset_options(optionsset) ! initiate command level for help routines call helplevel1('Initiate help level for OC') ! handling of inline arguments ONCE if(.not.startupmacro .and. narg.gt.0) then ! at present accept only one argument assumed to be a macro file name narg=0 cline=argline(1) last=0 ! if(cline(1:1).eq.'<') then ! write(*,*)'OC reads can start a macro from the command line' ! else call macbeg(cline,last,logok) ! macropath=string ! endif endif ! write(*,*)'----------TOP LEVEL COMMAND INPUT' ! read the command line with gparc to have output on logfile ! NOTE read from macro file if set. last=len(aline) aline=' ' cline=' ' call gparcx(ocprompt,aline,last,5,cline,' ','?TOPHLP') j4=0 ! write(*,*)'Back from gparcx 1: "',trim(cline),'"',j4,last if(len_trim(cline).gt.80) then write(kou,101) 101 format(' *** Warning: long input lines may be truncated',& ' and cause errors') endif ! with empty line just prompt again, j4 incremented by eolch if(eolch(cline,j4)) goto 100 ! with macro command prefix character just prompt again if(cline(j4:j4).eq.'@') goto 100 ! with the new help facilities "tophlp" is difficult ... ! write(*,*)'Back from gparcx 2: "',trim(cline),'"',j4 if(cline(j4:j4+1).eq.'? ') then ! just provide the menu as help j4=0 call q3helpx(cline,j4,cbas,ncbas) goto 100 endif ! Now finally detect the command kom=ncomp(cline,cbas,ncbas,last) ! write(*,*)'Here if "??"',kom,last if(kom.le.0) then if(kom.lt.0) then write(kou,*)'Ambiguous command, available commands are:' else write(kou,*)'No such command, available commands are:' endif last=1 cline=' *' call q3helpx(cline,last,cbas,ncbas) write(*,*)'An OS command must be prefixed by @' goto 100 else ! check for options .... some of these do not work yet ! one should check for options after each subcommand or value entered ?? ! call ocmon_set_options(cline,last,optionsset) nops=0 110 continue if(.not.eolch(cline,last)) then if(cline(last:last).eq.'/') then ! this is an option! call getext(cline,last,2,option,' ',nopl) if(buperr.ne.0) then write(kou,*)'Error reading option',buperr buperr=0; goto 100 endif call ocmon_set_options(option,afo,optionsset) if(afo.ne.0) then write(kou,*)'Please give the command again' goto 100 endif goto 110 else ! set "last" back one character to prepare for next call of GPARx ! as the first thing done by GPARx is to increment last by 1 to bypass a , last=last-1 endif endif endif ! save command for help path MAYBE NOT NEEDED ANY LONGER ?? if(helprec%level.lt.maxhelplevel) then helprec%level=helprec%level+1 helprec%cpath(helprec%level)=cbas(kom) else write(*,*)'Warning, exceeded helprec%level limit 1' endif ! The IF loop is for handling of defaults in submenu. "l ,,,,," took all ! defaults but "l,,,,," did not .... ! if last>1 and cline(last-1:last-1) is a space and cline(last:last) a comma, ! increment last if(last.eq.1) then last=last+1 elseif(last.lt.len(cline)) then if(cline(last:last).ne.' ') then if(cline(last+1:last+1).eq.',') last=last+1 endif endif ! !================================================ separating main commands !------------------------- separating subcommands !......................... separating subsubcommands ! jump here if there is an inline argument ! 99 continue main: SELECT CASE(kom) ! command selection !================================================================= CASE DEFAULT write(kou,*)'No such command' goto 100 !================================================================= CASE(1) ! AMEND ! amend subcommands ! ['SYMBOL ','ELEMENT ','SPECIES ',& ! 'PHASE ','PARAMETER ','BIBLIOGRAPHY ',& ! 'TPFUN_SYMBOL ','CONSTITUTION ','QUIT ',& ! 'COMPONENTS ','GENERAL ','ASSESSMENT_RESLT',& ! 'OPTIMIZING_COEFS','EQUILIBRIUM ','REDUNDANT_SETS ',& ! 'LINES ',' ',' '] ! disable continue optimization ! iexit=0 ! iexit(2)=1 kom2=submenu(cbas(kom),cline,last,cam1,ncam1,4,'?TOPHLP') amend: SELECT CASE(kom2) CASE DEFAULT write(kou,*)'No such amendment',kom2 ! goto 100 !------------------------- case(1) ! amend symbol (of state variable function) call gparcx('Symbol name: ',cline,last,1,name1,' ','?Amend symbol') call capson(name1) do svss=1,nosvf() if(name1(1:16).eq.svflista(svss)%name) goto 1020 enddo write(kou,*)'No such symbol'; goto 100 1020 continue if(svflista(svss)%status.ne.0) then ! if any bit except SVCONST set we cannot amend it if(.not.btest(svflista(svss)%status,SVCONST)) then write(*,*)'Symbol is not amendable'; goto 100 endif endif ! No bits or the SVCONST bit is set, it is amendable, get its value actual_arg=' ' xxx=evaluate_svfun_old(svss,actual_arg,1,ceq) if(btest(svflista(svss)%status,SVCONST)) then ! symbol is a numeric constant or evaluated explicitly, we can change its value ! value must be set in all equilibria ?? call gparrdx('Give new value: ',cline,last,xxy,xxx,'?Amend symbol') if(buperr.eq.0) then call set_putfun_constant(svss,xxy) goto 100 else ! we want to amend something else buperr=0 endif endif ! Now we can set one special bit! But first clear input line last=len(cline) write(kou,1021) 1021 format('You can specify:'/& ' V for a symbol evaluated only when referenced explicitly'/& ' X for a symbol to be evaluated at a particular equilibrium') ! with SET ADVANCED SYMBOL one can set EXPORT/IMPORT for assessments call gparcdx('Please specify V or X',& cline,last,1,ch1,'X','?Amend symbol') call capson(ch1) if(ch1.eq.'V') then ! If V then set bit to evaluate symbol only when explicitly referenced svflista(svss)%status=ibset(svflista(svss)%status,SVFVAL) elseif(ch1.eq.'X') then ! if X then evaluate symbol only at specific equilibrium? ! For example H298 for experimental data on H(T)-H298 ! BEWARE: if equilibria are calculated in threads this must be calculated ! before the parallelization, testing bit EQNOTHREAD ll=ceq%eqno call gparidx('Specify equilibrium number:',cline,last,& neqdef,ll,'?Amend symbol evaluated at equilib') ! UNFINISHED! Check equilibrium exist or only allow current? if(neqdef.le.1 .or. neqdef.gt.noeq()) then write(*,*)'No such equilibrium'; goto 100 endif svflista(svss)%status=ibset(svflista(svss)%status,SVFEXT) svflista(svss)%eqnoval=neqdef ! set status bit that this equilibrium must be calculated before parallel calc ceq%status=ibset(ceq%status,EQNOTHREAD) write(*,*)'The value of this symbol calculated in equilibrium: ',& neqdef goto 100 else write(kou,*)'Illegal letter "',ch1,'"' endif !------------------------- case(2) ! amend element call gparcx('Element symbol: ',cline,last,1,elsym,' ',& '?Amend element') call find_element_by_name(elsym,iel) if(gx%bmperr.ne.0) goto 100 call get_element_data(iel,elsym,name1,dummy,mass,h298,s298) if(gx%bmperr.ne.0) goto 100 write(*,'(a)')'You are only allowed to change the mass' call gparrdx('New mass: ',cline,last,xxx,mass,'?Amend element') call new_element_data(iel,elsym,name1,dummy,xxx,h298,s298) ! write(kou,*)'Not implemented yet' !------------------------- case(3) ! amend species call gparcx('Species symbol: ',cline,last,1,name1,' ',& '?Amend species') call find_species_record(name1,loksp) if(gx%bmperr.ne.0) goto 100 write(*,'(a)')'You can only amend UNIQAC area and segments' call gparrdx('UNIQAC surface area (q): ',cline,last,xxx,one,& '?Amend species') if(xxx.le.zero) then write(*,'(a)')'Area must be >0, set to default 1.00' xxx=one endif call gparrdx('UNIQAC segments (r): ',cline,last,xxy,one,& '?Amend species') if(xxy.le.zero) then write(*,'(a)')'Segments must be >0, set to default 1.00' xxy=one endif ! mark UNIQUAC in species status word and allocate space for values call set_uniquac_species(loksp) if(gx%bmperr.ne.0) goto 100 call enter_species_property(loksp,1,xxx) call enter_species_property(loksp,2,xxy) if(gx%bmperr.ne.0) goto 100 !------------------------- case(4) ! amend phase subcommands call gparcx('Phase name: ',cline,last,1,name1,' ','?Amend for phase') if(buperr.ne.0) goto 990 call find_phase_by_name(name1,iph,ics) if(gx%bmperr.ne.0) goto 990 ! sometimes lokph is used below call get_phase_record(iph,lokph) call get_phasetup_name(iph,name1) ! kom3=submenu('Amend for phase '//trim(name1),& cline,last,camph,ncamph,2,'?TOPHLP') ! write(*,*)'Amend phase subcommand: ',kom3 amendphase: SELECT CASE(kom3) ! subsubcommands to AMEND PHASE ! ['ADDITION ','COMPOSITION_SET ','DISORDERED_FRACS',& ! ' ','DIFFUSION ','DEFAULT_CONSTIT ',& ! 'TERNARY_EXTRAPOL','FCC_PERMUTATIONS','BCC_PERMUTATIONS',& ! 'REMOVE_COMPSETS ','ASYMMETRIES ','AQUEUS_MODEL ',& ! 'QUASICHEM_MODEL ','FCC_CVM_TETRAHDR',' ',& ! ' ',' ','QUIT '] ! old !.................................................... CASE DEFAULT write(kou,*)'Amend phase subcommand error' !.................................................... case(1) ! amend phase addition kom4=submenu('Addition of',cline,last,caddph,naddph,1,& '?TOPHLP') ! write(*,*)'Amend phase addition: ',kom4 ! ['MAGNETIC_CONTRIB','QUIT ','GADDITION ',& ! 'TWOSTATE_LIQUID ','SCHOTTKY_ANOMALY','VOLUME_MODEL1 ',& ! 'LOWT_CP_MODEL ','LIQUID_2STATE ',' ',& ! 'ELASTIC_MODEL_A ','QUASICHEM_MODEL ','FCC_CVM_TETRAHDR'] ! amendphaseadd: SELECT CASE(kom4) case default write(*,*)'No such addition' ! Inden magnetism case(1) ! amend phase magnetic contribution idef=-3 ! zero value of antiferromagnetic factor means Inden-Qing model call gparidx('Antiferromagnetic factor: ',& cline,last,j4,idef,'?Amend magnetism') if(buperr.ne.0) goto 990 if(j4.eq.0) then ! Inden-Hillert-Qing-Xiong magnetic model has AFF=0 call gparcdx('BCC type phase: ',cline,last,1,chz,'N',& '?Amend magnetism') call gparcdx('Using individual Bohr magnetons: ',& cline,last,1,ch1,'N','?Amend magnetism') if(.not.(ch1.eq.'Y' .or. ch1.eq.'y')) then ! write(*,*)'PMON use BMAG parameter as average' call set_phase_status_bit(lokph,PHBMAV) aux=' ' else write(*,*)'PMON mark use IBM parameter' aux(2:2)='I' endif ! xiongmagnetic is a predefined addition index, chz is Y or y for BCC j2=xiongmagnetic aux(1:1)=chz call add_addrecord(lokph,aux,xiongmagnetic) else if(j4.eq.-1) then ! Inden magnetic for BCC call add_addrecord(lokph,'Y',indenmagnetic) else ! Inden magnetic for FCC call add_addrecord(lokph,'N',indenmagnetic) endif j2=indenmagnetic endif call gparcdx('Is the addition calculated per mole of atoms?',& cline,last,1,ch1,'Y','?Add per formula unit') ! The magnetic model calculates a molar Gibbs energy, must be multiplied with ! the number of atoms in the phase. j2 set above to the addition type if(ch1.eq.'Y' .or. ch1.eq.'y') then call setpermolebit(lokph,j2) endif !.................................................... case(2) ! QUIT goto 100 !.................................................... case(3) ! amend phase ... addition gaddition ! different additions can be added for different composition sets call get_phase_compset(iph,ics,lokph,lokcs) if(gx%bmperr.ne.0) goto 100 if(allocated(ceq%phase_varres(lokcs)%addg)) then xxy=ceq%phase_varres(lokcs)%addg(1) else ! maybe we will use more terms later .... xxy=zero allocate(ceq%phase_varres(lokcs)%addg(1)) endif !\hypertarget{Amend phase Gaddition}{} call gparrdx('Addition to G in J/FU (formula units): ',& cline,last,xxx,xxy,'?Amend Gaddition') ceq%phase_varres(lokcs)%addg(1)=xxx ! set bit that this should be calculated ceq%phase_varres(lokcs)%status2=& ibset(ceq%phase_varres(lokcs)%status2,CSADDG) !.................................................... case(4,8) ! amend phase add liquid_2state/twostate_liquid write(kou,667) 667 format('This addition require LNTH parameters for the',& ' Einstein T of the amorphous state'/'and G2 parameters',& ' for the transition to the liquid state.') ! WRONG IDEA to set bit to allow G2 to be composition independent ! call gparcdx('Is G2 composition dependent? ',& ! cline,last,1,ch1,'Y','?Amend twostate liquid') ! ensure ch1 is a captial letter! ! call capson(ch1) ! if ch1 is N then the addition record will have the twostatemodel2(=12) value ! and the PH2STATE in the phase record must be set also: ! phlista(lokph)%status1=ibset(phlista(lokph)%status1,PH2STATE) ! But as phlista is protected it is set inside add_addrecord modelx=twostatemodel1 ! inside add_addrecord modelx can be changed to twostatemodel2 if G2 fixed ch1='Y' call add_addrecord(lokph,ch1,modelx) call gparcdx('Is the low T calculated per mole atoms?',& cline,last,1,ch1,'Y','?Add per formula unit') ! The CP model calculates a molar Gibbs energy, must be multiplied with ! the number of atoms in the phase. if(ch1.eq.'Y' .or. ch1.eq.'y') then call setpermolebit(lokph,modelx) endif !.................................................... case(5) ! amend phase addition Schottky anomaly call add_addrecord(lokph,' ',schottkyanomaly) write(*,668) 668 format('This addition requires the TSCH and CSCH parameters') !.................................................... ! VOLUME MODEL1 case(6) ! volume model1 call add_addrecord(lokph,' ',volmod1) write(*,*)'Added volume model 1' !.................................................... ! Einstein low T model case(7) ! amend phase LowT_CP_model call add_addrecord(lokph,' ',einsteincp) write(*,*)'This addition requires the LNTH parameter' call gparcdx('Is the addition calculated for one mole atoms? ',& cline,last,1,ch1,'Y','?Add per formula unit') ! The CP model calculates a molar Gibbs energy, must be multiplied with ! the number of atoms in the phase. j2 set above to the addition type if(ch1.eq.'Y' .or. ch1.eq.'y') then call setpermolebit(lokph,einsteincp) endif !.................................................... ! case(8) ! same as 4 !.................................................... case(9) ! not used !.................................................... case(10) ! amend phase elastic model ! call add_addrecord(lokph,' ',elasticmodel1) write(*,*)'This addition is not yet implemented' !.................................................... case(11) ! amend phase addition unused continue !.................................................... case(12) ! amend phase ... smooth-Cp-step call add_addrecord(lokph,' ',secondeinstein) call gparcdx('Is the addition calculated for one mole? ',& cline,last,1,ch1,'Y','?Add per formula unit') ! The CP model calculates a molar Gibbs energy, must be multiplied with ! the number of atoms in the phase. j2 set above to the addition type if(ch1.eq.'Y' .or. ch1.eq.'y') then call setpermolebit(lokph,secondeinstein) endif write(*,672) 672 format('This addition recures the THT2 and DCP2 parameters') ! The smooth CP model calculates a molar Gibbs energy, must be multiplied with ! the number of atoms in the phase. j2 set above to the addition type end select amendphaseadd !.................................................... case(2) ! amend phase composition set add/remove call gparcdx('Add new set? ',cline,last,1,ch1,'Y ','?Add new cs') if(buperr.ne.0) goto 990 if(ch1.eq.'Y' .or. ch1.eq.'y') then call gparcx('Prefix: ',cline,last,1,prefix,' ',& '?Add new cs') call gparcx('Suffix: ',cline,last,1,suffix,' ',& '?Add new cs') call enter_composition_set(iph,prefix,suffix,ics) if(gx%bmperr.ne.0) goto 990 ! list the number of new composition set write(kou,*)'New composition set number is ',ics ! ask for default constitution of new set call ask_default_constitution(cline,last,iph,ics,ceq) else ! remove the highest (max is 9). Can be dangerous. Can not be made if there ! are several equilibra unless second argument is changed to .TRUE. call remove_composition_set(iph,.FALSE.) if(gx%bmperr.ne.0) goto 990 endif !.................................................... case(3) ! amend phase disordered_fracset if(.not.allowenter(2)) then gx%bmperr=4125 goto 990 endif ! we should check the number of sublattices of the phase ... ! idef=4 lokcs=phasetuple(iph)%lokvares idef=size(firsteq%phase_varres(lokcs)%sites) ! write(*,*)'PMON idef: ',idef call gparidx('Sum up to sublattice: ',cline,last,ndl,idef,& '?Amend phase disordfrac') if(buperr.ne.0) goto 990 call gparcdx('Should the ordered part cancel when disordered? ',& cline,last,1,ch1,'N','?Amend phase disordfrac') if(buperr.ne.0) goto 990 if(ch1.eq.'N' .or. ch1.eq.'n') then ! like sigma which is never completely disordered j4=0 else ! like FCC ordering where the disordered state can be modeled independently j4=1 write(kou,*)'This phase can be totally disordered' endif ch1='D' call add_fraction_set(iph,ch1,ndl,j4) ! forgot to add the sites lokcs=phasetuple(iph)%lokvares if(j4.eq.0) then xxx=zero do ll=1,ndl xxx=xxx+firsteq%phase_varres(lokcs)%sites(ll) enddo firsteq%phase_varres(lokcs)%disfra%fsites=xxx endif ! write(*,*)'pmon6: ',ndl,xxx if(gx%bmperr.ne.0) goto 990 !.................................................... case(4) ! Not used write(*,*)'Not implemented yet' !.................................................... case(5) ! DIFUSION properties ! copy the rest of the line to the subroutine text=cline(last:) call add_addrecord(lokph,text,DIFFCOEFS) !.................................................... case(6) ! amend phase default_constitution ! to change default constitution of any composition set give #comp.set. call ask_default_constitution(cline,last,iph,ics,ceq) !.................................................... case(7) ! TERNARY_EXTRAPOL ! this command is illegal for phases with sublattices (or permutations? ...) call get_sublattice_number(iph,ndl,ceq) if(gx%bmperr.ne.0) goto 990 if(ndl.gt.1) then write(*,*)'Toop/Kohler extrapolation not allowed ',& 'for phases with 2 or more sublattices' goto 100 endif write(kou,677) 677 format('The ternary extrapolation method is fragile',& ' and only limited tests have been made.') tkloop: do while(.true.) call gparcx('Constituent 1: ',cline,last,1,& xspecies(1),' ','?Amend phase ternary extrapol') call gparcx('Constituent 2: ',cline,last,1,& xspecies(2),' ','?Amend phase ternary extrapol') call gparcx('Constituent 3: ',cline,last,1,& xspecies(3),' ','?Amend phase ternary extrapol') call gparcx('Extrapolations (TiKTi, KKK etc): ',& cline,last,1,tkmode,' ','?Amend phase ternary extrapol') call capson(tkmode) ! letters K, M or T allowed in tkmode, T followed by integer, checked inside add ! this subroutine is in gtp3H.F90 (additions) call add_ternary_extrapol_method(lokph,tkmode,xspecies) if(gx%bmperr.ne.0) goto 990 dummy='N' call gparcdx('Another special ternary extrapolation for this phase?',& cline,last,1,ch1,dummy,'?Amend phase ternary extrapol') call capson(ch1) if(ch1.ne.'Y') exit tkloop enddo tkloop !.................................................... !\hypertarget{Amend FCC-permutations}{} case(8) ! amend phase ... FCC_PERMUTATIONS if(check_minimal_ford(lokph)) goto 100 call set_phase_status_bit(lokph,PHFORD) !.................................................... !\hypertarget{Amend BCC-permutations}{} case(9) ! amend phase ... BCC_PERMUTATIONS if(check_minimal_ford(lokph)) goto 100 call set_phase_status_bit(lokph,PHBORD) !.................................................... case(10) ! amend phase <...> remove_compsets write(*,*)'PMON: delete unstable composition sets' call delete_unstable_compsets(lokph,ceq) !.................................................... !************************************ begin amend phase ... asymmetries case(11) ! amend phase ... ASYMMETRIES for MQMQA phase ! moved LIST PHASE MQMQA ASYMMETRIES HERE if(.not.allocated(tersys)) then write(*,*)'No MQMQA phase asymmetries entered' goto 100 endif lokcs=phasetuple(iph)%lokvares write(*,*)'You can amend MQMQA asymmetry interactivly' ! copied from gtp3XQ listconst ! list element names, numbers and quad indices, i1 set to number of quads call list_quads(i1) ! ! tersys is global data write(*,3101)size(tersys) 3101 format(/'Listing of the ',i3,' ternary systems and their asymmetries',& /' i tern cat1 cat2 cat3 T/0 T/0 T/0 asymmetry code') do iz=1,size(tersys) write(*,3201)iz,tersys(iz)%seq,(tersys(iz)%el(j4),j4=1,3),& tersys(iz)%isasym,tersys(iz)%asymm 3201 format(i3,i5,2x,3(1x,i4),5x,3i4,5x,a) enddo write(*,3301) 3301 format('Number in cat1/2/3 columns is actual cation,'/& 'Number 1, 2 or 3 in T/0 columns refer to the cation colums.'/& 'Asymmetry code is KKK for symmetric, Tn for Toop n.') ! skip1: if(.false.) then !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! ! skip code below, maybe move to after call to varkappa1 ! listing of fraction in alphbetical order write(kou,4123)mqmqa_data%nquad,& (ceq%phase_varres(lokcs)%yfr(i1),i1=1,mqmqa_data%nquad) 4123 format('Fractions ',i2,' in species OC alphabetical order:',/& (12F6.3)) ! mqmqaf defined globally noq: if(.not.allocated(ceq%phase_varres(lokcs)%mqmqaf%xquad)) then write(*,*)'Quads not allocated' else write(kou,4122)mqmqa_data%nquad,& (ceq%phase_varres(lokcs)%mqmqaf%xquad(i1),i1=1,mqmqa_data%nquad) 4122 format('Fractions ',i2,' in Quad order: ',/(12F6.3)) write(kou,4124)mqmqa_data%nquad,mqmqa_data%ncat 4124 format(/'The ',i3,' quads for ',i2,' cations are arranged ',& 'in order of the n cations:'/& 'Quad ',9x,'1 2 ... n | n+1 n+2 ... 2n-1 | 2n .. | n(n+1)/2'/& 'Cation',9x,'1 1 ... 1 | 2 2 ... 2 | 3 .. | n'/& 'Cation',9x,'1 2 ... n | 2 3 ... n | 3 .. | n') write(kou,4126)mqmqa_data%quad2compvar 4126 format('quad2compvar: ',21(1x,i2)) ! ! write(kou,4127)mqmqa_data%emquad*(mqmqa_data%emquad-1),& ! mqmqa_data%emquad !4127 format('Number of varkappa_ij asymmetry variables, n*(n-1)/2: ',i3/& ! 'em2quad: ',21(1x,i2)) ! just a blank line write(kou,*) write(kou,308)'Fractions in OC order ',& (i2,i2=1,mqmqa_data%nquad) write(kou,308)'Fractions in Quad order ',& (mqmqa_data%con2quad(i2),i2=1,mqmqa_data%nquad) 308 format(a,15i3) ! write(kou,410)newXupdate 410 format(/'List of compvar, the binary asymmetric composition',& ' variables, last update:',i5/& ' seq cat_i cat_j varkappa_ij varkappa_ji xi_ij xi_ji') ! calculate varkappaij and varkappaji correcting for all ternaries mqmqavar=>ceq%phase_varres(lokcs) call calcasymvar(mqmqavar) j4=0 cat1: do i1=1,mqmqa_data%ncat-1 cat2: do i2=i1+1,mqmqa_data%ncat j4=j4+1 write(kou,412)j4,i1,i2,& ceq%phase_varres(lokcs)%mqmqaf%compvar(j4)%vk_ij,& ceq%phase_varres(lokcs)%mqmqaf%compvar(j4)%vk_ji,& ceq%phase_varres(lokcs)%mqmqaf%compvar(j4)%xi_ij,& ceq%phase_varres(lokcs)%mqmqaf%compvar(j4)%xi_ji 412 format(i5,2i6,3x,4(1PE12.4)) enddo cat2 enddo cat1 endif noq ! write(kou,444)'Values of y_i/k: ',& (ceq%phase_varres(lokcs)%mqmqaf%y_ik(i1),i1=1,mqmqa_data%ncat) 444 format(/a,(10f7.4)) ! endif skip1 !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! code above redundant, contune specify ternary asymmetry ! ! just an empty line before entering of new asymmetry write(kou,*) call gparidx('Index of ternary to modify (0=none)?',cline,last,& asymter,0,'?Asymmetry modify') if(asymter.le.0 .or. asymter.gt.size(tersys)) then write(*,*)'No change',size(tersys) goto 100 endif write(*,413) 413 format('Specify the Toop cation as 1, 2 or 3.',/& '(When implemented 0 can be used to set symmetric)') call gparidx('Specify 0, 1, 2 or 3',cline,last,& new_toop,0,'?Asymmetry modify') if(new_toop.gt.0 .and. new_toop.le.3) then ! allow only one asymmetric cation, save new_toop in tersys array tersys(asymter)%isasym(new_toop)=new_toop tersys(asymter)%asymm='T'//char(ichar('0')+new_toop)//' ' ! tersys will be 'T1 ', 'T2 ' or 'T3 ' else ! set isasym zero write(kou,*)'Restoring a ternary to symmetric does not work' goto 100 ! tersys(asymter)%isasym=0 tersys(asymter)%asymm='KKK' ! asymter=0 endif ! write(*,*)'MM tersys',asymter,' asymm: :',tersys(asymter)%asymm ! this should change the asymmetry ! tersys(iz)%asymm=ch3 ! write(*,414) 414 format('Listing of quads and current asymmetries') ! mqmqavar=>ceq%phase_varres(lokcs)%mqmqaf ! this call lists current asymmetries ! parres=>ceq%phase_varres(lokcs) ! call varkappadefs(parres) ! write(*,*)'Back from varkappadefs' ! each varkappa has a box, just update the global newXupdate ! mqf=>phres%mqmqaf ! box=>mqf%compvar(1) ! newXupdate=box%lastupdate+1 ! we must update all varkappa, there are mqmqa_data%ncat*(mqmqa_data%ncat-1)/2 newXupdate=newXupdate+1 parres=>ceq%phase_varres(lokcs) do iz=1,mqmqa_data%ncat*(mqmqa_data%ncat-1)/2 ! asymter is the index in the tersys array of the teranry with new asymmetry ! old call varkappa1(iz,parres,asymter,new_toop) call varkappa1(iz,parres,asymter) ! write(*,*)'MM back from varkappa1',iz enddo ! repeat short listing the asymmetries write(*,3101)size(tersys) do iz=1,size(tersys) write(*,3201)iz,tersys(iz)%seq,(tersys(iz)%el(j4),j4=1,3),& tersys(iz)%isasym,tersys(iz)%asymm enddo write(*,3301) ! list new asymmetries write(*,415) 415 format('Listing new asymmetries') call varkappadefs(parres) ! call list_quads(i1) continue !.................................................... case(12) ! amend phase ... aqueous model write(*,*)'Not implemented yet' ! call set_phase_status_bit(lokph,PHAQ1) !.................................................... case(13) ! amend phase ... quasicemichal model (2 versions) call gparidx('Quasichemical type: ',cline,last,jp,3,& '?Amend quasichemical') if(jp.lt.0 .or. jp.gt.3) then write(*,*)'Value must be between 1 and 3' else qcmodel=jp endif ! write(kou,*)'Not implemented yet' ! Future model bits ! call set_phase_status_bit(lokph,PHQCE) ! call set_phase_status_bit(lokph,PHFACTCE) !.................................................... case(14) ! amend phase ... FCC_CVM_TETRAHEDRON MODEL write(kou,*)'Not implemented yet' ! call set_phase_status_bit(lokph,PHCVMCE) !.................................................... case(15) ! amend phase ... unused write(kou,*)'Not implemented' !.................................................... case(16) ! moved !.................................................... case(17) ! moved !.................................................... case(18) ! amend phase ... quit goto 100 END SELECT amendphase !------------------------- end of amend phase case(5) ! amend parameter write(kou,*)'Not implemented yet, only ENTER PARAMETER' !------------------------- case(6) ! amend bibliography (in gtp3D) call enter_bibliography_interactivly(cline,last,1,j4) !------------------------- case(7) ! amend TPFUN symbol write(kou,*)' *** Dangerous if you have several equilibria!' call gparcx('TP-fun symbol: ',cline,last,1,name1,' ',& '?Amend TPfun') call find_tpsymbol(name1,idef,xxx) if(gx%bmperr.ne.0) then write(*,*)'Ambiguouos or unknown symbol'; goto 990 endif if(idef.eq.0) then ! it is a function , this call just read the function starting with low T etc. call enter_tpfun_interactivly(cline,last,funstring,jp) ! this stores the tpfun, lrot<0 means the symbol already exists lrot=-1 ! last argument -1 means not reading from TDB file ! call store_tpfun(name1,funstring,lrot,.FALSE.) call store_tpfun(name1,funstring,lrot,-1) if(gx%bmperr.ne.0) goto 990 ! mark functions not calculated. This should be done in all ceq ... ceq%eq_tpres(lrot)%tpused(1)=-one ceq%eq_tpres(lrot)%tpused(2)=-one elseif(idef.eq.2) then write(*,*)'You cannot change an optimizing coefficients' goto 100 else ! it is a constant, you can change if call gparrdx('Value: ',cline,last,xxy,xxx,'?Amend TPfun') call capson(name1) call store_tpconstant(name1,xxy) endif !------------------------- case(8) ! amend constitution (also as ENTER CONST and SET PHASE ) call ask_phase_constitution(cline,last,iph,ics,lokcs,ceq) if(gx%bmperr.ne.0) goto 990 !------------------------- case(9) ! QUIT amend continue !------------------------- case(10) ! amend components write(*,*)'WARNING: not fully implemented yet' ! goto 100 if(associated(ceq%lastcondition)) then write(kou,*)'Warning: All your conditions will be removed' endif i2=1 line=' ' do i1=1,noel() call get_component_name(i1,line(i2:),ceq) i2=len_trim(line)+2 enddo aline=' ' call gparcdx('Give all new components: ',cline,last,& 5,aline,line,'?Amend components') ! option is a character with the new components ... call amend_components(aline,ceq) if(gx%bmperr.ne.0) goto 990 !------------------------- case(11) ! amend general call amend_global_data(cline,last) !------------------------- case(12) ! amend assessment result if(.not.allocated(firstash%eqlista)) then write(kou,*)'No assessment record' goto 100 elseif(nvcoeff.le.0) then write(kou,*)'No variable optimizing coefficients'; goto 100 elseif(nvcoeff.ne.nvcoeffdone) then write(kou,*)'No optimization made with these coefficients',& nvcoeff,nvcoeffdone goto 100 elseif(mexp.ne.mexpdone) then write(kou,*)'No optimization made with these experiments',& mexp,mexpdone goto 100 endif call gparix('Index of coefficent to change: ',cline,last,& analyze,NONE,'?Amend assess result') if(buperr.ne.0) goto 990 xxy=zero if(analyze.lt.0) then ! using a negative coefficient, restore saved coefficients ! if nvcoefdone and mxexp same write(*,*)'Trying to restore saved coefficients' if(nvcoeffsave.eq.nvcoeff .and. mexpsave.eq.mexp) then if(allocated(savedcoeff)) then ! if analyze < 0 then restore sevedcoeff i2=0 do j2=0,size(firstash%coeffstate)-1 if(firstash%coeffstate(j2).ge.10) then ! this a variable coefficient i2=i2+1 firstash%coeffscale(j2)=savedcoeff(1,i2) firstash%coeffstart(j2)=savedcoeff(2,i2) ! I am not sure if xxx should be savedcoeff or scale*start ... ??? xxx=savedcoeff(3,i2) firstash%coeffvalues(j2)=xxx firstash%coeffrsd(j2)=zero ! this should update all other places including TP function call change_optcoeff(firstash%coeffindex(j2),xxx) endif enddo deallocate(savedcoeff) err0(2)=savesumerr write(*,*)'Restored saved coefficients' else write(*,*)'No coefficients saved' endif else ! giving a negative number makes it possible to use ANALYZE again ! for another set of coefficients and experiments write(kou,*)'Cannot restore as variable coefficients ',& 'or experiments changed' if(allocated(savedcoeff)) deallocate(savedcoeff) endif goto 100 else if(.not.allocated(savedcoeff)) then ! when ANALYZE first time save the current set of variable coefficients allocate(savedcoeff(3,nvcoeff)) mexpsave=0 ! if already allocated mexpsave nonzero endif i2=0 xxy=zero do j2=0,size(firstash%coeffstate)-1 ! only active coefficients saved ... extract the one to be changed if(firstash%coeffstate(j2).ge.10) then i2=i2+1 if(mexpsave.eq.0) then savedcoeff(1,i2)=firstash%coeffscale(j2) savedcoeff(2,i2)=firstash%coeffstart(j2) savedcoeff(3,i2)=firstash%coeffvalues(j2) ! write(*,'(a,3(1pe14.6))')'saved: ',(savedcoeff(iz,i2),iz=1,3) firstash%coeffrsd(j2)=zero endif if(analyze.eq.j2) then cormatix=i2 xxy=savedcoeff(1,i2)*savedcoeff(3,i2) ! write(*,*)'Coefficient: ',cormatix,xxy endif endif enddo if(mexpsave.eq.0) then write(*,*)'Saved ',i2,'currently variable coefficients' ! save current sum of errors, nvcoeff and mexp savesumerr=err0(2) nvcoeffsave=nvcoeff; mexpsave=mexp endif endif ! if xxy is zero it is not an optimized coefficient if(xxy.eq.zero) then write(kou,*)'Specified coefficent not set as variable',analyze if(allocated(savedcoeff)) deallocate(savedcoeff); goto 100 endif ! ask for new value with the current value as default call gparrdx('New value: ',cline,last,xxx,xxy,'?Amend assess result') delta=(xxx-xxy)/firstash%coeffscale(analyze) ! write(*,*)'Delta: ',xxx-xxy,delta ! UNFINISHED ! Now all variable coefficients should be modified using the correlation matrix i2=0 do j2=0,size(firstash%coeffstate)-1 ! modify all other coefficient according to the correlation matrix ! new_value_i = old_value_i + correlation_matrix_ji * delta (where j=analyze) if(firstash%coeffstate(j2).ge.10) then i2=i2+1 xxx=firstash%coeffvalues(j2) xxy=xxx+cormat(cormatix,i2)*delta ! firstash%coeffvalues(j2)=xxy*firstash%coeffscale(j2) ! %coeffvalues should be of the order 1 ! No change of %coeffstart and %coeffscale firstash%coeffvalues(j2)=xxy xxz=xxy*firstash%coeffscale(j2) ! optimizing coefficients are also TP functions, we must update the ! TP function value!! I do not understand this and "list tp" is wrong ! but it seems to work. If I set the value *firstash%coeffscale it blows up! call change_optcoeff(firstash%coeffindex(j2),xxz) ! set RSD to zero firstash%coeffrsd=zero ! write(*,'(a,2i4,4(1pe12.4))')'New value: ',i2,j2,& ! xxx,cormat(cormatix,i2),delta,firstash%coeffvalues(j2) endif enddo write(*,*)'To calculate a new set of errors use OPTIMIZE' ! write(*,*)'Not implemented yet' !------------------------- case(13) ! amend OPTIMIZING_COEFF, (rescale or recover) if(.not.allocated(firstash%eqlista)) then write(*,*)'No assessment record allocated'; goto 100 endif call gparcdx('Should the coefficients be rescaled?',& cline,last,1,ch1,'N','?Amend optim coeff') if(ch1.eq.'y' .or. ch1.eq.'Y') then ! set start values to current values ! firstash%coeffstart=firstash%coeffvalues*firstash%coeffscale ! firstash%coeffscale=firstash%coeffstart ! Note the "current value" is "start value" times "scaling factor" ! firstash%coeffvalues=one do j2=0,size(firstash%coeffstate)-1 if(firstash%coeffstate(j2).ge.10) then call get_value_of_constant_index(firstash%coeffindex(j2),xxx) if(gx%bmperr.ne.0) then write(*,*)'Error getting value of assessment coefficient',j2 goto 100 endif ! write(*,*)'Assessment coefficient value: ',xxx ! Set all values equal to the current value of the TP variable ... firstash%coeffscale(j2)=xxx firstash%coeffstart(j2)=xxx firstash%coeffvalues(j2)=one ! call change_optcoeff(firstash%coeffindex(j2),xxx) endif enddo firstash%coeffrsd=zero call listoptcoeff(mexp,err0,.FALSE.,lut) if(allocated(cormat)) then deallocate(cormat) deallocate(tccovar) endif else call gparcdx('Do you want to recover the coefficients values?',& cline,last,1,ch1,'N','?Amend optim coeffs') if(ch1.eq.'y' .or. ch1.eq.'Y') then ! set current optimizing values back to start values ! firstash%coeffvalues=firstash%coeffstart*firstash%coeffscale do j2=0,size(firstash%coeffstate)-1 ! This affects only current optimizing coefficients!! if(firstash%coeffstate(j2).ge.10) then xxx=firstash%coeffstart(j2) firstash%coeffvalues(j2)=xxx/firstash%coeffscale(j2) ! we must also change the value of the associated TP variable ?? call change_optcoeff(firstash%coeffindex(j2),xxx) endif enddo ! no change of start value or scaling factor but zero RSD and sum of squares firstash%coeffrsd=zero if(allocated(cormat)) then deallocate(cormat) deallocate(tccovar) endif err0(2)=zero call listoptcoeff(mexp,err0,.FALSE.,lut) else write(kou,557) 557 format('Nothing done as there are no other amend',& ' optimizing option') endif endif !------------------------- case(14) ! AMEND EQUILIBRIUM intended to add to experimental list write(*,*)'Not implemented yet' !------------------------- case(15) ! AMEND REDUDANT composition sets write(*,*)'This will set all unstable additional composition sets',& ' as suspended' ll=0 call suspend_unstable_sets(ll,ceq) !------------------------- case(16) ! AMEND LINEs of calculated equilibria ! possible amendment of all stored equilibria as ACTIVE or INACTIVE call amend_stored_equilibria(axarr,maptop) !------------------------- case(17) ! AMEND START_CONSTITUTION for assessments ! copy constitutions from one equilibrium to another, to handle miscibility gaps ! Default from "previous" if(.not.allocated(firstash%coeffstate)) then write(kou,*)'This is used during assessments' ! to copy start values from one experimental equilibria to another goto 100 endif ll=max(1,ceq%eqno-1) call gparidx('From equilibrium number: ',cline,last,& fromeq,ll,'?Amend start_constitution') ! copy constitutions of non-suspended phases from fromeq to current equilibrium call copyfracs(fromeq,ceq) ! write(*,*)'Not implemented yet' !------------------------- case(18) ! Nothing defined write(*,*)'Not implemented yet' END SELECT amend !================================================================= ! calculate subcommands ! ['TPFUN_SYMBOLS ','PHASE ','NO_GLOBAL ',& ! 'TRANSITION ','QUIT ','GLOBAL_GRIDMIN ',& ! 'SYMBOL ','EQUILIBRIUM ','ALL_EQUILIBRIA ',& ! 'WITH_CHECK_AFTER','TZERO_POINT ','CAREFULLY ',& ! 'ONLY_GRIDMIN ','BOSSES_METHOD ','PARAEQUILIBRIUM ',& ! 'LIQUID_EET ',' ',' '] CASE(2) kom2=submenu(cbas(kom),cline,last,ccalc,ncalc,8,'?TOPHLP') calculate: SELECT CASE(kom2) CASE DEFAULT write(kou,*)'No such calculate command' goto 100 !------------------------- CASE(1) ! calculate TPFUN symbols , use current values of T and P call gparcdx('name: ',cline,last,5,name1,'*','?Calculate TPfun') lrot=0 iel=index(name1,'*') if(iel.gt.1) name1(iel:)=' ' ! as TP functions call each other force recalculation and calculate all ! even if just a single function is requested call change_optcoeff(-1,zero) ! write(*,*)'PM calc tp: ',notpf() do j4=1,notpf() ! write(*,*)'PM call eval_tpfun: ',notpf() call eval_tpfun(j4,ceq%tpval,val,ceq%eq_tpres) if(gx%bmperr.gt.0) goto 990 enddo if(name1(1:1).ne.'*') then once=.TRUE. 2009 continue call find_tpfun_by_name(name1,lrot) ! write(*,*)'cui: ',lrot,iel,gx%bmperr if(gx%bmperr.ne.0) then if(iel.eq.0) goto 990 gx%bmperr=0 else ! found function number from lrot ??? j4=lrot call eval_tpfun(j4,ceq%tpval,val,ceq%eq_tpres) if(gx%bmperr.gt.0) goto 990 if(once) then once=.FALSE. write(lut,2011)1,ceq%tpval endif write(lut,2012)j4,val if(iel.gt.1) goto 2009 endif else write(lut,2011)notpf(),ceq%tpval 2011 format(/'Calculating ',i6,' functions for T,P=',F10.2,1PE15.7/& 3x,'No F',11x,'F.T',9x,'F.P',9x,'F.T.T',& 7x,'F.T.P',7x,'F.P.P') ! call cpu_time(starting) do j4=1,notpf() call eval_tpfun(j4,ceq%tpval,val,ceq%eq_tpres) if(gx%bmperr.gt.0) goto 990 write(lut,2012)j4,val 2012 format(I5,1x,6(1PE12.4)) enddo ! call cpu_time(ending) endif ! write(kou,2013)ending-starting !2013 format('CPU time used: ',1pe15.6) !--------------------------------------------------------------- case(2) ! calculate phase, _all _only_g or _g_and_dgdy, etc ! asks for phase name and constitution. DO NOT ALLOW * by setting iph=-1 ! before calling! iph=-1 call ask_phase_constitution(cline,last,iph,ics,lokcs,ceq) if(gx%bmperr.ne.0) goto 990 ! if iph<0 then * has been given as phase name if(iph.lt.0) then write(kou,*)'Cannot loop for all phases' goto 100 endif ! subcommands for calculate phase ! ['ONLY_G ','G_AND_DGDY ','ALL_DERIVATIVES ',& ! 'CONSTITUTION_ADJ','DIFFUSION_COEFF ','QUIT '] ! defcp=1 kom3=submenu('Calculate what for phase?',cline,last,ccph,nccph,defcp,& '?TOPHLP') ! if(kom2.le.0) goto 100 ! ph-a ph-G ph-G+dg/dy defcp=kom3 lut=optionsset%lut ! use current value of T and P if(kom3.ne.4) then write(*,2015)ceq%tpval 2015 format('Using T=',F9.2,' K and P=',1pe14.6,& ' Pa, results in J/F.U.') endif rgast=globaldata%rgas*ceq%tpval(1) ! this is the number of moles formula units the user specified cpham=ceq%phase_varres(lokcs)%amfu calcphase: SELECT CASE(kom3) !....................................................... CASE DEFAULT write(kou,*)'Calculate phase subcommand error' !....................................................... case(1) ! calculate_phase .. calculate phase < > only G call calcg(iph,ics,0,lokres,ceq) if(gx%bmperr.ne.0) goto 990 parres=>ceq%phase_varres(lokres) write(lut,2031)(cpham*rgast*parres%gval(j4,1),j4=1,4) ! G=H-T*S; H=G+T*S; S=-G.T; H = G + T*(-G.T) = G - T*G.T write(lut,2032)cpham*parres%gval(1,1)/parres%abnorm(1),& cpham*(parres%gval(1,1)-ceq%tpval(1)*parres%gval(2,1))*rgast,& parres%abnorm(1) 2031 format(/'G, dG/dT dG/dP d2G/dT2:',4(1PE14.6)) 2032 format('G/RT, H, atoms/F.U:',3(1PE14.6)) ! also list contributions from calculated additions ...!!! call list_addition_values(lut,parres) !....................................................... case(2) ! calculate phase < > G and dG/dy call calcg(iph,ics,1,lokres,ceq) if(gx%bmperr.ne.0) goto 990 parres=>ceq%phase_varres(lokres) nofc=noconst(iph,ics,firsteq) write(lut,2031)(cpham*rgast*parres%gval(j4,1),j4=1,4) write(lut,2033) 2033 format('dG/dy: ... dG/dy_i is NOT THE CHEMICAL POTENTIAL of i!') write(lut,2041)(rgast*parres%dgval(1,j4,1),j4=1,nofc) 2041 format(9x,5e14.4) !....................................................... case(3) ! calculate phase < > all derivatives call gparidx('Number of times: ',cline,last,times,1,& '?Calculate phase ... loop') ! attempt to measure calcg_interal bottlenecks ! call cpu_time(starting) ! zputime=starting call tabder(iph,ics,times,ceq) if(gx%bmperr.ne.0) goto 990 ! write 20 values ! write(*,'(7(1pE11.3)/7E11.3/7E11.3)')zputime write(*,2042) 2042 format('Values are per mole formula unit'/& ' NOTE THAT dG/dy_i is NOT THE CHEMICAL POTENTIAL of i!') ! if(gx%bmperr.ne.0) goto 990 !....................................................... case(4,5) ! calculate phase with constitution_adjustment ! or derivatives of chemical potentials and mobility data ! convert to phase tuple here as that is used in the application call do jp=1,nooftup() ! if(phasetuple(jp)%phaseix.eq.iph .and. & if(phasetuple(jp)%ixphase.eq.iph .and. & phasetuple(jp)%compset.eq.ics) then ! write(*,*)'This is phase tuple ',jp goto 2044 endif enddo write(*,*)'No such tuple' goto 100 2044 continue phtup=>phasetuple(jp) ! Get current constitution of the phase call calc_phase_molmass(iph,ics,xknown,aphl,totam,xxy,xxx,ceq) if(gx%bmperr.ne.0) then write(*,*)'Error finding current composition' goto 990 endif ! ask for overall composition totam=one quest='Mole fraction of XX:' do nv=1,noel()-1 if(totam.gt.zero) then ! assume elements as components call get_component_name(nv,elsym,ceq) quest(18:19)=elsym ! prompt with current mole fraction: call gparrdx(quest,cline,last,xxy,xknown(nv),& '?Calculate phase adjust') if(buperr.ne.0) then buperr=0; xxy=zero endif if(xxy.gt.totam) then write(kou,*)'Fraction too large, set to ',totam xxy=totam endif else xxy=zero endif xknown(nv)=xxy totam=totam-xxy ! yarr is used here to provide an array for the chemical potentials yarr(nv)=ceq%cmuval(nv) enddo ! after loop nv=noel() call get_component_name(nv,elsym,ceq) write(kou,2088)elsym,totam 2088 format('Mole fraction of ',a,' set to ',F8.5) xknown(nv)=totam yarr(nv)=ceq%cmuval(nv) ! use current T and P if(kom3.eq.4) then ! constituent adjustment, the FALSE means not quiet call equilph1b(phtup,ceq%tpval,xknown,xxx,yarr,.FALSE.,ceq) if(gx%bmperr.ne.0) goto 990 write(kou,2087)xxx,(yarr(nv),nv=1,noel()) 2087 format(/'Calculated Gibbs energy/FU/RT: ',1pe14.6,& ' and the chemical potentials/RT:'/6(1pe12.4)) else !............................................. ! calculate phase diffusion: chem.pot derivatives and mobilities ! mugrad(I,J) are derivatives of the chemical potential of endmember I ! with respect to endmember J ! mobilities(i) is mobility of component i ! derivatives of mu and mobilities, the FALSE means not quiet ! CCI call get_sublattice_number(phtup%ixphase,nsub,ceq) allocate(nkl(nsub)) allocate(nsites(nsub)) call get_sublattice_structure(phtup%ixphase,phtup%compset,& nsub,nkl,nsites,ceq) nend=1 do nv=1,nsub nend = nend * nkl(nv) enddo deallocate(nkl) deallocate(nsites) allocate(mugrad(nend*nend)) allocate(mobilities(noel())) mugrad(:)=zero mobilities(:)=zero call equilph1d(phtup,ceq%tpval,xknown,yarr,.FALSE.,& nend,mugrad,mobilities,ceq) if(gx%bmperr.ne.0) goto 990 write(kou,2096)nend 2096 format(/'Chemical potential derivative matrix, dG_I/dn_J for ',& i3,' endmembers') write(kou,2094)(nv,nv=1,nend) 2094 format(3x,6(6x,i6)/(3x,6i12)) do nv=0,nend-1 ! An extra LF is generated when just 6 components!! use ll, kp j4, i2 write(kou,2095)nv+1,(mugrad(nend*nv+jp),jp=1,nend) !2095 format(i3,6(1pe12.4)/(3x,6e12.4)) 2095 format(i3,6(1pe12.4)/(3x,6e12.4)) enddo write(kou,2098)noel() 2098 format(/'Mobility values mols/m2/s ?? for',i3,' components') write(kou,2095)1,(mobilities(jp),jp=1,noel()) !CCI deallocate(mugrad) deallocate(mobilities) call list_defined_properties(lut) !CCI endif !....................................................... case(6) ! Quit ! write(*,*)'Not implemeneted yet' END SELECT calcphase ! set bits to warn that listings may be inconsistent ceq%status=ibclr(ceq%status,EQNOEQCAL) ceq%status=ibset(ceq%status,EQINCON) !---------------------------------- end of calculate phase case(3) ! calculate equilibrium without initial global minimization if(minimizer.eq.1) then ! Lukas minimizer, first argument=0 means do not use grid minimizer ! call calceq1(0,ceq) write(kou,*)'Not implemented yet' else call calceq2(0,ceq) ! check that invmat allocated and stored ! write(*,*)'inverted y: ',ceq%phase_varres(2)%cinvy(1,1) endif if(gx%bmperr.ne.0) then ceq%status=ibset(ceq%status,EQFAIL) goto 990 endif !---------------------------------- case(4) ! calculate transition call calctrans(cline,last,ceq) ! clear this bit so there there will be no warning the listing is inconsistent if(gx%bmperr.ne.0) goto 990 ceq%status=ibclr(ceq%status,EQINCON) !---------------------------------- case(5) ! quit goto 100 !----------------------------------------------------------- case(6) ! calculate global grid minimum ! This command is depreciated as it has been misunderstood write(*,2101) 2101 format('This command has been removed as it has been misunderstood.',& /'It calculated points on the Gibbs energy curves of the ',& ' different phases'/'to be used as start points for the',& ' actual minimization.'/'It is replaced by the command ',& '"CALCULATE ONLY_GRIDMIN".'//& 'In order to calculate the equilibrium use "C E".'/) goto 100 ! ! extract values for mass balance calculation from conditions call extract_massbalcond(ceq%tpval,xknown,totam,ceq) if(gx%bmperr.ne.0) goto 990 ! debug output ! write(*,2101)totam,(xknown(j4),j4=1,noel()) !2101 format('UI N&x: ',F6.3,9F8.5) ! generate grid and find the phases and constitutions for the minimum. ! Note: global_gridmin calculates for total 1 mole of atoms, not totam ! call global_gridmin(1,ceq%tpval,totam,xknown,nv,iphl,icsl,& ! iphl is dimensioned (1:maxel), maxel=100, it is destroyed inside merge_grid .. ! call global_gridmin(1,ceq%tpval,xknown,nv,iphl,icsl,& ! aphl,nyphl,yarr,cmu,iphl,ceq) call global_gridmin(1,ceq%tpval,xknown,nv,iphl,icsl,& aphl,nyphl,cmu,ceq) if(gx%bmperr.ne.0) goto 990 ! write(kou,2102)nv,(iphl(j4),icsl(j4),j4=1,nv) ! we should write phase tuples ... ?? write(kou,2102)nv,(iphl(j4),icsl(j4),j4=1,nv) 2102 format('Number of stable phases ',i2/13(i4,i2)) ! In some cases "c n" converges better if we scale with the total amount here do j4=1,nv call get_phase_compset(iphl(j4),icsl(j4),lokph,lokcs) ceq%phase_varres(lokcs)%amfu=totam*ceq%phase_varres(lokcs)%amfu enddo ! if set clear this bit so we can list the equilibrium if(btest(ceq%status,EQNOEQCAL)) ceq%status=ibclr(ceq%status,EQNOEQCAL) !2103 format('Stable phase ',2i4,': ',a) !--------------------------------------------------------------- case(7) ! calculate symbol ! call evaluate_all_svfun(kou,ceq) ! to calculate derivatives this must be in the minimizer module call gparcdx('Name ',cline,last,1,name1,'*','?Calculate symbol') ! always calculate all state variable functions as they may depend on eachother ! write(*,*)'UI: calculating all functions' call meq_evaluate_all_svfun(-1,ceq) if(gx%bmperr.ne.0) then ! ignore error unless inside macro write(*,*)'UI: error calculating all functions', gx%bmperr if(kiu.ne.kiud) goto 990 gx%bmperr=0 endif if(name1(1:1).eq.'*') then ! this calculate them again ... and lists the values call meq_evaluate_all_svfun(lut,ceq) else ! This code is also used in SHOW (command 25) call capson(name1) ! call find_svfun(name1,istv,ceq) call find_svfun(name1,istv) if(gx%bmperr.ne.0) goto 990 mode=1 actual_arg=' ' ! write(*,*)'UI: calculating the requested function!' xxx=meq_evaluate_svfun(istv,actual_arg,mode,ceq) if(gx%bmperr.ne.0) goto 990 write(*,2047)name1(1:len_trim(name1)),xxx 2047 format(a,'= ',1pe16.8) endif if(gx%bmperr.ne.0) goto 990 !--------------------------------------------------------------- case(8) ! calculate equilibrium for current equilibrium ceq ! using the grid minimizer if(minimizer.eq.1) then ! Lukas minimizer, first argument=1 means use grid minimizer ! call calceq1(1,ceq) write(kou,*)'No longer available' else call calceq2(1,ceq) if(gx%bmperr.eq.4204) then ! if the error code is "too many iterations" try without grid minimizer ! it converges in many cases write(*,2048)gx%bmperr 2048 format('Error ',i5,', cleaning up and trying harder') gx%bmperr=0 call calceq2(0,ceq) endif endif ! calceq2 set appropriate bits for listing if(gx%bmperr.ne.0) then if(gx%bmperr.eq.4204) write(*,2049) 2049 format('If the conditions allow using the global minimizer, ',& ' try "CALCULATE CAREFULLY"') ceq%status=ibset(ceq%status,EQFAIL) goto 990 endif !--------------------------------------------------------------- case(9) ! calculate all equilibria ! rather complex to handle both parallel on non-parallel and with/without ! griminimizer ... if(allocated(firstash%eqlista)) then call gparcdx('With global minimizer? ',cline,last,1,ch1,'N',& '?Calculate all') ! mode=0 is without grid minimizer ?? mode=-1 ?? mode=1 if(ch1.eq.'N' .or. ch1.eq.'n') mode=0 ! if(ch1.eq.'N' .or. ch1.eq.'n') mode=-1 ! Seach for memory leaks call gparidx('How many times? ',cline,last,leak,1,'Calculate all') ! leak<0 means forever ... not allowed but leak=-1 generates output iz=leak if(leak.lt.1) leak=1 ! Minimize output listzero=.false. ! allow output file, if idef>1 no output idef=leak lut=optionsset%lut jp=0 i2=0 ! if compiled with parallel and gridminimizser set then calculate ! sequentially to create composition sets ! TEST THIS IN PARALLEL !!! call cpu_time(xxx) call system_clock(count=j4) threads=1 ! OPENMP parallel start !$ threads=omp_get_num_threads() !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> ! for parallelizing: ! YOU MUST UNCOMMENT USE OMP_LIB IN GTP3.F90 or PMON6.F90 ! YOU MUST USE THE SWICH -fopenmp FOR COMPILATION AND WHEN LINKING !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ! gridmin: if(mode.eq.1) then ! ! return here until leak is zero, a negative leak will never stop 2060 continue gridmin: if(mode.eq.1 .or. & btest(globaldata%status,GSNOPAR)) then ! if we use grid minimizer do not use parallel even if compiled with OpenMP do i1=1,size(firstash%eqlista) neweq=>firstash%eqlista(i1)%p1 jp=jp+1 if(neweq%weight.eq.zero) then if(listzero) write(kou,2050)neweq%eqno,neweq%eqname 2050 format('Zero weight equilibrium ',i4,2x,a) else i2=i2+1 call calceq3(mode,.FALSE.,neweq) if(gx%bmperr.ne.0) then write(kou,2051)gx%bmperr,neweq%eqno,neweq%eqname 2051 format(' *** Error code ',i5,' for equilibrium ',& i5,': ',a,' reset ') gx%bmperr=0 elseif(idef.eq.1) then ! extract names of stable phases jp=1 line=' ' do j3=1,nooftup() phtup=>phasetuple(j3) if(neweq%phase_varres(phtup%lokvares)%phstate.ge.PHENTSTAB) then call get_phasetup_name(j3,line(jp:)) jp=len_trim(line)+2 endif enddo call get_state_var_value('GMS ',gms,model,neweq) write(lut,2052)neweq%eqno,& trim(neweq%eqname),neweq%tpval(1),gms,trim(line) 2052 format(i4,2x,a,', T=',F8.2,', GMS= ',1pe12.4,', ',a) endif endif ! extra symbol calculations .... ! write(*,*)'Listing extra' if(idef.eq.1) then call list_equilibrium_extra(lut,neweq,plotunit0) if(gx%bmperr.ne.0) then write(kou,*)'Error ',gx%bmperr,' reset' gx%bmperr=0 endif endif enddo else ! Here we calculate without grid minimizer, if parallel we must turn off ! creating/removing composition sets!! not safe to do that!! !$ globaldata%status=ibset(globaldata%status,GSNOACS) !$ globaldata%status=ibset(globaldata%status,GSNOREMCS) ! !$OMP for an OMP directive ! !$ as "sentinel", will be compiled if -fopenmp ! this statement must not be inside a parallel do ... svss=size(firstash%eqlista) ! NOTE: $OMP threadprivate(gx) declared in TPFUN4.F90 ?? !----- $OMP parallel do private(neweq) !$OMP parallel do private(neweq,gms) paraloop: do i1=1,svss ! do i1=1,size(firstash%eqlista) ! the error code must be set to zero for each thread ?? !! jp=jp+1 gx%bmperr=0 neweq=>firstash%eqlista(i1)%p1 ! it seems stupid to get this value each loop but outside it is unity !$ threads=omp_get_num_threads() if(neweq%weight.eq.zero) then if(listzero) write(kou,2050)neweq%eqno,neweq%eqname else ! skip this output !-!$ if(.TRUE. .and. idef.eq.1) then !$ if(.TRUE. .and. iz.lt.0) then ! output only if "number of times" is negative above !$ write(*,663)'Equil/loop/thread/maxth/error: ',& !$ neweq%eqname,i1,omp_get_thread_num(),& !$ threads,gx%bmperr 663 format(a,a,5i5) ! calceq3 gives no output !$ call calceq3(mode,.FALSE.,neweq) !$ else ! note first argument zero means do not use grid minimizer call calceq3(mode,.FALSE.,neweq) !$ endif i2=i2+1 line=' ' if(gx%bmperr.ne.0) then write(kou,2051)gx%bmperr,neweq%eqno,neweq%eqname gx%bmperr=0 elseif(idef.eq.1) then if(threads.eq.1) then jp=1 do j3=1,nooftup() phtup=>phasetuple(j3) if(neweq%phase_varres(phtup%lokvares)%phstate.ge.PHENTSTAB) then call get_phasetup_name(j3,line(jp:)) jp=len_trim(line)+2 endif enddo endif call get_state_var_value('GMS ',gms,model,neweq) write(lut,2052)neweq%eqno,& trim(neweq%eqname),neweq%tpval(1),gms,trim(line) ! Listing extra' call list_equilibrium_extra(lut,neweq,plotunit0) if(gx%bmperr.ne.0) then gx%bmperr=0 endif endif endif enddo paraloop !- $OMP end parallel do not needed??? ! OPENMP parallel end loop ! allow composition sets to be created again !$ globaldata%status=ibclr(globaldata%status,GSNOACS) !$ globaldata%status=ibclr(globaldata%status,GSNOREMCS) endif gridmin call cpu_time(xxz) call system_clock(count=ll) xxy=ll-j4 ! or should i2 be used ?? write(*,669)i2,(xxz-xxx)/i2,xxy/i2 669 format(/'Calculated ',i8,' equlibria, average CPU and clock time',& F12.8,1x,F9.5) ! repeat this until leak is zero, if leak negative never stop. leak=leak-1 if(leak.ne.0) then goto 2060 endif ! call system_clock(count=ll) ! ?? jp ?? write(kou,664)jp,xxz-xxx,ll-j4,threads write(kou,664)xxz-xxx,ll-j4,threads !664 format('Calculated equilibria out of ',i5/& 664 format('Total CPU time: ',1pe12.4,' s and ',i7,' clockcycles',& ' using ',i4,' thread(s)') ! this unit may have been used to extract calculated data for plotting if(plotunit0.gt.0) then write(kou,670) 670 format('Closing a GNUPLOT file oc_many0.plt'/& 'that may need some editing before plotting') write(plotunit0,665)graphopt%plotend 665 format('e'/a) !665 format('e'/'pause mouse'/) close(plotunit0) ! UNFINISHED possibly we could reopen the file again and make oopies ! of tha data to avoid manual editing endif else write(kou,*)'You must first SET RANGE of experimental equilibria' endif !--------------------------------------------------------------- case(10) ! calculate with_check_after ! this is same as "calculate no_grid" but with automatic grid check after ! we must set global bit 18 and then clear it ! If bit 20 is set we will clear it now and set it afterwards if(btest(globaldata%status,GSNORECALC)) then globaldata%status=ibclr(globaldata%status,GSNORECALC) temporary=.TRUE. else temporary=.FALSE. endif globaldata%status=ibset(globaldata%status,GSTGRID) ! calculate with no grid before but check after call calceq2(0,ceq) if(gx%bmperr.ne.0) then ceq%status=ibset(ceq%status,EQFAIL) endif ! reset bit GSTGRID and maybe GSNORECALC globaldata%status=ibclr(globaldata%status,GSTGRID) if(temporary) & globaldata%status=ibset(globaldata%status,GSNORECALC) !------------------------------------------------------- case(11) ! CALCUALTE TZERO ! The degrees of freedom must be zero ll=degrees_of_freedom(ceq) if(ll.ne.0) then write(*,*)'You must have zero degrees of freedoms for this' goto 100 endif write(kou,*)'You should have calculated an equilibrium',& ' close to the T0 point' ! ask for 2 phases and which condition to vary ! try to remember the phases ... user may try several times if(dummy(1:1).ne.' ') dummy=name2 call gparcdx('First phase ',cline,last,1,name2,dummy,'?Tzero') call find_phase_by_name(name2,iph,ics) if(gx%bmperr.ne.0) goto 990 if(dummy(1:1).ne.' ') dummy=name3 call gparcdx('Second phase ',cline,last,1,name3,dummy,'?Tzero') call find_phase_by_name(name3,iph2,ics) if(gx%bmperr.ne.0) goto 990 dummy=name3 call list_conditions(kou,ceq) if(tzcond.eq.0) then j2=1 else j2=tzcond endif call gparidx('Release condition number',cline,last,tzcond,j2,'?Tzero') call tzero(iph,iph2,tzcond,xxx,ceq) if(gx%bmperr.ne.0) goto 990 write(*,*)'Equal Gibbs energy at:' call list_conditions(kou,ceq) ! a warning when list equilibria ceq%status=ibset(ceq%status,EQINCON) !------------------------------------------------------- ! case(12) ! merged with case(14) !------------------------------------------------------- case(13) ! Only gridmin no merge ! extract values for mass balance calculation from conditions call extract_massbalcond(ceq%tpval,xknown,totam,ceq) if(gx%bmperr.ne.0) goto 990 ! debug output ! write(*,2101)totam,(xknown(j4),j4=1,noel()) !2101 format('UI N&x: ',F6.3,9F8.5) ! generate grid and find the phases and constitutions for the minimum. ! Note: global_gridmin calculates for total 1 mole of atoms, not totam ! call global_gridmin(1,ceq%tpval,totam,xknown,nv,iphl,icsl,& ! iphl is dimensioned (1:maxel), maxel=100, it is destroyed inside merge_grid .. ! call global_gridmin(1,ceq%tpval,xknown,nv,iphl,icsl,& ! aphl,nyphl,yarr,cmu,iphl,ceq) temporary=.false. if(.not.btest(globaldata%status,GSNOMERGE)) then temporary=.true. globaldata%status=ibset(globaldata%status,GSNOMERGE) endif call global_gridmin(1,ceq%tpval,xknown,nv,iphl,icsl,& aphl,nyphl,cmu,ceq) if(temporary) globaldata%status=ibclr(globaldata%status,GSNOMERGE) if(gx%bmperr.ne.0) goto 990 ! In some cases "c n" converges better? if we scale with the total amount here?? do j4=1,nv call get_phase_compset(iphl(j4),icsl(j4),lokph,lokcs) ceq%phase_varres(lokcs)%amfu=totam*ceq%phase_varres(lokcs)%amfu enddo ! if set clear this bit so we can list the equilibrium if(btest(ceq%status,EQNOEQCAL)) ceq%status=ibclr(ceq%status,EQNOEQCAL) ! write(kou,2102)nv,(iphl(j4),icsl(j4),j4=1,nv) ! we should write phase tuples ... ?? write(kou,2102)nv,(iphl(j4),icsl(j4),j4=1,nv) !------------------------------------------------------- case(12,14) ! Calculate carefully the equilibrium (bosses_method) ! extract values for mass balance calculation from conditions call system_clock(count=startoftime) call cpu_time(start2) call extract_massbalcond(ceq%tpval,xknown,totam,ceq) if(gx%bmperr.ne.0) goto 990 call global_gridmin(1,ceq%tpval,xknown,nv,iphl,icsl,& aphl,nyphl,cmu,ceq) if(gx%bmperr.ne.0) goto 990 j4=1 if(kom.eq.14) j4=0 ! first parameter 0 means bosses_method, 1 means carefully call calculate_carefully(j4,ceq) if(gx%bmperr.ne.0) goto 990 call system_clock(count=endoftime) call cpu_time(finish2) call get_state_var_value('GS ',xxx,name1,ceq) if(gx%bmperr.ne.0) gx%bmperr=0 write(*,654)finish2-start2,endoftime-startoftime,xxx 654 format('Final result: ',1pe12.4,' cpu seconds, ',& i7,' cc, G=',1pe15.7,' J/mol') !------------------------------------------------------- case(15) ! CALCULATE PARAEQUILIBRIUM write(kou,876) 876 format('You should have calculated an equilibrium',& ' close to the paraequilibrium'/& 'and suspended all but the two phases involved') ! ask for 2 phases and the fast diffusing element ! try to remember the phases ... user may use the command several times if(dummy(1:1).ne.' ') dummy=name2 call gparcdx('Matrix phase ',cline,last,1,name2,dummy,& '?Calculate paraeq') call find_phasetuple_by_name(name2,tupix(1)) if(gx%bmperr.ne.0) goto 990 if(dummy(1:1).ne.' ') dummy=name3 call gparcdx('Growing phase ',cline,last,1,name3,dummy,& '?Calculate paraeq') call find_phasetuple_by_name(name3,tupix(2)) if(gx%bmperr.ne.0) goto 990 dummy=name3 ! call list_conditions(kou,ceq) call gparcdx('Fast diffusing element',cline,last,1,& elsym,parael,'?Calculate paraeq') call capson(elsym) call find_element_by_name(elsym,icond) parael=elsym call calc_paraeq(tupix,icond,xpara,meqrec,meqrec1,ceq) ! set a warning when list result ceq%status=ibset(ceq%status,EQINCON) if(gx%bmperr.ne.0) goto 990 write(kou,877)trim(elsym),xpara 877 format(/'Paraequilibrium fractions of ',a,': ',2F10.6/& 'Please note that the phase amounts are not adjusted,',& ' only the compositions'/) ! what are the conditions?? ! call list_conditions(kou,ceq) !------------------------------------------------------- case(16) ! CALCULATE LIQUID_EET, check how TZERO is calculated ll=degrees_of_freedom(ceq) if(ll.ne.0) then write(*,*)'You must have zero degrees of freedoms for this' goto 100 endif write(kou,878) 878 format(/'The Equi-Entropy T is the temperature where a solid phase ',& 'has the same entropy'/'as the liquid phase. This can be ',& 'considered as the limit of stability of the'/'solid phase ',& 'even if its Gibbs energy may become lower than the Gibbs ',& 'energy'/'of the liquid at an even higher T. This command ',& 'varies T or a composition'/'of the phase to find EET. ',& 'It may fail if there is no EET for the phase.'& //'You should have calculated an equilibrium',& ' close to the EET point already.') ! ask for liquid and another phase name and a condition to vary ! remember the phases ... a user may try several times dummy='LIQUID ' call gparcdx('The liquid phase ',cline,last,1,name2,dummy,'?EET ') call find_phase_by_name(name2,iph,ics) if(gx%bmperr.ne.0) goto 990 if(dummy(1:1).ne.' ') dummy=name3 call gparcdx('The solid phase ',cline,last,1,name3,dummy,'?EET ') call find_phase_by_name(name3,iph2,ics) if(gx%bmperr.ne.0) goto 990 dummy=name3 call list_conditions(kou,ceq) if(eetcond.eq.0) then j2=1 else j2=eetcond endif call gparidx('Release condition number',cline,last,eetcond,j2,'?EET') call liquid_eet(iph,iph2,eetcond,xxx,ceq) if(gx%bmperr.ne.0) then ! Failed calculation normally means T is negative, try to set it to 1 ! write(*,*)'Value of T: ',ceq%tpval(1), gx%bmperr ! ceq%tpval(1)=one ! does not change T ??? Why? goto 990 endif write(*,'(/a)')'The two phases has equal entropy at:' call list_conditions(kou,ceq) ! a warning when list equilibria ceq%status=ibset(ceq%status,EQINCON) !------------------------------------------------------- case(17) ! CALCULATE ?? write(kou,*)'Not implemented yet' !------------------------------------------------------- case(18) ! CALCULATE ?? write(kou,*)'Not implemented yet' END SELECT calculate !================================================================= ! SET SUBCOMMANDS ! ['CONDITION ','STATUS ','ADVANCED ',& ! 'LEVEL ','INTERACTIVE ','REFERENCE_STATE ',& ! 'QUIT ','ECHO ','PHASE ',& ! 'UNITS ','LOG_FILE ','WEIGHT ',& ! 'NUMERIC_OPTIONS ','AXIS ','INPUT_AMOUNTS ',& ! 'VERBOSE ','AS_START_EQUILIB','BIT ',& ! 'OPTCOEFF_VARIABL','OPTCOEFF_SCALED ','LMDIF_ACCURACY ',& ! 'RANGE_EXPER_EQU ','OPTCOEFF_FIXED ','SYSTEM_VARIABLE ',& ! 'INITIAL_T_AND_P ','LINEAR_SYSTEM ','GRID_GENERATOR '] CASE(3) ! SET SUBCOMMANDS ! disable continue optimization ! iexit=0 ! iexit(2)=1 kom2=submenu(cbas(kom),cline,last,cset,ncset,1,'?TOPHLP') if(kom2.le.0) goto 100 set: SELECT CASE(kom2) CASE DEFAULT write(kou,*)'Set subcommand error' !----------------------------------------------------------------------- CASE(1) ! set condition if(btest(globaldata%status,GSNOPHASE)) then write(kou,*)'You have no data!' goto 100 endif call set_condition(cline,last,ceq) !------------------------------------------------------------------ CASE(2) ! set status for elements, species, phases, constituents name1='STATUS of' kom3=submenu(name1,cline,last,cstatus,ncstat,3,'?TOPHLP') setstatus: SELECT CASE(kom3) !................................................................. CASE DEFAULT write(kou,*)'Set status subcommand error' !................................................................. case(1) ! set status element suspend/restore call gparcx('Element symbol: ',cline,last,1,name1,' ',& '?Set status element') call find_element_by_name(name1,iel) if(gx%bmperr.ne.0) goto 100 call gparcdx('New status: ',cline,last,1,ch1,'SUSPEND',& '?Set status element') call capson(ch1) if(ch1.eq.'S') then call change_element_status(name1,1,ceq) else ! restore element call change_element_status(name1,0,ceq) endif !................................................................. case(2) ! set status species suspend/restore call gparcx('Species symbol: ',cline,last,1,name1,' ',& '?Set status species') call find_species_record(name1,loksp) if(gx%bmperr.ne.0) goto 100 call gparcdx('New status: ',cline,last,1,ch1,'SUSPEND',& '?Set status species') call capson(ch1) if(ch1.eq.'S') then call change_species_status(name1,1,ceq) else call change_species_status(name1,0,ceq) endif !................................................................. case(3) ! set status phase (ENTERED, FIX, DORMANT, SUSPEND or HIDDEN) ! Now allow multiple phase names and *S, *D and *E ! argument 5 means whole input line call gparcx('Phase name(s): ',cline,last,5,line,'=',& '?Set status phase') string=line 3017 continue ll=index(string,'=') if(ll.eq.0) then call gparcx('More phase name(s): ',cline,last,5,line,'=',& 'Set status phase') string(len_trim(string)+2:)=line goto 3017 endif !3018 continue ! exttract first letter after = (if any) j4=ll call getext(string,j4,1,name1,' ',iph) ch1=name1(1:1) ! if user has given "=e 0" then keep the amount is cline cline=string(j4:) string(ll:)=' ' ! write(*,*)'s1: ',j4,cline(1:len_trim(cline)) if(ch1.eq.' ') then ! if ll==1 then input was finished by equal sign, ask for status call gparcdx(& 'New status S(uspend), D(ormant), E(ntered) or F(ixed)?',& cline,last,1,name1,'E','?Set status phase') ch1=name1(1:1) else last=0 endif nystat=99 call capson(ch1) ! new values of status ?? if(ch1.eq.'S') nystat=phsus if(ch1.eq.'D') nystat=phdorm if(ch1.eq.'E') nystat=phentered if(ch1.eq.'F') nystat=phfixed ! if(ch1.eq.'H') nystat=phhidden ! no longer available if(ch1.eq.'N') nystat=5 if(nystat.eq.99) then write(kou,*)'No such status' goto 100 endif xxx=zero ! write(*,*)'s2: ',last,cline(1:len_trim(cline)) if(nystat.eq.phentered .or. nystat.eq.phfixed) then call gparrdx('Amount: ',cline,last,xxx,zero,& 'Set status phase amount') endif call change_many_phase_status(string,nystat,xxx,ceq) if(gx%bmperr.ne.0) goto 100 !................................................................. CASE(4) ! set status constituent write(kou,*)'Not implemented yet' !................................................................. case(5) ! set status subcommand status for ? write(kou,*)'Not implemented yet' !................................................................. case(6) ! set status subcommand status for ? write(kou,*)'Not implemented yet' END SELECT setstatus !----------------------------------------------------------- case(3) ! set ADVANCED subcommands ! default is WORKING_DIRECT ! subsubcommands to SET ADVANCED ! character (len=16), dimension(ncadv) :: cadv=& ! ['EQUILIB_TRANSFER','QUIT ','SYMBOL ',& ! 'GRID_DENSITY ','SMALL_GRID_ONOFF','MAP_SPECIALS ',& ! 'GLOBAL_MIN_ONOFF','OPEN_POPUP_OFF ','WORKING_DIRECTRY',& ! 'HELP_POPUP_OFF ','EEC_METHOD ','LEVEL ',& ! 'NO_MACRO_STOP ','PROTECTION ','IGNORE_MACRO_ERR',& ! 'XTDB_DEFAULTS ',' ',' '] name1='Advanced command' ! kom3=submenu(name1,cline,last,cadv,ncadv,4,'?TOPHLP') ! changed default to working_directory kom3=submenu(name1,cline,last,cadv,ncadv,9,'?TOPHLP') advanced: select case(kom3) !................................................................. CASE DEFAULT write(kou,*)'Set advanced subcommand error' !................................................................. ! SET ADVANCED EQUILIB_TRANSFER ! transfer a ceq record from map results%savedceq to eqlista ! so it can be used interactivly case(1) if(.not.associated(maptop)) then write(kou,*)'There are no results from map or step' goto 100 else write(kou,3100)maptop%saveceq%free-1 3100 format('Saved ceq records from 1 to ',i3) endif write(kou,*)'To transfer CEQ from result area to current' call gparidx('Saved ceq number',cline,last,icon,1,& 'Set advanced transfer') if(icon.gt.0 .and. icon.lt.maptop%saveceq%free) then name1='COPIED_RESULTS_' i2=len_trim(name1)+1 call wriint(name1,i2,icon) write(*,*)'Equilibrium name: ',i2,': ',name1 call enter_equilibrium(name1,i1) if(gx%bmperr.ne.0) goto 990 write(*,*)'Created equilibrium ',i1 ! note... this will overwrite the name ... eqlista(i1)=maptop%saveceq%savedceq(icon) ! maybe not possible, eqlista is maybe protected ... no it is not write(*,*)'Trying to change name ...' eqlista(i1)%eqname=name1 call selecteq(i1,ceq) else write(kou,*)'No such saved equilibrium' endif ! set bit that data may be inconsistent eqlista(i1)%status=ibset(eqlista(i1)%status,EQINCON) !................................................................. case(2) ! quit continue !................................................................. case(3) ! SET ADVANCED SYMBOL to connect with TP constants ! Set the SVCONST bit and allow setting a new value at the same time if(.not.allocated(firstash%eqlista)) then write(kou,*)'Not allowed as no assessment coefficients' goto 100 endif call gparcx('Symbol name: ',cline,last,1,name1,' ',& '?Set adv symbol') call capson(name1) do svss=1,nosvf() if(name1(1:16).eq.svflista(svss)%name) exit enddo if(svss.gt.nosvf()) then write(kou,*)'No such symbol'; goto 100 endif if(.not.btest(svflista(svss)%status,SVCONST)) then write(kou,*)'Can only be used for constants'; goto 100 endif ! Here the symbols can be set to be EXPORTED or EXPORTED to assess coeff call gparix('Coefficient index, 0-99?',cline,last,jp,0,& '?Export symbol') if(jp.le.0 .or. jp.gt.size(firstash%coeffvalues)) then write(*,*)'No such coefficent'; goto 100 endif ! nv is index to TP function for coefficient nv=firstash%coeffindex(jp) call gparcdx('Export or Import?',cline,last,1,ch1,'E',& 'EXPORT SYMBOL') if(ch1.eq.'E') then ! UNFINISHED svflista(svss)%status=ibset(svflista(svss)%status,SVEXPORT) ! use firstash% record to handle value transfer ! probably more firstash variables should be set firstash%coeffvalues(jp)=svflista(svss)%svfv ! trying to set bit and copy value to TPFUN ! impossible as tpfuns is private to general_thermodynamic_package !! ! tpfuns(nv)%status=ibset(tpfuns(nv)%status,TPEXPORT) ! save the index to coefficient in %eqnoval !! svflista(svss)%eqnoval=jp else ! UNFINISHED this must also set a bit in the TP function/assessment record svflista(svss)%status=ibset(svflista(svss)%status,SVIMPORT) ! trying to set bit and copy value to TPFUN ! tpfuns(nv)%status=ibset(tpfuns(nv)%status,TPIMPORT) endif !................................................................. case(4) ! SET ADVANCED GRID_DENSITY call gparidx('Level: ',cline,last,ll,1,'?Set adv grid-density') if(ll.eq.0) then ! this set GSOGRID, small grid and clears GSXGRID globaldata%status=ibset(globaldata%status,GSOGRID) globaldata%status=ibclr(globaldata%status,GSXGRID) globaldata%status=ibclr(globaldata%status,GSYGRID) write(kou,3110)'Sparse','set' elseif(ll.eq.1) then ! DEFAULT, all gridbits are cleared globaldata%status=ibclr(globaldata%status,GSXGRID) globaldata%status=ibclr(globaldata%status,GSOGRID) globaldata%status=ibclr(globaldata%status,GSYGRID) write(kou,3110)'Normal','set' 3110 format(a,' grid ',a) elseif(ll.eq.2) then ! set GSXGRID (and clear GSOGRID and GSYGRID) globaldata%status=ibclr(globaldata%status,GSOGRID) globaldata%status=ibset(globaldata%status,GSXGRID) globaldata%status=ibclr(globaldata%status,GSYGRID) write(kou,3110)'Dense','set' elseif(ll.eq.3) then ! set GSYGRID (and clear GSXGRID and GSOGRID) globaldata%status=ibclr(globaldata%status,GSOGRID) globaldata%status=ibclr(globaldata%status,GSXGRID) globaldata%status=ibset(globaldata%status,GSYGRID) write(kou,3110)'Only level 0, 1 and 2 implemented' else write(*,*)'Only level 0, 1 and 2 implemented' endif !................................................................. case(5) ! SET ADVANCED SMALL_GRID_ONOFF ! replaced by setting grid_density to 0 write(*,*)'Please use SET ADVANCED GRID 0' continue ! if(btest(globaldata%status,GSOGRID)) then ! globaldata%status=ibclr(globaldata%status,GSOGRID) ! write(kou,3110)'Small','reset' ! else ! set GSOGRID and clear GSXGRID if set ! globaldata%status=ibclr(globaldata%status,GSXGRID) ! globaldata%status=ibset(globaldata%status,GSOGRID) ! write(kou,3110)'Small','set' ! endif !................................................................. case(6) ! MAP_SPECIALS ll=mapglobalcheck if(ll.le.0) ll=10 call gparidx('Global test interval during STEP/MAP?: ',& cline,last,mapglobalcheck,ll,'?Set adv global onoff') ! if(nofixphfortip) then ! write(*,*)'Always using fix phase when mapping' ! nofixphfortip=.false. ! else ! write(*,*)'Map diagrams with tie-lines in phase ',& ! 'without fix phase' ! nofixphfortip=.true. ! endif ! write(*,*)'Not implemented yet' ! write(*,*)'end of case 6' !................................................................. case(7) ! GLOBAL_MIN_ONOFF call gparcx('Turn global minimization off?: ',cline,last,& 1,ch1,'N','?Set adv global onoff') if(ch1.eq.'Y' .or. ch1.eq.'y') then globaldata%status=ibset(globaldata%status,GSNOGLOB) write(*,*)'Global minimizer turned off' else globaldata%status=ibclr(globaldata%status,GSNOGLOB) write(*,*)'Global minimizer turned on' endif ! if(btest(globaldata%status,GSNOGLOB)) then ! globaldata%status=ibclr(globaldata%status,GSNOGLOB) ! write(*,*)'Global minimizer turned on' ! else ! globaldata%status=ibset(globaldata%status,GSNOGLOB) ! write(*,*)'Global minimizer turned off' ! endif ! write(*,*)'Not implemented yet' !................................................................. case(8) ! OPEN_POPUP_OFF call gparcdx('Turn off popup for open? ',cline,last,& 1,ch1,'Y','?Set adv open popup') if(ch1.eq.'Y') then ! nopopup is declared in metlib3.F90 module ! nopenpopup is declared in metlib3.F90 module nopenpopup=.TRUE. write(kou,*)'Popup windows for open files turned off' else nopenpopup=.FALSE. write(kou,*)'Popup windows for open files enabled' endif !................................................................. case(9) ! WORKING DIRECTORY write(kou,*)'Current working directory: ',trim(workingdir) write(kou,*)'To change please select an OCM file in the directory' ! default extension (1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT, 6=XTDB, 7=DAT ! IMPORTANT: extensions also in utilities/ftinydialog.F90/ftinyopen !!!! ! try to set current working directory as input to allow editing ! cline=workingdir ! last=len_trim(cline) ! call gparcx('New: ',cline,last,1,string,trim(workingdir),& ! '?Set adv workdir') ! The promt here is never displayed ... ztyp=3 call gparfilex('Select new working directory',& cline,last,1,string,' ',ztyp,'?Set adv workdir') inquire(file=string,exist=logok) if(.not.logok) then write(*,*)'No such directory, working directory not changed' elseif(trim(workingdir).ne.trim(string)) then ! strip away any file name (up to last / or \) j4=len_trim(string) ch1=string(j4:j4) ! write(*,*)'P6 wdir: ',trim(string),' ',ch1,j4 do while(j4.gt.0 .and. .not.(ch1.eq.'/' .or. ch1.eq.'\')) j4=j4-1 ch1=string(j4:j4) ! write(*,*)'P6 wdir: ',trim(string),' ',ch1,j4 enddo string(j4:)=' ' ! this is a gfortran special extension call chdir(string,i1) if(i1.ne.0) then write(*,*)'Failed change working directory',i1 else write(*,'(a,a)')'New working directory: ',trim(string) workingdir=string endif endif ! write(*,*)'Cannot be changed' !................................................................. case(10) ! HELP_POPUP_OFF call gparcdx('Turn off popup help? ',cline,last,& 1,ch1,'Y','?Set adv help popup') if(ch1.eq.'Y') then ochelp%htmlhelp=.FALSE. htmlhelp=.FALSE. else htmlhelp=.TRUE. string=browser call gparcdx('Browser including full path ',& cline,last,1,browser,string,'?Set adv help popup') string=htmlfile call gparcdx('HTML help file including full path ',& cline,last,1,htmlfile,string,'?Set adv help popup') call init_help(browser,htmlfile) if(.not.ochelp%htmlhelp) write(kou,*)& 'Error initiating html help' endif !................................................................. case(11) ! SET ADVANCED EEC_METHOD call gparcdx('Turn on equi-entropy criterion (EEC)?',& cline,last,1,ch1,'Y','?Set adv EEC') if(ch1.eq.'Y' .or. ch1.eq.'y') then !check if there is a phase with liquid but set!! anyliq: do j4=1,noph() if(test_phase_status_bit(j4,PHLIQ)) exit anyliq enddo anyliq ! if we have not found any liquid j4>noph() here !! if(j4.gt.noph()) then write(kou,*)'No liquid phase! Set bit 10 of liquid phase' goto 100 endif call gparrdx('Low T limit (min 10)?',cline,last,xxx,1.0D3,& '?Set adv EEC') if(xxx.gt.1.0D1) then ! set_eec_check is in minimizer/matsmin.F90 ! call set_eec_check(xxx) globaldata%sysreal(1)=xxx endif else write(*,*)'EEC method for solids turned off as answer not Y' ! call set_eec_check(zero) globaldata%sysreal(1)=zero endif !................................................................. case(12) ! SET ADVANCED LEVEL call gparcdx('I am an beginner of OC: ',cline,last,1,ch1,'N',& '?Set adv level') if(ch1.eq.'Y') then globaldata%status=ibset(globaldata%status,1) write(*,*)'Bon courage!' else call gparcdx('I am an expert of OC: ',cline,last,1,ch1,'N',& '?Set adv level') if(ch1.eq.'Y') then globaldata%status=ibset(globaldata%status,2) write(*,*)'Felicitations!' else write(*,*)'Sorry, not yet' endif endif !................................................................. case(13) ! NO_MACRO_STOP on/off call gparcdx('Ignore macro @&: ',cline,last,1,ch1,'Y',& '?Set adv no-macro-stop') ! iox(8) is declared in metlib4 if(ch1.ne.'Y') then iox(8)=0 else iox(8)=1 endif !................................................................. case(14) ! PROTECTION call gparrdx('Code',cline,last,proda,zero,'?Set adv protect') call gparrdx('Privilege',cline,last,privilege,zero,& '?Set adv protect') !................................................................. case(15) ! IGNORE_MACRE_ERRORS normally a macro error returns inter continue !................................................................. case(16) ! SET ADVANCED XTDB_DEFAULTS dummy=lowtdef call gparcdx('Default low T limit',cline,last,1,lowtdef,dummy,& '?Set adv xtdb') unary1991=.FALSE. if(lowtdef.eq.'298.15 ') unary1991=.TRUE. dummy=hightdef call gparcdx('Default high T limit',cline,last,1,hightdef,dummy,& '?Set adv xtdb') ch1='N' call gparcdx('Include model descriptions (Y to include)',& cline,last,1,chz,ch1,'?Set adv xtdb') if(chz.eq.'Y') then includemodels=.TRUE. else includemodels=.FALSE. endif dummy=eldef call gparcdx('Default elements (NONE to remove)',& cline,last,1,eldef,dummy,'?Set adv xtdb') if(dummy(1:5).eq.'NONE ') eldef=' ' dummy=bibrefdef ! argument 4 equal to 5 means the whole line is read call gparcdx('Default bibiographic reference (One line!)',& cline,last,5,bibrefdef,dummy,'?Set adv xtdb') !................................................................. case(17) ! nit used continue !................................................................. case(18) ! not used continue end select advanced !----------------------------------------------------------- case(4) write(*,*)'Unused' !----------------------------------------------------------- ! end of macro excution (can be nested) case(5) ! set INTERACTIVE call macend(cline,last,logok) ! if this was the startupmacro set it false and possibly read an inline macro .. ! NOTE a startup macro can call other macros ... if(kiu.eq.kiud) startupmacro=.false. ! macropath=' ' ! write(*,*)'Macro terminated' !----------------------------------------------------------- case(6) ! set REFERENCE_STATE call gparcx('Component name: ',cline,last,1,name1,' ',& '?Set reference phase') call find_component_by_name(name1,iel,ceq) if(gx%bmperr.ne.0) goto 100 call gparcx('Reference phase: ',cline,last,1,name1,'SER ',& '?Set reference phase') if(name1(1:4).eq.'SER ') then write(kou,*)'Reference state is stable phase at 298.15 K and 1 bar' ! this means no reference phase, SER is at 298.15K and 1 bar iph=-1 else call find_phase_by_name(name1,iph,ics) if(gx%bmperr.ne.0) goto 100 ! temperature * means always to use current temperature xxy=-one call gparrx('Temperature: /*/: ',cline,last,xxx,xxy,& '?Set reference phase') ! write(*,*)'problem: ',buperr,xxx,xxy,one ! when calling gparr the default was not "set" as default and rubbish returned ! now the default is always the default even if not shown if(buperr.ne.0) then buperr=0 tpa(1)=-one elseif(xxx.le.zero) then tpa(1)=-one else tpa(1)=xxx endif xxy=1.0D5 call gparrdx('Pressure: ',cline,last,xxx,xxy,& '?Set reference phase') if(xxx.le.zero) then tpa(2)=xxy else tpa(2)=xxx endif endif call set_reference_state(iel,iph,tpa,ceq) if(gx%bmperr.eq.0) then ! write(kou,3104) 3104 format(' You may have to make a new calculation before the',& ' correct values'/& ' of chemical potentials or other properties are shown.') endif !----------------------------------------------------------- case(7) ! quit goto 100 !----------------------------------------------------------- case(8) ! set ECHO call gparcdx('On?',cline,last,1,ch1,'Y','?Set echo') if(ch1.eq.'Y' .or. ch1.eq.'y') then j4=1 else j4=0 endif call set_echo(j4) !----------------------------------------------------------- case(9) ! set PHASE subcommands (constitution, status) call gparcx('Phase name: ',cline,last,1,name1,' ',& '?Set phase') call find_phase_by_name(name1,iph,ics) if(gx%bmperr.ne.0) then if(name1(1:2).eq.'* ') then iph=-1 gx%bmperr=0 else goto 990 endif endif ! kom3=submenu(cbas(kom),cline,last,csetph,nsetph,2,'?TOPHLP') ! write(*,*)'submenu promt: ',cbas(kom) kom3=submenu('Set for phase what?',cline,last,csetph,nsetph,2,& '?TOPHLP') setphase: SELECT CASE(kom3) CASE DEFAULT write(kou,*)'Set phase status subcommand error' goto 100 !............................................................ case(1) ! quit continue !............................................................ ! begin code copied from 3045 case(2) ! SET PHASE STATUS if(iph.gt.0) then j4=get_phase_status(iph,ics,text,i1,xxx,ceq) if(gx%bmperr.ne.0) goto 100 if(xxx.ge.zero) then write(kou,3046)text(1:i1),xxx 3046 format('Current status is ',a,' with ',1pe15.6,& ' formula units.') else write(kou,3047)text(1:i1) 3047 format('Current status is ',a) endif endif call gparcdx(& 'Suspend, Dormant, Entered, Fixed, Hidden or Not hidden?',& cline,last,1,ch1,'SUSPEND','?Set phase status') nystat=99 call capson(ch1) ! new values of status ?? if(ch1.eq.'E') nystat=phentered if(ch1.eq.'S') nystat=phsus if(ch1.eq.'D') nystat=phdorm if(ch1.eq.'F') nystat=phfixed if(ch1.eq.'H') nystat=phhidden ! not avail if(ch1.eq.'N') nystat=5 if(nystat.eq.99) then write(kou,*)'No such status' goto 100 endif xxx=zero if(nystat.eq.phentered .or. nystat.eq.phfixed) then call gparrdx('Amount: ',cline,last,xxx,zero,& '?Set phase amount') endif call change_phase_status(iph,ics,nystat,xxx,ceq) if(gx%bmperr.ne.0) goto 100 if(iph.gt.0) then j4=get_phase_status(iph,ics,text,i1,xxy,ceq) if(gx%bmperr.ne.0) goto 100 if(xxy.ge.zero) then write(kou,3048)text(1:i1),xxy 3048 format('New status is ',a,' with ',1pe15.6,& ' formula units.') else write(kou,3049)text(1:i1) 3049 format('New status is ',a) endif else write(kou,*)'New status set for all phases' endif ! end code copied from 3045 !............................................................ case(3:4) !set phase default_constit wildcard allowed, also AMOUNT ! write(*,*)'SET PHASE AMOUNT or DEFAULT_CONST',kom3,iph,ics if(kom3.eq.3) then ! set default constituntion of phase ! call set_default_constitution(iph,ics,ceq) call ask_default_constitution(cline,last,iph,ics,ceq) else ! set phase amount call gparrdx('Amount: ',cline,last,xxx,zero,& '?Set phase constitution') call set_phase_amounts(iph,ics,xxx,ceq) endif !............................................................ ! subsubsub command case(5) ! set phase bits if(iph.lt.0) then write(kou,*)'Wildcards not allowed in this case' goto 100 endif call get_phase_record(iph,lokph) kom4=submenu('Set which bit?',cline,last,csetphbits,nsetphbits,9,& '?TOPHLP') phasebit: SELECT CASE(kom4) CASE DEFAULT ! allow any bit changes for experts ... if(btest(globaldata%status,GSADV)) then call getint(cline,last,ll) if(ll.ge.0 .and. ll.le.31) then write(kou,*)'Ahh, you are an expert ... changing bit: ',ll if(test_phase_status_bit(lokph,ll)) then call clear_phase_status_bit(lokph,ll) write(kou,*)'Clearing bit ',ll else call set_phase_status_bit(lokph,ll) endif else write(kou,*)'Illegal bit number',ll endif else write(kou,*)'Set phase bit subcommand error' endif !............................................................ case(1) ! FCC_PERMUTATIONS FORD ! if check returns .true. it is not allowed to set FORD or BORD if(check_minimal_ford(lokph)) goto 100 write(*,*)' *** WARNING: Depreceated command, use AMEND PHASE' call set_phase_status_bit(lokph,PHFORD) case(2) ! BCC_PERMUTATIONS BORD if(check_minimal_ford(lokph)) goto 100 write(*,*)' *** WARNING: Depreceated command, use AMEND PHASE' call set_phase_status_bit(lokph,PHBORD) case(3) ! IONIC_LIQUID_MDL this may require tests and ! other bits changed .. write(*,*)' *** WARNING: set by enter phase I2SL' ! write(kou,*)'Cannot be set interactivly yet, only from TDB' ! call set_phase_status_bit(lokph,PHIONLIQ) case(4) ! AQUEOUS_MODEL write(*,*)'Not implemented yet' ! call set_phase_status_bit(lokph,PHAQ1) case(5) ! QUASICHEMICAL write(*,*)'Not implemented yet' ! call set_phase_status_bit(lokph,PHQCE) case(6) ! FCC_CVM_TETRADRN write(*,*)'Not implemented yet' ! call set_phase_status_bit(lokph,PHCVMCE) case(7) ! FACT_QUASICHEMCL write(*,*)'Not implemented yet' ! call set_phase_status_bit(lokph,PHFACTCE) case(8) ! NO_AUTO_COMP_SET, do not create compsets automatically call set_phase_status_bit(lokph,PHNOCS) case(9) ! QUIT write(kou,*)'No other bits changed' case(10) ! EXTRA_DENSE_GRID, this can be toggled ... if(test_phase_status_bit(lokph,PHXGRID)) then write(kou,*)'Bit already set, is cleared' call clear_phase_status_bit(lokph,PHXGRID) else write(kou,*)'Extra gridpoints for this phase.' call set_phase_status_bit(lokph,PHXGRID) endif case(11) ! PHEECLIQ bit for EEC phase ! call set_phase_status_bit(lokph,PHFHV) write(*,*)'Bit for set for EEC liquid' call set_phase_status_bit(lokph,PHEECLIQ) call clear_phase_status_bit(lokph,PHID) end SELECT phasebit !............................................................ case(6) ! SET PHASE ... CONSTITUTION iph and ics set above call ask_phase_new_constitution(cline,last,iph,ics,lokcs,ceq) END SELECT setphase !------------------------------------------------------------- case(10) ! set UNIT (for state variables) write(kou,*)'Not implemented yet' !------------------------------------------------------------- case(11) ! set LOG_FILE ! tinyfiles_dialog has difficult returning a non-existant file name ! the argument "-8" means open a log file for output maptopbug=.true. if(associated(maptop)) then ! write(*,*)'PMON maptop bug 1A?',associated(maptop) maptopbug=.false. endif ztyp=-8 call gparfilex('Log file name: ',cline,last,1,model,'oclog',ztyp,& '?Set logfile') name1=model(1:5) call capson(name1) if(maptopbug .and. associated(maptop)) then ! for unkown reason maptop has become associated here but was not 8 lines above! ! write(*,*)'PMON maptop bug 1B?',associated(maptop) nullify(maptop) write(*,*)'PMON clear link to maptop' endif if(name1(1:5).eq.'NONE ') then ! close log file call openlogfile(' ',' ',-1) logfil=0 write(*,*)'Log file closed' else if(len_trim(model).eq.0) then model='OCLOG.LOG' elseif(index(model,'.LOG ').eq.0) then ! model=trim(model)//'./OCLOG.LOG' model=trim(model)//'.LOG' endif ! write(*,*)'PMON maptop bug 1D?',associated(maptop) write(*,*)'Setting logfile to: "',trim(model),'"' call gparcx('Title: ',cline,last,5,line,' ','?Set logfile') call openlogfile(model,line,39) ! write(*,*)'PMON maptop bug 1D?',associated(maptop) if(buperr.ne.0) then write(kou,*)'Error opening logfile: ',buperr logfil=0 else write(*,'(a,a)')'Commands will be logged in file ',trim(model) logfil=39 endif endif ! write(*,*)'PMON maptop bug 2?',associated(maptop) !------------------------------------------------------------- case(12) ! set weight if(.not.allocated(firstash%eqlista)) then write(kou,*)'You must first set a range of experimental equilibria' goto 100 endif ! NOTE mexp must be updated to the correct number of EXPERIMENTS ! that is done by OPTIMIZE updatemexp=.true. mexp=0 call gparrdx('Weight ',cline,last,xxx,one,'?Set weight') if(buperr.ne.0) goto 100 ! The weight must be 0 or positive xxx=abs(xxx) call gparcdx('Equilibria (abbrev name) or range: ',cline,last,& 1,name1,'CURRENT','?Set weight') ! THINK HOW TO UPDATE MEXP!!! <<<<<<<<<<<<<<<<<< if(name1(1:8).eq.'CURRENT ') then if(ceq%eqname(1:20).eq.'DEFAULT_EQUILIBRIUM ') then write(kou,*)'You cannot set weight for the default equilibrium' else ceq%weight=xxx endif elseif(name1(1:1).eq.'*') then ! set this weight for all i2=0 do i1=1,size(firstash%eqlista) firstash%eqlista(i1)%p1%weight=xxx i2=i2+1 enddo write(kou,3066)i2 else ll=1 ! write(*,*)'trying to extract a number from: ',trim(name1) call getint(name1,ll,i1) bupp: if(buperr.eq.0) then ! user provide a singe number or a range, if range the negative number also call getint(name1,ll,i2) if(buperr.ne.0) then ! it was a single number buperr=0 i2=-i1 endif i2=-i2 ll=0 ! setwei: do j4=i1,i2 setwei: do j4=1,size(firstash%eqlista) if(firstash%eqlista(j4)%p1%eqno.ge.i1 .and. & firstash%eqlista(j4)%p1%eqno.le.i2) then firstash%eqlista(j4)%p1%weight=xxx ! write(*,*)'Changing weight for equilibrium ',& ! firstash%eqlista(j4)%p1%eqno ll=ll+1 endif enddo setwei write(kou,3066)ll else ! set this weight to all equilibria with name abbriviations fitting name1 buperr=0 call capson(name1) if(name1(1:1).ne.' ') then write(*,*)'Equilibra with names matching: ',trim(name1) i2=0 do i1=1,size(firstash%eqlista) if(index(firstash%eqlista(i1)%p1%eqname,& name1(1:len_trim(name1))).gt.0) then firstash%eqlista(i1)%p1%weight=xxx i2=i2+1 endif enddo else write(*,*)'No name given' endif write(kou,3066)i2 endif bupp 3066 format('Changed weight for ',i5,' equilibria') endif !------------------------------------------------------------- ! turn on/off global minimization, creating composition sets ! convergence limits, iterations, minimum constituent fraction, etc case(13) ! set NUMERIC_OPTIONS i2=ceq%maxiter call gparidx('Max number of iterations: ',cline,last,i1,i2,& '?Set numeric') if(i1.gt.0) then ceq%maxiter=i1 endif !------------ xxx=ceq%xconv call gparrdx('Max error in fraction: ',cline,last,xxy,xxx,& '?Set numeric') !CCI if(xxy.gt.default_minxconv) then ceq%xconv=xxy else ceq%xconv=default_minxconv endif !CCI !------------ what is this? not used in gtp3X.F90 xxx=ceq%gdconv(1) call gparrdx('Max cutoff driving force: ',cline,last,xxy,xxx,& '?Set numeric') if(xxy.gt.default_mingdconv) then ceq%gdconv(1)=xxy !CCI else ceq%gdconv(1)=default_mingdconv !CCI endif !------------ if the point between two gridpoints in a phase is less then merge xxx=ceq%gmindif call gparrdx('Min difference merging gridpoints: ',cline,last,& xxy,xxx,'?Set numeric') !CCI !strange old value was 1000 times lower -1e-5 in the test vs -1.e-2 as default if(xxy.gt.default_mingridmin) then ceq%gmindif=xxy else ceq%gmindif=default_mingridmin endif !CCI !------------------------------------------------------------- case(14) ! set axis if(btest(globaldata%status,GSNOPHASE)) then write(kou,*)'You have no data!' goto 100 endif i1=noofaxis+1 call gparidx('Axis number',cline,last,iax,i1,'?Set axis') if(iax.lt.1 .or. iax.gt.maxax) then write(kou,3300)maxax 3300 format('Axis number must be between 1 and ',i1) goto 100 endif ! by giving a value of iax lesser than noofaxis one can change an already ! defined axis, values larger than i1 (=noofaxis+1) not allowed. if(iax.gt.i1) then iax=i1 write(kou,*)'Axis must be set in sequential order',& ', axis number set to ',iax endif ! as condition one may give a condition number followed by : ! or a single state variable like T, x(o) etc. if(iax.lt.i1) then ! set the current condition as default answer jp=1 call get_one_condition(jp,name1,axarr(iax)%seqz,ceq) if(gx%bmperr.ne.0) goto 990 jp=index(name1,'=') name1(jp:)=' ' ! set current axis limits as default dmin=axarr(iax)%axmin dmax=axarr(iax)%axmax else ! new axis, defaults 0 and 1 name1=' ' dmin=zero dmax=one endif ! reset default plot options call reset_plotoptions(graphopt,plotfile,textlabel) axplotdef=' ' call gparcdx('Condition varying along axis: ',cline,last,1,& text,name1,'?Set axis') call capson(text) ! if(text(1:1).eq.' ') goto 100 removeaxis: if(text(1:1).eq.' ' .or. text(1:4).eq.'NONE') then ! this means remove an axis, shift any higher axis down if(iax.lt.noofaxis) write(kou,*)'Shifting axis down' do i2=iax,noofaxis axarr(i2)=axarr(i2+1) enddo if(noofaxis.gt.1) then noofaxis=noofaxis-1 write(kou,*)'One axis removed' ! remove axplotdef for all axis!!! one may change from PD to step sep axplotdef=' ' endif goto 100 elseif(trim(name1).eq.trim(text)) then ! check if same variable, quit this IF loop continue else ! changed axis variable, set default limits dmin=zero dmax=one i1=len_trim(text) if(text(i1:i1).eq.':') then ! condition given as an index in the condition list terminated by : like "1:" i1=1 call getrel(text,i1,xxx) if(buperr.ne.0) then gx%bmperr=buperr; goto 990 endif i2=int(xxx) firstc=>ceq%lastcondition if(associated(firstc)) then firstc=>firstc%next pcond=>firstc%next i1=0 do while(.not.associated(pcond,firstc)) ! increment i1 only for active conditions as listed by list_condition if(pcond%active.eq.0) i1=i1+1 if(i1.eq.i2) goto 3310 pcond=>pcond%next enddo gx%bmperr=4131; goto 990 3310 continue else gx%bmperr=4131; goto 990 endif ! pcond points to condition record for axis, save in (map_axis) :: axarr ! check that it is not a fix phase condition (istv negative) if(pcond%statev.lt.0) then write(*,*)'Cannot set fix phase as axis' goto 100 endif ! copy the state variable to the axis record allocate(axarr(iax)%axcond(1)) axarr(iax)%axcond(1)=pcond%statvar(1) ! This is probably the only reference needed for the axis condition axarr(iax)%seqz=pcond%seqz axarr(iax)%more=0 ! remove axplotdef for all axis!!! axplotdef=' ' else ! a condition given as text ! check if axis variable is a condition, maybe create it if allowed ! write(*,*)'decoding axis condition: ',text(1:20) stvr=>stvrvar ! this call also accept state variable functions like t_c, cp (if entered) ! UNIFINISHED: but it also accepts unknown texts ... call decode_state_variable(text,stvr,ceq) if(gx%bmperr.ne.0) goto 990 ! write(*,*)'check if this state variable is a condition' pcond=>ceq%lastcondition i1=1; coeffs(1)=one ! call get_condition(i1,coeffs,istv,indices,iref,unit,pcond) call get_condition(i1,stvr,pcond) if(gx%bmperr.ne.0) then ! if new conditions are allowed then maybe enter this as condition write(*,*)'You must set the variable as a condition',& ' before setting it as axis' goto 990 endif axarr(iax)%nterm=pcond%noofterms axarr(iax)%istv=pcond%statev axarr(iax)%iref=pcond%iref axarr(iax)%iunit=pcond%iunit ! copy the state variable record to the axis record if(.not.allocated(axarr(iax)%axcond)) then allocate(axarr(iax)%axcond(1)) endif axarr(iax)%axcond(1)=pcond%statvar(1) axarr(iax)%seqz=pcond%seqz ! write(*,*)'Condition sequential index: ',axarr(iax)%seqz axarr(iax)%more=0 ! remove axplotdef for all axis!!! axplotdef=' ' endif endif removeaxis ! dmin=axvalold(1,iax) ! dmin=zero once=.TRUE. 3570 continue call gparrdx('Minimal value:',cline,last,xxx,dmin,'?Set axis') if(buperr.ne.0) goto 100 axarr(iax)%axmin=xxx ! axval(1,iax)=xxx ! dmax=axvalold(2,iax) ! dmax=one call gparrdx('Maximal value:',cline,last,xxx,dmax,'?Set axis') if(buperr.ne.0) goto 100 if(xxx.le.axarr(iax)%axmin) then write(kou,*)'Maximal value must be higher than minimal' if(once) then once=.FALSE. goto 3570 else write(kou,*)'Return to command level' goto 100 endif endif axarr(iax)%axmax=xxx ! axval(2,iax)=xxx ! default step 1/100 of difference ?? several diagram failed ... ! default step 1/40 of difference, same as TC ... dinc=0.025*(axarr(iax)%axmax-axarr(iax)%axmin) ! default step 1/50 of difference, somethimes better, sometimes worse ... ! dinc=0.02*(axarr(iax)%axmax-axarr(iax)%axmin) call gparrdx('Increment:',cline,last,xxx,dinc,'?Set axis') if(buperr.ne.0) goto 100 if(xxx.lt.0.01*dinc) then ! someone (me) set xxx=0 and got a lot of trouble ... write(*,*)'Too small increment not allowed.' xxx=0.01*dinc endif axarr(iax)%axinc=xxx ! iax can be smaller than noofaxis if an existing axis has been changed if(iax.gt.noofaxis) noofaxis=iax ! write(*,3602)(axval(i,iax),i=1,3) !3602 format(/'axlimits: ',3(1pe12.4)) !------------------------------------------------------------- case(15) ! set input amounts call set_input_amounts(cline,last,ceq) !------------------------- case(16) ! SET VERBOSE ! This toggles verbose for all commands. ! it is always turned of fwhen a command is finished ... ! write(kou,3603)'on/off',globaldata%status,GSVERBOSE if(btest(globaldata%status,GSSILENT)) then ! turn off VERBOSE and turn on SILENT ! globaldata%status=ibclr(globaldata%status,GSVERBOSE) globaldata%status=ibclr(globaldata%status,GSSILENT) write(kou,3603)'off',globaldata%status else ! turn on VERBOSE ! globaldata%status=ibset(globaldata%status,GSVERBOSE) globaldata%status=ibset(globaldata%status,GSSILENT) write(kou,3603)'on',globaldata%status,GSSILENT endif 3603 format('Silent is turned ',a,2x,z8,i5) ! if(ocv()) then ! write(kou,*)'Verbose mode on' ! else ! write(kou,*)'Verbose mode off' ! endif !------------------------- ! the current set of condition sill be used as start equilibrium for map/step ! Calculate the equilibrium and ask for a direction. case(17) ! SET AS_START_EQUILIBRIUM if(noofaxis.lt.2) then write(kou,*)'You must set two axis first' goto 100 endif call calceq2(1,ceq) if(gx%bmperr.ne.0) goto 990 call gparidx('Give an axis direction: ',cline,last,ndl,2,& '?Set as start equil') if(buperr.ne.0) goto 990 if(abs(ndl).gt.noofaxis) then write(kou,*)'Direction must be +/- axis number' goto 100 endif ! Store a copy of equilibrium and the direction in a equential list ! starting with starteq eqname='_START_EQUILIBRIUM_' jp=len_trim(eqname)+1 noofstarteq=noofstarteq+1 call wriint(eqname,jp,noofstarteq) call copy_equilibrium(neweq,eqname,ceq) if(gx%bmperr.ne.0) goto 990 neweq%multiuse=ndl starteqs(noofstarteq)%p1=>neweq ! if(associated(starteq)) then ! starteq%nexteq=neweq%eqno ! else ! starteq=>neweq ! starteq%nexteq=0 ! write(*,*)'Starteq next',starteq%nexteq ! endif write(*,*)'A copy of current equilibrium linked as start eqilibrium' !------------------------- case(18) ! SET BIT (all kinds of bits) just global implemented ! ['EQUILIBRIUM ','GLOBAL ','PHASE ',& kom3=submenu('Set which status word?',cline,last,csetbit,nsetbit,2,& '?TOPHLP') setbit: SELECT CASE(kom3) CASE DEFAULT write(kou,*)'SET BIT subcommand error' !................................................................ case(1) ! equilibrium status word ! EQNOTHREAD=0, EQNOGLOB=1, EQNOEQCAL=2, EQINCON=3, & ! EQFAIL=4, EQNOACS=5, EQGRIDTEST=6, EQGRIDCAL=7 3610 continue ! write(kou,*)'Current equlibrium status: ',ceq%status write(kou,3612)ceq%status call gparidx('Which bit? ',cline,last,ll,-1,'?Set status bit') if(cline(1:1).eq.'?') then write(kou,3612)ceq%status 3612 format('Set/reset bits of the equilibrium status word,',/& 'Bit If set means',/& ' 0 No threads allowed (no parallel calculation)',/& ' 1 No global minimization allowed',/& ' 2 No equilibrium has been calculated',/& ' 3 Conditions and results not consistent',/'-'/& ' 4 Last equilibrium calculation failed',/& ' 5 No automatic generation of composition sets',/& ' 6 Equilibrim tested by global minimizer',/& ' 7 Last results are from a grid minimization'/& 'Current value of status word: ',z8) goto 3610 endif if(ll.lt.0 .or. ll.gt.7) then write(kou,*)'No such bit, no bit changed' else call gparcdx('Do you want to set the bit?',cline,last,1,& ch1,'Y','?Set status bit') if(ch1.eq.'Y') then ceq%status=ibset(ceq%status,ll) write(kou,3614)'set',ceq%status 3614 format('Bit ',a,', new equilibrium status word: ',z8) else ceq%status=ibclr(ceq%status,ll) write(kou,3614)'cleared',ceq%status endif endif ! write(*,*)'Not implemented yet' !................................................................ ! maybe change order of questions, maybe check name exits etc .... case(2) ! global status word 3708 continue ! subroutine TOPHLP forces return with ? in position cline(last:last) write(kou,3709)globaldata%status 3709 format('Current global status word (hexadecimal): ',z8) call gparidx('Set/reset global status bit (from 0-31, -1 quits):',& cline,last,ll,-1,'?Global status bits') if(cline(1:1).eq.'?') then write(kou,3710) 3710 format('Set/reset bits of global status word ',& ' (only experts should change these) '/& 'Bit If set means:'/& ' 0 user is a beginner'/& ' 1 user is experienced'/& ' 2 user is an expert'/& ' 3 global minimizer will not be used'/'-'/& ' 4 global minimizer must not merge comp.sets.'/& ' 5 there are no data'/& ' 6 there are no phases'/& ' 7 comp.sets must not be created automatically'/'-'/& ' 8 comp.sets must not be deleted automatically'/& ' 9 data has changed since last save'/& '10 verbose is on'/& '11 verbose is permanently on'/'-'/& '12 supress warning messages'/& '13 no cleanup after an equilibrium calculation'/& '14 denser grid used in grid minimizer'/& '15 calculations in parallel is not allowed'/'-'/& '16 no global test at node points during STEP/MAP'/& '17 the components are not the elements'/& '18 test if equilibrium global AFTER calculation'/& '19 use old grid minimizer'/'-'/& '20 do not recalculate if global test AFTER fails'/& '21 use old map algorithm'/& '22 no automatic startpoints for MAP'/& '23-31 unused') goto 3708 endif if(ll.lt.0 .or. ll.gt.31) then write(kou,*)'No bit changed' elseif(btest(globaldata%status,GSADV) .or. ll.le.2) then ! user must have expert bit set to change any other bit than the user type bit call gparcdx('Do you want to set the bit?',cline,last,1,& ch1,'Y','?Global status bits') if(ch1.eq.'Y') then globaldata%status=ibset(globaldata%status,ll) write(kou,3617)ll,' set',globaldata%status 3617 format('Bit ',i2,a,', new equilibrium status word: ',z8) else globaldata%status=ibclr(globaldata%status,ll) write(kou,3617)ll,' cleared',globaldata%status endif ! replaced by question above ! if(btest(globaldata%status,ll)) then ! globaldata%status=ibclr(globaldata%status,ll) ! write(*,3711)'cleared',globaldata%status !3711 format('Bit ',a,', new value of status word: ',z8) ! else ! globaldata%status=ibset(globaldata%status,ll) ! write(*,3711)'set',globaldata%status ! endif if(.not.btest(globaldata%status,GSADV)) then ! if expert/experienced bit is cleared ensure that occational user bit is set globaldata%status=ibset(globaldata%status,GSOCC) endif else write(kou,*)'Cannot be changed unless you have expert status' endif !.................................................... case(3) ! set bit phase ... write(*,*)'Please use set phase ... bit ' end select setbit !------------------------- case(19) ! set optcoeff_variabl, 0 to 99 if(.not.btest(firstash%status,AHCOEF)) then write(kou,*)'No optimizing coefficients' goto 100 endif ! zero the relative standard deviation firstash%coeffrsd=zero call gparix('Coefficent index/range: ',cline,last,i1,-1,& '?Set variable coeff') if(i1.lt.0 .or. i1.ge.size(firstash%coeffstate)) then ! write(*,*)'Dimension ',size(firstash%coeffstate) ! coefficients have indices 0 to size(firstash%coeffstate)-1 write(kou,*)'No such coefficient' goto 100 endif ! upper limit must be negative and must follow directly on same line ! write(*,*)'pmon: ',last,': ',cline(last:last) if(last.lt.len(cline) .and. cline(last:last).eq.'-') then ! pick up upper range limit as a negative value, ! the question should thus never be asked ... last=last-1 call gparix('Upper index (as negative): ',cline,last,i2,-i1,& '?Set variable coeff') if(i2.lt.0) then ! a negative value, its positive value must be >=i1 i2=-i2 if(i2.lt.i1) then i2=i1 write(kou,*)'Illegal range, setting variable just: ',i1 endif ! elseif(i1.ge.size(firstash%coeffstate)) then ! coefficients have indices 0 to size(firstash%coeffstate)-1 ! i2=size(firstash%coeffstate)-1 ! write(kou,*)'Setting all coefficients fixed after ',i1 else ! any other value ignored i2=i1 write(kou,*)'Not understood, setting variable just: ',i1 endif else i2=i1 endif ! write(*,*)'pmon: ',i1,i2 ! possible loop if i2>i1 j4=i1 3740 continue ! write(*,*)'pmon: ',i1,i2,j4 xxy=firstash%coeffvalues(j4)*firstash%coeffscale(j4) ! this coefficient is not used, igore unless i1=i2 if(i2.gt.i1 .and. firstash%coeffstate(j4).eq.0) goto 3745 if(firstash%coeffstate(j4).lt.10) then nvcoeff=nvcoeff+1 endif firstash%coeffstate(j4)=10 if(i1.eq.i2) then ! when setting a single coefficient variable ask for value call gparrdx('Start value: ',cline,last,xxx,xxy,& '?Set variable coeff') if(buperr.ne.0) goto 100 ! set new value call change_optcoeff(firstash%coeffindex(j4),xxx) if(gx%bmperr.ne.0) goto 100 firstash%coeffvalues(j4)=one firstash%coeffscale(j4)=xxx firstash%coeffstart(j4)=xxx else ! coefficient used, set it variable with current value xxx=xxy endif 3745 if(i2.gt.j4) then j4=j4+1 goto 3740 endif write(kou,*)'Number of variable coefficients are ',nvcoeff !------------------------- case(20) ! set optcoeff_scaled write(*,*)'Not implemeneted yet' ! if(firstash%coeffstate(i1).lt.10) then ! nvcoeff=nvcoeff+1 ! endif ! zero the relative standard deviation ! firstash%coeffrsd=zero !------------------------- case(21) ! set lmdif_accuracy, always propose the default! optacc=1.0D-3 call gparrdx('LMDIF accuracy: ',cline,last,xxx,optacc,& '?Set optimizer conditions') write(kou,'("LMDIF accuracy set to ",1pe12.4)')xxx optacc=xxx !------------------------- case(22) ! set range_experimental_equilibria if(allocated(firstash%eqlista)) then write(kou,*)'Experimental equilibria already entered' goto 100 endif call gparidx('First equilibrium number: ',cline,last,i1,2,& '?Set range') j4=noeq() call gparidx('Last equilibrium number: ',cline,last,i2,j4,& '?Set range') if(i2.lt.i1) then write(kou,*)'No equilibria?' goto 100 endif ! allocate the firstash%eqlista array and store equilibrium numbers j4=i2-i1+1 firstash%firstexpeq=i1 write(*,*)'Allocating firstash%eqlista ',j4,i1 allocate(firstash%eqlista(j4)) do i2=1,j4 firstash%eqlista(i2)%p1=>eqlista(i1) i1=i1+1 enddo ! close the plotdataunits! do i1=1,9 if(plotdataunit(i1).gt.0) then write(plotdataunit(i1),22)graphopt%plotend 22 format('e'/a) !22 format('e'/'pause mouse'/) close(plotdataunit(i1)) plotdataunit(i1)=0 endif enddo ! write(*,*)'Not implemeneted yet' !------------------------- case(23) ! set optcoeff_fixed ! if(.not.allocated(firstash%eqlista)) then ! check not needed? ! write(*,*)'Error "firstash%eqlista" not allocated' ! goto 100 ! endif if(.not.btest(firstash%status,AHCOEF)) then write(kou,*)'No optimizing coefficients' goto 100 endif ! zero the relative standard deviation firstash%coeffrsd=zero ! lower limit or range call gparix('Coeffient index/range: ',cline,last,i1,-1,& '?Set fix coeff') if(i1.lt.0 .or. i1.ge.size(firstash%coeffstate)) then ! write(*,*)'Dimension ',size(firstash%coeffstate) ! coefficients have indices 0 to size(firstash%coeffstate)-1 write(kou,*)'No such coefficient' goto 100 endif ! allow writing range on same line as 5-7 but also as 5 -7 on separate lines ! write(*,*)'pmon1: ',last,': ',cline(last:last) frange: if(last.lt.len(cline) .and. cline(last:last).eq.'-') then last=last-1 ! upper limit must be negative call gparix('Upper index limit (as negative): ',& cline,last,i2,-i1,'?Set fix coeff') if(i2.lt.0) then ! a negative value, its positive value must be >=i1 i2=-i2 if(i2.lt.i1) then i2=i1 write(kou,*)'Illegal range, setting fixed just: ',i1 elseif(i2.ge.size(firstash%coeffstate)) then i2=size(firstash%coeffstate)-1 endif elseif(i1.ge.size(firstash%coeffstate)) then ! coefficients have indices 0 to size(firstash%coeffstate)-1 i2=size(firstash%coeffstate)-1 write(kou,*)'Setting all coefficients fixed after ',i1 else ! any other value ignored i2=i1 write(kou,*)'Not understood, setting fixed just: ',i1 endif else i2=i1 endif frange ! possible loop if i2>i1 j4=i1 ! write(*,*)'pmon2: ',i1,j4 3720 continue xxy=firstash%coeffvalues(j4)*firstash%coeffscale(j4) if(i1.eq.i2) then ! A single coefficient, when fixing a single coefficinet ask for value call gparrdx('Fix value: ',cline,last,xxx,xxy,& '?Set fix coeff') if(buperr.ne.0) goto 100 ! set new value call change_optcoeff(firstash%coeffindex(j4),xxx) if(gx%bmperr.ne.0) goto 100 firstash%coeffvalues(j4)=one firstash%coeffscale(j4)=xxx firstash%coeffstart(j4)=xxx else call get_value_of_constant_index(firstash%coeffindex(j4),xxx) endif ! set as fixed without changing any min/max values (first time) ! write(*,*)'pmon3: ',xxx,firstash%coeffstate(j4) if(firstash%coeffstate(j4).gt.13) then write(kou,*)'Coefficient state wrong, set to 1' firstash%coeffstate(j4)=1 nvcoeff=nvcoeff-1 elseif(firstash%coeffstate(j4).ge.10) then firstash%coeffstate(j4)=max(1,firstash%coeffstate(j4)-10) nvcoeff=nvcoeff-1 elseif(xxx.ne.zero) then ! mark that the coefficient is fixed and nonzero firstash%coeffstate(j4)=1 else ! firstash%coeffstate(j4)=0 ! Fixed zero parameters are not listed firstash%coeffstate(j4)=-1 endif if(i2.gt.j4) then j4=j4+1 goto 3720 endif write(kou,3730)nvcoeff 3730 format('Number of variable coefficients are now ',i3) !------------------------- case(24) ! SET SYSTEM_VARIABLE write(kou,3733) 3733 format('Variable 2 is frequency of stability checks during step/map') call gparidx('System variable: ',cline,last,ll,0,& '?Set system variable') ! if(ll.gt.0 .and. ll.le.10) then if(ll.eq.2) then ! sysparam(2) used during STEP/MAP often to check if equilibrium is stable call gparidx('System variable value: ',cline,last,j4,0,& '?Set system variable') globaldata%sysparam(ll)=j4 else write(*,*)'No other variable can be changed' endif !------------------------- case(25) ! SET INITIAL_T_AND_P start values?, NOT CONDITIONS!! write(kou,3750)ceq%tpval 3750 format(/'NOTE: these are only local values, not conditions',& 2(1pe12.4)/) call gparrdx('New value of T: ',cline,last,xxx,1.0D3,& 'Set initial TP') if(buperr.ne.0) goto 100 ceq%tpval(1)=xxx call gparrdx('New value of P: ',cline,last,xxx,1.0D5,& '?Set initial TP') if(buperr.ne.0) goto 100 ceq%tpval(2)=xxx !------------------------- !CCI case(26) ! SET LINEAR_SYSTEM !------------ Splitsolver? indexSplitsolver = default_splitsolver call gparidx('Would you allow the splitting of the linear system? (1=Y; 0=N) : ',& cline,last, indexSplitsolver,0,'?Set LINEAR_SYSTEM') if((indexSplitsolver.eq.0).or.(indexSplitsolver.eq.1)) then ceq%splitsolver = indexSplitsolver else ceq%splitsolver = default_splitsolver endif !------------ Pre-conditioner? indexPrecond = default_precondsolver call gparidx('Would you enable the use of a Jacobi preconditioner? (1=Y; 0=N) : ',& cline,last, indexPrecond,0,'?Set LINEAR_SYSTEM') if((indexPrecond.eq.0).or.(indexPrecond.eq.1)) then ceq%precondsolver = indexPrecond else ceq%precondsolver = default_precondsolver endif !------------ Scale the change of phase amount? typeOfChange = default_typechangephaseamount call gparidx('How do scale all changes in phase amount with total number of atom ? (2=max, 1=sum; 0=one) : ',& cline,last, typeOfChange,0,'?Set LINEAR_SYSTEM') if((typeOfChange.eq.0).or.(typeOfChange.eq.1).or.(typeOfChange.eq.2)) then ceq%type_change_phase_amount = typeOfChange else ceq%type_change_phase_amount = default_typechangephaseamount endif !CCI !------------------------- case(27) ! SET GRID_GENERATOR continue END SELECT set !================================================================= ! ENTER with subcommand for element, species etc ! ['TPFUN_SYMBOL ','ELEMENT ','SPECIES ',& ! 'PHASE ','PARAMETER ','BIBLIOGRAPHY ',& ! 'CONSTITUTION ','EXPERIMENT ','QUIT ',& ! 'EQUILIBRIUM ','SYMBOL ','OPTIMIZE_COEFF ',& ! 'COPY_OF_EQUILIB ','COMMENT ','MANY_EQUILIBRIA ',& ! 'MATERIAL ','PLOT_DATA ','GNUPLOT_TERMINAL',& ! ' ',' ',' '] CASE(4) ! disable continue assessment optimization (not reelevant) ! iexit=0 ! iexit(2)=1 kom2=submenu(cbas(kom),cline,last,center,ncent,11,'?TOPHLP') enter: SELECT CASE(kom2) CASE DEFAULT write(kou,*)'Enter subcommand error' !--------------------------------------------------------------- ! maybe change order of questions, maybe check name exits etc .... CASE(1) ! enter TPFUN symbol (constants, functions, tables) call gparcx('TPfun name: ',cline,last,1,name1,' ','?Enter TPfun') if(buperr.ne.0) goto 990 ! if(badsymname(name1)) then if(.not.proper_symbol_name(name1,0)) then write(kou,*)'Bad symbol name' goto 990 endif ! check if already entered, call find_tpsymbol(name1,idef,xxx) if(gx%bmperr.ne.0) then ! new symbol, can be function, constant or table (??) gx%bmperr=0 call gparcdx('Function, constant or table? ',cline,last,1,name2,& 'FUNCTION ','?Enter TPfun') if(buperr.ne.0) goto 990 call capson(name2) if(compare_abbrev(name2,'FUNCTION ')) then ! this call just read the function call enter_tpfun_interactivly(cline,last,funstring,jp) if(gx%bmperr.ne.0) goto 990 ! here the function is stored lrot=0 ! call store_tpfun(name1,funstring,lrot,.FALSE.) ! last argument -1 means not reading from TDB file call store_tpfun(name1,funstring,lrot,-1) if(gx%bmperr.ne.0) goto 990 elseif(compare_abbrev(name2,'CONSTANT ')) then ! Enter a numeric constant call gparrdx('Value: ',cline,last,xxx,zero,'?Enter TPfun') call store_tpconstant(name1,xxx) elseif(compare_abbrev(name2,'TABLE ')) then write(kou,*)'Tables are not implemented yet' else write(kou,*)'No such type of symbol' endif else ! symbol already exist, idef=0 function, =1 constant, =2 oprimizing coefficient if(idef.eq.0) then write(kou,*)'Use AMEND to change existing TP function' elseif(idef.eq.2) then write(kou,*)'You cannot change values of optimizing ',& 'coefficients this way' else ! Values of constants can be changed here call gparrdx('New value: ',cline,last,xxy,xxx,'?Enter TPfun') if(buperr.ne.0) goto 990 call capson(name1) call store_tpconstant(name1,xxy) ! we must evaluate all TPFUNS in all equilibria to be sure value propagates! endif endif !--------------------------------------------------------------- case(2) ! enter element if(.not.allowenter(1)) then gx%bmperr=4125 goto 990 endif call gparcx('Element symbol: ',cline,last,1,elsym,' ',& '?Enter element') if(buperr.ne.0) goto 990 call capson(elsym) if(.not.(elsym(1:1).ge.'A' .and. elsym(1:1).le.'Z')) then write(*,*)'An element symbol must start with a letter A-Z' goto 100 endif call gparcdx('Element full name: ',cline,last,1,name1,elsym,& '?Enter element') call gparcdx('Element reference phase: ',cline,last,1,& name2,'SER ','?Enter element') call gparrdx('Element mass (g/mol): ',cline,last,mass,one,& '?Enter element') if(buperr.ne.0) goto 990 call gparrdx('Element H298-H0: ',cline,last,h298,zero,& '?Enter element') if(buperr.ne.0) goto 990 call gparrdx('Element S298: ',cline,last,s298,one,'?Enter element') if(buperr.ne.0) goto 990 ! call enter_element(elsym,name1,name2,mass,h298,s298) call store_element(elsym,name1,name2,mass,h298,s298) if(gx%bmperr.ne.0) goto 990 !--------------------------------------------------------------- case(3) ! enter species ! Allow entering species even if there are phases entered ! needed for the MQMQA model ! if(.not.allowenter(1)) then ! gx%bmperr=4125 ! goto 990 ! endif !>>> There may be problems with MQMQA quads such as Fe,Mn/SI1/4O,Al2/3O call gparcx('Species symbol: ',cline,last,1,name1,' ',& '?Enter species') ! check if it is an MQMQA quad name2=name1 call capson(name2) iz=index(name2,'/') if(iz.gt.0 .and. & (name2(iz+1:iz+1).ge.'A' .and. name2(iz+1:iz+1).le.'Z')) then ! A MQMQA species has a letter after the / ! In MQMQA species, the two sublattices indicated by / ! but we musr also separate species in same, for example: Fe,Mn/Si1/4O,Al2/3O mqmqass=' ' call gparcx('MQMQA specification: ',cline,last,5,& mqmqass,' ','?Enter MQMQA species') ! typically mqmqass is Na/Cl 6.0 6.0 2.4 (last values the FNN/SNN ratio ! or Mg,Na/Cl 6.00 3.00 3.00 etc. as in Solgsmax DAT files ! check species used before quad numbers must already be entered! ! mqmqanend should be negative at first call write(*,575)trim(name1),trim(mqmqass),mqmqanend 575 format('Call mqmqa_species: "',a,'" "',a,'" ',i5) call mqmqa_species(name1,mqmqass,mqmqanend) else ! A species with no / or an ionic / followed by + - or number call gparcx('Species stoichiometry: ',cline,last,1,name2,' ',& '?Enter species') call decode_stoik(name2,noelx,ellist,stoik) if(gx%bmperr.ne.0) goto 990 ! all species must be entered call enter_species(name1,noelx,ellist,stoik) endif if(gx%bmperr.ne.0) goto 990 !--------------------------------------------------------------- case(4) ! enter phase if(.not.allowenter(2)) then gx%bmperr=4125 goto 990 endif call enterphase(cline,last) !--------------------------------------------------------------- case(5) ! enter parameter only if there are phases if(btest(globaldata%status,GSNOPHASE)) then write(kou,*)'You must enter a phase before' goto 100 endif ! the last 0 means enter call enter_parameter_interactivly(cline,last,0) ! Strange things may happen when entering parameters interactively ! This was due to an error in tpfun package ... not yet fixed ... ?? call change_optcoeff(-1,zero) do j4=1,notpf() call eval_tpfun(j4,ceq%tpval,val,ceq%eq_tpres) if(gx%bmperr.gt.0) goto 990 enddo call change_optcoeff(-1,zero) if(gx%bmperr.ne.0) goto 990 !--------------------------------------------------------------- case(6) ! enter bibliography call enter_bibliography_interactivly(cline,last,0,j4) if(gx%bmperr.ne.0) goto 990 write(kou,*)'Bibliography number is ',j4 !--------------------------------------------------------------- case(7) ! enter constitution call ask_phase_constitution(cline,last,iph,ics,lokcs,ceq) if(gx%bmperr.ne.0) goto 990 !--------------------------------------------------------------- case(8) ! enter experiment ! almost the same as set_condition ... if(btest(globaldata%status,GSNOPHASE)) then write(kou,*)'You have no data!' goto 100 endif ! enter_experiments is in models/gtp3D ... call enter_experiment(cline,last,ceq) !--------------------------------------------------------------- case(9) ! enter QUIT goto 100 !--------------------------------------------------------------- case(10) ! enter equilibrium is always allowed if there are phases if(.not.allowenter(3)) then write(kou,*)'You must have entered your system first' goto 100 endif ! generate a default names line EQ_x ehere x is eqfree call geneqname(quest) call gparcdx('Name: ',cline,last,1,text,quest,'?Enter equilibrium') if(buperr.ne.0) goto 100 call enter_equilibrium(text,ieq) if(gx%bmperr.ne.0) goto 990 ! by default also select this equilibrium write(kou,303)ieq,trim(text) 303 format('Equilibrium number is ',i3,', name: ',a) call gparcdx('Select this equilibrium: ',cline,last,1,ch1,'Y',& '?Enter equilibrium') if(yeschk(ch1)) then call selecteq(ieq,ceq) ! COPY current values of entered symbols from first equilibrium ceq%svfunres=firsteq%svfunres endif ! write(*,*)'pmon: ',ceq%eqno,ieq !--------------------------------------------------------------- case(11) ! enter symbol (for state variables expressions) ! several questions asked inside this call call enter_svfun(cline,last,ceq) if(gx%bmperr.ne.0) goto 990 !--------------------------------------------------------------- ! enter optimizing coefficients called A00 to A99 (or whatever set as max) case(12) if(.not.allocated(firstash%coeffstate)) then call gparidx('Number of coefficients: ',cline,last,i1,100,& '?Enter coeffs') if(buperr.ne.0) goto 100 i1=i1-1 if(i1.lt.1) then write(*,*)'You must have at least 1 coefficient' goto 100 elseif(i1.gt.99) then write(*,*)'You cannot have more than 100 coefficient' goto 100 endif allocate(firstash%coeffvalues(0:i1)) allocate(firstash%coeffrsd(0:i1)) allocate(firstash%coeffscale(0:i1)) allocate(firstash%coeffstart(0:i1)) allocate(firstash%coeffmin(0:i1)) allocate(firstash%coeffmax(0:i1)) allocate(firstash%coeffindex(0:i1)) allocate(firstash%coeffstate(0:i1)) ! coeffvalues should be of the order of one firstash%coeffvalues=one firstash%coeffrsd=zero firstash%coeffscale=zero firstash%coeffstart=zero firstash%coeffmin=zero firstash%coeffmax=zero firstash%coeffindex=0 firstash%coeffstate=0 ! create the corresponding TP constants for coeffvalues call enter_optvars(j4) call makeoptvname(name1,i1) write(kou,556)name1(1:3),i1 556 format(/'Coefficients entered with symbols A00 to ',a/& 'Note that indices are from 0 to ',i2) do i2=0,i1 firstash%coeffindex(i2)=j4+i2 enddo firstash%status=ibset(firstash%status,AHCOEF) else write(kou,553)size(firstash%coeffstate) 553 format('You have already ',i3,' optimizing coefficients entered') endif call gparidx('Size of workspace: ',cline,last,lwam,2500,& '?Enter coeffs') ! if(lwam.gt.2000) lwam=2000 if(allocated(wam)) then deallocate(wam) deallocate(iwam) endif ! write(*,551)firstash%status !551 format('Assessment status word: ',z8) !--------------------------------------------------------------- ! enter copy_of equilibrium (for test!) case(13) ! Check if there is any phases, otherwise not allowed if(btest(globaldata%status,GSNOPHASE)) then write(kou,*)'Not allowed unless you have data!' goto 100 endif call gparcx('Name of new equilibrium: ',cline,last,1,text,' ',& '?Enter copyof') if(buperr.ne.0) goto 100 if(text(1:1).eq.' ') then write(*,*)'You must specify a unique name' goto 100 endif call copy_equilibrium(neweq,text,ceq) ! write(*,*)'Back from copy equilibrium' if(gx%bmperr.ne.0) goto 990 write(kou,*)'New equilibrium no: ',neweq%eqno !--------------------------------------------------------------- ! enter COMMENT for current equilibrium case(14) write(*,*)'Current equilibrium name: ',ceq%eqname call gparcx('One line text: ',cline,last,5,text,' ',& '?Enter comment') ceq%comment=text !--------------------------------------------------------------- ! enter MANY_EQUILIBRIA ! The plotdataunit array should be zero at first call, then the unit is opened ! (if there are any plot_data commands). It will remain open until ! a set range command is given case(15) ! write(*,*)'Working dir: ',trim(workingdir) call enter_many_equil(cline,last,plotdataunit) if(gx%bmperr.ne.0) goto 990 !--------------------------------------------------------------- ! enter MATERIAL ! ask for database, then major element, mass/mole fraction of elements ! read the database; jump possibly to SCHEIL/STEP calculation ! or simply ask for T and calculate equilibrium; case(16) call enter_material(cline,last,nv,xknown,ceq) if(gx%bmperr.ne.0) goto 990 xxy=firsteq%tpval(1) call gparrdx('Temperature ',cline,last,xxx,xxy,'?Enter material') ! set T and P cline='P=1E5 T=' i1=len_trim(cline)+1 call wrinum(cline,i1,10,0,xxx) i1=0 call set_condition(cline,i1,ceq) ! calculate the equilibrium call calceq2(1,ceq) if(gx%bmperr.ne.0) then ceq%status=ibset(ceq%status,EQFAIL) goto 990 endif !--------------------------------------------------------------- ! enter PLOT DATA ! the file ocmanyi.plt with unit plotdataunit(i) must already be open! ! it is opened in the enter_many_equilibria if there is a plot_data command case(17) call gparidx('Dataset number:',cline,last,i1,1,'?Enter plot data') ! here only the normal plotdata units 1 to 9 are legal if(i1.gt.0 .and. i1.lt.10) then if(plotdataunit(i1).lt.10) then write(kou,*)'No plotdata file for this dataset' goto 100 endif call gparrdx('X coordinate:',cline,last,xxx,zero,& '?Enter plot data') call gparrdx('Y coordinate:',cline,last,xxy,one,& '?Enter plot data') call gparidx('Symbol:',cline,last,i2,1,& '?Enter plot data') write(plotdataunit(i1),171)i1,xxx,xxy,i2 171 format(i3,2(1pe14.6),i5,' have a nice day') else write(kou,*)'No plotdata file for dataset ',i1 endif !--------------------------------------------------------------- ! ENTER GNUPLOT_TERMINAL case(18) write(kou,172)graphopt%gnutermax 172 format('GNUPLOT terminals are:',i2/& 4x,'Name',5x,'> command',6x,'GNUPLOT options') write(kou,173)(i2,graphopt%gnutermid(i2),& trim(graphopt%gnuterminal(i2)),i2=1,graphopt%gnutermax) 173 format(i2,2x,a,' > set terminal ',a) write(kou,174) 174 format('Change (exact match required) or enter a new GNUPLOT termial') call gparcx('Terminal id (8 chars):',cline,last,1,text,' ',& '?Enter GNUTERM') call capson(text) if(text(1:1).eq.' ') goto 100 do i1=1,graphopt%gnutermax if(text(1:8).eq.graphopt%gnutermid(i1)) then string=graphopt%gnuterminal(i1) write(*,*)'Modifying terminal ',graphopt%gnutermid(i1) goto 176 endif enddo ! gnutermid not found, a new terminal call gparcdx('You want to enter a new terminal "'//trim(text)//'"?',& cline,last,1,ch1,'Y','?Enter GNUTERM') if(ch1.ne.'Y') then write(*,*)'Please try again'; goto 100 endif if(graphopt%gnutermax.ge.8) then write(kou,*)'There can max be 8 terminals' goto 100 endif i1=graphopt%gnutermax+1 graphopt%gnutermax=i1 string=' ' ! enter a new set terminal id and definition 176 continue graphopt%gnutermid(i1)=text(1:8) call gparcx('Text after set terminal (see GNUPLOT manual):',& cline,last,5,text,string,'?Enter GNUTERM') graphopt%gnuterminal(i1)=text if(i1.ne.1) then ! SCREEN has no file extention call gparcx('File extention:',cline,last,1,text,' ',& '?Enter GNUTERM') graphopt%filext(i1)=text(1:4) endif write(*,179)i1,graphopt%gnutermid(i1),trim(graphopt%gnuterminal(i1)),& trim(graphopt%filext(i1)) 179 format('New terminal definition for plot '/& i2,2x,a,'set terminal ',a/4x,'with file extention: ',a) !---------------------------------------------------------------- ! enter unused case(19) write(*,*)'Not implemeneted yet' !---------------------------------------------------------------- ! enter unused case(20) !---------------------------------------------------------------- ! enter unused case(21) END SELECT enter !================================================================= ! exit CASE(5) call gparcdx('Are you sure?',cline,last,1,ch1,'N','?Exit') if(ch1.eq.'y' .or. ch1.eq.'Y') then if(logfil.gt.0) then write(logfil,*)'set interactive' endif call openlogfile(' ',' ',-1) stop 'Ha en bra dag' endif !================================================================= ! list with subcommands ! ['DATA ','SHORT ','PHASE ',& ! 'STATE_VARIABLES ','BIBLIOGRAPHY ','MODEL_PARAM_ID ',& ! 'AXIS ','TPFUN_SYMBOLS ','QUIT ',& ! 'PARAMETER ','EQUILIBRIA ','RESULTS ',& ! 'CONDITIONS ','SYMBOLS ','LINE_EQUILIBRIA ',& ! 'OPTIMIZATION ','MODEL_PARAM_VAL ','ERROR_MESSAGE ',& ! ,ACTIVE_EQUILIBR ','ELEMENTS ',' ',& ! , ',' ',' '] ! SHOW is main cammand 25 CASE(6,25) ! LIST and SHOW if(kom.eq.25) then ! SHOW is the same as LIST STATE_VARIABLES including also CALC SYMBOL !! kom2=4 else ! default for LIST is RESULT, number 12 kom2=submenu(cbas(kom),cline,last,clist,nclist,12,'?TOPHLP') if(kom2.le.0) goto 100 endif lut=optionsset%lut ! write(*,*)'PMON: show xliqni should come here ... YES ',kom,kom2 list: SELECT CASE(kom2) !----------------------------------------------------------- CASE DEFAULT write(kou,*)'LIST FORMAT subcommand error' goto 100 !----------------------------------------------------------- case(1) ! list data, not dependent on equilibrium!! ! NOTE output file for SCREEN can be set by /output= ! LIST DATA SCREEN/TDB/MACRO/LaTeX ! it is also possible to give SAVE TDB ! character (len=16), dimension(nlform) :: llform=& ! ['SCREEN ',' ','MACRO ',& ! ' ',' ',' '] if(globaldata%encrypted.ne.0) then write(kou,*)'Illegal for encrypted databases' goto 100 endif kom3=submenu('Output format for data?',cline,last,llform,nlform,1,& '?TOPHLP') ! write(*,*)'LIST DATA output format',kom3 if(kom3.eq.1) then ! list on screen call list_many_formats(cline,last,kom3,kou) if(gx%bmperr.ge.4000 .and. gx%bmperr.le.nooferm) then write(kou,*)bmperrmess(gx%bmperr) elseif(gx%bmperr.ne.0) then write(kou,*)'Error code ',gx%bmperr endif elseif(kom3.eq.3) then write(*,*)'Output in MACRO format not yet implemented' else ! TDB format does not work here, use SAVE write(*,*)'Use SAVE to list with other formats than SCREEN' ! ztyp=-1 ! call gparfilex('File name: ',cline,last,1,filename,text,ztyp,& ! '?Save TDB') ! kl=max(index(filename,'.dat '),index(filename,'.TDB ')) ! if(kl.le.0) then ! kl=len_trim(filename)+1 ! if(kl.eq.1) then ! write(*,*)'Too short file name' ! goto 100 ! endif ! filename(kl:)='.DAT ' ! endif ! call list_TDB_format(filename) ! else ! if(tdbfile(1:1).ne.' ') & ! write(kou,*)'Database file: ',trim(tdbfile) ! endif ! else ! write(kou,*)'Unknown format' endif !----------------------------------------------------------- case(2) ! list short with status bits if(kom2.eq.20) then ch1='C' else ! note D is a hidden option including the status bits call gparcdx('Option (A/C/M/P)',cline,last,1,ch1,chshort,& '?List short') call capson(ch1) endif write(lut,6022)ceq%eqname,globaldata%rgasuser,& globaldata%pnorm,globaldata%status,ceq%status 6022 format('Equilibrium name',9x,'Gas constant Pressure norm',& 5x,'Status Global Equilib'/& 1x,a,1pe12.4,2x,1pe12.4,10x,z8,2x,z8) !.................................................................... ! options are A=all phases; P=some phases; C=components; M=phase models if(ch1.eq.'A') then ! A all chshort='A' call list_all_elements(lut) call list_all_species(lut) call list_all_phases(lut,ceq) !.................................................................... elseif(ch1.eq.'D') then ! just the phases ! P phases sorted: stable/ unstable in driving force order/ dormant the same chshort='P' call list_sorted_phases(lut,1,ceq) if(btest(ceq%status,EQFAIL)) write(lut,6305)'above' !.................................................................... elseif(ch1.eq.'P') then ! just the phases without status bits ! P phases sorted: stable/ unstable in driving force order/ dormant the same chshort='P' call list_sorted_phases(lut,0,ceq) if(btest(ceq%status,EQFAIL)) write(lut,6305)'above' elseif(ch1.eq.'C') then !.................................................................... ! global values and the chemical potentials chshort='C' write(kou,*) call list_global_results(lut,ceq) ! write(lut,6303)'Some component data ....................' write(lut,6303)'Some data for components ...............' j4=1 if(listresopt.ge.4 .and. listresopt.le.7) then j4=2 endif call list_components_result(lut,j4,ceq) !.................................................................... elseif(ch1.eq.'M') then ! list models for all phases do iph=1,noph() call list_phase_model(iph,1,lut,' ',ceq) enddo !.................................................................... else write(kou,*)'Only option A, C, M and P implemented' endif !----------------------------------------------------------- case(3) ! list phase subcommands call gparcx('Phase name: ',cline,last,1,name1,' ','?List phase') if(buperr.ne.0) goto 990 call find_phase_by_name(name1,iph,ics) if(gx%bmperr.ne.0) goto 990 kom3=submenu('List what for phase?',cline,last,clph,nclph,2,& '?TOPHLP') listphase: SELECT CASE(kom3) !............................................................... CASE DEFAULT write(kou,*)'list phase subcommand error' !............................................................... CASE(1) ! list phase data call list_phase_data(iph,' ',lut) !............................................................... ! list phase constitution case(2) ! list phase constitution ! call list_phase_results(iph,ics,mode,kou,firsteq) write(lut,6051)version,ceq%eqno,ceq%eqname 6051 format(/'OC version',a,' equilibrium: ',i3,', ',& a,3x,a4,'.',a2,'.',a2) mode=110 once=.TRUE. call list_phase_results(iph,ics,mode,lut,once,ceq) if(gx%bmperr.ne.0) then write(*,*)'Last equilibrium calculation failed' goto 990 endif !............................................................... case(3) ! list phase model (including disordered fractions) write(kou,6070)'For ',ceq%eqno,ceq%eqname 6070 format(a,'equilibrium: ',i3,', ',a) call list_phase_model(iph,ics,lut,' ',ceq) END SELECT listphase !------------------------------ ! THIS IS ALSO THE SHOW command and list model-parameter-value case(17) of LIST ! SHOW STATE VARIABLE VALUE case(4,17) ! list state_variable or model_parameter_value, or SHOW !6099 continue if(btest(ceq%status,EQNOEQCAL) .or. btest(ceq%status,EQFAIL)) then write(lut,6101) 6101 format(' *** Warning,',& 'equilibrium not calculated, values are probably wrong') elseif(btest(ceq%status,EQINCON)) then write(lut,6102) 6102 format(' *** Warning, values can be inconsistent with',& ' current conditions') endif once=.TRUE. ! LOOP here for list state_variables or model_parameter_values or SHOW 6105 continue ! write(*,*)'At label 6105: ',last,' "',trim(cline),'"',kom,kom2 ! NOTE: 4th argument is 5 because otherwise a "," will terminate reading cline ! and state variables like x(fcc,cr) will not work. if(kom.eq.25) then ! SHOW: this execute the SHOW command ! write(*,*)'PMON: show xliqni should come here ... YES ' call gparcx('Property: ',cline,last,5,line,' ','?Show property') else ! the command is LIST STATE_VARIABLES if(kom2.eq.4) then call gparcx('State variable: ',cline,last,5,line,' ',& '?List state variables') else ! the command is LIST MODEL_PARAMETER_VALUE if(once) then write(kou,*)'Remember always to specify the phase!' once=.FALSE. endif call gparcx('Parameter ident: ',cline,last,5,line,' ',& '?List model parameter val') endif endif ! if line empty return to command level j4=1 if(eolch(line,j4)) goto 100 j4=index(line,',') if(j4.gt.0) then ! check if there is a , before a ( as that is not allowed. There are ! state variables like x(fcc,cr) ... (this is not a strong test ...) ll=index(line,'(') if(ll.le.0 .or. ll.gt.j4) then write(*,*)'Please use a space as separator',& ' except within ( ) as in x(liq,cr) !' goto 100 endif endif ! model is just used to return texts model=' ' ! we should extract the text from last up to first space and save rest in cline j4=index(line,' ') name1=line(1:j4) call capson(name1) ! dot derivatives not allowed explicitly, must be entered as symbols if(index(name1,'.').gt.0) then write(kou,*)'You must enter dot derivatives as symbols!' goto 100 endif ! note gparc etc increment last before looking for answer, keep space in cline cline=line(j4:) last=1 ! if(index(name1,'*').gt.0) then ! allow also DGM(#) to generate many values ... if(index(name1,'*').gt.0 .or. index(name1,'DGM(#)').gt.0) then ! generate many values ! i1 values are resturned in yarr with dimension maxconst. ! longstring are the state variable symbols for the values ... call get_many_svar(name1,yarr,maxconst,i1,longstring,ceq) if(gx%bmperr.eq.0) then ! not a nice output, we should include the state variables FIX!! write(lut,6106)i1,longstring(1:len_trim(longstring)) 6106 Format('Listing of ',i3,' state variables:'/a) write(lut,6107)(yarr(i2),i2=1,i1) 6107 format('Values: ',5(1pe14.6)/(8x,5(1pe14.6))) if(index(name1,'*,').gt.0) write(*,6121)trim(name1) 6121 format(' *** Note that for unstable phases ',a,& ' is not shown or listed as zero') endif else ! the value of a state variable, symbol? or model parameter variable is returned ! STRANGE the symbol xliqni is accepted in get_state_var_value ??? ! write(*,*)'pmon show: call get_state_var_value',' :',trim(name1) ! get_state_var_value is in gtp3F.F90 call get_state_var_value(name1,xxx,model,ceq) ! write(*,*)'pmon back from get_state_var_value',xxx,' :',trim(model) ! write(*,*)'PMON: show xliqni should come here 6 ... ',gx%bmperr if(gx%bmperr.eq.0) then write(lut,6108)trim(model),xxx 6108 format(1x,a,'=',1PE15.7) else gx%bmperr=0 ! write(*,*)'PMON: show xliqni should come here ... NO!!!' ! If error then try to calculate a symbol ... ! below copied from calculate symbol, first calculate all symbols ignore errors ! calculate all symbols ignoring errors (note dot derivatives not calculated) call meq_evaluate_all_svfun(-1,ceq) if(gx%bmperr.ne.0) gx%bmperr=0 call capson(line) ! call find_svfun(name1,istv,ceq) ! write(*,*)'PMON: calling find_svfun again ...' call find_svfun(name1,istv) if(gx%bmperr.ne.0) goto 990 mode=1 actual_arg=' ' xxx=meq_evaluate_svfun(istv,actual_arg,mode,ceq) ! write(*,*)'pmon error: calling meq_evaluate_svfun',istv,xxx if(gx%bmperr.ne.0) goto 990 write(kou,2047)trim(name1),xxx ! this format statement elsewhere !2047 format(a,'= ',1pe16.8) endif endif if(gx%bmperr.ge.4000 .and. gx%bmperr.le.nooferm) then write(lut,*)bmperrmess(gx%bmperr) elseif(gx%bmperr.ne.0) then write(lut,*)'Error code ',gx%bmperr endif gx%bmperr=0 ! try to pick up more properties etc from cline if not empty if(.not.eolch(cline,last)) then ! there are more symbols, state variables or model_parameters in cline last=last-1 goto 6105 elseif(kom.ne.25) then ! for list state_variables and list model_parameter_value ask for more goto 6105 endif !----------------------------------------------------------- case(5) ! list data bibliography call gparcdx('Bibliographic id:',cline,last,1,name1,'ALL',& '?List biblio') if(name1.eq.'ALL ') name1=' ' call list_bibliography(name1,lut) !----------------------------------------------------------- case(6) ! list model_parameter_identifiers call list_defined_properties(lut) !----------------------------------------------------------- case(7) ! list axis if(noofaxis.le.0) then write(kou,*)'No axis set' goto 100 endif write(lut,6131) 6131 format(4x,'Axis variable',12x,'Min',9x,'Max',9x,'Max increment') !6131 format(4x,'Axis variable',12x,'Start',7x,'Final',7x,'Increment') do iax=1,noofaxis jp=1 call get_one_condition(jp,text,axarr(iax)%seqz,ceq) if(gx%bmperr.ne.0) then write(kou,*)'PMON: Condition sequential index: ',& iax,axarr(iax)%seqz goto 990 endif ! we just want the expression, remove the value including the = sign jp=index(text,'=') text(jp:)=' ' ! write(kou,6132)iax,axvar(iax),(axval(j4,iax),j4=1,3) write(lut,6132)iax,text(1:24),& axarr(iax)%axmin,axarr(iax)%axmax,axarr(iax)%axinc 6132 format(i2,2x,a,3(1pe12.4)) enddo !----------------------------------------------------------- case(8) ! list tpfun symbol call gparcdx('name: ',cline,last,5,name1,'*','?List TPfun') lrot=0 iel=index(name1,'*') if(iel.gt.1) name1(iel:)=' ' if(name1(1:1).ne.'*') then 6140 continue call find_tpfun_by_name(name1,lrot) ! write(*,*)'cui: ',lrot,iel,gx%bmperr if(gx%bmperr.ne.0) then if(iel.eq.0) goto 990 gx%bmperr=0 else longstring=' ' write(longstring,6142)lrot 6142 format(i5) jp=len_trim(longstring)+2 call list_tpfun(lrot,0,longstring(jp:)) call wrice2(lut,0,12,78,1,longstring) if(iel.gt.1) goto 6140 endif else call list_all_funs(lut) endif !------------------------------------------------------------ case(9) ! list quit !------------------------------------------------------------ case(10) ! list parameter for a phase (just one). Last 1 means list call enter_parameter_interactivly(cline,last,1) !----------------------------------------------------------- case(11,19) ! list EQUILIBRIA and list ACTIVE_EQUILIBRIA (not result) ! if 19 then skip equilibria with zero weight nv=noeq() ! skip if there is just one equilibrium kom=6=LIST; kom2=19=ACTIVE-EQUIL ! write(*,*)'PMON: ',kom,kom2,nv if(kom2.eq.19 .and. nv.eq.1) goto 100 write(lut,6212) 6212 format('Number Name',25x,'T Weight Comment & phases') jp=0 do iel=1,nv if(associated(ceq,eqlista(iel))) then name1='**' else name1=' ' endif ! write(*,*)'PMON: ',kom2,iel,eqlista(iel)%weight,jp ! j4=len_trim(eqlista(iel)%comment) ! write(*,*)'PMON eqlista: ',len_trim(eqlista(iel)%comment),& ! eqlista(iel)%weight text=eqlista(iel)%comment jz=len_trim(text) if(jz.lt.20) then ! if there is space add names of stable phases if(jz.gt.0) then text(jz+1:)=' & '; jz=jz+4 else jz=1 endif do iz=1,nooftup() i2=phasetuple(iz)%lokvares if(eqlista(iel)%phase_varres(i2)%phstate.gt.0) then if(eqlista(iel)%phase_varres(i2)%phstate.eq.2) then ! prefix any FIX phase with * text(jz:jz)='*'; jz=jz+1 endif call get_phasetup_name(iz,text(jz:)) ! text is limited to 72 characters and anyway only 32 are written jz=min(len_trim(text)+2,40) endif enddo ! write(*,*)'PMON phases: ',trim(text) endif if(eqlista(iel)%weight.gt.zero) then ! always list equilibria with weight>0 write(lut,6203)iel,name1(1:2),eqlista(iel)%eqname,& eqlista(iel)%tpval(1),eqlista(iel)%weight,trim(text) 6203 format(i4,1x,a2,1x,a,1x,F8.2,1x,F5.2,1x,a) elseif(iel.eq.1 .or. kom2.eq.11) then ! for kom2=11 list all equilibria without including weight ! NOTE all equilibria outside "range" (default and step/map) has weight= -1.0 write(lut,6202)iel,name1(1:2),eqlista(iel)%eqname,& eqlista(iel)%tpval(1),trim(text) 6202 format(i4,1x,a2,1x,a,1x,F8.2,7x,a) elseif(eqlista(iel)%weight.eq.zero) then jp=jp+1 endif ! if(j4.gt.1) then ! write(lut,6204)eqlista(iel)%comment(1:j4) !6204 format(12x,a) ! endif enddo if(kom2.eq.19 .and. jp.gt.0) & write(lut,'(/"Number of equilibria with zero weight: ",i4)')jp !------------------------------ case(12) ! LIST RESULTS (maybe also LIST ESTIMATED_ACCURA?) ! skip if no calculation made if(btest(globaldata%status,GSNOPHASE)) then write(kou,*)'No results as no data' goto 100 elseif(btest(ceq%status,EQGRIDCAL)) then write(kou,*)' *** Last calculation was not a full equilibrium' endif call gparidx('Results output mode: ',cline,last,& listresopt,lrodef,'?List results') if(buperr.ne.0) then write(kou,*)'No such mode, using default' buperr=0 listresopt=lrodef endif ! CCI extending the number of listing options ! if(listresopt.gt.0 .and. listresopt.le.9) then ! if(listresopt.gt.0 .and. listresopt.le.11) then if(listresopt.gt.0 .and. listresopt.le.12) then lrodef=listresopt endif ! CCI end call date_and_time(optres,name1) write(lut,6051)version,ceq%eqno,ceq%eqname,& optres(1:4),optres(5:6),optres(7:8) ! write comment line if any if(len_trim(ceq%comment).gt.0) then write(lut,6308)trim(ceq%comment) 6308 format(3x,a) endif if(btest(ceq%status,EQFAIL)) then write(lut,6305)'below' 6305 format(/' *** The results ',a,& ' are not a valid equilibrium as last calculation failed'/) ! elseif(btest(globaldata%status,GSNOEQCAL)) then elseif(btest(ceq%status,EQNOEQCAL)) then write(lut,6307)'below' 6307 format(/' *** The results listed ',a,' does not represent',& ' a calculated equilibrium'/) elseif(btest(ceq%status,EQINCON)) then write(lut,6306)'below' 6306 format(/' *** The results listed ',a,' may be inconsistent',& ' with the current conditions'/) endif write(lut,6302)'Conditions .............................' 6302 format(a,20('.'),':') 6303 format(/a,20('.'),':') call list_conditions(lut,ceq) write(lut,6303)'Some global data, reference state SER ..' call list_global_results(lut,ceq) if(btest(ceq%status,EQNOEQCAL)) then write(*,6277)ceq%status 6277 format(' *** No results as no equilibrium calculated! ',z8) goto 6363 endif ! write(lut,6303)'Some component data ....................' write(lut,6303)'Some data for components ...............' j4=1 if(listresopt.ge.4 .and. listresopt.le.7) then ! j4=2 means mass fractions j4=2 endif call list_components_result(lut,j4,ceq) ! Phase output starts with newline ! write(lut,6304,advance='no')'Some Phase data ........................' write(lut,6304,advance='no')'Some data for phases ...................' 6304 format(/a,20('.'),':') if(listresopt.le.1) then ! 1: stable phases with mole fractions in value order mode=1000 elseif(listresopt.eq.2) then ! 2: stable phases with mole fractions and constitution in value order mode=1010 elseif(listresopt.eq.3) then ! 3: stable phases with mole fractions and constitution in alphabetical order mode=1110 elseif(listresopt.eq.4) then ! 4: stable phases with mass fractions in value order mode=1001 elseif(listresopt.eq.5) then ! 5: stable phases with mass fractions in alphabetical order mode=1101 elseif(listresopt.eq.6) then ! 6: stable phases with mass fractions and constitution in value order mode=1011 elseif(listresopt.eq.7) then ! 7: all phases with mass fractions in value order mode=1 elseif(listresopt.eq.8) then ! 9: all phases with mole fractions in alphabetical order mode=110 elseif(listresopt.eq.9) then ! 9: all phases with mole fractions an constitutions in value order mode=10 elseif(listresopt.eq.10) then ! CCI ! 10: stable phases with constituent fractions time FU of hase in value order ! SOLGASMIX type output mode=10000 elseif(listresopt.eq.11) then ! 11: stable phases with constituent fractions time FU of hase in value order mode=10010 ! CCI end elseif(listresopt.eq.12) then ! 12: just one line per phase, no compositions mode=10020 else ! all phase with with mole fractions mode=0 endif ics=1 once=.TRUE. do iph=1,noph() ics=0 6310 continue ics=ics+1 ! moved to gtp3C ! if(listresopt.ge.4 .and. listresopt.le.7) then ! use phase amount in mass ! write(lut,6308)'Mass ' !6308 format('Name Status ',a,' Volume',& ! ' Form.U At/FU DGM X/W:') ! ' Form.U At/FU DGM Frac:') ! else ! use phase amount in mole ! write(lut,6308)'Moles ' ! endif call list_phase_results(iph,ics,mode,lut,once,ceq) if(gx%bmperr.ne.0) then ! if error take next phase gx%bmperr=0 else ! else take next composition set goto 6310 endif enddo ! list experiments if any 6363 continue if(associated(ceq%lastexperiment)) then write(lut,491)ceq%weight !491 format(/'Weight ',F6.2) 491 format('Weight ',F6.2) ! list all experiments ........................................ call meq_list_experiments(lut,ceq) write(lut,*) ! else ! write(*,*)'No experiments found' endif if(btest(ceq%status,EQNOEQCAL)) goto 100 ! list if anyting should be calculated or listed separately (not their values) if(allocated(ceq%eqextra)) then write(lut,492)ceq%eqextra(1)(1:len_trim(ceq%eqextra(1))),& ceq%eqextra(2)(1:len_trim(ceq%eqextra(2))) 492 format('Calculate: ',a/'List: ',a) ! else ! write(*,*)'No extra lines' endif ! make sure phases with positive DGM listed call list_phases_with_positive_dgm(mode,lut,ceq) if(btest(ceq%status,EQFAIL)) then write(lut,6305)'above' elseif(btest(ceq%status,EQNOEQCAL)) then write(lut,6307)'above' elseif(btest(ceq%status,EQINCON)) then write(lut,6306)'above' endif !------------------------------ case(13) ! list conditions write(kou,6070)'Conditions for ',ceq%eqno,ceq%eqname call list_conditions(lut,ceq) !------------------------------ case(14) ! list symbols (state variable functions, not TP funs) call list_all_svfun(lut,ceq) !------------------------------ ! list line_equilibria, (line-equilibria) of calculated and stored equilibria case(15) ! temporary listing of all stored equilibria as test ! IDEA: Add question for symbols and state variables to be listed!! ! Add a heading to make spece for more dara ! ceq #; Next; T; axis value; 0-n user symbols; ! 9999 9999 20000.00 +1.2345E+00 1.2345E+00 1.2345E+00 1.2345E+00 1.2345E+00 call list_stored_equilibria(lut,axarr,maptop) !------------------------------ ! list optimization, several suboptions ! character (len=16), dimension(noptopt) :: optopt=& ! ['SHORT ','LONG ','COEFFICIENTS ',& ! 'GRAPHICS ','DEBUG ','MACRO ',& ! 'EXPERIMENTS ','CORRELATION_MTRX','MQMQA_QUAD '] case(16) if(.not.allocated(firstash%coeffstate)) then write(kou,*)'No listing as no optimizing parameters' goto 100 endif call date_and_time(optres,name1) kom2=submenu('List ',cline,last,optopt,noptopt,1,'?TOPHLP') ! allow output file lut=optionsset%lut ! if errs not allocated no optimization made if(allocated(errs)) then ! trying to avoid segmentation fault when errs destryed by PLOT with APPEND if(size(errs).ne.mexp) then write(*,*)'Allocation error of "errs"',size(errs),mexp ! deallocate(errs) ! write(*,*)'Deallocated errs' write(*,*)' **** Warning, datastructure corrupted, save what you can' goto 100 endif write(lut,600)optres(1:4),optres(5:6),optres(7:8),& name1(1:2),name1(3:4),err0(3) 600 format(/'Optimization results at ',a4,'.',a2,'.',a2,& ':',a2,'h',a2,', normalized sum of error: ',1pe12.4) else write(*,*)'No current optimization' endif listopt: SELECT CASE(kom2) !.......................................................... case DEFAULT write(kou,*)'No such option' !........................................................... ! list optimization short case(1) ! short ! if(updatemexp) then ! write(*,*)'You must OPTIMIZE first' ! goto 100 ! endif ! write(kou,*)'Still no current optimization' if(allocated(errs)) then if(size(errs).eq.mexp) then ! in matsmin call listoptshort(lut,mexp,nvcoeff,errs) else ! After PLOT ... with APPEND of experimental data "errs" seems destroyed?? write(kou,*)'Allocation error: ',mexp,size(errs) deallocate(errs) endif endif ! in gtp3C call listoptcoeff(mexp,err0,.FALSE.,lut) !........................................................... ! list optimization long case(2) ! long write(*,*)'Not implemented yet' !........................................................... ! list optimization coefficients case(3) ! coefficient values if(mexp.eq.mexpdone .and. nvcoeff.eq.nvcoeffdone) then call listoptcoeff(mexp,err0,.TRUE.,lut) else call listoptcoeff(mexp,err0,.FALSE.,lut) endif !........................................................... ! list optimization graphics, plot calculated vs experiment values case(4) ! graphics write(*,*)'Not implemented yet' !........................................................... ! list optimization debug ?? case(5) ! debug if(nvcoeff.ne.nvcoeffdone .or. mexp.ne.mexpdone) then write(*,*)'No optimization done with current set of ',& 'coefficients or experiments' goto 100 elseif(.not.allocated(fjac)) then write(*,*)'No optimization done' goto 100 endif write(*,*)'Listing the Jacobian: ',nvcoeff,mexp ! iflag=2 ! call fdjac2(mexp,nvcoeff,coefs,errs,fjac,mexp,iflag,zero,wam) ! write(*,*)'fjac: ',nvcoeff,mexp,iflag do i2=1,mexp write(*,563)(fjac(i2,ll),ll=1,nvcoeff) enddo if(allocated(cov1)) then write(*,*)'The covariance matrix Jac^T * Jac: ' do i2=1,nvcoeff write(*,563)(cov1(i2,ll),ll=1,nvcoeff) enddo endif !........................................................... ! list optimization macro: create macro file with all experiments case(6) ! MACRO include experiments write(*,*)'Not implemented yet' !........................................................... ! list optimization experiments case(7) ! experiments with weight>0 if(allocated(errs)) then call listoptshort(lut,mexp,nvcoeff,errs) else write(kou,*)'No current optimization' endif !........................................................... ! list optimization correlation matrix case(8) ! unused if(nvcoeff.eq.nvcoeffdone .and. allocated(cormat)) then write(kou,*)'Correlation matrix is (symmetric):' do i2=1,nvcoeff write(kou,563)(cormat(i2,j2),j2=1,i2) enddo write(kou,*)'Covariance matrix is (symmetric): ' do i2=1,nvcoeff write(kou,563)(cov1(i2,j2),j2=1,i2) enddo else write(*,*)'No correlation matrix calculated' endif !........................................................... ! list optimization RSD (according to OC and TC) case(9) write(kou,3998) 3998 format(/'Relative Standard Deviation (RSD) values according',& ' to OC and TC'/'Variable OC TC') i2=0 do i1=0,size(firstash%coeffstate)-1 if(firstash%coeffstate(i1).ge.10) then i2=i2+1 write(*,'(i7,2(1pe12.4))')i2,& sqrt(abs(cov1(i2,i2))),& sqrt(abs(tccovar(i2,i2))) endif enddo write(kou,3999)sqrt(err0(3)) 3999 format('The difference is the square root of the normalized',& ' sum or errors: ',1pe12.4) end SELECT listopt !------------------------------ ! list model_parameter_values, part of case(4) ! case(17) ! write(*,*)'Not implemented yet' !------------------------------ ! list error message case(18) i2=4204 call gparidx('Error code: ',cline,last,i1,i2,'?List error msg') if(i1.ge.4000 .and. i1.le.nooferm) then write(kou,4999)i1,bmperrmess(i1) 4999 format('The error code ',i4,', means: '/a) else write(kou,*)'Not a standard OC error message' endif !------------------------------ ! list ?? nonzero_equilibria/active-equil merged with list equilibra, case 11 ! case(19) ! write(*,*)'Not implemented yet' !------------------------------ ! list elements case(20) call list_all_elements(kou) !------------------------------ ! list Excell CSV file, code copied from PLOT case(21) if(noofaxis.gt.1 .or. .not.associated(maptop)) then write(kou,*)'You must give a STEP command before list excell_csv' goto 100 endif wildcard=.FALSE. iax=1 jp=1 call get_one_condition(jp,text,axarr(iax)%seqz,ceq) if(gx%bmperr.ne.0) then write(*,*)'PMON Error getting axis condition from index: ',& iax,axarr(iax)%seqz goto 990 endif ! we just want the expression, remove the value including the = sign jp=index(text,'=') text(jp:)=' ' axplotdef(1)=text if(maptop%tieline_inplane.eq.1) then ! if tie-lines in the plane is 1 (.e. YES) and calculating axis was x(A) ! then plot axis should be x(*,cu) jp=index(text,'(') if(jp.gt.0) then text=text(1:jp)//'*,'//text(jp+1:) endif endif ! default for second axis always NP(*) axplotdef(2)='NP(*)' ! the 4th argument to gparc means the following: ! 1 TEXT TERMINATED BY SPACE OR "," ! 2 TEXT TERMINATED BY SPACE ! 3 TEXT TERMINATED BY ";" OR "." ! 4 TEXT TERMINATED BY ";" ! 5 TEXT UP TO END-OF-LINE ! 6 TEXT UP TO AND INCLUDING ";" ! 7 TEXT TERMINATED BY SPACE OR "," BUT IGNORING SUCH INSIDE ( ) ! >31, THE CHAR(JTYP) IS USED AS TERMINATING CHARACTER iax=1 call gparcdx('Independent variable',& cline,last,7,axplot(iax),axplotdef(iax),'?List excell CSV') ! dependent variables, can be wildcard iax=2 call gparcdx('Dependent values',& cline,last,7,axplot(iax),axplotdef(iax),'?List excell CSV') if(buperr.ne.0) goto 990 if(index(axplot(iax),'*').gt.0 .or. index(axplot(iax),'#').gt.0) then wildcard=.TRUE. endif if(index(axplot(iax),'*').gt.0) then ! generate many values ! the values are returned in yarr with dimension maxconst. ! longstring are the state variable symbols for the values ... call get_many_svar(axplot(iax),yarr,maxconst,i1,longstring,ceq) if(gx%bmperr.ne.0) then ! if error go back to command level write(kou,*)'Illegal axis variable! Error code: ',gx%bmperr goto 100 endif elseif(index(axplot(iax),'#').gt.0) then ! generate many values including for metastable phases ! the values are returned in yarr with dimension maxconst. ! longstring are the state variable symbols for the values ... call get_many_svar(axplot(iax),yarr,maxconst,i1,longstring,ceq) if(gx%bmperr.ne.0) then ! if error go back to command level write(kou,*)'Illegal axis variable! Error code: ',gx%bmperr goto 100 endif else ! the value of a state variable or model parameter variable is returned ! STRANGE the symbol xliqni is accepted in get_state_var_value ??? call get_state_var_value(axplot(iax),xxx,model,ceq) if(gx%bmperr.ne.0) then ! if error check if it is a complicated symbol like CP=H.T gx%bmperr=0 ! If error then try to calculate a symbol ... call capson(axplot(iax)) call find_svfun(axplot(iax),istv) if(gx%bmperr.ne.0) then write(kou,*)'Illegal axis variable, error: ',gx%bmperr goto 100 endif endif endif ! output file, NOTE if /APPEND the file already open! if(optionsset%lut.ne.kou) then write(*,*)'Appended on CSV files not implemented yet',& optionsset%lut close(optionsset%lut); optionsset%lut=0 ! goto 1234 endif if(buperr.ne.0) buperr=0 ! What does -5 as argument mean?? Well, open for write!! ztyp=-5 call gparfilex('Output file: ',cline,last,1,plotfile,' ',ztyp,& '?List excell CSV') ! make sure there is a file name if(len_trim(plotfile).le.0) then plotfile=' ' if(buperr.ne.0) then ! write(*,*)'PMON buperr: ',buperr buperr=0 endif write(*,*)'Output on screen' else jp=index(plotfile,'.') if(jp.le.0) then jp=len_trim(plotfile) plotfile(jp+1:)='.csv' endif write(*,*)'Output will be on: ',trim(plotfile) endif if(plotfile(1:2).eq.'./') then ! save in macro directory if iumaclevl>0, else in current working directory if(iumaclevl.gt.0) then ! we are executing a macro, skip the ./ aline=plotfile(3:) plotfile=trim(macropath(iumaclevl))//aline else ! running interactivly prefix with working directory (default?) aline=plotfile(2:) plotfile=trim(workingdir)//aline endif ! trouble passing on ling file names .... ! write(*,*)'PMON working directory: ',trim(workingdir) ! write(*,*)'Saving on file: ',trim(plotfile) endif 1234 continue ! use the graphics record to transfer data ... graphopt%pltax(1)=axplot(1) graphopt%pltax(2)=axplot(2) graphopt%filename=plotfile ! this command only for tabulating STEP commands graphopt%status=ibset(graphopt%status,GRCSVTABLE) graphopt%status=ibclr(graphopt%status,GRISOPLETH) ! added ceq in the call to make it possible to handle change of reference states ! if(buperr.ne.0) buperr=0 call ocplot2(jp,maptop,axarr,graphopt,version,ceq) graphopt%status=ibclr(graphopt%status,GRCSVTABLE) if(gx%bmperr.ne.0) goto 990 write(*,*)'CSV output saved on file: ',trim(plotfile) ! write(*,*)'Not implemented yet' !------------------------------------------------------------------- ! list MQMQA_SPECIAL ! character (len=16), dimension(mqmqacc) :: mqmqalist=& ! ['QUADS ','ASYMMETRIES ','DEBUG ',& ! 'EXCESS ','AMEND_VARKAPPA ',' '] case(22) ! allow output file ! lut=optionsset%lut ! if errs not allocated no optimization made ! if(allocated(errs)) then ! trying to avoid segmentation fault when errs destryed by PLOT with APPEND ! if(size(errs).ne.mexp) then ! write(*,*)'Allocation error of "errs"',size(errs),mexp ! deallocate(errs) ! write(*,*)'Deallocated errs' call gparcx('Phase name: ',cline,last,1,name1,' ','?List phase') if(buperr.ne.0) goto 990 ! special to debug read database if(name1.eq.'DEBUG') then mqmqtdb=.true. goto 100 endif call find_phase_by_name(name1,iph,ics) if(gx%bmperr.ne.0) goto 990 ! A stupid way to find lokvares ... (or lokcs, I have forgooten which) if(.not.allocated(mqmqa_data%contyp)) then ! if this not allocated there is no MQMQA data write(*,*)'No data for MQMQA phases' exit main endif lokcs=1 do while(ceq%phase_varres(lokcs)%phlink.ne.iph) lokcs=lokcs+1 enddo ! write(*,*)'lokcs: ',lokcs,lokph,iph ! kom2=submenu('MQMQA special?',& cline,last,mqmqalist,mqmqacc,3,'?TOPHLP') !.......................................................... mqmqa: select case(kom2) case DEFAULT write(kou,*)'No such option' !........................................................... ! list quads, this is independent of the phase case(1) ! Quads jquad=0 qlista: do i1=1,nosp() call get_species_location(i1,loksp,name1) if(gx%bmperr.ne.0) goto 990 if(index(name1,'-Q').le.0) cycle qlista ! this is a species that is a quad jquad=jquad+1 call get_species_component_data(loksp,i2,iphl,stoik,xxx,xxy,ceq) if(gx%bmperr.ne.0) goto 990 do j4=1,i2 ! pick up element symbols call get_element_data(iphl(j4),ellist(j4),name2,& dummy,mass,h298,s298) enddo write(kou,1680)i1,loksp,name1,& (ellist(j4),stoik(j4),j4=1,i2) 1680 format(i3,i4,1x,a,1x,4(a2,F8.6,1x)) ! this is in quad alphabetical order, not in alphabetical order of quad elements call mqmqa_quadbonds(jquad,quadbonds) if(i2.eq.2) then write(kou,1681)(quadbonds(j4),j4=1,3) else write(kou,1681)(quadbonds(j4),j4=1,i2) endif 1681 format(26x,'bonds: ',4(F10.6,1x)) ! max length 8+25+4*11=33+44=77 enddo qlista ! if(jquad.eq.0) write(kou,*)'No MQMQA quads found' ! ! ! maybe include listing of mqmqa_data%constoi(1..4,index) !........................................................... ! list Asymmetries ! note: tersys, xquad, compvar are not linked from the phase!!! case(2) ! copied from gtp3XQ listconst ! list element names, numbers and quad indices, i1 set to number of quads call list_quads(i1) ! ! tersys is global data ts: if(allocated(tersys)) then write(*,3101)size(tersys) !3101 format(/'Listing of the ',i3,' ternary systems and their asymmetries',& ! /' i seq cat1 cat2 cat3 T/0 T/0 T/0 asymmetry code') do iz=1,size(tersys) write(*,3201)iz,tersys(iz)%seq,(tersys(iz)%el(j4),j4=1,3),& tersys(iz)%isasym,tersys(iz)%asymm !3201 format(i3,i5,2x,3(1x,i4),5x,3i4,5x,a) enddo write(*,3301) !3301 format('Number in T/0 column is actual asymmetric cation'/) else write(kou,*)'No ternary asymmetry data allocated' endif ts ! ! listing of fraction in alphbetical order write(kou,4123)mqmqa_data%nquad,& (ceq%phase_varres(lokcs)%yfr(i1),i1=1,mqmqa_data%nquad) !4123 format('Fractions ',i2,' in species OC alphabetical order:',/& ! (12F6.3)) ! mqmqaf defined globally anoq: if(.not.allocated(ceq%phase_varres(lokcs)%mqmqaf%xquad)) then write(*,*)'Quads not allocated' else write(kou,4122)mqmqa_data%nquad,& (ceq%phase_varres(lokcs)%mqmqaf%xquad(i1),i1=1,mqmqa_data%nquad) !4122 format('Fractions ',i2,' in Quad order: ',/(12F6.3)) write(kou,4124)mqmqa_data%nquad,mqmqa_data%ncat !4124 format(/'The ',i3,' quads for ',i2,' cations are arranged ',& ! 'in order of the n cations:'/& ! 'Quad ',9x,'1 2 ... n | n+1 n+2 ... 2n-1 | 2n .. | n(n+1)/2'/& ! 'Cation',9x,'1 1 ... 1 | 2 2 ... 2 | 3 .. | n'/& ! 'Cation',9x,'1 2 ... n | 2 3 ... n | 3 .. | n') write(kou,4126)mqmqa_data%quad2compvar !4126 format('quad2compvar: ',21(1x,i2)) write(kou,4127)mqmqa_data%emquad*(mqmqa_data%emquad-1),& mqmqa_data%emquad 4127 format('Number of varkappa_ij asymmetry variables, n*(n-1)/2: ',i3/& 'em2quad: ',21(1x,i2)) ! just a blank line write(kou,*) write(kou,308)'Fractions in OC order ',& (i2,i2=1,mqmqa_data%nquad) write(kou,308)'Fractions in Quad order ',& (mqmqa_data%con2quad(i2),i2=1,mqmqa_data%nquad) !308 format(a,15i3) ! write(kou,410)newXupdate !410 format(/'List of compvar, the binary asymmetric composition',& ! ' variables, last update:',i5/& ! ' seq cat_i cat_j varkappa_ij varkappa_ji xi_ij xi_ji') ! calculate varkappaij and varkappaji correcting for all ternaries mqmqavar=>ceq%phase_varres(lokcs) call calcasymvar(mqmqavar) j4=0 acat1: do i1=1,mqmqa_data%ncat-1 acat2: do i2=i1+1,mqmqa_data%ncat j4=j4+1 write(kou,412)j4,i1,i2,& ceq%phase_varres(lokcs)%mqmqaf%compvar(j4)%vk_ij,& ceq%phase_varres(lokcs)%mqmqaf%compvar(j4)%vk_ji,& ceq%phase_varres(lokcs)%mqmqaf%compvar(j4)%xi_ij,& ceq%phase_varres(lokcs)%mqmqaf%compvar(j4)%xi_ji !412 format(i5,2i6,3x,4(1PE12.4)) enddo acat2 enddo acat1 endif anoq ! write(kou,444)'Values of y_i/k: ',& (ceq%phase_varres(lokcs)%mqmqaf%y_ik(i1),i1=1,mqmqa_data%ncat) !444 format(/a,(10f7.4)) write(kou,*) ! an empty line before extended information ! NOTE THIS IS PART OF REDUNDANT COMMAND LIST MQ AMEND_VARKAPPA ! call gparcdx('Details on varkappa?',cline,last,1,ch1,'N',& ! '?Varkappa') ! if(ch1.ne.'N') then mqmqavar=>ceq%phase_varres(lokcs) call varkappadefs(mqmqavar) ! endif ! repeat the asymmetries ! if(allocated(tersys)) then ! write(*,3101)size(tersys) ! do iz=1,size(tersys) ! write(*,3201)iz,tersys(iz)%seq,(tersys(iz)%el(j4),j4=1,3),& ! tersys(iz)%isasym,tersys(iz)%asymm ! enddo ! write(*,3301) ! list again element names, numbers and quad indices ! call list_quads(i1) ! else ! write(kou,*)'No ternary asymmetry data allocated' ! endif ! !........................................................... ! list DEBUG for implementation of asymmetric models case(3) ! list the constituents of the phase in the order they have in constitlink ! THIS IS AN EMERGY SUBROUTINE IN gtp3XQ NOT CONFORMING WITH THE STRUCTURE call listconst(iph) ! ! check consistency of some data in mqma_data!! ! some also in gtp_mqmqa_var!! write(*,1687)mqmqa_data%nconst,mqmqa_data%nquad,& mqmqa_data%ncon1,mqmqa_data%ncat,& mqmqa_data%ncon2,mqmqa_data%nan,& mqmqa_data%npair,mqmqa_data%lcat 1687 format(/'Values of some duplicate global data:',& 'Number of quads: ',2i4/& 'Number of cations: ',2i4/& 'Number of anions: ',2i4/& 'Number of pairs: ',i4/& 'Value of cation*(cation+1)/2: ',i4/) ! i2=0 write(*,1688) 1688 format('Debug settings:'/'0 no debug'/'1 debug asymmetry'/& '2 debug some more'/& '3 debug reading TDB'/& '4 debug parameter calculation'/& '5 debug partial derivative calculation') call gparidx('Set mqmqa debug?',cline,last,i1,i2,'?MQMQA debug') mqmqdebug=.false. mqmqdebug2=.false. mqmqtdb=.false. mqmqxcess=.false. mqmqder=.false. if(i1.eq.1) then ! asymmetry debug mqmqdebug=.true. elseif(i1.eq.2) then mqmqdebug2=.true. elseif(i1.eq.3) then ! tdb reading debug mqmqtdb=.true. elseif(i1.eq.4) then ! calculation debug mqmqxcess=.true. elseif(i1.eq.5) then ! partial derivative debug mqmqder=.true. endif ! !........................................................... ! list excess tree case(4) call get_phase_record(iph,lokph) call listpartree(lokph) !........................................................... ! list mqmqa AMEND_VARKAPPA case(5) ! ! CODE BELOW REPLACED by new code around line 1374 AMEND PHASE ... ASYMMETRY ! that code around line 1288 ! ! list element names, numbers and quad indices, i1 set to number of quads write(*,*)'USE AMEND PHASE ... ASYMMETRY instead' goto 100 ! call list_quads(i1) ! tersys is defined globally ts2: if(allocated(tersys)) then write(*,3101)size(tersys) !3101 format(/'Listing of the ',i3,' ternary systems and their asymmetries',& ! /' i seq cat1 cat2 cat3 T/0 T/0 T/0 asymmetry code') do iz=1,size(tersys) write(*,3201)iz,tersys(iz)%seq,(tersys(iz)%el(j4),j4=1,3),& tersys(iz)%isasym,tersys(iz)%asymm !3201 format(i3,i5,2x,3(1x,i4),5x,3i4,5x,a) enddo ! ************************* this code redundant ************************* write(*,3301) else write(kou,*)'No ternary asymmetry data allocated' endif ts2 if(size(tersys).gt.1) then write(*,*)'Implemented only for a single ternary' goto 100 else call gparidx('Specify varkappa index:',cline,last,iz,1,& '?List MQMQA varkappa modification') ! iz=1 endif ! ************************* this code redundant ************************* write(*,3401) 3401 format('Give 1, 2 or 3 for cat1, cat2 or cat3, 0 if no asymmetry') call gparidx('Specify Toop cation index:',cline,last,i2,0,& '?List MQMQA varkappa modification') ! In the general case we must check if the Toop constituent is in the ternary ! but if we have just one skip it at present ! As we have just 3 constituents, i2 must be 1, 2 or 3 ! remove any previous Toop element asymter=1 write(*,*)'THIS CODE REPLACED BY AMEND PHASE ... ASYMMETRY ' ! that code around line 1288 if(asymter.le.0 .or. asymter.gt.size(tersys)) then write(*,*)'No such ternary' goto 100 endif ! ************************* this code redundant ************************* ! new_asymmetry='KKK' ! tersys is set later inside varkappa1 .... keep for the moment ! tersys(iz)%asymm='KKK' ! if(i2.eq.0) then ! write(*,*)'Restoring symmetric ternary' ! elseif(i2.eq.1) then ! Binary 1-2 has 3 as Toop, binary 1-3 has 2 as Toop, binary 2-3 has 1 as Toop ! THIS IS A MESS suck ! new_asymmetry(1:1)='T' ! tersys(iz)%isasym(1)=1; tersys(iz)%asymm(1:1)='T' ! elseif(i2.eq.2) then ! new_asymmetry(2:2)='T' ! tersys(iz)%isasym(2)=2; tersys(iz)%asymm(2:2)='T' ! elseif(i2.eq.3) then ! new_asymmetry(3:3)='T' ! tersys(iz)%isasym(3)=3; tersys(iz)%asymm(3:3)='T' ! else ! write(kou,*)'Use 1, 2 or 3. No change of asymmetry' ! goto 990 ! endif iz=asymter write(*,3201)iz,tersys(iz)%seq,(tersys(iz)%el(j4),j4=1,3),& tersys(iz)%isasym,tersys(iz)%asymm ! Now modify the ivk, jvk and kvk arrays ..... write(*,*)'THIS CODE REPLACED BY AMEND PHASE ... ASYMMETRY ' ! that code around line 1288 write(*,*)'Now modify the ivk, jvk and kvk arrays .....' ! type(gtp_phase_varres), pointer :: phres ! phres is the pointer to the phase_varres record of mqmqa phase ! call varkappa1(iz,phres) ! TYPE(gtp_phase_varres), pointer :: parres parres=>ceq%phase_varres(lokcs) if(allocated(parres%mqmqaf%compvar)) then ! make sure the varkappa are updated ! deafult is 0, to update set box%lastupdate to -1 parres%mqmqaf%compvar(iz)%lastupdate=-1 write(kou,*)'BUG Asymmetry update works only for first cation' ! this code is redundant <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ! call varkappa1(iz,parres,asymter,new_asymmetry) ! write(kou,*)'Asymmetry updated' else write(kou,*)'This phase has no asymmetry records' endif ! ! THE CODE ABOVE REPLACED around line 1374 by AMEND PHASE ... ASYMMETRY ! !........................................................... ! case(6) write(kou,*)'Not implemented yet' end SELECT mqmqa !------------------------------ end list mqmqa_specials ! LIST ESTIMATE_ACCURACY. Additional calculations are made ! Eventually included in case(12) ??? case(23) if(btest(ceq%status,EQNOEQCAL) .or. btest(ceq%status,EQFAIL)) then write(kou,*)'You must calculate an equilibrium first' goto 100 endif xxy=5.0 call gparrdx('Estimated uncertainty in conditions (%): ',& cline,last,xxx,xxy,'?List confidence interval') i1=optionsset%lut if(i1.eq.0) i1=kou call calc_conf_interval(i1,xxx,ceq) if(gx%bmperr.ne.0) then ceq%status=ibset(ceq%status,EQFAIL) goto 990 endif !------------------------------ ! list WORKING_DIR case(24) write(kou,1685)trim(workingdir) 1685 format('Current working directory is: ',a) !------------------------------ ! list ?? case(25) write(kou,*)'Not implemented yet' !------------------------------ ! list ?? case(26) write(kou,*)'Not implemented yet' !------------------------------ ! list ?? case(27) write(kou,*)'Not implemented yet' end SELECT list !================================================================= ! quit case(7) if(cline(1:1).eq.'q') then call gparcdx('Are you sure?',cline,last,1,ch1,'N','?Quit') else ! upper case Q will quit without question ch1='y' endif if(ch1.eq.'y' .or. ch1.eq.'Y') then if(logfil.gt.0) then write(logfil,*)'set interactive' endif call openlogfile(' ',' ',-1) stop 'Have a nice day' endif !================================================================= ! READ subcommand ! ['UNFORMATTED ','TDB ','QUIT ',& ! 'DIRECT ','XTDB ','SELECTED_PHASES '] case(8) ! disable continue optimization ! iexit=0 ! iexit(2)=1 if(noel().ne.0) then write(kou,*)'You already have data, read destroys your current data' write(kou,*)'You must give a NEW Y command to remove data first' goto 100 ! else ! all records must be removed and init_gtp is called. This is fragile ... ! call new_gtp ! if(gx%bmperr.ne.0) goto 990 ! write(kou,*)'All previous data deleted' ! endif endif kom2=submenu(cbas(kom),cline,last,cread,ncread,2,'?TOPHLP') read: SELECT CASE(kom2) !----------------------------------------------------------- CASE DEFAULT if(cline(len_trim(cline):len_trim(cline)).ne.'?') then ! This avoids error messages when ? is typed write(kou,*)'Read subcommand error: ',trim(cline) endif !----------------------------------------------------------- case(1) ! read unformatted file created by SAVE if(ocufile(1:1).ne.' ') then text=ocufile call gparcdx('File name: ',cline,last,1,ocufile,text,& '?Read unformatted') else ! default extension (1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT, 6=XTDB, 7=DAT ! negative is for write, 0 read without filter, -100 write without filter ztyp=2 call gparfilex('File name: ',cline,last,1,ocufile,' ',ztyp,& '?Read unformatted') endif call gtpread(ocufile,text) if(gx%bmperr.ne.0) then ocufile=' '; goto 990 endif ! This is written by the gtpread subroutine ! kl=len_trim(text) ! if(kl.gt.1) then ! write(kou,8110)text(1:kl) ! endif !8110 format(/'Savefile text: ',a/) ! if there is an assessment record set nvcoeff ... if(allocated(firstash%coeffvalues)) then nvcoeff=0 kl=size(firstash%coeffvalues)-1 do j4=0,kl if(firstash%coeffstate(j4).ge.10) then nvcoeff=nvcoeff+1 endif enddo write(kou,3730)nvcoeff else write(*,*)'No coefficients allocated' endif if(allocated(firstash%eqlista)) then write(*,*)'There are experimental data' endif !--------------------------------------------------------- case(2,7) ! read TDB and read ENCRYPTED ! indicate if the database is encrypted! if(kom2.eq.7) then globaldata%encrypted=1 else globaldata%encrypted=0 endif ! write(*,*)'PM glovaldata%encrypted: ',globaldata%encrypted if(tdbfile(1:1).ne.' ') then ! set previous tdbfil as default text=tdbfile call gparcdx('File name: ',cline,last,1,tdbfile,text,'?Read TDB') else ! default extension (1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT, 6=XTDB, 7=DAT ! negative is for write, 0 read without filter, -100 write without filter ztyp=1 call gparfilex('File name: ',cline,last,1,tdbfile,' ',ztyp,& '?Read TDB') endif ! if tdbfle starts with "ocbase/" replace that with content of ocbase!! ! write(*,*)'PMON tdbfile: ',trim(tdbfile) ! check for replacement of OCBASE probably redundant now ... name1=tdbfile(1:7) call capson(name1) if(name1(1:7).eq.'OCBASE/' .or. name1(1:8).eq.'OCBASE\ ') then tdbfile=trim(ocbase)//tdbfile(7:) write(*,*)'database file: ',trim(tdbfile) endif ! this call checks the file exists and returns the elements ! it also lists the DATABASE_INFO text ! call checkdb2(tdbfile,'.tdb',jp,ellist) call checkdb2(tdbfile,'.tdb',jp,elbase) if(gx%bmperr.ne.0) then write(kou,*)'No database with this name' tdbfile=' ' goto 990 elseif(jp.eq.0) then write(kou,*)'No elements in the database' tdbfile=' ' goto 100 elseif(jp.lt.0) then ! encrypted databases return jp=-1, we do not know number of elements ... write(kou,*)'Cannot list elements in encrypted databases' j4=20 goto 8207 endif ! write(kou,8203)jp,(ellist(kl),kl=1,jp) j4=jp write(kou,8203)jp,(elbase(kl),kl=1,j4) 8203 format('Database has ',i2,' elements: ',18(a,1x)/(1x,28(1x,a))) ellist=' ' write(kou,8205) 8205 format('Give the elements to select, finish with empty line') 8207 continue jp=1 selection='Select elements /all/:' 8210 continue call gparcx(selection,cline,last,1,ellist(jp),' ','?Read TDB') if(jp.eq.1 .and. cline(1:4).eq.'all ') then ! this is if someone actually types "all". If he types "ALL" that will be AL jp=0 elseif(cline(1:1).eq.'q' .or. cline(1:1).eq.'Q' .or.& cline(1:4).eq.'NONE') then ! if user regets selection he can quit write(*,*)'Quitting, nothing selected' goto 100 elseif(ellist(jp).ne.' ') then call capson(ellist(jp)) jp=jp+1 if(jp.gt.size(ellist)) then write(kou,*)'Max number of elements selected: ',size(ellist) else ll=last ! Check if element exist, unless encrypted ... if(globaldata%encrypted.eq.0) then elcheck: do j5=1,j4 if(ellist(jp-1).eq.elbase(j5)) exit elcheck enddo elcheck ! if we come here with j4>j5 then ellist(jp) is not in elbase(1..j4) if(j5.gt.j4) then jp=jp-1 write(kou,'(a,i3,1x,a)')' *** WARNING: No such element:',& jp,ellist(jp) endif endif if(eolch(cline,last)) then ! if empty line list current selection and prompt for more write(*,8220)jp-1,(ellist(iel),iel=1,jp-1) else ! we must reset position in cline if there is more ... last=ll endif selection='Select elements /no more/:' goto 8210 endif else jp=jp-1 endif if(jp.eq.0) then write(kou,*)'All elements selected' else write(*,8220)jp,(ellist(iel),iel=1,jp) 8220 format('Selected ',i2,' elements: ',20(a,1x)) endif call readtdb(tdbfile,jp,ellist) if(gx%bmperr.ne.0) then ! inside readtdb any "buperr" will be set as gx%bmperr write(kou,*)'There were errors reading the TDB file', gx%bmperr if(gx%bmperr.ge.4000 .and. gx%bmperr.le.nooferm) then write(kou,*)bmperrmess(gx%bmperr) endif write(kou,*)'Please correct these before continuing' ! ignore any type ahead last=len(cline) call gparcdx('Do you want to continue anyway?',& cline,last,1,ch1,'N','?Read TDB error') if(ch1.ne.'Y') then stop 'Good luck fixing the TDB file' endif endif ! also list the bibliography write(kou,*) call list_bibliography(' ',kou) write(kou,*) if(firsteq%multiuse.ne.0) then write(*,8221) 8221 format(/' *** There were warnings from reading the database'/& ' *** If you run a macro file please scroll back and check!'/) endif !----------------------------------------------------------- !8300 continue case(3) ! read quit goto 100 !----------------------------------------------------------- case(4) ! read direct write(*,*)'Read direct not implemented yet' !----------------------------------------------------------- ! read the new XTDB format for Calphad databases case(5) ! read XTDB if(xtdbfile(1:1).ne.' ') then text=xtdbfile write(*,*)'debug; ',trim(text) call gparcdx('File name: ',cline,last,1,xtdbfile,text,'?Read XTDB') else ! THESE TYPES ARE USED ALSO IN METLIB4 ! default extension (1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT, 6=XTDB, 7=DAT, 8=LOG ! negative is for write, 0 read without filter, -100 write without filter ztyp=6 call gparfilex('File name: ',cline,last,1,xtdbfile,' ',ztyp,& '?Read XTDB') endif if(xtdbfile(1:1).eq.' ') goto 100 ! this call checks the file exists and returns the elements ! It is in gtp3EY and can handle the j5 then ellist(jp) is not in elbase(1..j4) if(j5.gt.j4) then jp=jp-1 write(kou,'(a,i3,1x,a)')'No such element: ',jp,ellist(jp) endif if(eolch(cline,last)) then ! if empty line list current selection and prompt for more write(*,8220)jp-1,(ellist(iel),iel=1,jp-1) else ! we must reset position in cline if there is more ... last=ll endif selection='Select elements /no more/:' goto 8219 endif else jp=jp-1 endif if(jp.eq.0) then write(kou,*)'All elements selected' else write(*,8220)jp,(ellist(iel),iel=1,jp) !8220 format('Selected ',i2,' elements: ',20(a,1x)) endif ! SPECIAL SELECT_PHASES ! ask for phses to be selected, max 100, seltdbph global variable allocate(seltdbph(100)) j4=0 selection='Select phase(s) /all/:' selph: do while (.TRUE.) call gparcdx(selection,& cline,last,1,line,' ','?Read select phase') if(line(1:1).eq.' ') exit selph selection='Select more phase(s):' ! There is at least one phase name in line j2=1 phname: do while(.not.eolch(line,j2)) j4=j4+1 if(j4.gt.100) then write(*,*)'Max 100 phases can be selected' exit selph endif j2=j2-1 ! getext increments i2 by 1 at each call. A space or , between each name ! write(*,*)'pmon 1:',trim(line),j2,j4 call getext(line,j2,1,seltdbph(j4),' ',i1) call capson(seltdbph(j4)) ! write(*,*)'pmon 2:',seltdbph(j4),i1 enddo phname enddo selph ! nselph is a global variabel nselph=j4 if(nselph.gt.0) then write(*,*)nselph,' phase abbreviations specified ' else write(*,*)'No phase specified, all will be read' endif ! do j2=1,j4,3 ! write(*,'(a,1x,a,1x,a)')(trim(seltdbph(j2+i1)),i1=0,2) ! enddo ! Finally read the TDB file ! if seltdbph is allocated only those phase will be inlcuded call readtdb(tdbfile,jp,ellist) deallocate(seltdbph) if(gx%bmperr.ne.0) then ! inside readtdb any "buperr" will be set as gx%bmperr write(kou,*)'There were errors reading the TDB file', gx%bmperr if(gx%bmperr.ge.4000 .and. gx%bmperr.le.nooferm) then write(kou,*)bmperrmess(gx%bmperr) endif write(kou,*)'Please correct these before continuing' ! ignore any type ahead last=len(cline) call gparcdx('Do you want to continue anyway?',& cline,last,1,ch1,'N','?Read TDB error') if(ch1.ne.'Y') then stop 'Good luck fixing the TDB file' endif endif ! also list the bibliography write(kou,*) call list_bibliography(' ',kou) write(kou,*) if(firsteq%multiuse.ne.0) then write(*,8221) !8221 format(/' *** There were warnings from reading the database'/& ! ' *** If you run a macro file please scroll back and check!'/) endif ! case(7) ! read ENCRYPTED ! part of read TDB case(8) ! read ? write(*,*)'Not implemented yet' case(9) ! read ? write(*,*)'Not implemented yet' end SELECT read !================================================================= ! SAVE in various formats (NOT MACRO and LATEX, use LIST DATA) ! It is a bit inconsistent as one READ TDB but not SAVE TDB ... ! ['TDB ',' ','QUIT ',& ! 'DIRECT ','UNFORMATTED ','XTDB '] CASE(9) ! default is 3, unformatted kom2=submenu(cbas(kom),cline,last,csave,ncsave,1,'?TOPHLP') if(kom2.le.0 .or. kom2.gt.ncsave) goto 100 ! call date_and_time(optres,name1) ! optres(1:8) is year+month+day, name1(1:4) is hour and minutes model=' '//optres(1:4)//'.'//optres(5:6)//'.'//optres(7:8)//& ' '//name1(1:2)//'h'//name1(3:4)//' ' save: SELECT CASE(kom2) !----------------------------------------------------------- CASE DEFAULT write(kou,*)'save subcommand error' !----------------------------------------------------------- case(1) ! save TDB, same as list data TDB ! format 1 is TDB, see list data ... if(globaldata%encrypted.ne.0) then write(kou,*)'Illegal for encrypted databases' goto 100 endif ! gparfilex next to last argument is negative if ztyp=-1 call gparfilex('File name: ',cline,last,1,filename,text,ztyp,& '?Save TDB') ! Bosse do not understand ??? kl=max(index(filename,'.dat '),index(filename,'.TDB ')) if(kl.le.0) then kl=len_trim(filename)+1 if(kl.eq.1) then write(*,*)'Too short file name' goto 100 endif ! Bosse do not understand ??? ! filename(kl:)='.DAT ' endif ! inside list_TDB_format ! write(*,*)'PMON calling list_TDB_formats' call list_TDB_format(filename) ! write(*,*)'PMON back from list_TDB_formats' if(gx%bmperr.ge.4000 .and. gx%bmperr.le.nooferm) then write(kou,*)bmperrmess(gx%bmperr) elseif(gx%bmperr.ne.0) then write(kou,*)'Error code ',gx%bmperr endif !----------------------------------------------------------- case(2) ! used to be SOLGAS no longer available continue !----------------------------------------------------------- case(3) ! save quit, do nothing continue !----------------------------------------------------------- case(4) ! save DIRECT write(*,*)'Not implemented' goto 100 ! probably never to be implemented, save UNFORMATTED can include STEP/MAP if(ocdfile(1:1).ne.' ') then text=ocdfile call gparcdx('File name: ',cline,last,1,ocdfile,text,'?Save direct') else ! default extension (1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT, 6=XTDB, 7=DAT ! negative is for write, 0 read without filter, -100 write without filter ztyp=-4 call gparfilex('File name: ',cline,last,1,ocdfile,' ',ztyp,& '?Save direct') endif jp=0 kl=index(ocdfile(2:),'.')+1 if(kl.le.0) then jp=len_trim(ocdfile) elseif(ocdfile(kl+1:kl+1).eq.' ') then ! just ending a filename with . not accepted as extention jp=kl endif if(kl.le.1 .and. jp.le.0) then write(kou,*)'Missing file name, nothing saved' goto 100 endif if(jp.gt.0) ocdfile(jp+1:)='.OCD ' text='M '//model call gtpsave(ocdfile,text) !----------------------------------------------------------- case(5) ! save unformatted 132 continue ! save unformatted after step/map not recommended as equilibria ! unless equilibria with _MAPLINE and _MAPNODE not deleted ! Reading an unformatted file with these prevents any new new STEP/MAP call findeq('_MAPLINE_1 ',ieq) if(gx%bmperr.eq.0) then write(kou,*)'Please use DELETE STEP_MAP before unformatted save' goto 100 else ! there are no map/step equilibria, OK to save gx%bmperr=0 endif ! if(ocufile(1:1).ne.' ') then text=ocufile call gparcdx('File name: ',cline,last,1,ocufile,text,& '?Save unformatted') else ! default extension (1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT, 6=XTDB, 7=DAT ! negative is for write, 0 read without filter, -100 write without filter ztyp=-2 call gparfilex('File name: ',cline,last,1,ocufile,' ',ztyp,& '?Save unformatted') endif jp=0 ! ignore first letter as in macro files a file name may start with ./ kl=index(ocufile(2:),'.')+1 if(kl.le.1) then jp=len_trim(ocufile) elseif(ocufile(kl+1:kl+1).eq.' ') then ! just ending a filename with . not accepted as extention jp=kl endif if(kl.le.1 .and. jp.le.0) then write(kou,*)'Missing file name, nothing saved' goto 100 endif ! I have no way to handle the extention to upper case ... inside C routine ! if(jp.gt.0) ocufile(jp+1:)='.ocu ' if(jp.gt.0) ocufile(jp+1:)='.OCU ' inquire(file=ocufile,exist=logok) if(logok) then call gparcdx('File exists, overwrite?',cline,last,1,ch1,'N',& '?Save overwite') if(ch1.ne.'Y') then write(*,133) 133 format('Please use another file name') ocufile=' ' goto 132 endif write(*,134)trim(ocufile) 134 format(/'Overwriting previous results on ',a) endif text='U '//model call gtpsave(ocufile,text) !----------------------------------------------------------- case(6) ! SAVE XTDB ! write(kou,*)'PMON: XTDB format still fragile' if(globaldata%encrypted.ne.0) then write(kou,*)'Illegal for encrypted databases' goto 100 endif ! is there any data? if(noph().le.0) then write(kou,*)'There is no data to save' goto 100 endif ! Ask for file name ! default extension (1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT, 6=XTDB, 7=DAT ! negative is for write, 0 read without filter, -100 write without filter ztyp=-6 call gparfilex('File name: ',cline,last,1,xtdbfile,' ',ztyp,& '?Save XTDB') ! zext='XTDB' ! this subrouine is in gtp3EX.F90 call write_xtdbformat(xtdbfile,zext) if(gx%bmperr.ne.0) goto 990 end SELECT save !================================================================= ! help ... just list the commands case(10) call q3helpx(cline,last,cbas,ncbas) goto 100 !================================================================= ! subcommands to INFORMATION ... very little implemented ! ['ELEMENTS ','SPECIES ','PHASES ',& ! 'QUIT-INFO ','COMPOSITION_SET ','EQUILIBRIUM ',& ! 'HELP_SYSTEM ','CONDITIONS ','DATABASES ',& ! 'CHANGES ','PHASE_DIAGRAM ','PROPERTY_DIAGRAM',& ! 'STATE_VARIABLES ',' ',' '] case(11) ! kom2=submenu(cbas(kom),cline,last,cinf,ninf,10,'?TOPHLP') ! initial default is CHANGES iz=10 ! return here until quit 207 continue kom2=submenu('Topic?',cline,last,cinf,ninf,iz,'?TOPHLP') ! change default to quit iz=4 information: select case(kom2) !------------------------------------------------------- CASE DEFAULT write(*,*)'Information subcommand error' !-------------------------------------------------------- ! INFO elements case(1) write(kou,210) 210 format('The elements are those from the periodic chart.'/& 'Normally the components are the same as the elemets but',& ' the user',/'can define any orthogonal set of species as',& ' components.') call q4help('Info elements',jp) !-------------------------------------------------------- ! info species case(2) write(kou,211) 211 format('Species are molecular like aggregates of elements with',& ' fixed stoichiometry.',/'The elements are the simplest',& ' species.'/'The constituents of a phase are a subset of',& ' the species.') call q4help('Info species',jp) !-------------------------------------------------------- ! info phases case(3) call q4help('Info phases',jp) !-------------------------------------------------------- ! quit, we must exit to top level here !! case(4) goto 100 !-------------------------------------------------------- ! info composition set case(5) call q4help('Info compset',jp) !-------------------------------------------------------- ! info equilibrium case(6) call q4help('Info equilibrium',jp) !-------------------------------------------------------- ! INFO help system case(7) ! none call q4help('Info helpsystem',jp) !-------------------------------------------------------- ! INFO conditions case(8) ! none call q4help('Info conditions',jp) !-------------------------------------------------------- ! INFO databases case(9) ! none call q4help('Info databases',jp) !-------------------------------------------------------- ! changes case(10) write(kou,'(a/)')'Writing from "OCHOME/changes.txt"' open(31,file=trim(OCHOME)//'/changes.txt ',access='sequential',& err=990,iostat=buperr) changes: do while(.TRUE.) do i1=1,40 read(31,17,end=244,err=990)line write(kou,17)trim(line) 17 format(a) enddo write(kou,*)'Press return to continue, q to quit' read(kiu,17)ch1 if(ch1.eq.'q' .or. ch1.eq.'Q') exit changes enddo changes 244 close(31) !-------------------------------------------------------- ! INFO phase diagram case(11) ! none call q4help('Info phasediagram',jp) !-------------------------------------------------------- ! INFO property diagram case(12) ! none call q4help('Info propertydiagram',jp) !-------------------------------------------------------- ! INFO statevariables case(13) ! none call q4help('Info statevariables',jp) !-------------------------------------------------------- ! INFO case(14) ! none ! call q4help('Info ',jp) !-------------------------------------------------------- ! INFO case(15) ! none ! call q4help('Info ',jp) end select information goto 207 !================================================================= ! back / goto, return to calling (main) program case(12) write(*,*)'Welcome back!' return !================================================================= ! NEW command, same as reinitiate case(13) ! NEW ! one must deallocate everyting explicitly to use memory again call gparcdx('All data will be removed, are you sure?',cline,last,& 1,ch1,'N','?New') if(ch1.ne.'Y') then write(kou,*)'*** NO CHANGE, upper case Y needed for NEW' goto 100 endif ! remove global check during map mapglobalcheck=0 stepspecial=.FALSE. !------remove assessment data ! write(*,*)'No segmentation fault 1' if(allocated(firstash%eqlista)) then write(*,*)'Assessment data removed, not deallocated: memory leak' endif ! write(*,*)'No segmentation fault 2' if(allocated(firstash%eqlista)) deallocate(firstash%eqlista) deallocate(firstash) ! write(*,*)'No segmentation fault 3, deallocate errs ' if(mexp.gt.0) deallocate(errs) mexp=0 updatemexp=.true. nvcoeff=0 ! initiate the limit on number of equilibria saved during step/map totalsavedceq=0 ! iexit=0 ! iexit(2)=1 ! write(*,*)'No Segmentation fault 4' !----- deleting map results ... ! write(*,*)'PM Deleting map results' if(associated(maptopsave)) then ! this is necessary only if no plot of last step/map made ... write(kou,*)'We link to maptopsave' maptop%plotlink=>maptopsave nullify(maptopsave) endif seqxyz=0 ! write(*,*)'Calling delete_mapresults' call delete_mapresults(maptop) if(gx%bmperr.ne.0) then write(*,*)'Error deleting map results! Report this error with macro!' stop endif ! write(*,*)'Back from delete_mapresults' nullify(maptop) nullify(mapnode) nullify(maptopsave) seqxyz=0 !----- deallocate local axis records do jp=1,noofaxis if(allocated(axarr(jp)%axcond)) deallocate(axarr(jp)%axcond) ! deallocate(axarr(jp)%indices) ! deallocate(axarr(jp)%coeffs) enddo noofaxis=0 ! remove some more defaults ... defcp=1 ! deallocate does not work on pointers!!! nullify(starteqs(1)%p1) noofstarteq=0 ! ! this routine fragile, inside new_gtp init_gtp is called ! write(*,*)'No segmentation fault 7, calling new_gtp' call new_gtp if(gx%bmperr.ne.0) then write(*,*)'Error deleting data! Report this error with macro!' stop endif write(kou,*)'All data removed, reinitiating' call init_gtp(intv,dblv) if(gx%bmperr.ne.0) then write(*,*)'Error initiating! Report this error with macro!' stop endif ! write(kou,*)'Workspaces initiated' ! ceq=>firsteq goto 20 !================================================================= ! macro begin case(14) ! file name is asked inside macbeg call macbeg(cline,last,logok) if(buperr.ne.0 .or. gx%bmperr.ne.0) goto 990 !================================================================= ! about case(15) write(kou,15010)version,linkdate 15010 format(/'This is OpenCalphad (OC), a free software for ',& 'thermodynamic calculations as described in:'/& 'B Sundman, U R Kattner, M Palumbo and S G Fries, ',& 'Int Mat and Manu Innov (2015) 4:1; '/& 'B Sundman, X-G Lu and H Ohtani, Comp Mat Sci, Vol 101 ',& '(2015) 127-137'/'B Sundman, N Dupin and B Hallstedt, ',& 'Calphad, Vol 75 (2021) 102330'//& 'It is available for download at http://www.opencalphad.org or'/& 'the sundmanbo/opencalphad repository at https://www.github.com'//& 'This software is protected by the GNU General Public License'/& 'either version 2 of the license, or any later version.'/& 'You may use freely and distribute copies as long as you provide ',& 'the source code'/'and use the GNU GPL license also for your own',& ' additions and modifications.'//& 'The software is provided "as is" without any warranty of any ',& 'kind, either'/'expressed or implied. ',& 'The full license text is provided with the software'/& 'or can be obtained from the Free Software Foundation ',& 'http://www.fsf.org'//& 'Copyright 2011-2022, Bo Sundman, Gif sur Yvette, France.'/& 'Contact person Bo Sundman, bo.sundman@gmail.com'/& 'This version ',a,' was compiled ',a/) !================================================================= ! debug subcommands case(16) kom2=submenu(cbas(kom),cline,last,cdebug,ncdebug,1,'?TOPHLP') debug: SELECT CASE (kom2) !------------------------------ CASE DEFAULT write(kou,*)'Debug subcommand error ',kom2 !------------------------------ ! debug free lists CASE(1) write(*,*)'Check components masses' call compmassbug(ceq) ! write(*,*)'Calculating equilibrium record size' ! kom3=ceqsize(ceq) ! write(kou,*)'Current equilibrium record memory use: ',kom3 ! list all tuples write(kou,1617) 1617 format('Phase tuples content:'/& 'Tuple lokph compset ixphase lokvares nextcs phase name',& ' disfra vareslink') do jp=1,nooftup() call get_phasetup_name(jp,name1) ! this is a check that %ihaseix and lokvares are correct ! if(phasetuple(jp)%compset.eq.1) then ! call get_phase_compset(jp,1,lokph,lokcs) ! else ! call get_phase_compset(phasetuple(jp)%ixphase,& ! phasetuple(jp)%compset,lokph,lokcs) ! endif ! write(kou,16020)jp,phasetuple(jp),name1,lokph,lokcs write(kou,16020)jp,phasetuple(jp),name1,& ceq%phase_varres(phasetuple(jp)%lokvares)%disfra%varreslink 16020 format(i3,': ',2i7,2i9,i6,3x,a,2x,i6) enddo call list_free_lists(kou) write(*,*)'Testing tupix converter' 16100 continue call gparidx('phase index',cline,last,i1,0,'none') if(i1.gt.0) then call gparidx('composition set',cline,last,i2,1,'none') write(*,*)'Tuple index: ',gettupix(i1,i2) if(gx%bmperr.eq.0) goto 16100 goto 990 endif !------------------------------ ! debug stop_on_error CASE(2) if(stop_on_error) then stop_on_error=.FALSE. write(kou,*)'No longer stop on error' else write(kou,*)'Macro will stop if error' stop_on_error=.true. endif !------------------------------ ! debug parameter structure case(3) ! advanced listing of data structure ! open file ! negative is for write, 0 read without filter, -100 write without filter write(*,*)'PMON: DEBUG case 3' ztyp=-7 call gparfilex('Output file',cline,last,1,string,' ',ztyp,& '?Debug parameter') if(string(1:1).eq.' ') then string='parameter_output.DAT' write(kou,*)' *** No file name given, will use: ',trim(string) endif ! slen=len_trim(string) ! add extention .dat if to extenstion provided ! if(index(string,'.').le.0) then ! string(slen+1:)='.DAT ' ! endif ! close any previous output file close(21) open(21,file=string,access='sequential',status='unknown',& err=990, iostat=buperr) lut=21 ! select phase phlistloop: do while(name1(1:1).ne.' ') call gparcx('Phase: ',cline,last,1,name1,' ',& '?Set Advanced') if(name1(1:1).eq.' ') exit phlistloop call find_phase_by_name(name1,iph,ics) if(gx%bmperr.ne.0) then write(*,*)'No such phase; ',trim(name1) exit phlistloop endif call get_phase_record(iph,lokph) ! list parameter structure call debug_phaseparameters(lokph,lut,ceq) ! another phase enddo phlistloop write(lut,*)'Closing file' write(kou,*)'Closing file ',trim(string) close(lut) !---------------------------------- ! debug species case(4) do i1=1,nosp() call get_species_location(i1,loksp,name1) if(gx%bmperr.ne.0) goto 990 call get_species_component_data(loksp,i2,iphl,stoik,xxx,& xxy,ceq) if(gx%bmperr.ne.0) goto 990 write(kou,1670)i1,loksp,name1,xxx,xxy,(iphl(j4),stoik(j4),j4=1,i2) 1670 format(2i4,1x,a12,1x,2F6.2,2x,10(i3,1x,F7.4)) enddo !--------------------------------- ! debug tpfun case(5) call gparidx('Function index:',cline,last,ll,-1,'?Debug TPfun') call list_tpfun_details(ll) !--------------------------------- ! debug browser case(6) ! testing using HTML helpfile with "anchors" like ! related to a question or command ! and the the help utility will search for a specific label as below ! NOTE in the LaTeX file \usepackage{hyperref} ! and in the text \hypertarget{selectname} ! using "path/browser" "file://path/helpfile#label" should position ! the html window at label!! ! the label "selectname" is in the html file ... call gparcdx('File name: ',cline,last,5,model,& './manual\html\ochelp.html#selectelement ','?Debug browser') ! browser='"C:\Program Files\Mozilla firefox\firefox.exe" ' ! this browser can be opened without "" browser='C:\PROGRA~1\INTERN~1\iexplore.exe ' ! it works to open the ochelp.html on the first page ! string=trim(browser)//& ! ' -file ./manual/html/ochelp.html' ! write(*,'(a)')trim(string) ! gnu fortran ... ! call system(...) ! call execute_command_line(string) ! now the complicated one ... string=trim(browser)//& ' "file://C:\Users\bosse\documents\oc\oc\src\'//& trim(model(3:))//'"' write(*,'(a)')trim(string) call execute_command_line(string) ! This command works in a Windows terminal window: ! "C:\program files\Mozilla firefox\firefox.exe" ! "file://c:\users\bosse\documents\oc\oc\src\manual\html\ochelp.html#selectelement" ! but problems using as command ... ! This works also: !c:\Program Files\internet explorer\iexplore.exe" "file://c:\users\bosse\documents\oc\oc\src\manual\html\ochelp.html#selectelement" ! maybe possible to access by directory names with only 8 bytes ... !linux!linux!linux!linux!linux!linux!linux!linux!linux!linux!linux!linux!linux ! !> call gparcd('File name: ',cline,last,5,model,& !> '/home/bosse/OC/OC5-20/manual/ochelp.html#selectelement ',q1help) ! this browser can be opened without "" !> browser='/usr/bin/firefox ' !> string=trim(browser)//' "file:'//trim(model(1:))//'"' !> write(*,'(a)')trim(string) ! This command works in a Linux terminal window: ! /usr/bin/firefox -file /home/bosse/OC/OC5-20/manual/ochelp.html ! it does not work to add #selectelement at the end (no such file name) ! This work in Linux terminal window: ! /usr/bin/firefox "file:/home/bosse/.../manual/ochelp.html#selectelement" ! !linux!linux!linux!linux!linux!linux!linux!linux!linux!linux!linux!linux!linux !--------------------------------- ! debug trace case(7) call gparcdx('Read TDB debug?',cline,last,1,ch1,'Y','?Debug dbcheck') if(ch1.eq.'Y') then dbcheck=.TRUE. else dbcheck=.FALSE. endif call gparcdx('HTML help?',cline,last,1,ch1,'Y','?Debug trace') if(ch1.eq.'Y') then helptrace=.TRUE. else helptrace=.FALSE. endif call gparcdx('plotting?',cline,last,1,ch1,'N','?Debug plot') if(ch1.eq.'Y') then plottrace=.TRUE. else plottrace=.FALSE. endif !.................................. ! debug symbol value case(8) ! this allows a command "debug symbol value" which will test if symbol ! has the specified value (+/- 10^(-6). ! Should be useful in the test macros ... ! 4th argument 2 means terminate at " ", ignore any , call gparcx('Symbol: ',cline,last,2,name1,' ','?Debug symbol value') call gparrx('Value: ',cline,last,xxy,zero,'?Debug symbol value') call capson(name1) ! code below copied from SHOW command model=' ' call get_state_var_value(name1,xxx,model,ceq) if(gx%bmperr.ne.0) then gx%bmperr=0 ! If error then try to calculate a symbol ... ! below copied from calculate symbol, first calculate all symbols ignore errors ! calculate all symbols ignoring errors (note dot derivatives not calculated) call meq_evaluate_all_svfun(-1,ceq) if(gx%bmperr.ne.0) gx%bmperr=0 call capson(line) call find_svfun(name1,istv) if(gx%bmperr.ne.0) then write(*,*)'Error finding symbol' stop endif mode=1 actual_arg=' ' xxx=meq_evaluate_svfun(istv,actual_arg,mode,ceq) if(gx%bmperr.ne.0) then write(*,*)'Error calculating symbol' stop endif write(kou,2047)trim(name1),xxx endif ! test for NaN, a NaN is never equal to itself ! if(xxx /= xxx) then if(xxx .ne. xxx) then write(kou,*)'Calculated value of ',trim(name1),' is NaN' stop endif xxz=1.0D-6 if(abs(xxy).gt.1.0d0) xxz=xxz*abs(xxy) if(abs(xxx-xxy).gt.xxz) then write(kou,'(a,2(1pe12.4))')'Symbol value outside limit!',xxx,xxy stop else write(kou,*)'Testing symbol ',trim(name1),' value OK ++++++++' endif !.................................. ! debug map_startpoints commented away ! debug ender MQMQA species case(9) ! nullify(starteqs(1)%p1) ! starteqs(1)%p1=>ceq ! call auto_startpoints(maptop,noofaxis,axarr,seqxyz,starteqs) ! if(gx%bmperr.ne.0) goto 990 !.................................. ! debug grid. This calculates grid for phases one by one and check case(10) call check_all_phases(0,ceq) !.................................. ! DEBUG Kohler/Toop and MQMQA_QUADS constituent test case(11) ! specifying which sublattice each element belong to ! jp=0 ! mqmqa: do while(.true.) ! call gparcdx('MQMQA quadrupoles: ',& ! cline,last,5,aline,' ','?Debug MQMQA') ! if(aline(1:1).eq.' ') exit mqmqa ! call mqmqa_constituents(aline,const,jp) ! jp=1 ! enddo mqmqa ! if(gx%bmperr.ne.0) goto 990 ! finished by an empty line, then replace species by endmembers ! call mqmqa_rearrange(const) !.................................. ! add list ternary extrapolation methods write(kou,1682) 1682 format(/'Data for ternary extrapolation methods') call list_ternary_extrapol_data(kou) write(kou,'("no more")') ! if(.not.allocated(mqmqa_data%contyp)) then write(*,*)'No MQMQA data entered' goto 100 endif call gparcx('Phase name: ',cline,last,1,name1,'LIQUID ',& '?Debug mqmqa') if(buperr.ne.0) goto 990 call find_phase_by_name(name1,iph,ics) if(gx%bmperr.ne.0) goto 990 write(*,*)'Constituents in sublattices: ',& mqmqa_data%ncon1,mqmqa_data%ncon2 do jp=1,mqmqa_data%nconst call get_constituent_name(iph,jp,name2,xxx) if(gx%bmperr.ne.0) goto 990 write(*,12)jp,(mqmqa_data%contyp(kl,jp),kl=1,10),& (mqmqa_data%constoi(kl,jp),kl=1,4),trim(name2) 12 format('Quad ',i3,1x,4i3,1x,i3,1x,5i3,1x,4F6.2,1x,a) enddo !........................ case(12) ! test bombmatta for mapping nullify(starteqs(1)%P1) starteqs(1)%P1=>ceq call bombmatta(maptop,noofaxis,axarr,seqxyz,starteqs) END SELECT debug !================================================================= ! select command case(17) kom2=submenu(cbas(kom),cline,last,cselect,nselect,1,'?TOPHLP') selct: SELECT CASE(kom2) !----------------------------------------------------------- CASE DEFAULT write(kou,*)'Select subcommand error' goto 100 !----------------------------------------------------------- CASE(1) ! select equilibrium if(ceq%eqno.lt.noeq()) then name1='NEXT' else name1='DEFAULT' endif call gparcdx('Give name or number?',cline,last,1,text,& name1,'?Select equilibrium') if(buperr.ne.0) goto 990 ! if the user types "next" in lower case or an abbrev it does not work call capson(text) if(compare_abbrev(text,'NEXT ')) then i1=ceq%eqno+1 call selecteq(i1,ceq) if(gx%bmperr.ne.0) goto 990 neqdef=i1 elseif(compare_abbrev(text,'PREVIOUS ')) then i1=max(ceq%eqno-1,1) call selecteq(i1,ceq) if(gx%bmperr.ne.0) goto 990 neqdef=i1 elseif(compare_abbrev(text,'LAST ')) then i1=noeq() call selecteq(i1,ceq) if(gx%bmperr.ne.0) goto 990 neqdef=i1 elseif(compare_abbrev(text,'FIRST ')) then i1=1 call selecteq(i1,ceq) if(gx%bmperr.ne.0) goto 990 neqdef=i1 else ! check if number j4=1 call getint(text,j4,i1) if(buperr.ne.0) then buperr=0 ! findeq accepts PREVIOUS and FIRST (same as DEFAULT) ieq=ceq%eqno call findeq(text,ieq) if(gx%bmperr.ne.0) goto 990 neqdef=ieq ceq=>eqlista(ieq) else call selecteq(i1,ceq) if(gx%bmperr.ne.0) goto 990 neqdef=i1 endif endif write(kou,'(a,i4,", name: ",a)')'Current equilibrium no: ',& ceq%eqno,ceq%eqname !----------------------------------------------------------- CASE(2) ! select minimizer write(kou,*)'Sorry, only one available: ',minimizers(2) write(kou,*)'Selected minimizer: ',minimizers(minimizer) !----------------------------------------------------------- case(3) ! select graphics write(kou,*)'Not implemented yet' !----------------------------------------------------------- case(4) ! select language, at present only 1 English and 2 French write(kou,*)'Not implemented yet' !----------------------------------------------------------- case(5) ! select optimizer write(kou,845)optimizers(optimizer) write(kou,844)optimizers 844 format('Available optimizers: '/,(2x,a,2x,a,2x,a)) 845 format('Current optimizer is: '/,2x,a) call gparcdx('Do you want to use LMDIF?',cline,last,1,ch1,'Y',& '?Select optimizer') if(ch1.eq.'Y') then optimizer=1 else write(*,*)'Sorry VA05AD is no longer available' endif write(kou,*)'You have selected ',optimizers(optimizer) !----------------------------------------------------------- case(6) goto 100 END SELECT selct !================================================================= ! DELETE not much implemented ... ! ['ELEMENTS ','SPECIES ','PHASE ',& ! 'QUIT ','COMPOSITION_SET ','EQUILIBRIUM ',& ! 'STEP_MAP_RESULTS',' ',' '] CASE(18) ! disable continue optimization ! iexit=0 ! iexit(2)=1 kom2=submenu(cbas(kom),cline,last,crej,nrej,6,'?TOPHLP') delete: SELECT CASE(kom2) !----------------------------------------------------------- CASE DEFAULT write(kou,*)'Delete subcommand error' goto 100 !----------------------------------------------------------- ! delete element case(1) write(kou,18010) 18010 format(' *** Warning, this command will delete the data for the',& ' element, species or'/' phase specified and the data cannot',& ' be recovered unless read again from'/' file. If you',& ' only want to temporarily remove some data use QUIT'/& ' from this command and then SET STATUS'/) write(kou,*)'Not implemented yet' !----------------------------------------------------------- ! delete species case(2) write(kou,18010) write(kou,*)'Not implemented yet' !----------------------------------------------------------- ! delete phase case(3) write(kou,18010) write(kou,*)'Not implemented yet' !----------------------------------------------------------- ! quit case(4) goto 100 !----------------------------------------------------------- ! delete composition set, always that with higest number case(5) call gparcx('Phase name: ',cline,last,1,name1,' ','?Delete phase') if(buperr.ne.0) goto 990 call find_phase_by_name(name1,iph,ics) if(gx%bmperr.ne.0) goto 990 call remove_composition_set(iph,.FALSE.) if(gx%bmperr.ne.0) goto 990 !----------------------------------------------------------- ! delete equilibria case(6) call gparcx('Equilibrium name or abbr.:',cline,last,1,name1,' ',& '?Delete equilibrium') if(buperr.ne.0) goto 990 call delete_equilibria(name1,ceq) if(gx%bmperr.ne.0) goto 990 !----------------------------------------------------------- ! delete step_map_results case(7) if(associated(maptopsave)) then ! this is necessary only if no plot of last step/map made ... maptop%plotlink=>maptopsave nullify(maptopsave) write(*,*)'maptopsave nullified' endif seqxyz=0 ! this does not delete _mapnode and _mapline equilibria ??? call delete_mapresults(maptop) ! remove any results from step and map ! if(associated(maptop)) then ! write(*,*)'maptop nullified: ',maptop%next%seqx ! maptop%next%seqx=0 ! maptop%next%seqy=0 ! maptop%seqx=0 ! maptop%seqy=0 ! nullify(maptop) ! endif nullify(maptop) nullify(mapnode) nullify(maptopsave) !----- deallocate local axis records do jp=1,noofaxis if(allocated(axarr(jp)%axcond)) deallocate(axarr(jp)%axcond) enddo noofaxis=0 ! remove some more defaults ... defcp=1 ! deallocate does not work on pointers!!! nullify(starteqs(1)%p1) noofstarteq=0 call reset_plotoptions(graphopt,plotfile,textlabel) axplotdef=' ' !----------------------------------------------------------- ! case(8) continue !----------------------------------------------------------- ! case(9) continue end SELECT delete !================================================================= ! STEP, must be tested if compatible with assessments ! ['NORMAL ','SEPARATE ','QUIT ',& ! 'CONDITIONAL ','TZERO ','LIQUID_EET ',& ! 'SHEIL_GULLIVER ','PARAEQUILIBRIUM ','FAST '] case(19) ! disable continue optimization ! iexit=0 ! iexit(2)=1 if(noofaxis.ne.1) then write(kou,*)'You must set exactly one independent axis variable',& ' for a step calculation.' goto 100 endif ll=degrees_of_freedom(ceq) if(ll.ne.0) then write(*,*)'Degrees of freedom not zero',ll goto 100 endif ! forget any previous step special stepspecial=.FALSE. ! IMPORTANT I have changed the order between option and reinitiate!! kom2=submenu('Step options?',cline,last,cstepop,nstepop,1,'?TOPHLP') ! skip here for step quit and other cases not implemented: case(3 and 4) if(kom2.eq.3 .or. kom2.eq.4) goto 100 ! check if there are previous results if(associated(maptop)) then write(kou,833) 833 format('There are previous results from step or map') call gparcdx('Delete them?',cline,last,1,ch1,'Y','?Step old data') if(ch1.eq.'y' .or. ch1.eq.'Y') then ! there should be a more careful deallocation to free memory call delete_mapresults(maptop) ! deallocate(maptop%saveceq) nullify(maptop) nullify(maptopsave) write(kou,*)'Previous results removed' ! This is to keep trace of total number of saved equilibria totalsavedceq=0 ! delete equilibria associated with STEP/MAP call delete_equilibria('_MAP*',ceq) seqxyz=0 ! remove all graphopt settings call reset_plotoptions(graphopt,plotfile,textlabel) axplotdef=' ' else ! for step separate it seems difficult to have correct seqx !! ! seqxyz(1)=maptop%next%seqx seqxyz(1)=max(maptop%next%seqx,maptop%previous%seqx,maptop%seqx) seqxyz(2)=maptop%seqy ! list maptop for debugging ! write(*,*)'PM maptop node: ',trim(maptop%nodeceq%eqname) ! maptopcheck=>maptop%next ! do while(.not.associated(maptopcheck,maptop)) ! write(*,*)'PM: maptop node: ',trim(maptopcheck%nodeceq%eqname) ! maptopcheck=>maptopcheck%next ! if(.not.associated(maptopcheck%previous%next,maptopcheck)) then ! write(*,*)'PM next and previous does not agree' ! endif ! enddo ! if(associated(maptop%plotlink)) then ! write(*,*)'PM plotlink: ',trim(maptop%plotlink%nodeceq%eqname) ! endif ! end debugging maptopsave=>maptop nullify(maptop) write(*,'(a,2i4)')'Previous results kept',seqxyz endif endif ! indicate to graphics that we have a step calculation graphopt%noofcalcax=1 step: SELECT CASE(kom2) !----------------------------------------------------------- CASE DEFAULT write(kou,*)'No such step option' !----------------------------------------------------------- ! STEP NORMAL case(1) ! maptop is returned as main map/step record for results ! noofaxis is current number of axis, axarr is array with axis data ! starteq is start, equilibria, if empty set it to ceq if(noofstarteq.eq.0) then noofstarteq=1 starteqs(1)%p1=>ceq endif if(associated(maptop)) then ! can one have several STEP commands YES! write(*,*)'Deleting previous step/map results missing' goto 100 endif ! seqzyz are initial values for creating equilibria for lines and nodes call map_setup(maptop,noofaxis,axarr,seqxyz,starteqs) ! mark that interactive listing of conditions and results may be inconsistent ceq%status=ibset(ceq%status,EQINCON) if(.not.associated(maptop)) then ! if one has errors in map_setup maptop may not be initiated, if one ! has saved previous calculations in maptopsave restore those if(associated(maptopsave)) then write(kou,*)'Restoring previous map results' maptop=>maptopsave nullify(maptopsave) endif elseif(associated(maptopsave)) then ! THIS ERROR WITH LOST CALCULATONS MAY BE THERE FOR STEP SEPERATE AND MAP ! write(*,*)'PM linking previous results' write(kou,'(a)')'Link set to previous step/map results.' maptop%plotlink=>maptopsave endif ! debugging: last maptop/line used ! write(*,'(a,2i4)')'PMON: sexy 1:',maptop%next%seqx,maptop%seqy ! remove start equilibria nullify(starteqs(1)%p1) noofstarteq=0 if(gx%bmperr.ne.0) goto 990 !----------------------------------------------------------- ! STEP SEPARATE case(2) ! calculate for each entered phase separately (one by one) ! starteqs(1)%p1=>ceq ! noofstarteq=1 ! it will always use the current equilibrium ! can one have several STEP commands?? stepspecial(1)=.TRUE. if(associated(maptop)) then write(*,*)'Deleting previous step/map results missing' goto 100 endif call step_separate(maptop,noofaxis,axarr,seqxyz,ceq) ! mark that interactive listing of conditions and results may be inconsistent ceq%status=ibset(ceq%status,EQINCON) if(.not.associated(maptop)) then ! if one has errors in map_setup maptop may not be initiated, if one ! has saved previous calculations in maptopsave restore those if(associated(maptopsave)) then write(kou,*)'Restoring previous map results' ! maptop=>maptopsave maptop%plotlink=>maptopsave nullify(maptopsave) endif elseif(associated(maptopsave)) then write(kou,'(a)')'Link set to previous map/step results' maptop%plotlink=>maptopsave endif ! set default yaxis as GM(*) if(axplotdef(2)(1:1).eq.' ') then axplotdef(2)='GM(*)' endif ! update maptop%seqx to maptop%prvious%seqx+1 to allow more maptop records maptop%seqx=maptop%previous%seqx+1 ! write(*,'(a,4i4)')'PMON: separate seqx:',maptop%next%seqx,& ! maptop%seqx,maptop%previous%seqx,maptop%seqy ! remove start equilibria nullify(starteqs(1)%p1) noofstarteq=0 stepspecial(1)=.TRUE. !----------------------------------------------------------- ! STEP QUIT, note quitting already above case(3) !----------------------------------------------------------- ! STEP CONDITIONAL (NOT for Scheil-Gulliver), note quitting already above case(4) write(kou,*)'Not implemented yet' !----------------------------------------------------------- ! STEP TZERO plotlink case(5) write(kou,871) 871 format('For this command you must already have used',& ' "calculate tzero"'/& 'for the two phases you will specify below and you must',& ' have specified an axis'/& 'with the composition of the fast diffusing element.') call gparcx('Have you done all that?',cline,last,1,& name1,'NO','?Step Tzero') call capson(name1) if(name1(1:1).ne.'Y') goto 100 call gparcx('First phase name: ',cline,last,1,name1,' ',& '?Step Tzero') if(buperr.ne.0) goto 990 call find_phase_by_name(name1,iph,ics) if(gx%bmperr.ne.0) goto 990 if(ics.ne.1) then write(*,*)'You must use first composition set' goto 100 endif call gparcx('Second phase name: ',cline,last,1,name2,' ',& '?Step Tzero') call find_phase_by_name(name2,iph2,ics) if(gx%bmperr.ne.0) goto 990 if(ics.ne.1) then write(*,*)'You must use first composition set' goto 100 endif ! normally T is the first condition j2=1 call gparidx('Release condition number',cline,last,tzcond,j2,& '?Step Tzero') ! Delete previous step/map results if(associated(maptop)) then write(kou,*)'Previous map/step results will be deleted' call delete_mapresults(maptop) endif nullify(maptop) nullify(maptopsave) ! step tzero stepspecial(3)=.TRUE. ! This is to keep trace of total number of saved equilibria totalsavedceq=0 ! initiate indexing nodes and lines seqxyz=0 ! remove all graphopt settings call reset_plotoptions(graphopt,plotfile,textlabel) axplotdef=' ' ! call tzero(iph,iph2,tzcond,xxx,ceq) call step_tzero(maptop,noofaxis,axarr,seqxyz,iph,iph2,tzcond,ceq) if(gx%bmperr.ne.0) goto 990 ! sum the points calculated jp=maptop%linehead(1)%number_of_equilibria+& maptop%linehead(2)%number_of_equilibria write(kou,'(a,i5,a)')'Calculated ',jp,' points along the tzero line' !----------------------------------------------------------- ! STEP LIQUID_EET, not yet implemented case(6) write(kou,*)'Not implemented yet' goto 100 write(kou,879) 879 format('For this command you must already have',& ' "calculatd liquid_EET"'/& 'for the phases you specify below and you must',& ' have selected an axis condion') call gparcx('Have you done all that?',cline,last,1,& name1,'NO','?Step liquid_eet') call capson(name1) if(name1(1:1).ne.'Y') goto 100 call gparcx('The liquid phase name: ',cline,last,1,name1,' ',& '?Step liquid_eet') if(buperr.ne.0) goto 990 call find_phase_by_name(name1,iph,ics) if(gx%bmperr.ne.0) goto 990 if(ics.ne.1) then write(*,*)'You must use first composition set' goto 100 endif call gparcx('The solid phase name: ',cline,last,1,name2,' ',& '?Step liquid_eet') call find_phase_by_name(name2,iph2,ics) if(gx%bmperr.ne.0) goto 990 if(ics.ne.1) then write(*,*)'You must use first composition set' goto 100 endif ! normally T is the first condition j2=1 call gparidx('Release condition number',cline,last,tzcond,j2,& '?Step liquid_eet') ! Delete previous step/map results if(associated(maptop)) then write(kou,*)'Previous map/step results will be deleted' call delete_mapresults(maptop) endif nullify(maptop) nullify(maptopsave) ! step EET stepspecial(5)=.TRUE. ! This is to keep trace of total number of saved equilibria totalsavedceq=0 ! initiate indexing nodes and lines seqxyz=0 ! remove all graphopt settings call reset_plotoptions(graphopt,plotfile,textlabel) axplotdef=' ' ! call step_tzero(maptop,noofaxis,axarr,seqxyz,iph,iph2,tzcond,ceq) call step_eet(maptop,noofaxis,axarr,seqxyz,iph,iph2,tzcond,ceq) if(gx%bmperr.ne.0) goto 990 ! sum the points calculated jp=maptop%linehead(1)%number_of_equilibria+& maptop%linehead(2)%number_of_equilibria write(kou,'(a,i5,a)')'Calculated ',jp,' points along the EET line' !----------------------------------------------------------- ! STEP SCHEIL_GULLIVER and STEP FAST case(7,9) write(kou,872) 872 format('Before this command you must have set an alloy composition',& ' and calculated'/& 'an equilibrium in the liquid and have set an axis with T',& ' as variable.') call gparcx('Have you done all that?',cline,last,1,& name1,'NO','?Step Scheil') call capson(name1) if(name1(1:1).ne.'Y') goto 100 ! Delete previous step/map results if(associated(maptop)) then write(kou,*)'Previous map/step results will be deleted' call delete_mapresults(maptop) endif write(kou,873) 873 format('The simulation will decrease T and change the liquid',& ' composition depending'/& 'on the solids formed until there is no liquid stable.') nullify(maptop) nullify(maptopsave) ! This is to keep trace of total number of saved equilibria totalsavedceq=0 ! initiate indexing nodes and lines seqxyz=0 ! remove all graphopt settings call reset_plotoptions(graphopt,plotfile,textlabel) axplotdef=' ' ! step scheil stepspecial(2)=.TRUE. if(kom2.eq.9) then ! ask for fast diffusing elements in Scheil simulation nv=1 fast=' ' line='A fast diffusing element: ' fastel: do while(.TRUE.) call gparcx(trim(line),cline,last,1,elsym,' ','?Step Scheil') if(elsym(1:1).ne.' ') then call capson(elsym) call find_element_by_name(elsym,iel) if(gx%bmperr.ne.0) goto 990 fast(nv)=elsym nv=nv+1 if(nv.gt.3) exit fastel line='Another fast diffusing element: ' else exit fastel endif enddo fastel call step_scheil2(maptop,noofaxis,axarr,seqxyz,fast,ceq) else ! step scheil with no fast diffusiing elements call step_scheil(maptop,noofaxis,axarr,seqxyz,ceq) endif if(gx%bmperr.ne.0) goto 990 ! sum the points calculated ! write(*,*)'Finished Scheil simulation' ! jp=maptop%linehead(1)%number_of_equilibria+& ! maptop%linehead(2)%number_of_equilibria ! write(kou,'(a,i5,a)')'Calculated ',jp,' points for the simulation' !----------------------------------------------------------- ! STEP PARAEQUILIBRIUM case(8) write(kou,874) 874 format('Before this command you must have set an alloy composition',& ' and calculated',/& 'and suspended all phases except the two involved and',& ' you should have'/& 'calculated a paraequilibrium') call gparcx('Have you done all that?',cline,last,1,& name1,'NO','?Step paraeq') call capson(name1) if(name1(1:1).ne.'Y') goto 100 if(dummy(1:1).ne.' ') dummy=name2 call gparcdx('Matrix phase ',cline,last,1,name2,dummy,'?Step paraeq') call find_phasetuple_by_name(name2,tupix(1)) if(gx%bmperr.ne.0) goto 990 if(dummy(1:1).ne.' ') dummy=name3 call gparcdx('Growing phase ',cline,last,1,name3,dummy,'?Step paraeq') call find_phasetuple_by_name(name3,tupix(2)) if(gx%bmperr.ne.0) goto 990 dummy=name3 call gparcdx('Fast diffusing element',cline,last,1,& elsym,parael,'?Step paraeq') call find_element_by_name(elsym,icond) parael=elsym write(kou,875)trim(name1) 875 format('The simulation will vary the axis variable and calulate',& ' compositions'/'of the two phases which have the same',& ' chemical potential of ',a) ! Delete previous step/map results if(associated(maptop)) then write(kou,*)'Previous map/step results will be deleted' call delete_mapresults(maptop) endif nullify(maptop) nullify(maptopsave) ! This is to keep trace of the total number of saved equilibria totalsavedceq=0 ! initiate indexing nodes and lines seqxyz=0 ! remove all graphopt settings call reset_plotoptions(graphopt,plotfile,textlabel) ! set default plot axis axplotdef(1)='W(*,'//trim(parael)//') ' ! one can calculate paraequilibria diagrams at constant T ! axplotdef(2)='T ' ! step paraequil stepspecial(4)=.TRUE. call step_paraequil(maptop,noofaxis,axarr,seqxyz,tupix,icond,ceq) if(gx%bmperr.ne.0) goto 990 ! sum the points calculated ! jp=maptop%linehead(1)%number_of_equilibria+& ! maptop%linehead(2)%number_of_equilibria write(kou,'(a,2i5,a)')'Paraequilibrium points: ',totalsavedceq !----------------------------------------------------------- ! STEP FAST part of STEP SCHEIL ! case(9) ! write(kou,*)'Not implemented yet' end SELECT step !================================================================= ! MAP, must be tested if compatible with assessments case(20) ! maybe disable continue optimization ?? if(noofaxis.lt.2) then write(kou,*)'You must set two axis with independent variables' goto 100 endif if(noofaxis.gt.3) then write(kou,*)'More than 3 axis not implemented yet' goto 100 endif ! tzeroline=.FALSE. ! separate=.FALSE. stepspecial=.FALSE. ! indicate to graphics we have calculated with 2 axis graphopt%noofcalcax=noofaxis write(kou,20014) 20014 format('The map command is fragile, please send problematic diagrams',& ' to the',/'OC development team'/) ! when setting logfile the maptop became associated !! ! write(*,*)'PMON maptop bug 3?',associated(maptop) if(associated(maptop)) then write(kou,833) call gparcdx('Reinitiate?',cline,last,1,ch1,'Y','?Map old data') if(ch1.eq.'y' .or. ch1.eq.'Y') then call delete_mapresults(maptop) ! deallocate(maptop%saveceq) nullify(maptop) nullify(maptopsave) ! This is to keep trace of total number of saved equilibria totalsavedceq=0 ! this removes all previous equilibria associated with STEP/MAP commands ! already done by delete_mapresults ! call delete_equilibria('_MAP*',ceq) ! if(gx%bmperr.ne.0) then ! write(kou,*)'Error removing old MAP equilibria' ! goto 990 ! endif ! initiate indexing nodes and lines seqxyz=0 ! remove all graphopt settings call reset_plotoptions(graphopt,plotfile,textlabel) axplotdef=' ' else ! start indexing new nodes/lines from previous ! write(*,*)'mapnode: ',maptop%seqx,maptop%previous%seqx,& ! maptop%next%seqx seqxyz(1)=maptop%next%seqx seqxyz(2)=maptop%seqy ! seqxyz(3) can be used for something else ... maptopsave=>maptop nullify(maptop) ! write(*,*)'seqxyz: ',seqxyz endif ! this should never be done ! It destroys the possibility to find old nodes ! call delete_equilibria('_MAP*',ceq) endif ! maptop is returned as main map/step record for results ! noofaxis is current number of axis, axarr is array with axis data ! starteq is start equilibria, if empty set it to ceq ! if(.not.associated(starteq)) then if(noofstarteq.eq.0) then noofstarteq=1 starteqs(1)%p1=>ceq endif ceq=>starteqs(1)%p1 ll=degrees_of_freedom(ceq) if(ll.ne.0) then write(*,*)'Degrees of freedom not zero ',ll goto 100 endif ! maptop is first nullified inside map_setup, then alloctated to return result call map_setup(maptop,noofaxis,axarr,seqxyz,starteqs) if(gx%bmperr.ne.0) then write(kou,*)'Error return from MAP: ',gx%bmperr gx%bmperr=0 ! else ! write(*,*)'Map command finished without error' endif if(.not.associated(maptop)) then ! if one has errors in map_setup maptop may not be initiated, if one ! has saved previous calculations in maptopsave restore those if(associated(maptopsave)) then write(kou,*)'Restoring previous map results' maptop=>maptopsave nullify(maptopsave) endif elseif(associated(maptopsave)) then write(kou,'(a)')'Link set to previous map results' maptop%plotlink=>maptopsave nullify(maptopsave) endif ! remove start equilibria noofstarteq=0 nullify(starteqs(1)%p1) ! mark that interactive listing of conditions and results may be inconsistent ceq%status=ibset(ceq%status,EQINCON) if(gx%bmperr.ne.0) goto 990 ! end of MAP command !================================================================= ! PLOT COMMAND with many options and EXTRA ! Always specify the axis first when giving this command, default is previous!! ! loop with subcommands comes after case(21) if(.not.associated(maptop)) then write(kou,*)'You must give a STEP or MAP command before PLOT' goto 100 endif wildcard=.FALSE. ! values of stepspecial ... ! write(*,*)'stepspecial: ',stepspecial pltaxdef: do iax=1,2 plotdefault: if(axplotdef(iax)(1:1).eq.' ') then ! If there is no previous plot axis variable, propose one iaxval: if(iax.eq.1 .and. stepspecial(2)) then ! Scheil, PFL (Phase Fraction Liquid) is a special function if(iax.eq.1) text='PFL' elseif(iax.le.noofaxis) then ! extract the actual axis condition used for calculation jp=1 call get_one_condition(jp,text,axarr(iax)%seqz,ceq) if(gx%bmperr.ne.0) then write(*,*)'Error getting axis condition from index: ',& iax,axarr(iax)%seqz goto 990 endif jp=index(text,'=') text(jp:)=' ' if(.not.(text(1:2).eq.'MU' .or. text(1:2).eq.'AC' .or.& text(1:4).eq.'LNAC')) then if(maptop%tieline_inplane.eq.1) then ! if tie-lines in the plane is 1 (.e. YES) and calculating axis was x(cu) ! then plot axis should be x(*,cu) jp=index(text,'(') if(jp.gt.0) then text=text(1:jp)//'*,'//text(jp+1:) endif endif ! do not modify axis variables MU(C), AC(C), LNAC(C) !!! endif else ! this the vertical axis of a STEP calculation, most often T as axis 1 ! maybe change default for iax=1 also. Most frequent vertical axis is NP(*) if(iax.eq.2) text='NP(*)' if(stepspecial(1)) then ! step separate, default vertical axis is GM, horizontal fraction if(iax.eq.2) text='GM(*)' elseif(stepspecial(2)) then ! Scheil, PFL (Phase Fraction Liquid) or PFS are special plot functions if(iax.eq.1) text='PFL' if(iax.eq.2) text='T' elseif(stepspecial(3)) then ! Tzero, fraction vs T if(iax.eq.2) text='w(c)' elseif(stepspecial(4)) then ! Paraequilibrium, fraction vs T if(iax.eq.2) text='T' elseif(stepspecial(5)) then ! step liquid_eet if(iax.eq.2) text='T' endif nullify(maptop%plotlink) endif iaxval axplotdef(iax)=text endif plotdefault ! the 4th argument to gparc means the following: ! 1 TEXT TERMINATED BY SPACE OR "," ! 2 TEXT TERMINATED BY SPACE ! 3 TEXT TERMINATED BY ";" OR "." ! 4 TEXT TERMINATED BY ";" ! 5 TEXT UP TO END-OF-LINE ! 6 TEXT UP TO AND INCLUDING ";" ! 7 TEXT TERMINATED BY SPACE OR "," BUT IGNORING SUCH INSIDE ( ) ! >31, THE CHAR(JTYP) IS USED AS TERMINATING CHARACTER !------------------------------------------------------------------------ ! Here the user specifies his axis for plotting 21000 continue if(iax.eq.1) then call gparcdx('Horizontal axis variable',& cline,last,7,axplot(iax),axplotdef(iax),'?Plot command') ! Note "7" means that a "," inside x(liq,fe) will not return just "x(liq" else call gparcdx('Vertical axis variable',& cline,last,7,axplot(iax),axplotdef(iax),'?Plot command') endif if(buperr.ne.0) goto 990 ! extract a possible scaling factor like 0.001*GM(*) jp=1 call getrel(axplot(iax),jp,xxx) if(buperr.eq.0) then ! there is a numerical factor graphopt%scalefact(iax)=xxx ! a number must be followed by a * if(axplot(iax)(jp:jp).ne.'*') then write(*,*)'Scaling factor must be followed by *' goto 990 else ! Fortran allows overlapping strings in assignments axplot(iax)=axplot(iax)(jp+1:) endif else ! no scaling factor, graphopt%scalfactor(iax) already unity buperr=0 endif if(index(axplot(iax),'*').gt.0 .or. index(axplot(iax),'#').gt.0) then ! if(wildcard) then ! write(*,*)'Wildcards allowed for one axis only' ! goto 21000 ! else wildcard=.TRUE. ! endif endif if(axplotdef(iax).ne.axplot(iax)) then ! if new axis variable then reset default plot options ! plot ranges and their defaults call reset_plotoptions(graphopt,plotfile,textlabel) ! check that axis variable is a correct state variable or symbol ! Most code copied from show variable (case(4,17) around line 3273) ! Avoid capson of axplot(iax) for possible other problems later name1=axplot(iax) call capson(name1) if(name1(1:4).eq.'PFL ' .or. name1(1:4).eq.'PFS ') then ! this is a special function allowed in Scheil simulations for phase frac liq if(.not.stepspecial(2)) then write(*,*)'The PFL and PFS functions are allowed only for Scheil simulations' goto 100 endif elseif(index(axplot(iax),'*').gt.0) then ! generate many values ! the values are returned in yarr with dimension maxconst. ! longstring are the state variable symbols for the values ... call get_many_svar(axplot(iax),yarr,maxconst,i1,longstring,ceq) if(gx%bmperr.ne.0) then ! if error go back to command level write(kou,*)'Illegal axis variable! Error code: ',gx%bmperr goto 100 ! else ! write(*,*)'pmon test value: ',yarr(1) endif elseif(index(axplot(iax),'#').gt.0) then ! generate many values including for metastable phases ! the values are returned in yarr with dimension maxconst. ! longstring are the state variable symbols for the values ... call get_many_svar(axplot(iax),yarr,maxconst,i1,longstring,ceq) if(gx%bmperr.ne.0) then ! if error go back to command level write(kou,*)'Illegal axis variable! Error code: ',gx%bmperr goto 100 ! else ! write(*,*)'pmon test value: ',yarr(1) endif else ! the value of a state variable or model parameter variable is returned ! STRANGE the symbol xliqni is accepted in get_state_var_value ??? call get_state_var_value(axplot(iax),xxx,model,ceq) if(gx%bmperr.ne.0) then ! if error check if it is a complicated symbol like CP=H.T gx%bmperr=0 ! If error then try to calculate a symbol ... call capson(axplot(iax)) ! call find_svfun(axplot(iax),istv,ceq) call find_svfun(axplot(iax),istv) if(gx%bmperr.ne.0) then write(kou,*)'Illegal axis variable, error: ',gx%bmperr goto 100 endif endif endif endif ! remember most recent axis as default (and to avoid reset) axplotdef(iax)=axplot(iax) enddo pltaxdef ! first argument is the number of plot axis, always 2 at present jp=2 if(associated(maptopsave)) then write(kou,'(a)')'Link set to maptopsave' maptop%plotlink=>maptopsave endif ! restore default graphopt%linetype ! graphopt%linetype=1 !----------------------------------------------------------- ! PLOT subcommands, default is PLOT, NONE does not work ... ! subcommands to PLOT OPTIONS/ GRAPHICS OPTIONS ! THIS IS A MESS, should be reorganized in levels ! character (len=16), dimension(nplt) :: cplot=& ! ['RENDER ','SCALE_RANGES ','FONT ',& ! 'AXIS_LABELS ',' ','TITLE ',& ! 'GRAPHICS_FORMAT ','OUTPUT_FILE ',' ',& ! 'QUIT ','POSITION_OF_KEYS','APPEND ',& ! 'TEXT_LABEL ',' ','EXTRA '] !------------------- ! return here after each sub or subsub command 21100 continue if(graphopt%gnutermsel.lt.1 .or. & graphopt%gnutermsel.gt.graphopt%gnutermax) then write(kou,*)'No such graphics terminal: ',graphopt%gnutermsel elseif(graphopt%gnutermsel.ne.1) then write(kou,2910)trim(graphopt%gnutermid(graphopt%gnutermsel)),& trim(plotfile),trim(graphopt%filext(graphopt%gnutermsel)) 2910 format(/'Graphics output as ',a,' on file: ',a,'.',a) endif write(kou,21112) 21112 format(/'Note: give only one option per line!') kom2=submenu('Plot options?',cline,last,cplot,nplt,1,'?TOPHLP') plotoption: SELECT CASE(kom2) !----------------------------------------------------------- CASE DEFAULT write(kou,*)'No such plot option' !----------------------------------------------------------- ! PLOT RENDER no more options to plot ... case(1) !2190 continue ! use the graphics record to transfer data ... ! write(*,*)'PMON render plot',associated(maptop%plotlink) graphopt%pltax(1)=axplot(1) graphopt%pltax(2)=axplot(2) if(graphopt%gibbstriangle) then ! if gibbstriangle make sure min is 0 graphopt%plotmin(1)=zero graphopt%dfltmin(1)=zero graphopt%plotmin(2)=zero graphopt%dfltmin(2)=zero if(graphopt%rangedefaults(1).ne.0 .or. & graphopt%rangedefaults(2).ne.0) then ! if gibbstriangle and scaling make sure xmax and ymax are the same xxx=min(graphopt%plotmax(1),graphopt%plotmax(2)) graphopt%plotmax(1)=xxx graphopt%dfltmax(1)=xxx graphopt%plotmax(2)=xxx graphopt%dfltmax(2)=xxx endif endif graphopt%filename=' ' graphopt%filename=plotfile ! write(*,*)'PMON6 tieline_inplane: ',maptop%tieline_inplane,& ! graphopt%status if(maptop%tieline_inplane.lt.0) then ! set the isopleth bit if(index(graphopt%pltax(1),'*').eq.0 .and. & index(graphopt%pltax(1),'*').eq.0) then graphopt%status=ibset(graphopt%status,GRISOPLETH) ! write(*,*)'PMON6 isopleth: ',graphopt%status,grisopleth else ! Probably meaningless to plot fractions ... but who knows? graphopt%status=ibclr(graphopt%status,GRISOPLETH) ! write(*,*)'PMON6 not isopleth: ',graphopt%status,grisopleth endif else ! for step and tie-lines in plane clear the bit graphopt%status=ibclr(graphopt%status,GRISOPLETH) endif ! write(*,*)'PMON call ocplot2: ',graphopt%status,grisopleth ! added ceq in the call to make it possible to handle change of reference states call ocplot2(jp,maptop,axarr,graphopt,version,ceq) if(gx%bmperr.ne.0) goto 990 ! write(*,*)'Plot saved on file: ',trim(plotfile) ! always restore default plot file name and plot option to screem if(graphopt%gnutermsel.ne.1) & write(kou,*)'Restoring plot device to screen' graphopt%gnutermsel=1 plotfile='ocgnu' graphopt%filename=plotfile !----------------------------------------------------------- ! PLOT SCALE_RANGE of either X or Y case(2) call gparcdx('For X or Y axis? ',cline,last,1,ch1,'Y','?Plot limits') if(ch1.eq.'X' .or. ch1.eq.'x') then ! if(graphopt%axistype(1).eq.1) then ! write(kou,*)'The x axis set to linear' ! graphopt%axistype(1)=0 ! else ! graphopt%axistype(1)=1 ! endif goto 21120 elseif(ch1.eq.'Y' .or. ch1.eq.'y') then ! if(graphopt%axistype(2).eq.1) then ! write(kou,*)'The y axis set to linear' ! graphopt%axistype(2)=0 ! else ! graphopt%axistype(2)=1 ! endif goto 21130 else write(kou,*)'Please answer X or Y' endif goto 21100 !............................................ user limits X axis (1) 21120 continue call gparcdx('Default limits',cline,last,1,ch1,'N','?Plot limits') if(ch1.eq.'Y' .or. ch1.eq.'y') then graphopt%rangedefaults(1)=0 else graphopt%rangedefaults(1)=1 twice=.FALSE. 21104 continue call gparrdx('Low limit',cline,last,xxx,graphopt%dfltmin(1),& '?Plot limits') if(graphopt%gibbstriangle .and. xxx.ne.zero) then write(*,*)'Lower limit of a Gibbs triangle plot must be zero' goto 21100 endif graphopt%plotmin(1)=xxx graphopt%dfltmin(1)=xxx once=.TRUE. 21105 continue call gparrdx('High limit',cline,last,xxx,& graphopt%dfltmax(1),'?Plot limits') if(xxx.le.graphopt%plotmin(1)) then if(once) then write(kou,*)'Think before typing' once=.FALSE. elseif(twice) then write(kou,*)'Back to command level' goto 100 else write(kou,*)'Please give the low limit again!' twice=.TRUE. goto 21104 endif write(kou,21106)graphopt%plotmin(1) 21106 format('High limit must be higher than low: ',1pe14.6) goto 21105 endif graphopt%plotmax(1)=xxx graphopt%dfltmax(1)=xxx endif goto 21100 !---------------------------------------------- user limits Y axis (2) 21130 continue call gparcdx('Default limits',cline,last,1,ch1,'N','?Plot limits') if(ch1.eq.'Y' .or. ch1.eq.'y') then graphopt%rangedefaults(2)=0 else graphopt%rangedefaults(2)=1 twice=.FALSE. 21107 continue call gparrdx('Low limit',cline,last,xxx,graphopt%dfltmin(2),& '?Plot limits') if(graphopt%gibbstriangle .and. xxx.ne.zero) then write(*,*)'Lower limit of a Gibbs triangle plot must be zero' goto 21100 endif graphopt%plotmin(2)=xxx graphopt%dfltmin(2)=xxx once=.TRUE. 21108 continue call gparrdx('High limit',cline,last,xxx,& graphopt%dfltmax(2),'?Plot limits') if(xxx.le.graphopt%plotmin(2)) then if(once) then write(*,*)'Think before typing' once=.FALSE. elseif(twice) then write(kou,*)'Back to command level' goto 100 else write(kou,*)'Please give the low limit again!' twice=.TRUE. goto 21107 endif write(kou,21106)graphopt%plotmin(2) goto 21108 endif graphopt%plotmax(2)=xxx graphopt%dfltmax(2)=xxx endif goto 21100 !----------------------------------------------------------- ! PLOT unused select FONT case(3) call gparcdx('Font (check what your GNUPLOT has): ',& cline,last,1,name1,graphopt%font,'?Plot font') graphopt%font=name1 ! font size ignored but it is better to have the question now ... call gparidx('Font size: ',cline,last,iz,16,'?Plot font') write(*,*)'Size is ignored at present ...' ! write(*,*)'Font is now: ',graphopt%font ! we have to change "font" in all terminals and key allgnu: do i1=1,graphopt%gnutermax iz=index(graphopt%gnuterminal(i1),'"') if(iz.le.0) cycle allgnu i2=index(graphopt%gnuterminal(i1)(iz:),',') name1=graphopt%gnuterminal(i1)(iz+i2-1:) graphopt%gnuterminal(i1)(iz+1:)=graphopt%font i2=len_trim(graphopt%gnuterminal(i1)) graphopt%gnuterminal(i1)(i2+1:)=name1 ! write(*,'(a,i2,2x,a)')'pmon: ',i1,trim(graphopt%gnuterminal(i1)) enddo allgnu iz=index(graphopt%labelkey,'"') if(iz.gt.0) then i2=index(graphopt%labelkey(iz:),',') name1=graphopt%labelkey(iz+i2-1:) graphopt%labelkey(iz+1:)=graphopt%font i2=len_trim(graphopt%labelkey) graphopt%labelkey(i2+1:)=name1 ! write(*,*)'pmon key: ',trim(graphopt%labelkey) endif goto 21100 !----------------------------------------------------------- ! PLOT AXIS_LABELS case(4) call gparcdx('For X or Y axis? ',cline,last,1,ch1,'X',& '?Plot axis labels') if(ch1.eq.'X' .or. ch1.eq.'x') then call gparcdx('Axis label: ',cline,last,5,& graphopt%plotlabels(2),axplot(1),'?Plot axis labels') ! remember that plotlabel(1) is the title graphopt%labeldefaults(2)=len(graphopt%plotlabels(2)) elseif(ch1.eq.'Y' .or. ch1.eq.'y') then call gparcdx('Axis label: ',cline,last,5,& graphopt%plotlabels(3),axplot(2),'?Plot axis labels') ! remember that plotlabel(1) is the title graphopt%labeldefaults(3)=len(graphopt%plotlabels(3)) else write(kou,*)'Please answer X or Y' endif goto 21100 !----------------------------------------------------------- ! PLOT unused case(5) !----------------------------------------------------------- ! PLOT TITLE case(6) call gparcdx('Plot title',cline,last,5,line,'DEFAULT','?Plot title') if(line(1:8).eq.'DEFAULT ') then graphopt%labeldefaults(1)=0 else graphopt%plotlabels(1)=line graphopt%labeldefaults(1)=len_trim(graphopt%plotlabels(1)) endif goto 21100 !----------------------------------------------------------- ! PLOT GRAPHICS_FORMAT and PLOT OUTPUT_FILE ! when setting graphics format always also ask for plot file case(7,8) ! write(*,*)'P6 kom2: ',kom2 if(kom2.eq.7) then ! subroutine TOPHLP forces return with ? in position cline(1:1) 29130 continue call gparidx('Graphics format index:',cline,last,grunit,1,& '?Plot formats') if(cline(1:1).eq.'?' .or. & grunit.lt.1 .or. grunit.gt.graphopt%gnutermax) then write(kou,29133) 29133 format('Avalable graphics formats are:') write(kou,29135)(i1,graphopt%gnutermid(i1),& i1=1,graphopt%gnutermax) 29135 format(i3,2x,a) goto 29130 endif graphopt%gnutermsel=grunit write(kou,*)'Graphics format set to: ',graphopt%gnutermid(grunit) endif !----------------------------------------------------------- ! PLOT OUTPUT_FILE, always asked when changing graphics terminal type 21140 continue ! default extension: 1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT, 6=XTDB, 7=DAT, 8=LOG ! negative is for write, 0 read without filter, -100 write without filter ! DO NOT USE tinyfiledialog here ... write(*,*)'To use file the browser give just a <' call gparcdx('Plot file',cline,last,1,plotfile,'ocgnu','?Plot file') ! to avoid confusion abot use of > and < if(plotfile(1:1).eq.'<' .or. plotfile(1:1).eq.'>') then ! use the file browser ztyp=-5 call gparfilex('File name: ',cline,last,1,plotfile,' ',ztyp,& '?Plot file') ! make sure there is a plt extention jp=index(plotfile,'.') if(jp.le.0) then jp=len_trim(plotfile) plotfile(jp+1:)='.plt' endif write(*,*)'Output will be on: ',trim(plotfile) endif once=.false. if(plotfile(1:2).eq.'./') then ! save in macro directory if iumaclevl>0, else in current working directory ! write(*,*)'PMON1: ',trim(plotfile),len_trim(plotfile) ! write(*,*)'PMON2: ',trim(macropath(iumaclevl)),& ! len_trim(macropath(iumaclevl)),iumaclevl if(iumaclevl.gt.0) then ! we are executing a macro, skip the ./ aline=plotfile(3:) plotfile=trim(macropath(iumaclevl))//aline else ! running interactivly prefix with working directory (default?) aline=plotfile(2:) plotfile=trim(workingdir)//aline endif ! trouble passing on ling file names .... ! write(*,*)'PMON3: ',trim(aline) write(*,*)'PMON working directory: ',trim(workingdir) write(*,*)'Saving on file: ',trim(plotfile) once=.true. endif if(plotfile(1:6).ne.'ocgnu ') then if(index(plotfile,'.').le.0) then if(graphopt%gnutermsel.ne.1) then filename=trim(plotfile)//'.'//& graphopt%filext(graphopt%gnutermsel) else ! just changing name of the GNUPLOT command file filename=trim(plotfile)//'.plt ' plotfile=filename endif endif ! filename=trim(plotfile)//'.plt ' inquire(file=filename,exist=logok) if(logok) then call gparcdx('File exists, overwrite?',& cline,last,1,ch1,'N','PLOT file') if(.not.(ch1.eq.'Y' .or. ch1.eq.'y')) then write(*,133) plotfile=' ' goto 21140 endif write(*,134)trim(filename) once=.true. endif endif ! if(.not.once) write(*,'('P134)trim(filename) ! I am not sure how to inform user where the plot file is saved .... goto 21100 !----------------------------------------------------------- ! PLOT unused case(9) !----------------------------------------------------------- ! PLOT QUIT case(10) ! just return to command level !----------------------------------------------------------- ! PLOT position of line labels (position_of_keys) case(11) write(kou,21200) 21200 format('Key to lines can be positioned: '/& 'top/bottom left/center/right inside/outside on/off') call gparcdx('Position?',cline,last,5,line,'top right','?Plot keys') ! iz=min(index(line,',')-1,len_trim(line)) graphopt%labelkey=trim(line) ! call gparcdx('Font,size: ',cline,last,5,line,'arial,12',& ! '?Plot keys') if(line(1:3).ne.'off') then call gparidx('Size: ',cline,last,iz,12,'?Plot keys') graphopt%labelkey=trim(graphopt%labelkey)//' font "'& //trim(graphopt%font)//',' ll=len_trim(graphopt%labelkey)+1 write(graphopt%labelkey(ll:),'(i2,a)')iz,'"' endif write(*,*)'GNUPLOT will use: set key ',trim(graphopt%labelkey) goto 21100 !----------------------------------------------------------- ! PLOT APPEND a gnuplot file or csv file case(12) write(kou,*)'Give a file name with graphics in GNUPLOT or csv format' ! append plot file, specifying extension PLT ! default extension (1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT, 6=XTDB, 7=DAT ! negative is for write, 0 read without filter, -100 write without filter ! if(len_trim(graphopt%appendfile).gt.1) then ! text=trim(graphopt%appendfile) ! ztyp=5 ! call gparfilex('File name',cline,last,1,filename,text,ztyp,& ! '?Plot append') ! else ztyp=5 call gparfilex('File name',cline,last,1,filename,' ',ztyp,& '?Plot append') ! endif ! check file exits, convert csv to plt, and add .plt if necessary ... jp=max(index(filename,'.csv '),index(filename,'.CSV ')) write(*,*)'Full file name: ',trim(filename) if(jp.gt.0) then ! the csv file must be converted to a plt file ------------- csv special begin ! default separator in FactSage is ";" ch1=';' call gparcdx('Separating character (, ; or ?)',cline,last,& 1,ch1,';','?CSV separator') write(*,21205)trim(filename) 21205 format(/'Converting csv file: ',a,' to csvappend.plt') open(23,file=filename,status='old',access='sequential',err=21300) ! First column is x-axis, the remaining columns are y-axis ! write(*,*)'Converting CSV file to GNUPLOT file: csvappend.plt' ! create a new file for the GNUPLOT, overwrite any old open(31,file='csvappend.plt',status='unknown',access='sequential',& err=21300) ! write header ! FactSage: x LiF;K-K-F-F;Li-Li-F-F;Th-Th-F-F;K-Li-F-F;K-Th-F-F;Li-Th-F-F ! 0.02;0.027281;7.84E-05;0.33126;0.0028241;0.62185;0.016708 ! "N(LI)","Y(LIQUID,..-Q02)","Y(LIQUID,..-Q04)","Y(LIQUID,..-Q06)","Y(LIQUID,..-Q01)","Y(LIQUID,..-Q05)","Y(LIQUID,..-Q03)" ! 2.00000E-01, 2.31701E-02, 3.51556E-02, 5.35191E-01, 1.20145E-02, 1.72251E-01, 2.22218E-01 read(23,21210,end=21300)string 21210 format(a) call date_and_time(optres,name1) write(31,21220)trim(filename),optres(1:4),optres(5:6),& optres(7:8),name1(1:2),name1(3:4),trim(string) 21220 format('# Converted by OC from csv file: ',a/& '# ',a4,'-',a2,'-',a2,2x,a2,'h',a2/& '# ',a//& 'set terminal wxt size 840,700 font "Arial,16"'/& 'set title "OpenCalphad CSV" '/& 'set origin 0.0, 0.0'/& 'set size 1.0, 1.0'//& '$OCCSV2502000 << EOD') ! on the second line to the last one are values to be plotted as symbols read(23,21210,end=21250)string ! write(*,*)'Read line 2: ',trim(string) ioc=1; ip=1; jp=1 commas: do while(.true.) ! ch1 should be the separating character ip=index(string(ip:),ch1) if(ip.le.0) exit commas ! replace ch1 by a space string(jp+ip-1:jp+ip-1)=' ' ioc=ioc+1 ip=jp+ip+1 jp=ip ! write(*,*)'CSV commas: ',ip,jp,ioc enddo commas ! there are ioc values to be plotted ! write(*,*)'written line 1: ',trim(string),ioc do while(.true.) ! add a space at the end of line ... GNUPLOT need that write(31,'(a," ")')trim(string) ip=1; jp=1 ! we have to replace ch1 with a space on every line .... read(23,21210,end=21250)string ! write(*,*)'Read line n: ',trim(string) tty17: do while(ip.gt.0) jp=ip ip=index(string(ip:),ch1) if(ip.eq.0) exit tty17 ip=jp+ip-1 string(ip:ip)=' ' ! write(*,*)'Loop ip: ',ip enddo tty17 ! write(*,'(a," ")')'written line n: ',trim(string) enddo ! end of file ! we have read the whole csv file, close the PLT file 21250 continue close(23) ! add the GNUPLOT ending write(31,21260)ioc 21260 format('EOD'//& 'plot for [i=2:',i3,& '] $OCCSV2502000 using 1:i with points pt (i-1) notitle'/) close(31) ! set the newly created PLT file as appendfile filename='csvappend.plt' endif !------------------------ end csv special jp=index(filename,'.plt ') if(jp.le.0) then jp=len_trim(filename) filename(jp+1:)='.plt' endif ! test file exists by opening and closing it open(23,file=filename,status='old',access='sequential',err=21300) close(23) graphopt%appendfile=filename goto 21100 ! error opening file, remove any previous appended file 21300 continue if(graphopt%appendfile(1:1).ne.' ') then write(*,21304)trim(graphopt%appendfile) 21304 format('Error, removing append file: ',a) else write(kou,*)'No such file name: ',trim(filename) endif graphopt%appendfile=' ' goto 21100 !----------------------------------------------------------- ! PLOT TEXT anywhere on plot case(13) labelp=>graphopt%firsttextlabel if(associated(labelp)) then call gparcdx('Modify existing text?',cline,last,1,ch1,'NO',& '?Plot texts') if(ch1.eq.'y' .or. ch1.eq.'Y') then jp=0 do while(associated(labelp)) jp=jp+1 write(kou,2310)jp,labelp%xpos,labelp%ypos,& labelp%textfontscale,labelp%angle,& trim(labelp%textline) 2310 format(i3,2(1pe12.4),2x,0pF5.2,2x,i4,5x,a) labelp=>labelp%nexttextlabel enddo call gparidx('Which text index?',cline,last,kl,1,'?Plot texts') if(kl.lt.1 .or. kl.gt.jp) then write(*,*)'No such text label' goto 21100 endif labelp=>graphopt%firsttextlabel do jp=2,kl labelp=>labelp%nexttextlabel enddo call gparcdx('New text: ',cline,last,5,text,& labelp%textline,'?Plot texts') labelp%textline=trim(text) call gparrdx('New X position: ',cline,last,xxx,& labelp%xpos,'?Plot texts') call gparrdx('New Y position: ',cline,last,xxy,& labelp%ypos,'?Plot texts') call gparrdx('New Fontscale: ',cline,last,& textfontscale,labelp%textfontscale,'?Plot texts') if(textfontscale.lt.0.2) textfontscale=0.2 call gparidx('New angle (degrees): ',cline,last,j4,& labelp%angle,'?Plot texts') if(buperr.ne.0) then write(*,*)'Error reading coordinates'; buperr=0; goto 21100 endif labelp%xpos=xxx labelp%ypos=xxy labelp%textfontscale=textfontscale labelp%angle=j4 ! ask for more options goto 21100 endif endif ! input a new label call gparrdx('X position: ',cline,last,xxx,zero,'?Plot texts') call gparrdx('Y position: ',cline,last,xxy,zero,'?Plot texts') call gparrdx('Fontscale: ',cline,last,textfontscale,0.8D0,& '?Plot texts') if(textfontscale.le.0.2) textfontscale=0.2 call gparidx('Angle (degree): ',cline,last,j4,0,'?Plot texts') if(buperr.ne.0) then write(*,*)'Error reading coordinates'; buperr=0; goto 21100 endif line=' ' if(noofaxis.eq.2) then ! Calculate the equilibria at the specific point write(kou,22100) 22100 format(' *** Note: the positioning of the text will use the ',& 'axis variables for which',/11x,'the diagram was calculated',& ' even if you plot with other variables!') call gparcdx('Do you want to calculate the equilibrium? ',& cline,last,1,ch1,'Y','?Plot texts') if(ch1.eq.'y' .or. ch1.eq.'Y') then ! Check if plotted diagram (axplot) has same axis as calculated (axarr)?? ! Or better, calculate using the plot axis ... line=' ' call calc_diagram_point(axarr,axplot,xxx,xxy,line,ceq) if(gx%bmperr.ne.0) then write(*,*)'Calculation failed ',gx%bmperr gx%bmperr=0 line='Sorry calculation failed' endif ! when implemented add the stable phase names to "line" as default for text endif endif ! There is no gparcd which allows editing the existing text ... use emacs!! text=' ' call gparcdx('Text: ',cline,last,5,text,line,'?Plot texts') if(text(1:1).eq.' ') then write(*,*)'Label ignored' goto 21100 endif ! I know one should never allocate pointers but this is the only way ??? allocate(textlabel) textlabel%xpos=xxx textlabel%ypos=xxy textlabel%textfontscale=textfontscale textlabel%angle=j4 textlabel%textline=trim(text) if(associated(graphopt%firsttextlabel)) then textlabel%nexttextlabel=>graphopt%firsttextlabel ! write(*,*)trim(graphopt%firsttextlabel%textline) else nullify(textlabel%nexttextlabel) endif graphopt%firsttextlabel=>textlabel ! the record is now linked from graphopt, nullify the pointer ... ! (some memory lost ...) nullify(textlabel) ! also clean the cline character otherwise labels may be overwritten cline=' ' last=len(cline) goto 21100 !--------------------------------------------------------- ! PLOT unused case(14) !--------------------------------------------------------- ! PLOT EXTRA, subsubcommand case(15) ! subsubcommands to PLOT (may not be updated!!) ! character (len=16), dimension(nplt2) :: cplot2=& ! ['COLOR ','LOGSCALE ','RATIOS_XY ',& ! 'LINE_TYPE ','MANIPULATE_LINES','PAUSE_OPTION ',& ! 'LOWER_LEFT_TEXT ','TIE_LINES ','GIBBS_TRIANGLE ',& ! 'QUIT ','SPAWN ','NO_HEADING ',& ! 'AXIS_FACTOR ','GRID ',' ',& ! ' ',' ',' '] !------------------------------------------------------------------- ! default set to GIBBS-TRIANGLE kom3=submenu('Extra options?',cline,last,cplot2,nplt2,9,'?TOPHLP') plotextra: SELECT CASE(kom3) case default ! this is typically when using a ? or ?? write(*,*)'No such extra option' cline=' ' last=len(cline) goto 21100 !............................................... ! PLOT EXTRA axis_factor for example to plot kJ or GPa instead of J and Pa case(13) call gparcdx('Which axis?',cline,last,1,ch1,'Y',& '?Plot extra factor') call capson(ch1) if(ch1.eq.'Y' .or. ch1.eq.'X') then call gparrdx('Factor?',cline,last,xxx,1.0D-3,& '?Plot extra factor') if(ch1.eq.'X') graphopt%scalefact(1)=abs(xxx) if(ch1.eq.'Y') graphopt%scalefact(2)=abs(xxx) ! write(*,*)'PMON: ',graphopt%scalefact(1),graphopt%scalefact(2) else write(*,*)'No such axis' endif goto 21100 !............................... ! PLOT EXTRA COLOR ... and some more things ... case(1) ! monovariant and tielinecolor declared in smp2.F90 call gparcdx('Monovariant color ',cline,last,1,& name1,monovariant,'?Plot color') call capson(name1) do kl=1,6 if(name1(kl:kl).lt.'0' .or. name1(kl:kl).gt.'9') then if(name1(kl:kl).lt.'A' .or. name1(kl:kl).gt.'F') then write(*,*)'The color must be a hexadecimal value',& ' between 000000 (black) and FFFFFF (white)' goto 21100 endif endif enddo monovariant=name1(1:6) call gparcdx('Tie-line color ',cline,last,1,& name1,tielinecolor,'?Plot font') call capson(name1) do kl=1,6 if(name1(kl:kl).lt.'0' .or. name1(kl:kl).gt.'9') then if(name1(kl:kl).lt.'A' .or. name1(kl:kl).gt.'F') then write(*,*)'Wrong color, must be between 000000 and FFFFFF' goto 21100 endif endif enddo tielinecolor=name1(1:6) goto 21100 !............................................... ! PLOT EXTRA Gibbs triangle case(9) chz='Y' if(graphopt%gibbstriangle) chz='N' call gparcdx('A Gibbs triangle diagram?',cline,last,5,ch1,chz,& 'PLOT Gibbs triangle') if(ch1.eq.'y' .or. ch1.eq.'Y') then graphopt%gibbstriangle=.TRUE. write(*,22500) 22500 format('The Gibbs triangle layout courtesy of',& ' Catalina Pineda Heresi at RUB, Germany') else graphopt%gibbstriangle=.FALSE. endif goto 21100 !............................................... ! PLOT EXTRA GRID case(14) call gparcdx('Plot grid?',cline,last,1,ch1,'Y',& '?Plot extra factor') call capson(ch1) if(ch1.eq.'Y') then graphopt%setgrid=1 else graphopt%setgrid=0 endif goto 21100 !............................................... ! PLOT EXTRA LINE_TYPE case(4) j4=last if(eolch(cline,j4)) then ! write this only if the lime is empty write(*,22300) 22300 format('Default 1 restore normal line types:',/& ' 0 means dashed lines,'/,' 1 means full line',/& '>1 means symbol at each calculated point') endif call gparidx('Line type?',cline,last,iz,1,'?Plot line symbols') if(iz.eq.0) then ! this means dashed lines and possibly symbols if already set .. graphopt%linetype=0 elseif(iz.gt.1) then ! graphopt%linetype=iz ! this means symboles and possibly dashed lines if already set graphopt%linewp=iz else ! this means full lines and no symbols graphopt%linewp=1 graphopt%linetype=1 endif ! write(*,*)'Only partially implemented' goto 21100 !............................................... ! PLOT EXTRA LOGSCALE case(2) call gparcdx('For x or y axis (or NONE)? ',cline,last,1,ch1,'y',& '?Plot logax') if(ch1.eq.'x') then if(graphopt%axistype(1).eq.1) then write(kou,*)'The x axis set to linear' graphopt%axistype(1)=0 else graphopt%axistype(1)=1 ! set range to defaults when changing to LOG graphopt%rangedefaults(1)=0 endif elseif(ch1.eq.'y') then if(graphopt%axistype(2).eq.1) then write(kou,*)'The y axis set to linear' graphopt%axistype(2)=0 else graphopt%axistype(2)=1 ! set range to defaults when changing to LOG graphopt%rangedefaults(2)=0 endif else write(kou,*)'Both axis set to be linear' graphopt%axistype(1)=0 graphopt%axistype(2)=0 endif goto 21100 !............................................... ! PLOT EXTRA text in lower left corner case(7) call gparcx('Text in lower left corner?',cline,last,1,text,' ',& '?Extra lower-left-corner') graphopt%lowerleftcorner=text goto 21100 !............................................... ! PLOT EXTRA MANIPULATE LINE COLORS case(5) write(kou,22400) 22400 format('OC uses GNUPLOT and it is possible to edit',& ' the file "ocgnu.plt" file'/& 'generated by OC to use extensive facilities',& ' provided by GNUPLOT.'/& 'Only a few of them is provided here.'/& 'OC has 10 different colors to identify the lines plotted.',& ' Line 11 or'/' higher will repeat these colors. With',& ' this command you can select'/' one of these 10 colors',& ' to be used for the first line plotted.') call gparidx('The color index should be on the first line?',& cline,last,flc,1,'?Plot manipulate colors') if(flc.lt.1 .or. flc.gt.10) then write(*,*)'Number must be between 1 and 10' else graphopt%linett=flc endif goto 21100 !............................................... ! PLOT EXTRA remove headings case(12) call gparcdx('Remove headings?',cline,last,1,ch1,'N',& '?Plot no heading') if(ch1.ne.'N') then write(*,*)'No title set!',ch1 graphopt%status=ibset(graphopt%status,GRNOTITLE) else graphopt%status=ibclr(graphopt%status,GRNOTITLE) endif goto 21100 !............................................... ! PLOT EXTRA PAUSE_OPTIONS uselss?? case(6) write(kou,*)'Specify option after pause !' call gparcx('GNUPLOT pause option?',cline,last,5,text,' ',& '?Plot pause') if(len_trim(text).eq.0) then write(kou,*)'Warning, plot will exit directly!' ! text='-1' endif graphopt%plotend='pause '//text goto 21100 !............................................... ! PLOT EXTRA QUIT case(10) goto 21100 !............................................... ! PLOT EXTRA RATIOS case(3) call gparrdx('X-axis plot ratio',cline,last,xxx,graphopt%xsize,& '?Plot ratios') if(xxx.le.0.1) then write(*,*)'Ratio set to 0.1' xxx=0.1D0 endif graphopt%xsize=xxx call gparrdx('Y-axis plot ratio',cline,last,xxx,graphopt%ysize,& 'PLOT ratios') if(xxx.le.0.1) then write(*,*)'Ratio set to 0.1' xxx=0.1D0 endif graphopt%ysize=xxx goto 21100 !............................................... ! PLOT EXTRA spawn plot case(11) call gparcdx('Spawn plot?',cline,last,1,ch1,'N','?Plot extra') if(ch1.eq.'Y') then graphopt%status=ibset(graphopt%status,GRKEEP) else graphopt%status=ibclr(graphopt%status,GRKEEP) endif goto 21100 !............................................... ! PLOT EXTRA Tie-line plot increment case(8) call gparidx('Tie-line plot increment?',cline,last,kl,3,& '?Plot tieline') if(kl.lt.0) kl=0 graphopt%tielines=kl goto 21100 !............................................... ! PLOT EXTRA unused case(15) goto 21100 !............................................... ! PLOT EXTRA unused case(16) goto 21100 !............................................... ! PLOT EXTRA unused case(17) goto 21100 !............................................... ! PLOT EXTRA unused case(18) goto 21100 !----------------------------------------------------------- end select plotextra goto 21100 !----------------------------------------------------------- end SELECT plotoption !================================================================= ! HPCALC case(22) call hpcalc buperr=0 !================================================================= ! FIN, do not ask if sure, the French always know what they do ... case(23) if(logfil.gt.0) then write(logfil,*)'set interactive' endif call openlogfile(' ',' ',-1) stop 'Au revoir' !================================================================= ! OPTIMIZE and CONTINUE. Current optimizer is optimizers(optimizer) case(24) call gparidx('Number of iterations: ',cline,last,i1,nopt1,& '?Optimize') if(buperr.ne.0) goto 100 nopt1=i1 nopt=i1 ! write(*,606)'dead 1',mexp,nvcoeff,iexit 606 format(a,10i4) ! some optimizers have no CONTINUE ! if(optimizer.eq.1) iexit(4)=0 ! continue: if(mexp.gt.0 .and. iexit(4).eq.2) then ! iexit(4) from previous optimize allows continue with same Jacobian ! call gparcd('Continue with same Jacobian? ',cline,last,1,& ! ch1,'Y',q1help) ! if(ch1.eq.'Y') then ! ient=1 ! goto 987 ! endif ! endif continue ! Initiate arrays when new optimization ! ient=0 if(.not.allocated(firstash%eqlista)) then write(kou,*)'There are no equilibria with experiments!' goto 100 endif ! write(*,*)'dead 2A',mexp,nvcoeff ! if(allocated(www)) then ! write(*,*)'Deallocating www: ',size(www),www(1) ! deallocate(www) ! endif ! write(*,*)'dead 2B',mexp,nvcoeff if(allocated(coefs)) deallocate(coefs) ! write(*,*)'dead 2C',mexp,nvcoeff if(allocated(errs)) deallocate(errs) ! write(*,*)'dead 3',mexp,nvcoeff ! size of errors array, sum experiments for all equilibria mexp=0 do i1=1,size(firstash%eqlista) ! skip equilibria with zero weight if(firstash%eqlista(i1)%p1%weight.eq.zero) cycle if(associated(firstash%eqlista(i1)%p1%lastexperiment)) then i2=firstash%eqlista(i1)%p1%lastexperiment%seqz mexp=mexp+i2 else write(*,*)'No experiment in equilibrium ',i1 endif enddo ! write(*,*)'Number of experiments: ',mexp allocate(errs(mexp)) updatemexp=.false. ! copy the variable coefficients to coefs if(nvcoeff.le.0) then write(*,*)'No coefficients to optimize' nvcoeff=0 else i2=0 allocate(coefs(nvcoeff)) do i1=0,size(firstash%coeffstate)-1 if(firstash%coeffstate(i1).ge.10) then i2=i2+1 if(i2.gt.nvcoeff) then write(kou,*)'More variable coefficients than expected',& i2,nvcoeff goto 100 endif coefs(i2)=firstash%coeffvalues(i1) ! coefs(i2)=firstash%coeffvalues(i1)*firstash%scale(i1) ! We do not have to bother about the associtated TP variable, it will ! be set by the calfun routine to coefs*firstashscale ! call change_optcoeff(firstash%coeffindex(i1),& ! firstash%coeffvalues(i1)) ! firstash%coeffvalues(i1)) if(gx%bmperr.ne.0) then write(*,*)'Error finding coefficient TP fun' goto 100 endif endif enddo if(i2.lt.nvcoeff) then write(kou,*)'Internal error for variable coefficients',& i2,nvcoeff goto 100 endif endif ! JUMP HERE IF CONTINUE optimization ... NOT YET implemented 987 continue ! mexp Number of experiments ! nvcoeff Number of coefficients to be optimized ! errs Array with differences with experiments and calculated values ! coefs Array with coefficients if(mexp.le.0 .or. nvcoeff.le.0) then write(kou,569)mexp,nvcoeff 569 format('Cannot optimize with zero experiments or coefficients',2i5) goto 100 endif firstash%lwam=lwam write(*,558)mexp,nvcoeff,mexp*nvcoeff+5*nvcoeff+mexp,lwam 558 format(/'*************************************************************'/& '>>> Start of optimization using LMDIF'/& '>>> with ',i4,' experiments and ',i3,' coefficients.',/& '>>> Workspace needed ',i6,', out of allocated ',i6/& '*************************************************************') ! j4=nopt if(.not.allocated(iwam)) then ! value of lwam set by user allocate(iwam(lwam)) allocate(wam(lwam)) endif if(allocated(fjac)) deallocate(fjac) ! fjac is used to calculate the Jacobian and other things ! err0(1) is set to the sum of errors squared for the initial values of coefs 573 format(a,6(1pe12.4)) allocate(fjac(mexp,nvcoeff)) ! write(*,'(a,10(1pe12.4))')'lmdif1: ',(coefs(iz),iz=1,nvcoeff) !->->->->->-> HERE THE OPTIMIZATION IS MADE <-<-<-<-<-<- ! nfev set to number of iterations ! write(*,*)'LMDIF dimensions: ',mexp,nvcoeff,lwam call lmdif1(calfun,mexp,nvcoeff,coefs,errs,optacc,nopt,nfev,& iwam,wam,lwam,fjac,err0) ! call lmdif1(mexp,nvcoeff,coefs,errs,optacc,nopt,nfev,& ! iwam,wam,lwam,fjac,err0) !->->->->->-> HERE THE OPTIMIZATION IS MADE <-<-<-<-<-<- mexpdone=mexp nvcoeffdone=nvcoeff ! on return nopt is set to a message but ! first copy the coefs to coeffvalues ... ! write(*,573)'Coeffs ut: ',(coefs(j2),j2=1,nvcoeff) i2=0 do i1=0,size(firstash%coeffstate)-1 if(firstash%coeffstate(i1).ge.10) then i2=i2+1 firstash%coeffvalues(i1)=coefs(i2) ! write(*,555)'final: ',i1,i2,& ! firstash%coeffvalues(i1)*firstash%coeffscale(i1),& ! coefs(i2),firstash%coeffscale(i1) !555 format(a,2i3,3(1pe12.4)) endif enddo ! then calculate final sum of errots xxx=zero do i2=1,mexp xxx=xxx+errs(i2)**2 enddo ! this is the final sum of errors squared err0(2)=xxx if(mexp-nvcoeff.gt.0) then ! should I add or subract 1?? err0(3)=xxx/real(mexp-nvcoeff) else ! when equal number of experiment and coefficients err0(3)=1.0D30 endif ! The top nvcoeff*nvcoeff submatrix of fjac is R^T * R ! write(*,*)'The unsymmetric R^T*R submatrix returned from lmfif1:' ! do i2=1,nvcoeff ! write(*,563)(fjac(j2,i2),j2=1,nvcoeff) ! enddo ! read(*,'(a)')ch1 ! cormat will be the CORRELATION MATRIX if optimization successful ! otherwise it will not be allocated if(allocated(cormat)) then deallocate(cormat) deallocate(tccovar) endif !--------------- begin calculate correlation matrix and RSD ! zero the relative standard deviations (RSD) firstash%coeffrsd=zero if(j4.gt.0 .and. nopt.gt.0 .and. nopt.le.6) then ! if there is a result calculate the Jacobian in fjac ! mexp,nvcoeff,coeffs,errs are same as in the call to lmdif1 ! This will overwrite the fjac returned from the call to lmdif1 ! write(*,*)'Calculating the Jacobian: ' ! allocate array to extract calculated values of experiments if(allocated(calcexp)) deallocate(calcexp) allocate(calcexp(mexp)) iflag=2 ! penulitima argument zero means use machine precision to calculate derivative ! call fdjac2(mexp,nvcoeff,coefs,errs,fjac,mexp,iflag,zero,wam) call fdjac2(calfun,mexp,nvcoeff,coefs,errs,fjac,mexp,iflag,zero,wam) ! debug output ... ! write(*,*)'pmon: fjac: ',nvcoeff,mexp,iflag ! do i2=1,mexp ! write(*,563)(fjac(i2,ll),ll=1,nvcoeff) ! enddo 563 format(6(1pe12.4)) ! write(*,*)'End listing of Jacobian fjac calculated by fdjac2' ! read(*,'(a)')ch1 ! Next calculate M = (fjac)^T (fjac); ( ^T means transponat) if(allocated(cov1)) deallocate(cov1) ! the cov1 is symmetric and should have these dimensions: allocate(cov1(nvcoeff,nvcoeff)) cov1=zero do i2=1,nvcoeff do j2=1,nvcoeff xxx=zero do ll=1,mexp xxx=xxx+fjac(ll,i2)*fjac(ll,j2) ! write(*,564)'xxx: ',i2,j2,ll,xxx 564 format(a,3i5,1pe12.4) enddo ! this matrix is symmetric ... which index first ??? cov1(j2,i2)=xxx ! cov1(i2,j2)=xxx enddo enddo ! write(*,*)'M = (Jac)^T (Jac); (^T means transponat)',nvcoeff ! do i2=1,nvcoeff ! write(*,563)(cov1(i2,ll),ll=1,nvcoeff) ! enddo ! invert cov1 using LAPACK+BLAS via Lukas routine ... if(nvcoeff.gt.1) then ! cormat deallocated above, dimension is cormat(nvcoeff,nvcoeff) !! allocate(cormat(nvcoeff,nvcoeff)) allocate(tccovar(nvcoeff,nvcoeff)) ! symmetric? call mdinv(nvcoeff,nvcoeff+1,cov1,cormat,nvcoeff,iflag) ! NOTE: cov1 and cormat should both have dimension cov1(nvcoeff,nvcoeff) call mdinv(nvcoeff,cov1,cormat,nvcoeff,iflag) ! invert unsymmetrical matrix if(iflag.eq.0) then write(*,*)'Failed invert matrix=Jac^T*Jac',iflag endif ! RSD depend on scaling factor of coefficient ! write(*,*)'PMON norm.error and covariant matrix: ',err0(3) ! do i1=1,nvcoeff ! write(*,'(6(1pe12.4))')(cormat(i1,i2),i2=1,nvcoeff) ! enddo ! all elements in the covariance matrix should be multiplied with err0(3) tccovar=cormat do i1=1,nvcoeff do i2=1,nvcoeff ! I get exactly the same RSD as TC if I ignore the normalized error !! ! but according to theory it should be multiplied with the normalized error cormat(i1,i2)=err0(3)*cormat(i1,i2) enddo enddo ! divide all values with the square root of the diagonal elements ! save covarance matrix n cov1 cov1=cormat do i1=1,nvcoeff do i2=1,nvcoeff xxx=sqrt(abs(cov1(i1,i1)*cov1(i2,i2))) cormat(i1,i2)=cormat(i1,i2)/xxx enddo enddo ! write(*,*)'Correlation after dividing with sqrt(abs(c_ii*c_jj))' ! do i1=1,nvcoeff ! write(*,'(6(1pe12.4))')(cormat(i1,i2),i2=1,nvcoeff) ! enddo elseif(abs(cov1(1,1)).gt.1.0D-38) then ! cov1 is just a single value allocate(cormat(1,1)) allocate(tccovar(1,1)) ! cormat(1,1)=one ! IF THERE IS A SINGLE VARIABLE ITS CORRELATION MATRIX MUST BE UNITY cormat(1,1)=one tccovar(1,1)=one else write(*,*)'Correlation matrix singular' endif endif ! write the correlation matrix this is still very uncertain ,,, ! if(allocated(cormat)) then ! if(nvcoeff.gt.0) then ! write(*,*)'Correlation matrix (symmetric):' ! do i2=1,nvcoeff ! write(kou,'(8(1pe10.2))')(cormat(i2,j2),j2=1,nvcoeff) ! enddo ! endif ! endif ! zero all RSD values firstash%coeffrsd=zero if(allocated(cormat) .and. allocated(cov1)) then ! calculate the RSD (Relative Standard Deviation) for each parameter ! the last calculated values of the experiments in calcexp ! write(*,*)'The sum of all calculated equilibria,',& ! ' very different magnitudes ...' xxx=zero do i2=1,mexp ! the calculated value is stored in calcexp by fdjac if calcexp is allocated! xxx=xxx+calcexp(i2) ! write(*,766)i2,calcexp(i2),xxx 766 format('pmon: Calculated value',i4,2(1pe12.4)) enddo ! ll=max(1,mexp-nvcoeff) ! This value may be negative! ! xxy=xxx/real(ll) ! the difference between the calculated and experimental value is errs(1:mexp) ! err0(2) is sum of all errors squared ! xxx=err0(2)/real(ll) ... this is err0(3) ! I am not sure about this ... i2=0 do i1=0,size(firstash%coeffstate)-1 if(firstash%coeffstate(i1).ge.10) then ! this is an optimized parameter, they are indexed starting from zero!! i2=i2+1 ! But in cormat they are indexed from 1 .. nvcoeff ! firstash%coeffrsd(i1)=sqrt(abs(cormat(i2,i2))*xxx)/xxy ! write(*,'(a,3(1pe12.4))')'RSD: ',cov1(i2,i2),xxx,xxy ! firstash%coeffrsd(i1)=abs(sqrt(abs(cov1(i2,i2))*xxx)/xxy) ! we have already multiplied all terms in covariance matrix with err0(3) ! firstash%coeffrsd(i1)=abs(sqrt(abs(cov1(i2,i2))*err0(3) firstash%coeffrsd(i1)=abs(sqrt(abs(cov1(i2,i2)))) endif enddo endif ! deallocate calcexp to avoid storing these values when running LMDIF if(allocated(calcexp)) deallocate(calcexp) !--------------- end calculate correlation matrix and RSD ! some nice output ..... write(kou,5020) if(j4.eq.0) then write(*,*)'Dry run with zero iterations' elseif(nopt.eq.0) then write(kou,5000)nopt 5000 format(/'*** No optimization due to improper input parameters',i3) elseif(nopt.eq.1) then write(kou,5001)nopt,optacc 5001 format(/'LMDIF return code ',i2/& 'Relative error for sum of squares is within ',1pe10.2) elseif(nopt.eq.2) then write(kou,5002)nopt,optacc 5002 format(/'LMDIF return code ',i2/& 'Relative error of parameters is within ',1pe10.2) elseif(nopt.eq.3) then write(kou,5003)nopt 5003 format(/'LMDIF return code ',i2,': successful optimization') elseif(nopt.eq.4) then write(kou,5004)nopt 5004 format(/'*** LMDIF return code ',i2/& 'Sum of squares does not decrease') elseif(nopt.eq.5) then write(kou,5005)nopt,nfev 5005 format(/'*** LMDIF return code ',i2/& 'Maximum calls of function ',i5,' exceeded') elseif(nopt.eq.6) then write(kou,5006)nopt,optacc 5006 format(/'*** LMDIF return code ',i2/& 'Cannot reduce error, requested accuracy ',1pe10.2,' too small') ! '*** Cannot reduce error, requested accuracy 123456789. too small elseif(nopt.eq.6) then write(kou,5007)nopt,optacc 5007 format(/'*** LMDIF return code ',i2/& 'Cannot improve result, requested accuracy ',1pe10.2,' too small') else write(kou,5008)nopt 5008 format('*** LMDIF return code ',i7/& 'Unknown code, see LMDIF documentation.') endif write(kou,5010)nfev,err0 5010 format(/'Iterations ',i4,', sum of errors changed from ',& 1pe14.6,' to ',1pe14.6/17x,'Normalized sum of errors:',20x,1pe14.6) write(kou,5020) 5020 format(/78('*')) ! finally list the coefficient values call listoptcoeff(mexp,err0,.FALSE.,lut) ! end of call to LMDIF !================================================================= ! SHOW is immpemented as a special case of LIST STATE_VARIABLES ! CASE(25) ! write(kou,*)'Not implemented yet' !================================================================= ! not used CASE(26) continue write(kou,*)'Not implemented yet' !================================================================= ! unused CASE(27) write(kou,*)'Not implemented yet' !================================================================= ! unused CASE(28) write(kou,*)'Not implemented yet' !================================================================= ! unused CASE(29) write(kou,*)'Not implemented yet' !================================================================= ! unused CASE(30) write(kou,*)'Not implemented yet' !================================================================= ! END SELECT main ! command executed, prompt for another command unless error code if(gx%bmperr.eq.0) goto 100 !============================================================ ! handling errors 990 continue write(kou,991)gx%bmperr,buperr,kiu 991 format(/'Error codes: ',3i6) if(gx%bmperr.ge.4000 .and. gx%bmperr.le.nooferm) then write(kou,992)trim(bmperrmess(gx%bmperr)) 992 format('Message: ',a/) else write(kou,*)'No defined error message, maybe I/O error' endif ! if(kiu.ne.kiud) then if(stop_on_error) then ! error running a macro, terminate macro and return interactive write(*,*)'Error running MACRO file, return to interactive mode?' if(iox(8).eq.0) then ! iox(8) is nonzero if one has set "no stop on @&" ! in such a case ignore any error read(*,993)ch1 993 format(a) if(ch1.eq.' ') then call macend(cline,last,logok) kiu=kiud else write(*,*)'Continue on your own risk ' endif endif endif ! if(stop_on_error) then ! turn off macro but remain inside software ! if(kiu.ne.kiud) then ! call macend(cline,last,logok) ! write(kou,*)'Stop_on_error set, press return to finish program' ! read(kiu,17)ch1 ! stop ! endif gx%bmperr=0; buperr=0 goto 100 ! end subroutine oc_command_monitor !\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\bergin{verbatim} integer function submenu(query,cline,last,ccomnd,ncomnd,kdef,menutarget) ! general subcommand decoder ! query is the prompt ! cline and last is user input and position ! ccomnd is the menu and ncomnd number of menu entries ! kdef is the default (to be added to query) ! implicit double precision (a-h,o-z) implicit none character cline*(*),ccomnd(*)*(*),query*(*),menutarget*(*) integer last,kdef,ncomnd !\end{verbatim} ! external q2help character defansw*16,query1*64,text*256 integer kom2,lend,lenq logical once lenq=len_trim(query) if(query(lenq:lenq).eq.'?') then query1=query(1:lenq) else query1=query(1:lenq)//' what?' lenq=lenq+6 endif once=.true. ! this is to force loading of q2help on MacOS (did not help) ! write(*,*)'In submenu target:',trim(menutarget),' "',trim(cline),'"',last submenu=0 ! if cline(last:last) is "," skip one character ! write(kou,*)'submenu 1: ',query(1:lenq),last,trim(cline),kdef if(last+2.lt.len(cline)) then if(cline(last:last).eq.',') last=last+1 else ! write(*,*)'Submenu input too long: "',trim(cline),'"',last last=len(cline)-2 endif if(cline(last:last+2).eq.' ? ' .or. cline(last:last+1).eq.'? ') then ! This handles help for things like "set ?" ! if cline is just "?" just display menu but reset last to 1 ! in order to provide help also specific for the command call q3helpx(cline,last,ccomnd,ncomnd) last=len(cline) goto 1000 endif 100 continue ! write(*,*)'submenu command input' if(kdef.lt.1 .or. kdef.gt.ncomnd) then ! no default answer if(eolch(cline,last)) then ! empty line, note fourth argument 5 copes whole of cline into text ! the hypertext is the submenu prompt, last argument set to mark TOPHLP! call gparcx(query1(1:lenq),cline,last,5,text,' ','?TOPHLP') if(buperr.ne.0) goto 1000 ! write(*,*)'At the TOP LEVEL no default: ',trim(text),last cline=text else cline=cline(last:) endif else ! there is a default answer ! this eolch skips spaces. If only spaces it returns TRUE if(eolch(cline,last)) then ! there is no user input passed to this subroutine, write the question defansw=ccomnd(kdef) lend=len_trim(defansw)+1 333 continue ! this is submenu command input ! note fourth argument 5 copes whole of cline into text ! the queary is the hypertarget, last argument to indicate TOPHLP ! if user answers a single ? retutn here, if ?? use webrowser call gparcdx(query1(1:lenq),cline,last,5,text,defansw,'?TOPHLP') if(buperr.ne.0) goto 1000 ! write(*,*)'submenu input 3: ',trim(text),last if(text(1:1).eq.'?') then if(text(2:2).ne.'?') then ! if we have just a ? here we should display the menue ! write(*,*)'TOP LEVEL default: ',trim(text),last call q3helpx(' * ',last,ccomnd,ncomnd) last=len(cline) ! note that two ?? should have been taken care of inside gparcdx endif goto 333 endif cline=text else ! if first character is , take default answer ! write(*,102)'submenu 7: ',last,trim(cline) 102 format(a,i5,'"',a,'"') if(cline(last:last).eq.',') then ! a , means accept default answer submenu=kdef goto 1000 else defansw=ccomnd(kdef) lend=len_trim(defansw)+1 ! note fourth argument 5 copes whole of cline into text ! gparcd skips one character, backspace last, it does not matter if it is , last=last-1 ! in this case there is no user input in this call call gparcdx(query1(1:lenq),cline,last,5,text,defansw,'?TOPHLP') if(buperr.ne.0) goto 1000 cline=text ! cline=cline(last:) ! write(*,*)'sumbemu: ',trim(cline),last ! added 20190207 because "enter gamma ac(a)/x(a); gave segmentation fault ! but that was not the error, the error was missing = ! once=.false. endif endif endif ! ! write(*,102)'submenu 9: ',last,trim(cline) kom2=ncomp(cline,ccomnd,ncomnd,last) if(kom2.le.0) then if(once) then if(cline(1:1).ne.'?') once=.false. if(kom2.lt.0) write(kou,*)'Ambiguous answer, please try again' write(kou,*)'Possible answers are:' last=1 cline=' *' ! call nghelp(cline,last,ccomnd,ncomnd) call q3helpx(cline,last,ccomnd,ncomnd) last=len(cline) goto 100 else write(kou,*)'Answer not understood, returning to upper level' goto 1000 endif else submenu=kom2 if(helprec%level.lt.maxhelplevel) then helprec%level=helprec%level+1 helprec%cpath(helprec%level)=ccomnd(kom2) else write(*,*)'Warning, exceeded helprec%level limit 2' endif endif ! write(*,102)'submenu last: ',last,trim(cline) 1000 continue return end function submenu !\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\begin{verbatim} subroutine ocmon_set_options(useroption,afo,optionsset) implicit none character*(*) useroption integer afo TYPE(ocoptions) :: optionsset !\end{verbatim} integer next,kom,slen,errno,jj,ztyp character option*64,string*64,dummy*128,date*8,time*10 integer, parameter :: nopt=9 character (len=16), dimension(nopt) :: copt=& ['OUTPUT ','ALL ','FORCE ',& 'VERBOSE ','SILENT ','APPEND ',& ' ',' ',' '] ! copy "option" to a local string as it may be just a single character!! option=' ' option=useroption ! /? will list options afo=0 if(option(1:2).eq.'? ') then write(kou,10) 10 format('Available options (preceded by /) are:') next=1 dummy=' * ' call q3helpx(dummy,next,copt,nopt) ! write(*,*)'Back from q3help' afo=1 goto 1000 endif kom=ncomp(option,copt,nopt,next) if(kom.le.0) then write(kou,*)'Unknown option ignored: ',option(1:len_trim(option)) goto 1000 else select case(kom) case default write(kou,*)'Option not implemented: ',option(1:len_trim(option)) write(kou,10) next=1 dummy=' * ' call q3helpx(dummy,next,copt,nopt) afo=1 !----------------------------------- case(1) ! /output means open a file and ovewrite any previous content ! write(*,*)'Option not implemented: ',option(1:len_trim(option)) ! next argument after = must be a file name ! 6 means extension DAT ! jj=next+1 ! if(eolch(option,jj)) then ! default extension (1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT, 6=XTDB, 7=DAT ! negative is for write, 0 read without filter, -100 write without filter ztyp=-7 call gparfilex('Output file',option,next,1,string,' ',ztyp,& '?Command options') if(string(1:1).eq.' ') then string='ocoutput.DAT' write(kou,*)' *** No file name given, will use: ',trim(string) endif slen=len_trim(string) ! else ! call getext(option,next,2,string,' ',slen) ! endif ! add extention .dat if to extenstion provided if(index(string,'.').le.0) then string(slen+1:)='.DAT ' endif ! close any previous output file close(21) open(21,file=string,access='sequential',status='unknown',& err=900, iostat=errno) optionsset%lut=21 ! write a header call date_and_time(date,time) 232 format(/'%%%%%%%%%% OC output ',a,a4,'-',a2,'-',a2,2x,a2,'h',a2) write(21,232)'written: ',date(1:4),date(5:6),date(7:8),& time(1:2),time(3:4) write(kou,231)'Output',trim(string) !----------------------------------- case(2) ! /all ?? write(*,*)'Option not implemented: ',trim(option) !----------------------------------- case(3) ! /force write(*,*)'Option not implemented: ',trim(option) !----------------------------------- case(4) ! /verbose globaldata%status=ibset(globaldata%status,GSVERBOSE) write(kou,*)'VERBOSE option set ... but not really implemented' !----------------------------------- case(5) ! /silent globaldata%status=ibclr(globaldata%status,GSVERBOSE) globaldata%status=ibset(globaldata%status,GSSILENT) !----------------------------------- case(6) ! /APPEND, open file and write at end ! write(*,*)'Option not implemented: ',option(1:len_trim(option)) ! next argument after = must be a file name ! jj=next ! if(eolch(option,jj)) then ! default extension (1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT, 6=XTDB, 7=DAT ! negative is for write, 0 read without filter, -100 write without filter ztyp=-7 call gparfilex('Append to file:',option,next,& 1,string,' ',ztyp,'?Command options') if(string(1:1).eq.' ') then string='ocappend.DAT' write(kou,*)' *** No file name given, will use: ',trim(string) endif ! else ! call getext(option,next,2,string,' ',slen) ! endif ! add extention .dat if to extension provided slen=len_trim(string) if(index(string,'.').le.0) then string(slen+1:)='.DAT ' endif ! close any previous output file (should not be necessary) close(21) open(21,file=string,access='sequential',status='unknown',& err=900, iostat=errno) optionsset%lut=21 ! read until end-of-file 200 continue read(21,210,end=220)dummy 210 format(a) goto 200 ! write not allowed after finding EOF, we must backspace 220 continue backspace(21) ! write a header call date_and_time(date,time) write(21,232)'appended: ',date(1:4),date(5:6),date(7:8),& time(1:2),time(3:4) write(kou,231)'Append',trim(string) 231 format(a,' on file: ',a) !----------------------------------- case(7) ! continue !----------------------------------- case(8) ! continue !----------------------------------- case(9) ! continue end select endif goto 1000 ! errors 900 continue write(kou,*)'Failed to open output file, error cofe=',errno goto 1000 1000 continue return end subroutine ocmon_set_options !\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\begin{verbatim} subroutine ocmon_reset_options(optionsset) implicit none TYPE(ocoptions) :: optionsset ! TYPE(ocoptions), pointer :: optionsset !\end{verbatim} if(btest(globaldata%status,GSVERBOSE)) then ! reset verbose option if(.not.btest(globaldata%status,GSSETVERB)) then ! if user has SET VERBOSE do not resest VERBOSE globaldata%status=ibclr(globaldata%status,GSVERBOSE) endif endif ! reset output unit option if(optionsset%lut.ne.kou) then close(optionsset%lut) optionsset%lut=kou write(kou,"(a,i4)")'Output unit reset to screen: ',kou endif !1000 continue return end subroutine ocmon_reset_options !\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ END MODULE cmon1oc ================================================ FILE: src/utilities/GETKEY/M_getkey.F90 ================================================ !=======================================================================-------- !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()() !=======================================================================-------- ! These routines are available for general use. I ask that you send me ! interesting alterations that are available for public use; and that you ! include a note indicating the original author -- John S. Urban ! Last updated May 5th, 2009 !=======================================================================-------- !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()() !=======================================================================-------- ! make Fortran/C interface for C routine getkey(3C) module M_getkey use iso_c_binding implicit none public interface character function getkex() bind(c, name='getkeyC') use iso_c_binding implicit none character(kind=c_char) :: getkey end function getkex end interface end module M_getkey !=======================================================================-------- !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()() !=======================================================================-------- !------------------------------------------------------------------------------- ================================================ FILE: src/utilities/GETKEY/Makefile ================================================ OBJS=getkey.o bintxt.o EXE=tin all: $(EXE) getkey.o: # uncomment the appropriate line below # for MAC # gcc -c -DBSD getkey.c # for Linux # gcc -c -DLinux getkey.c # for other UNIX systems # gcc -c -DG77 getkey.c # for CYGWIN on Windows # gcc -c -DCYGWIN getkey.c gfortran -c M_getkey.F90 bintxt.o: gfortran -c bintxt.F90 $(EXE): $(OBJS) # gfortran -o $(EXE) testbintxt2.F90 bintxt.o getkey.o ================================================ FILE: src/utilities/GETKEY/getkey.c ================================================ /* * @(#) Driver for reading a character from keyboard in raw I/O mode */ #include #include #include #include #include /*--------------------------*/ #ifdef BSD #include #else /*--------------------------*/ #ifdef Linux #define G77 #endif #ifdef CYGWIN #define G77 #endif #ifdef G77 #include #else #include #endif /* modified to sys/termios.h above */ /*--------------------------*/ #endif #include /*V13 #include */ /*V13 #include */ /******************************************************************************/ /* return the next key typed in hot (raw I/O) mode. */ char getkeyC(void) { #ifdef BSD struct sgttyb oldtty, newtty; char c; ioctl(0, TIOCGETP, &oldtty); newtty = oldtty; newtty.sg_flags = RAW; ioctl(0, TIOCSETP, &newtty); read(0, &c, 1); ioctl(0, TIOCSETP, &oldtty); #else struct termio oldtty, newtty; /*V13 struct termios oldtty, newtty; */ char c; ioctl(0, TCGETA, &oldtty); /*V13 tcgetattr(0, &oldtty); */ newtty = oldtty; newtty.c_iflag = BRKINT | IXON | ISTRIP; newtty.c_lflag = 0; newtty.c_cc[VEOF] = 1; ioctl(0, TCSETA, &newtty); /*V13 tcsetattr(0, TCSANOW, &newtty); */ read(0, &c, 1); ioctl(0, TCSETA, &oldtty); /*V13 tcsetattr(0, TCSANOW, &oldtty); */ #endif /* fprintf(stderr,"C:c=%c\n",c); */ /* fflush(stdout); */ return(c); } /******************************************************************************/ /* Commonly, a C routine called name_ can be called from Fortran as name; plus less-common ones */ int getkey4f_(void) { return(getkeyC()); } int _getkey4f(void) { return(getkeyC()); } int getkey4f(void) { return(getkeyC()); } int GETKEY4F(void) { return(getkeyC()); } /* http://www.urbanjost.altervista.org/LIBRARY/libCLI/Getkey/getkey.html */ ================================================ FILE: src/utilities/TINYFILEDIALOGS/Makefile ================================================ OBJS=tinyfiledialogs.o tinyopen.o ftinyopen.o EXE=gopen all: $(EXE) tinyfiledialogs.o: gcc -c tinyfiledialogs.c tinyopen.o: gcc -c tinyopen.c ftinyopen.o: gfortran -c ftinyopen.F90 $(EXE): $(OBJS) gfortran -o $(EXE) main.F90 ftinyopen.o tinyopen.o tinyfiledialogs.o clean: rm *.o *.exe ================================================ FILE: src/utilities/TINYFILEDIALOGS/compile_and_link ================================================ gcc -c tinyfiledialogs.c gcc -c tinyopen.c gfortran -o fopen main.F90 tinyopen.o tinyfiledialogs.c -lcomdlg32 -lole32 ================================================ FILE: src/utilities/TINYFILEDIALOGS/ftinyopen.F90 ================================================ module ftinyopen use iso_c_binding implicit none ! A C function that returns a string need a pointer to the array of single char type (c_ptr) :: C_String_ptr ! This is the Fortran equivalent to a string of single char character (len=1, kind=c_char), dimension(:), pointer :: filchar => null() !\begin{verbatim} ! Interface to a C routine which opens a window for browsing a file to open interface function tinyopen(typ) bind(c, name="tinyopen") use iso_c_binding implicit none integer(c_int), value :: typ type (C_Ptr) :: tinyopen end function tinyopen end interface !\end{verbatim} contains !\begin{verbatim} subroutine getfilename(typ,filename) ! Fortran routine to call a C routine to browse for a file name ! typ if default extension: ! 1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT ,6=XTDB, 7=DAT, 8=LOG character (len=*) :: filename integer typ !\end{verbatim} integer jj ! the current directory can be found by ! character directory*128 ! call getcwd(directory) ! specify a name of a file type: ! write(*,*)'In ftinyopen ',typ ! 1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=plt, 6=XTDB, 7=DAT, 8=LOG C_String_ptr = tinyopen(typ) ! convert C pointer to Fortran pointer call c_f_pointer(C_String_ptr,filchar,[256]) filename=' ' if(associated(filchar)) then ! convert the array of single characters to a Fortran character jj=1 do while(filchar(jj).ne.c_null_char) filename(jj:jj)=filchar(jj) jj=jj+1 enddo endif ! write(*,*)'ftinyopen getfilename: ',trim(filename),typ 1000 continue return end subroutine getfilename end module ftinyopen ================================================ FILE: src/utilities/TINYFILEDIALOGS/tinyfiledialogs.c ================================================ /*_________ / \ tinyfiledialogs.c v3.6.4 [Sep 14, 2020] zlib licence |tiny file| Unique code file created [November 9, 2014] | dialogs | Copyright (c) 2014 - 2020 Guillaume Vareille http://ysengrin.com \____ ___/ http://tinyfiledialogs.sourceforge.net \| git clone http://git.code.sf.net/p/tinyfiledialogs/code tinyfd ____________________________________________ | | | email: tinyfiledialogs at ysengrin.com | |____________________________________________| _________________________________________________________________________________ | | | the windows only wchar_t UTF-16 prototypes are at the bottom of the header file | |_________________________________________________________________________________| _________________________________________________________ | | | on windows: - since v3.6 char is UTF-8 by default | | - if you want MBCS set tinyfd_winUtf8 to 0 | | - functions like fopen expect MBCS | |_________________________________________________________| If you like tinyfiledialogs, please upvote my stackoverflow answer https://stackoverflow.com/a/47651444 tiny file dialogs (cross-platform C C++) InputBox PasswordBox MessageBox ColorPicker OpenFileDialog SaveFileDialog SelectFolderDialog Native dialog library for WINDOWS MAC OSX GTK+ QT CONSOLE & more SSH supported via automatic switch to console mode or X11 forwarding one C file + a header (add them to your C or C++ project) with 8 functions: - beep - notify popup (tray) - message & question - input & password - save file - open file(s) - select folder - color picker Complements OpenGL Vulkan GLFW GLUT GLUI VTK SFML TGUI SDL Ogre Unity3d ION OpenCV CEGUI MathGL GLM CPW GLOW Open3D IMGUI MyGUI GLT NGL STB & GUI less programs NO INIT NO MAIN LOOP NO LINKING NO INCLUDE The dialogs can be forced into console mode Windows (XP to 10) ASCII MBCS UTF-8 UTF-16 - native code & vbs create the graphic dialogs - enhanced console mode can use dialog.exe from http://andrear.altervista.org/home/cdialog.php - basic console input Unix (command line calls) ASCII UTF-8 - applescript, kdialog, zenity - python (2 or 3) + tkinter + python-dbus (optional) - dialog (opens a console if needed) - basic console input The same executable can run across desktops & distributions C89/C18 & C++98/C++20 compliant: tested with C & C++ compilers VisualStudio MinGW-gcc GCC Clang TinyCC OpenWatcom-v2 BorlandC SunCC ZapCC on Windows Mac Linux Bsd Solaris Minix Raspbian using Gnome Kde Enlightenment Mate Cinnamon Budgie Unity Lxde Lxqt Xfce WindowMaker IceWm Cde Jds OpenBox Awesome Jwm Xdm Cwm Bindings for LUA and C# dll, Haskell, Fortran Included in LWJGL(java), Rust, Allegrobasic Thanks for contributions, bug corrections & thorough testing to: - Don Heyse http://ldglite.sf.net for bug corrections & thorough testing! - Paul Rouget - License - This software is provided 'as-is', without any express or implied warranty. In no event will the authors be held liable for any damages arising from the use of this software. Permission is granted to anyone to use this software for any purpose, including commercial applications, and to alter it and redistribute it freely, subject to the following restrictions: 1. The origin of this software must not be misrepresented; you must not claim that you wrote the original software. If you use this software in a product, an acknowledgment in the product documentation would be appreciated but is not required. 2. Altered source versions must be plainly marked as such, and must not be misrepresented as being the original software. 3. This notice may not be removed or altered from any source distribution. */ #ifndef __sun #define _POSIX_C_SOURCE 2 /* to accept POSIX 2 in old ANSI C standards */ #endif #include #include #include #include #include #ifdef _WIN32 #ifdef __BORLANDC__ #define _getch getch #endif #ifndef _WIN32_WINNT #define _WIN32_WINNT 0x0500 #endif #ifndef TINYFD_NOLIB #include #include #include #endif #include #include #define TINYFD_NOCCSUNICODE #define SLASH "\\" #else #include #include #include /* on old systems try instead */ #include #include #include /* on old systems try instead */ #define SLASH "/" #endif /* _WIN32 */ #include "tinyfiledialogs.h" #define MAX_PATH_OR_CMD 1024 /* _MAX_PATH or MAX_PATH */ #ifndef MAX_MULTIPLE_FILES #define MAX_MULTIPLE_FILES 1024 #endif #define LOW_MULTIPLE_FILES 32 char const tinyfd_version[8] = "3.6.4"; /******************************************************************************************************/ /**************************************** UTF-8 on Windows ********************************************/ /******************************************************************************************************/ #ifdef _WIN32 /* if you want to use UTF-8 ( instead of the UTF-16/wchar_t functions at the end of tinyfiledialogs.h ) Make sure your code is really prepared for UTF-8 (on windows, functions like fopen() expect MBCS and not UTF-8) */ int tinyfd_winUtf8 = 1; /* on windows char strings can be 1:UTF-8(default) or 0:MBCS */ /* for MBCS change this to 0, here or in your code */ #endif /******************************************************************************************************/ /******************************************************************************************************/ /******************************************************************************************************/ int tinyfd_verbose = 0 ; /* on unix: prints the command line calls */ int tinyfd_silent = 1 ; /* 1 (default) or 0 : on unix, hide errors and warnings from called dialogs*/ static int const tinyfd_allowCursesDialogs = 0 ; /* 0 (default) or 1 : curses dialogs are difficult to use, on windows they are only ascii*/ #if defined(TINYFD_NOLIB) && defined(_WIN32) int tinyfd_forceConsole = 1 ; #else int tinyfd_forceConsole = 0 ; /* 0 (default) or 1 */ #endif /* for unix & windows: 0 (graphic mode) or 1 (console mode). 0: try to use a graphic solution, if it fails then it uses console mode. 1: forces all dialogs into console mode even when the X server is present, if the package dialog (and a console is present) or dialog.exe is installed. on windows it only make sense for console applications */ char tinyfd_response[1024]; /* if you pass "tinyfd_query" as aTitle, the functions will not display the dialogs but and return 0 for console mode, 1 for graphic mode. tinyfd_response is then filled with the retain solution. possible values for tinyfd_response are (all lowercase) for graphic mode: windows_wchar windows applescript kdialog zenity zenity3 matedialog qarma python2-tkinter python3-tkinter python-dbus perl-dbus gxmessage gmessage xmessage xdialog gdialog for console mode: dialog whiptail basicinput no_solution */ #if defined(TINYFD_NOLIB) && defined(_WIN32) static int gWarningDisplayed = 1 ; #else static int gWarningDisplayed = 0 ; #endif static char const gTitle[]="missing software! (we will try basic console input)"; #ifdef _WIN32 char const tinyfd_needs[] = "\ ___________\n\ / \\ \n\ | tiny file |\n\ | dialogs |\n\ \\_____ ____/\n\ \\|\ \ntiny file dialogs on Windows needs:\ \n a graphic display\ \nor dialog.exe (enhanced console mode)\ \nor a console for basic input"; #else char const tinyfd_needs[] = "\ ___________\n\ / \\ \n\ | tiny file |\n\ | dialogs |\n\ \\_____ ____/\n\ \\|\ \ntiny file dialogs on UNIX needs:\ \n applescript\ \nor kdialog\ \nor zenity (or matedialog or qarma)\ \nor python (2 or 3)\ \n + tkinter + python-dbus (optional)\ \nor dialog (opens console if needed)\ \nor xterm + bash\ \n (opens console for basic input)\ \nor existing console for basic input"; #endif #ifdef _MSC_VER #pragma warning(disable:4996) /* allows usage of strncpy, strcpy, strcat, sprintf, fopen */ #pragma warning(disable:4100) /* allows usage of strncpy, strcpy, strcat, sprintf, fopen */ #pragma warning(disable:4706) /* allows usage of strncpy, strcpy, strcat, sprintf, fopen */ #endif char * getCurDir(void) { static char lCurDir [MAX_PATH_OR_CMD]; return getcwd(lCurDir, sizeof(lCurDir)); } static char * getPathWithoutFinalSlash( char * aoDestination, /* make sure it is allocated, use _MAX_PATH */ char const * aSource) /* aoDestination and aSource can be the same */ { char const * lTmp ; if ( aSource ) { lTmp = strrchr(aSource, '/'); if (!lTmp) { lTmp = strrchr(aSource, '\\'); } if (lTmp) { strncpy(aoDestination, aSource, lTmp - aSource ); aoDestination[lTmp - aSource] = '\0'; } else { * aoDestination = '\0'; } } else { * aoDestination = '\0'; } return aoDestination; } static char * getLastName( char * aoDestination, /* make sure it is allocated */ char const * aSource) { /* copy the last name after '/' or '\' */ char const * lTmp ; if ( aSource ) { lTmp = strrchr(aSource, '/'); if (!lTmp) { lTmp = strrchr(aSource, '\\'); } if (lTmp) { strcpy(aoDestination, lTmp + 1); } else { strcpy(aoDestination, aSource); } } else { * aoDestination = '\0'; } return aoDestination; } static void ensureFinalSlash( char * aioString ) { if ( aioString && strlen( aioString ) ) { char * lastcar = aioString + strlen( aioString ) - 1 ; if ( strncmp( lastcar , SLASH , 1 ) ) { strcat( lastcar , SLASH ) ; } } } static void Hex2RGB( char const aHexRGB [8] , unsigned char aoResultRGB [3] ) { char lColorChannel [8] ; if ( aoResultRGB ) { if ( aHexRGB ) { strcpy(lColorChannel, aHexRGB ) ; aoResultRGB[2] = (unsigned char)strtoul(lColorChannel+5,NULL,16); lColorChannel[5] = '\0'; aoResultRGB[1] = (unsigned char)strtoul(lColorChannel+3,NULL,16); lColorChannel[3] = '\0'; aoResultRGB[0] = (unsigned char)strtoul(lColorChannel+1,NULL,16); /* printf("%d %d %d\n", aoResultRGB[0], aoResultRGB[1], aoResultRGB[2]); */ } else { aoResultRGB[0]=0; aoResultRGB[1]=0; aoResultRGB[2]=0; } } } static void RGB2Hex( unsigned char const aRGB [3] , char aoResultHexRGB [8] ) { if ( aoResultHexRGB ) { if ( aRGB ) { #if (defined(__cplusplus ) && __cplusplus >= 201103L) || (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || defined(__clang__) sprintf(aoResultHexRGB, "#%02hhx%02hhx%02hhx", aRGB[0], aRGB[1], aRGB[2]); #else sprintf(aoResultHexRGB, "#%02hx%02hx%02hx", aRGB[0], aRGB[1], aRGB[2]); #endif /*printf("aoResultHexRGB %s\n", aoResultHexRGB);*/ } else { aoResultHexRGB[0]=0; aoResultHexRGB[1]=0; aoResultHexRGB[2]=0; } } } static void replaceSubStr( char const * aSource , char const * aOldSubStr , char const * aNewSubStr , char * aoDestination ) { char const * pOccurence ; char const * p ; char const * lNewSubStr = "" ; size_t lOldSubLen = strlen( aOldSubStr ) ; if ( ! aSource ) { * aoDestination = '\0' ; return ; } if ( ! aOldSubStr ) { strcpy( aoDestination , aSource ) ; return ; } if ( aNewSubStr ) { lNewSubStr = aNewSubStr ; } p = aSource ; * aoDestination = '\0' ; while ( ( pOccurence = strstr( p , aOldSubStr ) ) != NULL ) { strncat( aoDestination , p , pOccurence - p ) ; strcat( aoDestination , lNewSubStr ) ; p = pOccurence + lOldSubLen ; } strcat( aoDestination , p ) ; } static int filenameValid( char const * aFileNameWithoutPath ) { if ( ! aFileNameWithoutPath || ! strlen(aFileNameWithoutPath) || strpbrk(aFileNameWithoutPath , "\\/:*?\"<>|") ) { return 0 ; } return 1 ; } #ifndef _WIN32 static int fileExists( char const * aFilePathAndName ) { FILE * lIn ; if ( ! aFilePathAndName || ! strlen(aFilePathAndName) ) { return 0 ; } lIn = fopen( aFilePathAndName , "r" ) ; if ( ! lIn ) { return 0 ; } fclose( lIn ) ; return 1 ; } #elif defined(TINYFD_NOLIB) static int fileExists( char const * aFilePathAndName ) { FILE * lIn ; if ( ! aFilePathAndName || ! strlen(aFilePathAndName) ) { return 0 ; } if ( tinyfd_winUtf8 ) return 1; /* we cannot test */ lIn = fopen( aFilePathAndName , "r" ) ; if ( ! lIn ) { return 0 ; } fclose( lIn ) ; return 1 ; } #endif static void wipefile(char const * aFilename) { int i; struct stat st; FILE * lIn; if (stat(aFilename, &st) == 0) { if ((lIn = fopen(aFilename, "w"))) { for (i = 0; i < st.st_size; i++) { fputc('A', lIn); } } fclose(lIn); } } #ifdef _WIN32 /* windows only (not for wchar_t): you can set char to 1:utf-8(default) or 0:MBCS */ void tinyfd_setWinUtf8(int aIsUtf8) /* made to be used from C# to modify the global variable tinyfd_winUtf8 */ { tinyfd_winUtf8 = aIsUtf8; } static int replaceChr( char * aString , char aOldChr , char aNewChr ) { char * p ; int lRes = 0 ; if ( ! aString ) { return 0 ; } if ( aOldChr == aNewChr ) { return 0 ; } p = aString ; while ( (p = strchr( p , aOldChr )) ) { * p = aNewChr ; p ++ ; lRes = 1 ; } return lRes ; } #if !defined(WC_ERR_INVALID_CHARS) /* undefined prior to Vista, so not yet in MINGW header file */ #define WC_ERR_INVALID_CHARS 0x00000080 #endif static int sizeUtf16From8(char const * aUtf8string) { return MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, aUtf8string, -1, NULL, 0); } static int sizeUtf16FromMbcs(char const * aMbcsString) { return MultiByteToWideChar(CP_ACP, MB_ERR_INVALID_CHARS, aMbcsString, -1, NULL, 0); } static int sizeUtf8(wchar_t const * aUtf16string) { return WideCharToMultiByte(CP_UTF8, WC_ERR_INVALID_CHARS, aUtf16string, -1, NULL, 0, NULL, NULL); } static int sizeMbcs(wchar_t const * aMbcsString) { int lRes = WideCharToMultiByte(CP_ACP, 0, aMbcsString, -1, NULL, 0, NULL, NULL); /* DWORD licic = GetLastError(); */ return lRes; } wchar_t * tinyfd_utf8to16(char const * aUtf8string) { static wchar_t * lUtf16string = NULL; int lSize; free(lUtf16string); if (!aUtf8string) {lUtf16string = NULL; return NULL;} lSize = sizeUtf16From8(aUtf8string); lUtf16string = (wchar_t *)malloc(lSize * sizeof(wchar_t)); lSize = MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, aUtf8string, -1, lUtf16string, lSize); if (lSize == 0) { free(lUtf16string); lUtf16string = NULL; } return lUtf16string; } static char * utf16toMbcs(wchar_t const * aUtf16string) { static char * lMbcsString = NULL; int lSize; free(lMbcsString); if (!aUtf16string) { lMbcsString = NULL; return NULL; } lSize = sizeMbcs(aUtf16string); lMbcsString = (char *)malloc(lSize); lSize = WideCharToMultiByte(CP_ACP, 0, aUtf16string, -1, lMbcsString, lSize, NULL, NULL); if (lSize == 0) { free(lMbcsString); lMbcsString = NULL; } return lMbcsString; } char * tinyfd_utf8toMbcs(char const * aUtf8string) { wchar_t const * lUtf16string; lUtf16string = tinyfd_utf8to16(aUtf8string); return utf16toMbcs(lUtf16string); } static wchar_t * mbcsTo16(char const * aMbcsString) { static wchar_t * lMbcsString = NULL; int lSize; free(lMbcsString); if (!aMbcsString) { lMbcsString = NULL; return NULL; } lSize = sizeUtf16FromMbcs(aMbcsString); lMbcsString = (wchar_t *)malloc(lSize * sizeof(wchar_t)); lSize = MultiByteToWideChar(CP_ACP, 0, aMbcsString, -1, lMbcsString, lSize); if (lSize == 0) { free(lMbcsString); lMbcsString = NULL; } return lMbcsString; } char * tinyfd_utf16to8(wchar_t const * aUtf16string) { static char * lUtf8string = NULL; int lSize; free(lUtf8string); if (!aUtf16string) { lUtf8string = NULL; return NULL; } lSize = sizeUtf8(aUtf16string); lUtf8string = (char *)malloc(lSize); lSize = WideCharToMultiByte(CP_UTF8, WC_ERR_INVALID_CHARS, aUtf16string, -1, lUtf8string, lSize, NULL, NULL); if (lSize == 0) { free(lUtf8string); lUtf8string = NULL; } return lUtf8string; } char * mbcsTo8(char const * aMbcsString) { wchar_t const * lUtf16string; lUtf16string = mbcsTo16(aMbcsString); return tinyfd_utf16to8(lUtf16string); } #ifdef TINYFD_NOLIB static int dirExists(char const * aDirPath) { struct stat lInfo; if (!aDirPath || !strlen(aDirPath)) return 0; if (stat(aDirPath, &lInfo) != 0) return 0; else if ( tinyfd_winUtf8 ) return 1; /* we cannot test */ else if (lInfo.st_mode & S_IFDIR) return 1; else return 0; } void tinyfd_beep(void) { printf("\a"); } #else /* ndef TINYFD_NOLIB */ void tinyfd_beep(void) { Beep(440,300); } static void wipefileW(wchar_t const * aFilename) { int i; struct _stat st; FILE * lIn; if (_wstat(aFilename, &st) == 0) { if ((lIn = _wfopen(aFilename, L"w"))) { for (i = 0; i < st.st_size; i++) { fputc('A', lIn); } } fclose(lIn); } } static wchar_t * getPathWithoutFinalSlashW( wchar_t * aoDestination, /* make sure it is allocated, use _MAX_PATH */ wchar_t const * aSource) /* aoDestination and aSource can be the same */ { wchar_t const * lTmp; if (aSource) { lTmp = wcsrchr(aSource, L'/'); if (!lTmp) { lTmp = wcsrchr(aSource, L'\\'); } if (lTmp) { wcsncpy(aoDestination, aSource, lTmp - aSource); aoDestination[lTmp - aSource] = L'\0'; } else { *aoDestination = L'\0'; } } else { *aoDestination = L'\0'; } return aoDestination; } static wchar_t * getLastNameW( wchar_t * aoDestination, /* make sure it is allocated */ wchar_t const * aSource) { /* copy the last name after '/' or '\' */ wchar_t const * lTmp; if (aSource) { lTmp = wcsrchr(aSource, L'/'); if (!lTmp) { lTmp = wcsrchr(aSource, L'\\'); } if (lTmp) { wcscpy(aoDestination, lTmp + 1); } else { wcscpy(aoDestination, aSource); } } else { *aoDestination = L'\0'; } return aoDestination; } static void Hex2RGBW(wchar_t const aHexRGB[8], unsigned char aoResultRGB[3]) { wchar_t lColorChannel[8]; if (aoResultRGB) { if (aHexRGB) { wcscpy(lColorChannel, aHexRGB); aoResultRGB[2] = (unsigned char)wcstoul(lColorChannel + 5, NULL, 16); lColorChannel[5] = '\0'; aoResultRGB[1] = (unsigned char)wcstoul(lColorChannel + 3, NULL, 16); lColorChannel[3] = '\0'; aoResultRGB[0] = (unsigned char)wcstoul(lColorChannel + 1, NULL, 16); /* printf("%d %d %d\n", aoResultRGB[0], aoResultRGB[1], aoResultRGB[2]); */ } else { aoResultRGB[0] = 0; aoResultRGB[1] = 0; aoResultRGB[2] = 0; } } } static void RGB2HexW( unsigned char const aRGB[3], wchar_t aoResultHexRGB[8]) { if (aoResultHexRGB) { if (aRGB) { /* wprintf(L"aoResultHexRGB %s\n", aoResultHexRGB); */ swprintf(aoResultHexRGB, #if !defined(__BORLANDC__) && !defined(__TINYC__) && !(defined(__MINGW32__) && !defined(__MINGW64_VERSION_MAJOR)) 8, #endif #if (defined(__cplusplus ) && __cplusplus >= 201103L) || (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || defined(__clang__) L"#%02hhx%02hhx%02hhx", aRGB[0], aRGB[1], aRGB[2]); #else L"#%02hx%02hx%02hx", aRGB[0], aRGB[1], aRGB[2]); #endif } else { aoResultHexRGB[0] = 0; aoResultHexRGB[1] = 0; aoResultHexRGB[2] = 0; } } } static int dirExists(char const * aDirPath) { struct _stat lInfo; wchar_t * lTmpWChar; int lStatRet; int lDirLen; if (!aDirPath) return 0; lDirLen = strlen(aDirPath); if (!lDirLen) return 1; if ( (lDirLen == 2) && (aDirPath[1] == ':') ) return 1; if (tinyfd_winUtf8) { lTmpWChar = tinyfd_utf8to16(aDirPath); lStatRet = _wstat(lTmpWChar, &lInfo); if (lStatRet != 0) return 0; else if (lInfo.st_mode & S_IFDIR) return 1; else return 0; } else if (_stat(aDirPath, &lInfo) != 0) return 0; else if (lInfo.st_mode & S_IFDIR) return 1; else return 0; } static int fileExists(char const * aFilePathAndName) { struct _stat lInfo; wchar_t * lTmpWChar; int lStatRet; FILE * lIn; if (!aFilePathAndName || !strlen(aFilePathAndName)) { return 0; } if (tinyfd_winUtf8) { lTmpWChar = tinyfd_utf8to16(aFilePathAndName); lStatRet = _wstat(lTmpWChar, &lInfo); if (lStatRet != 0) return 0; else if (lInfo.st_mode & _S_IFREG) return 1; else return 0; } else { lIn = fopen(aFilePathAndName, "r"); if (!lIn) { return 0; } fclose(lIn); return 1; } } static int replaceWchar(wchar_t * aString, wchar_t aOldChr, wchar_t aNewChr) { wchar_t * p; int lRes = 0; if (!aString) { return 0; } if (aOldChr == aNewChr) { return 0; } p = aString; while ((p = wcsrchr(p, aOldChr))) { *p = aNewChr; #ifdef TINYFD_NOCCSUNICODE p++; #endif p++; lRes = 1; } return lRes; } #endif /* TINYFD_NOLIB */ #endif /* _WIN32 */ /* source and destination can be the same or ovelap*/ static char * ensureFilesExist(char * aDestination, char const * aSourcePathsAndNames) { char * lDestination = aDestination; char const * p; char const * p2; size_t lLen; if (!aSourcePathsAndNames) { return NULL; } lLen = strlen(aSourcePathsAndNames); if (!lLen) { return NULL; } p = aSourcePathsAndNames; while ((p2 = strchr(p, '|')) != NULL) { lLen = p2 - p; memmove(lDestination, p, lLen); lDestination[lLen] = '\0'; if (fileExists(lDestination)) { lDestination += lLen; *lDestination = '|'; lDestination++; } p = p2 + 1; } if (fileExists(p)) { lLen = strlen(p); memmove(lDestination, p, lLen); lDestination[lLen] = '\0'; } else { *(lDestination - 1) = '\0'; } return aDestination; } #ifdef _WIN32 #ifndef TINYFD_NOLIB static int __stdcall EnumThreadWndProc(HWND hwnd, LPARAM lParam) { wchar_t lTitleName[MAX_PATH]; GetWindowTextW(hwnd, lTitleName, MAX_PATH); /* wprintf(L"lTitleName %ls \n", lTitleName); */ if (wcscmp(L"tinyfiledialogsTopWindow", lTitleName) == 0) { SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE | SWP_NOSIZE); return 0; } return 1; } static void hiddenConsoleW(wchar_t const * aString, wchar_t const * aDialogTitle, int aInFront) { STARTUPINFOW StartupInfo; PROCESS_INFORMATION ProcessInfo; if (!aString || !wcslen(aString) ) return; memset(&StartupInfo, 0, sizeof(StartupInfo)); StartupInfo.cb = sizeof(STARTUPINFOW); StartupInfo.dwFlags = STARTF_USESHOWWINDOW; StartupInfo.wShowWindow = SW_HIDE; if (!CreateProcessW(NULL, (LPWSTR)aString, NULL, NULL, FALSE, CREATE_NEW_CONSOLE, NULL, NULL, &StartupInfo, &ProcessInfo)) { return; /* GetLastError(); */ } WaitForInputIdle(ProcessInfo.hProcess, INFINITE); if (aInFront) { while (EnumWindows(EnumThreadWndProc, (LPARAM)NULL)) {} SetWindowTextW(GetForegroundWindow(), aDialogTitle); } WaitForSingleObject(ProcessInfo.hProcess, INFINITE); CloseHandle(ProcessInfo.hThread); CloseHandle(ProcessInfo.hProcess); } int tinyfd_messageBoxW( wchar_t const * aTitle, /* NULL or "" */ wchar_t const * aMessage, /* NULL or "" may contain \n and \t */ wchar_t const * aDialogType, /* "ok" "okcancel" "yesno" "yesnocancel" */ wchar_t const * aIconType, /* "info" "warning" "error" "question" */ int aDefaultButton) /* 0 for cancel/no , 1 for ok/yes , 2 for no in yesnocancel */ { int lBoxReturnValue; UINT aCode; if (aTitle&&!wcscmp(aTitle, L"tinyfd_query")){ strcpy(tinyfd_response, "windows_wchar"); return 1; } if (aIconType && !wcscmp(L"warning", aIconType)) { aCode = MB_ICONWARNING; } else if (aIconType && !wcscmp(L"error", aIconType)) { aCode = MB_ICONERROR; } else if (aIconType && !wcscmp(L"question", aIconType)) { aCode = MB_ICONQUESTION; } else { aCode = MB_ICONINFORMATION; } if (aDialogType && !wcscmp(L"okcancel", aDialogType)) { aCode += MB_OKCANCEL; if (!aDefaultButton) { aCode += MB_DEFBUTTON2; } } else if (aDialogType && !wcscmp(L"yesno", aDialogType)) { aCode += MB_YESNO; if (!aDefaultButton) { aCode += MB_DEFBUTTON2; } } else { aCode += MB_OK; } aCode += MB_TOPMOST; lBoxReturnValue = MessageBoxW(GetForegroundWindow(), aMessage, aTitle, aCode); if (((aDialogType && wcscmp(L"okcancel", aDialogType) && wcscmp(L"yesno", aDialogType))) || (lBoxReturnValue == IDOK) || (lBoxReturnValue == IDYES)) { return 1; } else { return 0; } } static int messageBoxWinGui8( char const * aTitle, /* NULL or "" */ char const * aMessage, /* NULL or "" may contain \n and \t */ char const * aDialogType, /* "ok" "okcancel" "yesno" "yesnocancel" */ char const * aIconType, /* "info" "warning" "error" "question" */ int aDefaultButton) /* 0 for cancel/no , 1 for ok/yes , 2 for no in yesnocancel */ { int lIntRetVal; wchar_t lTitle [128] = L""; wchar_t * lMessage = NULL; wchar_t lDialogType [16] = L""; wchar_t lIconType [16] = L""; wchar_t * lTmpWChar; if (aTitle) { lTmpWChar = tinyfd_utf8to16(aTitle); wcscpy(lTitle, lTmpWChar); } if (aMessage) { lTmpWChar = tinyfd_utf8to16(aMessage); lMessage = malloc((wcslen(lTmpWChar) + 1)* sizeof(wchar_t)); wcscpy(lMessage, lTmpWChar); } if (aDialogType) { lTmpWChar = tinyfd_utf8to16(aDialogType); wcscpy(lDialogType, lTmpWChar); } if (aIconType) { lTmpWChar = tinyfd_utf8to16(aIconType); wcscpy(lIconType, lTmpWChar); } lIntRetVal = tinyfd_messageBoxW(lTitle, lMessage,lDialogType, lIconType, aDefaultButton ); free(lMessage); return lIntRetVal ; } /* return has only meaning for tinyfd_query */ int tinyfd_notifyPopupW( wchar_t const * aTitle, /* NULL or L"" */ wchar_t const * aMessage, /* NULL or L"" may contain \n \t */ wchar_t const * aIconType) /* L"info" L"warning" L"error" */ { wchar_t * lDialogString; size_t lTitleLen; size_t lMessageLen; size_t lDialogStringLen; if (aTitle&&!wcscmp(aTitle, L"tinyfd_query")){ strcpy(tinyfd_response, "windows_wchar"); return 1; } lTitleLen = aTitle ? wcslen(aTitle) : 0; lMessageLen = aMessage ? wcslen(aMessage) : 0; lDialogStringLen = 3 * MAX_PATH_OR_CMD + lTitleLen + lMessageLen; lDialogString = (wchar_t *)malloc(2 * lDialogStringLen); wcscpy(lDialogString, L"powershell.exe -command \"\ function Show-BalloonTip {\ [cmdletbinding()] \ param( \ [string]$Title = ' ', \ [string]$Message = ' ', \ [ValidateSet('info', 'warning', 'error')] \ [string]$IconType = 'info');\ [system.Reflection.Assembly]::LoadWithPartialName('System.Windows.Forms') | Out-Null ; \ $balloon = New-Object System.Windows.Forms.NotifyIcon ; \ $path = Get-Process -id $pid | Select-Object -ExpandProperty Path ; \ $icon = [System.Drawing.Icon]::ExtractAssociatedIcon($path) ;"); wcscat(lDialogString, L"\ $balloon.Icon = $icon ; \ $balloon.BalloonTipIcon = $IconType ; \ $balloon.BalloonTipText = $Message ; \ $balloon.BalloonTipTitle = $Title ; \ $balloon.Text = 'lalala' ; \ $balloon.Visible = $true ; \ $balloon.ShowBalloonTip(5000)};\ Show-BalloonTip"); if (aTitle && wcslen(aTitle)) { wcscat(lDialogString, L" -Title '"); wcscat(lDialogString, aTitle); wcscat(lDialogString, L"'"); } if (aMessage && wcslen(aMessage)) { wcscat(lDialogString, L" -Message '"); wcscat(lDialogString, aMessage); wcscat(lDialogString, L"'"); } if (aMessage && wcslen(aIconType)) { wcscat(lDialogString, L" -IconType '"); wcscat(lDialogString, aIconType); wcscat(lDialogString, L"'"); } wcscat(lDialogString, L"\""); /* wprintf ( L"lDialogString: %ls\n" , lDialogString ) ; */ hiddenConsoleW(lDialogString, aTitle, 0); free(lDialogString); return 1; } static int notifyWinGui( char const * aTitle, /* NULL or "" */ char const * aMessage, /* NULL or "" may NOT contain \n nor \t */ char const * aIconType) { wchar_t lTitle [128] = L""; wchar_t * lMessage = NULL; wchar_t lIconType[16] = L""; wchar_t * lTmpWChar; if (tinyfd_winUtf8) { if (aTitle) { lTmpWChar = tinyfd_utf8to16(aTitle); wcscpy(lTitle, lTmpWChar); } if (aMessage) { lTmpWChar = tinyfd_utf8to16(aMessage); lMessage = malloc((wcslen(lTmpWChar) + 1)* sizeof(wchar_t)); wcscpy(lMessage, lTmpWChar); } if (aIconType) { lTmpWChar = tinyfd_utf8to16(aIconType); wcscpy(lIconType, lTmpWChar); } } else { if (aTitle) { lTmpWChar = mbcsTo16(aTitle); wcscpy(lTitle, lTmpWChar); } if (aMessage) { lTmpWChar = mbcsTo16(aMessage); lMessage = malloc((wcslen(lTmpWChar) + 1)* sizeof(wchar_t)); wcscpy(lMessage, lTmpWChar); } if (aIconType) { lTmpWChar = mbcsTo16(aIconType); wcscpy(lIconType, lTmpWChar); } } tinyfd_notifyPopupW( lTitle, lMessage, lIconType); free(lMessage); return 1; } wchar_t * tinyfd_inputBoxW( wchar_t const * aTitle, /* NULL or L"" */ wchar_t const * aMessage, /* NULL or L"" may NOT contain \n nor \t */ wchar_t const * aDefaultInput) /* L"" , if NULL it's a passwordBox */ { static wchar_t lBuff[MAX_PATH_OR_CMD]; wchar_t * lDialogString; FILE * lIn; FILE * lFile; int lResult; size_t lTitleLen; size_t lMessageLen; size_t lDialogStringLen; if (aTitle&&!wcscmp(aTitle, L"tinyfd_query")){ strcpy(tinyfd_response, "windows_wchar"); return (wchar_t *)1; } lTitleLen = aTitle ? wcslen(aTitle) : 0 ; lMessageLen = aMessage ? wcslen(aMessage) : 0 ; lDialogStringLen = 3 * MAX_PATH_OR_CMD + lTitleLen + lMessageLen; lDialogString = (wchar_t *)malloc(2 * lDialogStringLen); if (aDefaultInput) { swprintf(lDialogString, #if !defined(__BORLANDC__) && !defined(__TINYC__) && !(defined(__MINGW32__) && !defined(__MINGW64_VERSION_MAJOR)) lDialogStringLen, #endif L"%ls\\AppData\\Local\\Temp\\tinyfd.vbs", _wgetenv(L"USERPROFILE")); } else { swprintf(lDialogString, #if !defined(__BORLANDC__) && !defined(__TINYC__) && !(defined(__MINGW32__) && !defined(__MINGW64_VERSION_MAJOR)) lDialogStringLen, #endif L"%ls\\AppData\\Local\\Temp\\tinyfd.hta", _wgetenv(L"USERPROFILE")); } lIn = _wfopen(lDialogString, L"w"); if (!lIn) { free(lDialogString); return NULL; } if ( aDefaultInput ) { wcscpy(lDialogString, L"Dim result:result=InputBox(\""); if (aMessage && wcslen(aMessage)) { wcscpy(lBuff, aMessage); replaceWchar(lBuff, L'\n', L' '); wcscat(lDialogString, lBuff); } wcscat(lDialogString, L"\",\"tinyfiledialogsTopWindow\",\""); if (aDefaultInput && wcslen(aDefaultInput)) { wcscpy(lBuff, aDefaultInput); replaceWchar(lBuff, L'\n', L' '); wcscat(lDialogString, lBuff); } wcscat(lDialogString, L"\"):If IsEmpty(result) then:WScript.Echo 0"); wcscat(lDialogString, L":Else: WScript.Echo \"1\" & result : End If"); } else { wcscpy(lDialogString, L"\n\ \n\ \n\ "); wcscat(lDialogString, L"tinyfiledialogsTopWindow"); wcscat(lDialogString, L"\n\ \n\ \n\ \n\ \n\ \n\ \n\ \n\ \n\ \n\ \n\
\n"); wcscat(lDialogString, aMessage ? aMessage : L""); wcscat(lDialogString, L"\n\ \n\ \n\ \n\
\n\

\n\ \n\
\n\
\n"); wcscat(lDialogString, L"\n\ \n\ \n\ \n\
\n\
\n\
\n\ \n\ \n\ " ) ; } fputws(lDialogString, lIn); fclose(lIn); if (aDefaultInput) { swprintf(lDialogString, #if !defined(__BORLANDC__) && !defined(__TINYC__) && !(defined(__MINGW32__) && !defined(__MINGW64_VERSION_MAJOR)) lDialogStringLen, #endif L"%ls\\AppData\\Local\\Temp\\tinyfd.txt",_wgetenv(L"USERPROFILE")); #ifdef TINYFD_NOCCSUNICODE lFile = _wfopen(lDialogString, L"w"); fputc(0xFF, lFile); fputc(0xFE, lFile); #else lFile = _wfopen(lDialogString, L"wt, ccs=UNICODE"); /*or ccs=UTF-16LE*/ #endif fclose(lFile); wcscpy(lDialogString, L"cmd.exe /c cscript.exe //U //Nologo "); wcscat(lDialogString, L"\"%USERPROFILE%\\AppData\\Local\\Temp\\tinyfd.vbs\" "); wcscat(lDialogString, L">> \"%USERPROFILE%\\AppData\\Local\\Temp\\tinyfd.txt\""); } else { wcscpy(lDialogString, L"cmd.exe /c mshta.exe \"%USERPROFILE%\\AppData\\Local\\Temp\\tinyfd.hta\""); } /* wprintf ( "lDialogString: %ls\n" , lDialogString ) ; */ hiddenConsoleW(lDialogString, aTitle, 1); swprintf(lDialogString, #if !defined(__BORLANDC__) && !defined(__TINYC__) && !(defined(__MINGW32__) && !defined(__MINGW64_VERSION_MAJOR)) lDialogStringLen, #endif L"%ls\\AppData\\Local\\Temp\\tinyfd.txt", _wgetenv(L"USERPROFILE")); /* wprintf(L"lDialogString: %ls\n", lDialogString); */ #ifdef TINYFD_NOCCSUNICODE if (!(lIn = _wfopen(lDialogString, L"r"))) #else if (!(lIn = _wfopen(lDialogString, L"rt, ccs=UNICODE"))) /*or ccs=UTF-16LE*/ #endif { _wremove(lDialogString); free(lDialogString); return NULL; } memset(lBuff, 0, MAX_PATH_OR_CMD * sizeof(wchar_t) ); #ifdef TINYFD_NOCCSUNICODE fgets((char *)lBuff, 2*MAX_PATH_OR_CMD, lIn); #else fgetws(lBuff, MAX_PATH_OR_CMD, lIn); #endif fclose(lIn); wipefileW(lDialogString); _wremove(lDialogString); if (aDefaultInput) { swprintf(lDialogString, #if !defined(__BORLANDC__) && !defined(__TINYC__) && !(defined(__MINGW32__) && !defined(__MINGW64_VERSION_MAJOR)) lDialogStringLen, #endif L"%ls\\AppData\\Local\\Temp\\tinyfd.vbs", _wgetenv(L"USERPROFILE")); } else { swprintf(lDialogString, #if !defined(__BORLANDC__) && !defined(__TINYC__) && !(defined(__MINGW32__) && !defined(__MINGW64_VERSION_MAJOR)) lDialogStringLen, #endif L"%ls\\AppData\\Local\\Temp\\tinyfd.hta", _wgetenv(L"USERPROFILE")); } _wremove(lDialogString); free(lDialogString); /* wprintf( L"lBuff: %ls\n" , lBuff ) ; */ #ifdef TINYFD_NOCCSUNICODE lResult = !wcsncmp(lBuff+1, L"1", 1); #else lResult = !wcsncmp(lBuff, L"1", 1); #endif /* printf( "lResult: %d \n" , lResult ) ; */ if (!lResult) { return NULL ; } /* wprintf( "lBuff+1: %ls\n" , lBuff+1 ) ; */ #ifdef TINYFD_NOCCSUNICODE if (aDefaultInput) { lDialogStringLen = wcslen(lBuff) ; lBuff[lDialogStringLen - 1] = L'\0'; lBuff[lDialogStringLen - 2] = L'\0'; } return lBuff + 2; #else if (aDefaultInput) lBuff[wcslen(lBuff) - 1] = L'\0'; return lBuff + 1; #endif } static int inputBoxWinGui( char * aoBuff, char const * aTitle, /* NULL or "" */ char const * aMessage, /* NULL or "" may NOT contain \n nor \t */ char const * aDefaultInput) /* "" , if NULL it's a passwordBox */ { wchar_t lTitle [128] = L""; wchar_t * lMessage = NULL; wchar_t lDefaultInput[MAX_PATH_OR_CMD] = L""; wchar_t * lTmpWChar; char * lTmpChar; if (tinyfd_winUtf8) { if (aTitle) { lTmpWChar = tinyfd_utf8to16(aTitle); wcscpy(lTitle, lTmpWChar); } if (aMessage) { lTmpWChar = tinyfd_utf8to16(aMessage); lMessage = malloc((wcslen(lTmpWChar) + 1)* sizeof(wchar_t)); wcscpy(lMessage, lTmpWChar); } if (aDefaultInput) { lTmpWChar = tinyfd_utf8to16(aDefaultInput); wcscpy(lDefaultInput, lTmpWChar); } } else { if (aTitle) { lTmpWChar = mbcsTo16(aTitle); wcscpy(lTitle, lTmpWChar); } if (aMessage) { lTmpWChar = mbcsTo16(aMessage); lMessage = malloc((wcslen(lTmpWChar) + 1)* sizeof(wchar_t)); wcscpy(lMessage, lTmpWChar); } if (aDefaultInput) { lTmpWChar = mbcsTo16(aDefaultInput); wcscpy(lDefaultInput, lTmpWChar); } } lTmpWChar = tinyfd_inputBoxW( lTitle, lMessage, lDefaultInput); free(lMessage); if (!lTmpWChar) { aoBuff[0] = '\0'; return 0; } if (tinyfd_winUtf8) { lTmpChar = tinyfd_utf16to8(lTmpWChar); } else { lTmpChar = utf16toMbcs(lTmpWChar); } strcpy(aoBuff, lTmpChar); return 1; } wchar_t * tinyfd_saveFileDialogW( wchar_t const * aTitle, /* NULL or "" */ wchar_t const * aDefaultPathAndFile, /* NULL or "" */ int aNumOfFilterPatterns, /* 0 */ wchar_t const * const * aFilterPatterns, /* NULL or {"*.jpg","*.png"} */ wchar_t const * aSingleFilterDescription) /* NULL or "image files" */ { static wchar_t lBuff[MAX_PATH_OR_CMD]; wchar_t lDirname[MAX_PATH_OR_CMD]; wchar_t lDialogString[MAX_PATH_OR_CMD]; wchar_t lFilterPatterns[MAX_PATH_OR_CMD] = L""; wchar_t * p; wchar_t * lRetval; wchar_t const * ldefExt = NULL; int i; HRESULT lHResult; OPENFILENAMEW ofn = {0}; if (aTitle&&!wcscmp(aTitle, L"tinyfd_query")){ strcpy(tinyfd_response, "windows_wchar"); return (wchar_t *)1; } lHResult = CoInitializeEx(NULL, 0); getPathWithoutFinalSlashW(lDirname, aDefaultPathAndFile); getLastNameW(lBuff, aDefaultPathAndFile); if (aNumOfFilterPatterns > 0) { ldefExt = aFilterPatterns[0]; if (aSingleFilterDescription && wcslen(aSingleFilterDescription)) { wcscpy(lFilterPatterns, aSingleFilterDescription); wcscat(lFilterPatterns, L"\n"); } wcscat(lFilterPatterns, aFilterPatterns[0]); for (i = 1; i < aNumOfFilterPatterns; i++) { wcscat(lFilterPatterns, L";"); wcscat(lFilterPatterns, aFilterPatterns[i]); } wcscat(lFilterPatterns, L"\n"); if (!(aSingleFilterDescription && wcslen(aSingleFilterDescription))) { wcscpy(lDialogString, lFilterPatterns); wcscat(lFilterPatterns, lDialogString); } wcscat(lFilterPatterns, L"All Files\n*.*\n"); p = lFilterPatterns; while ((p = wcschr(p, L'\n')) != NULL) { *p = L'\0'; p++; } } ofn.lStructSize = sizeof(OPENFILENAMEW); ofn.hwndOwner = GetForegroundWindow(); ofn.hInstance = 0; ofn.lpstrFilter = wcslen(lFilterPatterns) ? lFilterPatterns : NULL; ofn.lpstrCustomFilter = NULL; ofn.nMaxCustFilter = 0; ofn.nFilterIndex = 1; ofn.lpstrFile = lBuff; ofn.nMaxFile = MAX_PATH_OR_CMD; ofn.lpstrFileTitle = NULL; ofn.nMaxFileTitle = MAX_PATH_OR_CMD/2; ofn.lpstrInitialDir = wcslen(lDirname) ? lDirname : NULL; ofn.lpstrTitle = aTitle && wcslen(aTitle) ? aTitle : NULL; ofn.Flags = OFN_OVERWRITEPROMPT | OFN_NOCHANGEDIR | OFN_PATHMUSTEXIST ; ofn.nFileOffset = 0; ofn.nFileExtension = 0; ofn.lpstrDefExt = ldefExt; ofn.lCustData = 0L; ofn.lpfnHook = NULL; ofn.lpTemplateName = NULL; if (GetSaveFileNameW(&ofn) == 0) { lRetval = NULL; } else { lRetval = lBuff; } if (lHResult == S_OK || lHResult == S_FALSE) { CoUninitialize(); } return lRetval; } static char * saveFileDialogWinGui8( char * aoBuff, char const * aTitle, /* NULL or "" */ char const * aDefaultPathAndFile, /* NULL or "" */ int aNumOfFilterPatterns, /* 0 */ char const * const * aFilterPatterns, /* NULL or {"*.jpg","*.png"} */ char const * aSingleFilterDescription) /* NULL or "image files" */ { wchar_t lTitle [128] = L""; wchar_t lDefaultPathAndFile [MAX_PATH_OR_CMD] = L""; wchar_t lSingleFilterDescription [128] = L""; wchar_t * * lFilterPatterns; wchar_t * lTmpWChar; char * lTmpChar; int i ; lFilterPatterns = (wchar_t **) malloc(aNumOfFilterPatterns*sizeof(wchar_t *)); for (i = 0; i < aNumOfFilterPatterns; i++) { lTmpWChar = tinyfd_utf8to16(aFilterPatterns[i]); lFilterPatterns[i] = (wchar_t *)malloc( (wcslen(lTmpWChar)+1) * sizeof(wchar_t *)); wcscpy(lFilterPatterns[i], lTmpWChar); } if (aTitle) { lTmpWChar = tinyfd_utf8to16(aTitle); wcscpy(lTitle, lTmpWChar); } if (aDefaultPathAndFile) { lTmpWChar = tinyfd_utf8to16(aDefaultPathAndFile); wcscpy(lDefaultPathAndFile, lTmpWChar); } if (aSingleFilterDescription) { lTmpWChar = tinyfd_utf8to16(aSingleFilterDescription); wcscpy(lSingleFilterDescription, lTmpWChar); } lTmpWChar = tinyfd_saveFileDialogW( lTitle, lDefaultPathAndFile, aNumOfFilterPatterns, (wchar_t const** ) /*stupid cast for gcc*/ lFilterPatterns, lSingleFilterDescription); for (i = 0; i < aNumOfFilterPatterns; i++) { free(lFilterPatterns[i]); } free(lFilterPatterns); if (!lTmpWChar) { return NULL; } lTmpChar = tinyfd_utf16to8(lTmpWChar); strcpy(aoBuff, lTmpChar); (void) tinyfd_utf16to8(NULL); return aoBuff; } wchar_t * tinyfd_openFileDialogW( wchar_t const * aTitle, /* NULL or "" */ wchar_t const * aDefaultPathAndFile, /* NULL or "" */ int aNumOfFilterPatterns, /* 0 */ wchar_t const * const * aFilterPatterns, /* NULL or {"*.jpg","*.png"} */ wchar_t const * aSingleFilterDescription, /* NULL or "image files" */ int aAllowMultipleSelects) /* 0 or 1 ; -1 to free allocated memory and return */ { size_t lLengths[MAX_MULTIPLE_FILES]; wchar_t lDirname[MAX_PATH_OR_CMD]; wchar_t lFilterPatterns[MAX_PATH_OR_CMD] = L""; wchar_t lDialogString[MAX_PATH_OR_CMD]; wchar_t * lPointers[MAX_MULTIPLE_FILES+1]; wchar_t * p; int i, j; size_t lBuffLen, lFullBuffLen; HRESULT lHResult; OPENFILENAMEW ofn = { 0 }; static wchar_t * lBuff = NULL; free(lBuff); lBuff = NULL; if (aAllowMultipleSelects < 0) return (wchar_t *)0; if (aTitle&&!wcscmp(aTitle, L"tinyfd_query")){ strcpy(tinyfd_response, "windows_wchar"); return (wchar_t *)1; } if (aAllowMultipleSelects) { lFullBuffLen = MAX_MULTIPLE_FILES * MAX_PATH_OR_CMD + 1; lBuff = (wchar_t*)(malloc(lFullBuffLen * sizeof(wchar_t))); if (!lBuff) { lFullBuffLen = LOW_MULTIPLE_FILES * MAX_PATH_OR_CMD + 1; lBuff = (wchar_t*)( malloc( lFullBuffLen * sizeof(wchar_t))); } } else { lFullBuffLen = MAX_PATH_OR_CMD + 1; lBuff = (wchar_t*)(malloc(lFullBuffLen * sizeof(wchar_t))); } if (!lBuff) return NULL; lHResult = CoInitializeEx(NULL, 0); getPathWithoutFinalSlashW(lDirname, aDefaultPathAndFile); getLastNameW(lBuff, aDefaultPathAndFile); if (aNumOfFilterPatterns > 0) { if (aSingleFilterDescription && wcslen(aSingleFilterDescription)) { wcscpy(lFilterPatterns, aSingleFilterDescription); wcscat(lFilterPatterns, L"\n"); } wcscat(lFilterPatterns, aFilterPatterns[0]); for (i = 1; i < aNumOfFilterPatterns; i++) { wcscat(lFilterPatterns, L";"); wcscat(lFilterPatterns, aFilterPatterns[i]); } wcscat(lFilterPatterns, L"\n"); if (!(aSingleFilterDescription && wcslen(aSingleFilterDescription))) { wcscpy(lDialogString, lFilterPatterns); wcscat(lFilterPatterns, lDialogString); } wcscat(lFilterPatterns, L"All Files\n*.*\n"); p = lFilterPatterns; while ((p = wcschr(p, L'\n')) != NULL) { *p = L'\0'; p++; } } ofn.lStructSize = sizeof(OPENFILENAME); ofn.hwndOwner = GetForegroundWindow(); ofn.hInstance = 0; ofn.lpstrFilter = wcslen(lFilterPatterns) ? lFilterPatterns : NULL; ofn.lpstrCustomFilter = NULL; ofn.nMaxCustFilter = 0; ofn.nFilterIndex = 1; ofn.lpstrFile = lBuff; ofn.nMaxFile = lFullBuffLen; ofn.lpstrFileTitle = NULL; ofn.nMaxFileTitle = MAX_PATH_OR_CMD / 2; ofn.lpstrInitialDir = wcslen(lDirname) ? lDirname : NULL; ofn.lpstrTitle = aTitle && wcslen(aTitle) ? aTitle : NULL; ofn.Flags = OFN_EXPLORER | OFN_NOCHANGEDIR | OFN_PATHMUSTEXIST | OFN_FILEMUSTEXIST; ofn.nFileOffset = 0; ofn.nFileExtension = 0; ofn.lpstrDefExt = NULL; ofn.lCustData = 0L; ofn.lpfnHook = NULL; ofn.lpTemplateName = NULL; if (aAllowMultipleSelects) { ofn.Flags |= OFN_ALLOWMULTISELECT; } if (GetOpenFileNameW(&ofn) == 0) { free(lBuff); lBuff = NULL; } else { lBuffLen = wcslen(lBuff); lPointers[0] = lBuff + lBuffLen + 1; if (aAllowMultipleSelects && (lPointers[0][0] != L'\0')) { i = 0; do { lLengths[i] = wcslen(lPointers[i]); lPointers[i + 1] = lPointers[i] + lLengths[i] + 1; i++; } while (lPointers[i][0] != L'\0' && i < MAX_MULTIPLE_FILES ); if (i > MAX_MULTIPLE_FILES) { free(lBuff); lBuff = NULL; } else { i--; p = lBuff + lFullBuffLen - 1; *p = L'\0'; for (j = i; j >= 0; j--) { p -= lLengths[j]; memmove(p, lPointers[j], lLengths[j] * sizeof(wchar_t)); p--; *p = L'\\'; p -= lBuffLen; memmove(p, lBuff, lBuffLen*sizeof(wchar_t)); p--; *p = L'|'; } p++; wcscpy(lBuff, p); lBuffLen = wcslen(lBuff); } } if (lBuff) lBuff = (wchar_t*)(realloc(lBuff, (lBuffLen + 1) * sizeof(wchar_t))); } if (lHResult == S_OK || lHResult == S_FALSE) { CoUninitialize(); } return lBuff; } static char * openFileDialogWinGui8( char const * aTitle, /* NULL or "" */ char const * aDefaultPathAndFile, /* NULL or "" */ int aNumOfFilterPatterns, /* 0 */ char const * const * aFilterPatterns, /* NULL or {"*.jpg","*.png"} */ char const * aSingleFilterDescription, /* NULL or "image files" */ int aAllowMultipleSelects) /* 0 or 1 */ { wchar_t lTitle[128] = L""; wchar_t lDefaultPathAndFile[MAX_PATH_OR_CMD] = L""; wchar_t lSingleFilterDescription[128] = L""; wchar_t * * lFilterPatterns; wchar_t * lTmpWChar; char * lTmpChar; int i; lFilterPatterns = (wchar_t * *) malloc(aNumOfFilterPatterns*sizeof(wchar_t *)); for (i = 0; i < aNumOfFilterPatterns; i++) { lTmpWChar = tinyfd_utf8to16(aFilterPatterns[i]); lFilterPatterns[i] = (wchar_t *)malloc((wcslen(lTmpWChar)+1)*sizeof(wchar_t *)); wcscpy(lFilterPatterns[i], lTmpWChar); } if (aTitle) { lTmpWChar = tinyfd_utf8to16(aTitle); wcscpy(lTitle, lTmpWChar); } if (aDefaultPathAndFile) { lTmpWChar = tinyfd_utf8to16(aDefaultPathAndFile); wcscpy(lDefaultPathAndFile, lTmpWChar); } if (aSingleFilterDescription) { lTmpWChar = tinyfd_utf8to16(aSingleFilterDescription); wcscpy(lSingleFilterDescription, lTmpWChar); } lTmpWChar = tinyfd_openFileDialogW( lTitle, lDefaultPathAndFile, aNumOfFilterPatterns, (wchar_t const**) /*stupid cast for gcc*/ lFilterPatterns, lSingleFilterDescription, aAllowMultipleSelects); for (i = 0; i < aNumOfFilterPatterns; i++) { free(lFilterPatterns[i]); } free(lFilterPatterns); if (!lTmpWChar) return NULL; lTmpChar = tinyfd_utf16to8(lTmpWChar); (void) tinyfd_openFileDialogW(NULL,NULL,0,NULL,NULL,-1); return lTmpChar; } BOOL CALLBACK BrowseCallbackProc_enum(HWND hWndChild, LPARAM lParam) { char buf[255]; GetClassNameA(hWndChild, buf, sizeof(buf)); if (strcmp(buf, "SysTreeView32") == 0) { HTREEITEM hNode = TreeView_GetSelection(hWndChild); TreeView_EnsureVisible(hWndChild, hNode); return FALSE; } return TRUE; } BOOL CALLBACK BrowseCallbackProcW_enum(HWND hWndChild, LPARAM lParam) { wchar_t buf[255]; GetClassNameW(hWndChild, buf, sizeof(buf)); if (wcscmp(buf, L"SysTreeView32") == 0) { HTREEITEM hNode = TreeView_GetSelection(hWndChild); TreeView_EnsureVisible(hWndChild, hNode); return FALSE; } return TRUE; } static int __stdcall BrowseCallbackProc(HWND hwnd, UINT uMsg, LPARAM lp, LPARAM pData) { switch (uMsg) { case BFFM_INITIALIZED: SendMessage(hwnd, BFFM_SETSELECTION, TRUE, pData); break; case BFFM_SELCHANGED: EnumChildWindows(hwnd, BrowseCallbackProc_enum, 0); } return 0; } static int __stdcall BrowseCallbackProcW(HWND hwnd, UINT uMsg, LPARAM lp, LPARAM pData) { switch (uMsg) { case BFFM_INITIALIZED: SendMessage(hwnd, BFFM_SETSELECTIONW, TRUE, (LPARAM)pData); break; case BFFM_SELCHANGED: EnumChildWindows(hwnd, BrowseCallbackProcW_enum, 0); } return 0; } wchar_t * tinyfd_selectFolderDialogW( wchar_t const * aTitle, /* NULL or "" */ wchar_t const * aDefaultPath) /* NULL or "" */ { static wchar_t lBuff[MAX_PATH_OR_CMD]; wchar_t * lRetval; BROWSEINFOW bInfo; LPITEMIDLIST lpItem; HRESULT lHResult; if (aTitle&&!wcscmp(aTitle, L"tinyfd_query")){ strcpy(tinyfd_response, "windows_wchar"); return (wchar_t *)1; } lHResult = CoInitializeEx(NULL, COINIT_APARTMENTTHREADED); bInfo.hwndOwner = GetForegroundWindow(); bInfo.pidlRoot = NULL; bInfo.pszDisplayName = lBuff; bInfo.lpszTitle = aTitle && wcslen(aTitle) ? aTitle : NULL; if (lHResult == S_OK || lHResult == S_FALSE) { bInfo.ulFlags = BIF_USENEWUI; } bInfo.lpfn = BrowseCallbackProcW; bInfo.lParam = (LPARAM)aDefaultPath; bInfo.iImage = -1; lpItem = SHBrowseForFolderW(&bInfo); if (!lpItem) { lRetval = NULL; } else { SHGetPathFromIDListW(lpItem, lBuff); lRetval = lBuff ; } if (lHResult == S_OK || lHResult == S_FALSE) { CoUninitialize(); } return lRetval; } static char * selectFolderDialogWinGui8( char * aoBuff , char const * aTitle , /* NULL or "" */ char const * aDefaultPath ) /* NULL or "" */ { wchar_t lTitle [128] = L""; wchar_t lDefaultPath[MAX_PATH_OR_CMD] = L""; wchar_t * lTmpWChar; char * lTmpChar; if (aTitle) { lTmpWChar = tinyfd_utf8to16(aTitle); wcscpy(lTitle, lTmpWChar); } if (aDefaultPath) { lTmpWChar = tinyfd_utf8to16(aDefaultPath); wcscpy(lDefaultPath, lTmpWChar); } lTmpWChar = tinyfd_selectFolderDialogW( lTitle, lDefaultPath); if (!lTmpWChar) { return NULL; } lTmpChar = tinyfd_utf16to8(lTmpWChar); strcpy(aoBuff, lTmpChar); return aoBuff; } wchar_t * tinyfd_colorChooserW( wchar_t const * aTitle, /* NULL or "" */ wchar_t const * aDefaultHexRGB, /* NULL or "#FF0000"*/ unsigned char const aDefaultRGB[3], /* { 0 , 255 , 255 } */ unsigned char aoResultRGB[3]) /* { 0 , 0 , 0 } */ { static wchar_t lResultHexRGB[8]; CHOOSECOLORW cc; COLORREF crCustColors[16]; unsigned char lDefaultRGB[3]; int lRet; HRESULT lHResult; if (aTitle&&!wcscmp(aTitle, L"tinyfd_query")){ strcpy(tinyfd_response, "windows_wchar"); return (wchar_t *)1; } lHResult = CoInitializeEx(NULL, 0); if ( aDefaultHexRGB ) { Hex2RGBW(aDefaultHexRGB, lDefaultRGB); } else { lDefaultRGB[0] = aDefaultRGB[0]; lDefaultRGB[1] = aDefaultRGB[1]; lDefaultRGB[2] = aDefaultRGB[2]; } /* we can't use aTitle */ cc.lStructSize = sizeof(CHOOSECOLOR); cc.hwndOwner = GetForegroundWindow(); cc.hInstance = NULL; cc.rgbResult = RGB(lDefaultRGB[0], lDefaultRGB[1], lDefaultRGB[2]); cc.lpCustColors = crCustColors; cc.Flags = CC_RGBINIT | CC_FULLOPEN | CC_ANYCOLOR ; cc.lCustData = 0; cc.lpfnHook = NULL; cc.lpTemplateName = NULL; lRet = ChooseColorW(&cc); if (!lRet) { return NULL; } aoResultRGB[0] = GetRValue(cc.rgbResult); aoResultRGB[1] = GetGValue(cc.rgbResult); aoResultRGB[2] = GetBValue(cc.rgbResult); RGB2HexW(aoResultRGB, lResultHexRGB); if (lHResult == S_OK || lHResult == S_FALSE) { CoUninitialize(); } return lResultHexRGB; } static char * colorChooserWinGui8( char const * aTitle, /* NULL or "" */ char const * aDefaultHexRGB, /* NULL or "#FF0000"*/ unsigned char const aDefaultRGB[3], /* { 0 , 255 , 255 } */ unsigned char aoResultRGB[3]) /* { 0 , 0 , 0 } */ { static char lResultHexRGB[8]; wchar_t lTitle[128]; wchar_t lDefaultHexRGB[16]; wchar_t * lTmpWChar; char * lTmpChar; if (aTitle) { lTmpWChar = tinyfd_utf8to16(aTitle); wcscpy(lTitle, lTmpWChar); } if (aDefaultHexRGB) { lTmpWChar = tinyfd_utf8to16(aDefaultHexRGB); wcscpy(lDefaultHexRGB, lTmpWChar); } lTmpWChar = tinyfd_colorChooserW( lTitle, lDefaultHexRGB, aDefaultRGB, aoResultRGB ); if (!lTmpWChar) { return NULL; } lTmpChar = tinyfd_utf16to8(lTmpWChar); strcpy(lResultHexRGB, lTmpChar); return lResultHexRGB; } static int messageBoxWinGuiA( char const * aTitle , /* NULL or "" */ char const * aMessage , /* NULL or "" may contain \n and \t */ char const * aDialogType , /* "ok" "okcancel" "yesno" "yesnocancel" */ char const * aIconType , /* "info" "warning" "error" "question" */ int aDefaultButton ) /* 0 for cancel/no , 1 for ok/yes , 2 for no in yesnocancel */ { int lBoxReturnValue; UINT aCode ; if ( aIconType && ! strcmp( "warning" , aIconType ) ) { aCode = MB_ICONWARNING ; } else if ( aIconType && ! strcmp("error", aIconType)) { aCode = MB_ICONERROR ; } else if ( aIconType && ! strcmp("question", aIconType)) { aCode = MB_ICONQUESTION ; } else { aCode = MB_ICONINFORMATION ; } if ( aDialogType && ! strcmp( "okcancel" , aDialogType ) ) { aCode += MB_OKCANCEL ; if ( ! aDefaultButton ) { aCode += MB_DEFBUTTON2 ; } } else if ( aDialogType && ! strcmp( "yesno" , aDialogType ) ) { aCode += MB_YESNO ; if ( ! aDefaultButton ) { aCode += MB_DEFBUTTON2 ; } } else if (aDialogType && !strcmp("yesnocancel", aDialogType)) { aCode += MB_YESNOCANCEL; if (!aDefaultButton) { aCode += MB_DEFBUTTON3; } else if (aDefaultButton == 2) { aCode += MB_DEFBUTTON2; } } else { aCode += MB_OK ; } aCode += MB_TOPMOST; lBoxReturnValue = MessageBoxA(GetForegroundWindow(), aMessage, aTitle, aCode); if (((aDialogType && !strcmp("yesnocancel", aDialogType)) && (lBoxReturnValue == IDNO))) { return 2; } if ( ( ( aDialogType && strcmp("yesnocancel", aDialogType) && strcmp("okcancel", aDialogType) && strcmp("yesno", aDialogType))) || (lBoxReturnValue == IDOK) || (lBoxReturnValue == IDYES) ) { return 1 ; } else { return 0 ; } } static char * saveFileDialogWinGuiA( char * aoBuff , char const * aTitle , /* NULL or "" */ char const * aDefaultPathAndFile , /* NULL or "" */ int aNumOfFilterPatterns , /* 0 */ char const * const * aFilterPatterns , /* NULL or {"*.jpg","*.png"} */ char const * aSingleFilterDescription ) /* NULL or "image files" */ { char lDirname [MAX_PATH_OR_CMD] ; char lDialogString[MAX_PATH_OR_CMD]; char lFilterPatterns[MAX_PATH_OR_CMD] = ""; int i ; char * p; char * lRetval; HRESULT lHResult; char const * ldefExt = NULL; OPENFILENAMEA ofn = { 0 }; lHResult = CoInitializeEx(NULL,0); getPathWithoutFinalSlash(lDirname, aDefaultPathAndFile); getLastName(aoBuff, aDefaultPathAndFile); if (aNumOfFilterPatterns > 0) { ldefExt = aFilterPatterns[0]; if ( aSingleFilterDescription && strlen(aSingleFilterDescription) ) { strcpy(lFilterPatterns, aSingleFilterDescription); strcat(lFilterPatterns, "\n"); } strcat(lFilterPatterns, aFilterPatterns[0]); for (i = 1; i < aNumOfFilterPatterns; i++) { strcat(lFilterPatterns, ";"); strcat(lFilterPatterns, aFilterPatterns[i]); } strcat(lFilterPatterns, "\n"); if ( ! (aSingleFilterDescription && strlen(aSingleFilterDescription) ) ) { strcpy(lDialogString, lFilterPatterns); strcat(lFilterPatterns, lDialogString); } strcat(lFilterPatterns, "All Files\n*.*\n"); p = lFilterPatterns; while ((p = strchr(p, '\n')) != NULL) { *p = '\0'; p ++ ; } } ofn.lStructSize = sizeof(OPENFILENAME) ; ofn.hwndOwner = GetForegroundWindow(); ofn.hInstance = 0 ; ofn.lpstrFilter = strlen(lFilterPatterns) ? lFilterPatterns : NULL; ofn.lpstrCustomFilter = NULL ; ofn.nMaxCustFilter = 0 ; ofn.nFilterIndex = 1 ; ofn.lpstrFile = aoBuff; ofn.nMaxFile = MAX_PATH_OR_CMD ; ofn.lpstrFileTitle = NULL ; ofn.nMaxFileTitle = MAX_PATH_OR_CMD / 2; ofn.lpstrInitialDir = strlen(lDirname) ? lDirname : NULL; ofn.lpstrTitle = aTitle && strlen(aTitle) ? aTitle : NULL; ofn.Flags = OFN_OVERWRITEPROMPT | OFN_NOCHANGEDIR ; ofn.nFileOffset = 0 ; ofn.nFileExtension = 0 ; ofn.lpstrDefExt = ldefExt; ofn.lCustData = 0L ; ofn.lpfnHook = NULL ; ofn.lpTemplateName = NULL ; if ( GetSaveFileNameA ( & ofn ) == 0 ) { lRetval = NULL ; } else { lRetval = aoBuff ; } if (lHResult==S_OK || lHResult==S_FALSE) { CoUninitialize(); } return lRetval ; } static char * openFileDialogWinGuiA( char const * aTitle , /* NULL or "" */ char const * aDefaultPathAndFile , /* NULL or "" */ int aNumOfFilterPatterns , /* 0 */ char const * const * aFilterPatterns , /* NULL or {"*.jpg","*.png"} */ char const * aSingleFilterDescription , /* NULL or "image files" */ int aAllowMultipleSelects ) /* 0 or 1 */ { char lDirname [MAX_PATH_OR_CMD] ; char lFilterPatterns[MAX_PATH_OR_CMD] = ""; char lDialogString[MAX_PATH_OR_CMD] ; char * lPointers[MAX_MULTIPLE_FILES+1]; size_t lLengths[MAX_MULTIPLE_FILES]; int i , j ; char * p; size_t lBuffLen, lFullBuffLen; HRESULT lHResult; OPENFILENAMEA ofn = {0}; static char * lBuff = NULL; free(lBuff); lBuff = NULL; if (aAllowMultipleSelects) { lFullBuffLen = MAX_MULTIPLE_FILES * MAX_PATH_OR_CMD + 1; lBuff = (char *)(malloc(lFullBuffLen * sizeof(char))); if (!lBuff) { lFullBuffLen = LOW_MULTIPLE_FILES * MAX_PATH_OR_CMD + 1; lBuff = (char *)(malloc(lFullBuffLen * sizeof(char))); } } else { lFullBuffLen = MAX_PATH_OR_CMD + 1; lBuff = (char *)(malloc(lFullBuffLen * sizeof(char))); } if (!lBuff) return NULL; lHResult = CoInitializeEx(NULL,0); getPathWithoutFinalSlash(lDirname, aDefaultPathAndFile); getLastName(lBuff, aDefaultPathAndFile); if (aNumOfFilterPatterns > 0) { if ( aSingleFilterDescription && strlen(aSingleFilterDescription) ) { strcpy(lFilterPatterns, aSingleFilterDescription); strcat(lFilterPatterns, "\n"); } strcat(lFilterPatterns, aFilterPatterns[0]); for (i = 1; i < aNumOfFilterPatterns; i++) { strcat(lFilterPatterns, ";"); strcat(lFilterPatterns, aFilterPatterns[i]); } strcat(lFilterPatterns, "\n"); if ( ! (aSingleFilterDescription && strlen(aSingleFilterDescription) ) ) { strcpy(lDialogString, lFilterPatterns); strcat(lFilterPatterns, lDialogString); } strcat(lFilterPatterns, "All Files\n*.*\n"); p = lFilterPatterns; while ((p = strchr(p, '\n')) != NULL) { *p = '\0'; p ++ ; } } ofn.lStructSize = sizeof( OPENFILENAME ) ; ofn.hwndOwner = GetForegroundWindow(); ofn.hInstance = 0 ; ofn.lpstrFilter = strlen(lFilterPatterns) ? lFilterPatterns : NULL; ofn.lpstrCustomFilter = NULL ; ofn.nMaxCustFilter = 0 ; ofn.nFilterIndex = 1 ; ofn.lpstrFile = lBuff; ofn.nMaxFile = lFullBuffLen; ofn.lpstrFileTitle = NULL ; ofn.nMaxFileTitle = MAX_PATH_OR_CMD / 2; ofn.lpstrInitialDir = strlen(lDirname) ? lDirname : NULL; ofn.lpstrTitle = aTitle && strlen(aTitle) ? aTitle : NULL; ofn.Flags = OFN_EXPLORER | OFN_NOCHANGEDIR ; ofn.nFileOffset = 0 ; ofn.nFileExtension = 0 ; ofn.lpstrDefExt = NULL ; ofn.lCustData = 0L ; ofn.lpfnHook = NULL ; ofn.lpTemplateName = NULL ; if ( aAllowMultipleSelects ) { ofn.Flags |= OFN_ALLOWMULTISELECT; } if ( GetOpenFileNameA( & ofn ) == 0 ) { free(lBuff); lBuff = NULL ; } else { lBuffLen = strlen(lBuff); lPointers[0] = lBuff + lBuffLen + 1; if ( aAllowMultipleSelects && (lPointers[0][0] != '\0') ) { i = 0 ; do { lLengths[i] = strlen(lPointers[i]); lPointers[i+1] = lPointers[i] + lLengths[i] + 1 ; i ++ ; } while (lPointers[i][0] != L'\0' && i < MAX_MULTIPLE_FILES); if (i > MAX_MULTIPLE_FILES) { free(lBuff); lBuff = NULL; } else { i--; p = lBuff + MAX_MULTIPLE_FILES*MAX_PATH_OR_CMD - 1; *p = '\0'; for (j = i; j >= 0; j--) { p -= lLengths[j]; memmove(p, lPointers[j], lLengths[j]); p--; *p = '\\'; p -= lBuffLen; memmove(p, lBuff, lBuffLen); p--; *p = '|'; } p++; strcpy(lBuff, p); lBuffLen = strlen(lBuff); } } if (lBuff) lBuff = (char *)(realloc(lBuff, (lBuffLen + 1) * sizeof(char))); } if (lHResult==S_OK || lHResult==S_FALSE) { CoUninitialize(); } return lBuff; } static char * selectFolderDialogWinGuiA( char * aoBuff , char const * aTitle , /* NULL or "" */ char const * aDefaultPath ) /* NULL or "" */ { BROWSEINFOA bInfo ; LPITEMIDLIST lpItem ; HRESULT lHResult ; char * lRetval = NULL ; lHResult = CoInitializeEx(NULL, COINIT_APARTMENTTHREADED); /* we can't use aDefaultPath */ bInfo.hwndOwner = GetForegroundWindow(); bInfo.pidlRoot = NULL ; bInfo.pszDisplayName = aoBuff ; bInfo.lpszTitle = aTitle && strlen(aTitle) ? aTitle : NULL; if (lHResult == S_OK || lHResult == S_FALSE) { bInfo.ulFlags = BIF_USENEWUI; } bInfo.lpfn = BrowseCallbackProc; bInfo.lParam = (LPARAM)aDefaultPath; bInfo.iImage = -1 ; lpItem = SHBrowseForFolderA( & bInfo ) ; if ( lpItem ) { SHGetPathFromIDListA( lpItem , aoBuff ) ; lRetval = aoBuff; } if (lHResult==S_OK || lHResult==S_FALSE) { CoUninitialize(); } return lRetval; } static char * colorChooserWinGuiA( char const * aTitle, /* NULL or "" */ char const * aDefaultHexRGB, /* NULL or "#FF0000"*/ unsigned char const aDefaultRGB[3], /* { 0 , 255 , 255 } */ unsigned char aoResultRGB[3]) /* { 0 , 0 , 0 } */ { static char lResultHexRGB[8]; CHOOSECOLORA cc; COLORREF crCustColors[16]; unsigned char lDefaultRGB[3]; int lRet; if ( aDefaultHexRGB ) { Hex2RGB(aDefaultHexRGB, lDefaultRGB); } else { lDefaultRGB[0]=aDefaultRGB[0]; lDefaultRGB[1]=aDefaultRGB[1]; lDefaultRGB[2]=aDefaultRGB[2]; } /* we can't use aTitle */ cc.lStructSize = sizeof( CHOOSECOLOR ) ; cc.hwndOwner = GetForegroundWindow(); cc.hInstance = NULL ; cc.rgbResult = RGB(lDefaultRGB[0], lDefaultRGB[1], lDefaultRGB[2]); cc.lpCustColors = crCustColors; cc.Flags = CC_RGBINIT | CC_FULLOPEN; cc.lCustData = 0; cc.lpfnHook = NULL; cc.lpTemplateName = NULL; lRet = ChooseColorA(&cc); if ( ! lRet ) { return NULL; } aoResultRGB[0] = GetRValue(cc.rgbResult); aoResultRGB[1] = GetGValue(cc.rgbResult); aoResultRGB[2] = GetBValue(cc.rgbResult); RGB2Hex(aoResultRGB, lResultHexRGB); return lResultHexRGB; } #endif /* TINYFD_NOLIB */ static int dialogPresent(void) { static int lDialogPresent = -1 ; char lBuff [MAX_PATH_OR_CMD] ; FILE * lIn ; char const * lString = "dialog.exe"; if (!tinyfd_allowCursesDialogs) return 0; if (lDialogPresent < 0) { if (!(lIn = _popen("where dialog.exe","r"))) { lDialogPresent = 0 ; return 0 ; } while ( fgets( lBuff , sizeof( lBuff ) , lIn ) != NULL ) {} _pclose( lIn ) ; if ( lBuff[strlen( lBuff ) -1] == '\n' ) { lBuff[strlen( lBuff ) -1] = '\0' ; } if ( strcmp(lBuff+strlen(lBuff)-strlen(lString),lString) ) { lDialogPresent = 0 ; } else { lDialogPresent = 1 ; } } return lDialogPresent; } static int messageBoxWinConsole( char const * aTitle , /* NULL or "" */ char const * aMessage , /* NULL or "" may contain \n and \t */ char const * aDialogType , /* "ok" "okcancel" "yesno" "yesnocancel" */ char const * aIconType , /* "info" "warning" "error" "question" */ int aDefaultButton ) /* 0 for cancel/no , 1 for ok/yes , 2 for no in yesnocancel */ { char lDialogString[MAX_PATH_OR_CMD]; char lDialogFile[MAX_PATH_OR_CMD]; FILE * lIn; char lBuff [MAX_PATH_OR_CMD] = ""; strcpy(lDialogString, "dialog "); if (aTitle && strlen(aTitle)) { strcat(lDialogString, "--title \"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\" ") ; } if ( aDialogType && ( !strcmp( "okcancel" , aDialogType ) || !strcmp("yesno", aDialogType) || !strcmp("yesnocancel", aDialogType) ) ) { strcat(lDialogString, "--backtitle \"") ; strcat(lDialogString, "tab: move focus") ; strcat(lDialogString, "\" ") ; } if ( aDialogType && ! strcmp( "okcancel" , aDialogType ) ) { if ( ! aDefaultButton ) { strcat( lDialogString , "--defaultno " ) ; } strcat( lDialogString , "--yes-label \"Ok\" --no-label \"Cancel\" --yesno " ) ; } else if ( aDialogType && ! strcmp( "yesno" , aDialogType ) ) { if ( ! aDefaultButton ) { strcat( lDialogString , "--defaultno " ) ; } strcat( lDialogString , "--yesno " ) ; } else if (aDialogType && !strcmp("yesnocancel", aDialogType)) { if (!aDefaultButton) { strcat(lDialogString, "--defaultno "); } strcat(lDialogString, "--menu "); } else { strcat( lDialogString , "--msgbox " ) ; } strcat( lDialogString , "\"" ) ; if ( aMessage && strlen(aMessage) ) { replaceSubStr( aMessage , "\n" , "\\n" , lBuff ) ; strcat(lDialogString, lBuff) ; lBuff[0]='\0'; } strcat(lDialogString, "\" "); if (aDialogType && !strcmp("yesnocancel", aDialogType)) { strcat(lDialogString, "0 60 0 Yes \"\" No \"\""); strcat(lDialogString, "2>>"); } else { strcat(lDialogString, "10 60"); strcat(lDialogString, " && echo 1 > "); } strcpy(lDialogFile, getenv("USERPROFILE")); strcat(lDialogFile, "\\AppData\\Local\\Temp\\tinyfd.txt"); strcat(lDialogString, lDialogFile); /*if (tinyfd_verbose) printf( "lDialogString: %s\n" , lDialogString ) ;*/ system( lDialogString ) ; if (!(lIn = fopen(lDialogFile, "r"))) { remove(lDialogFile); return 0 ; } while (fgets(lBuff, sizeof(lBuff), lIn) != NULL) {} fclose(lIn); remove(lDialogFile); if ( lBuff[strlen( lBuff ) -1] == '\n' ) { lBuff[strlen( lBuff ) -1] = '\0' ; } /* if (tinyfd_verbose) printf("lBuff: %s\n", lBuff); */ if ( ! strlen(lBuff) ) { return 0; } if (aDialogType && !strcmp("yesnocancel", aDialogType)) { if (lBuff[0] == 'Y') return 1; else return 2; } return 1; } static int inputBoxWinConsole( char * aoBuff , char const * aTitle , /* NULL or "" */ char const * aMessage , /* NULL or "" may NOT contain \n nor \t */ char const * aDefaultInput ) /* "" , if NULL it's a passwordBox */ { char lDialogString[MAX_PATH_OR_CMD]; char lDialogFile[MAX_PATH_OR_CMD]; FILE * lIn; int lResult; strcpy(lDialogFile, getenv("USERPROFILE")); strcat(lDialogFile, "\\AppData\\Local\\Temp\\tinyfd.txt"); strcpy(lDialogString , "echo|set /p=1 >" ) ; strcat(lDialogString, lDialogFile); strcat( lDialogString , " & " ) ; strcat( lDialogString , "dialog " ) ; if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, "--title \"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\" ") ; } strcat(lDialogString, "--backtitle \"") ; strcat(lDialogString, "tab: move focus") ; if ( ! aDefaultInput ) { strcat(lDialogString, " (sometimes nothing, no blink nor star, is shown in text field)") ; } strcat(lDialogString, "\" ") ; if ( ! aDefaultInput ) { strcat( lDialogString , "--insecure --passwordbox" ) ; } else { strcat( lDialogString , "--inputbox" ) ; } strcat( lDialogString , " \"" ) ; if ( aMessage && strlen(aMessage) ) { strcat(lDialogString, aMessage) ; } strcat(lDialogString,"\" 10 60 ") ; if ( aDefaultInput && strlen(aDefaultInput) ) { strcat(lDialogString, "\"") ; strcat(lDialogString, aDefaultInput) ; strcat(lDialogString, "\" ") ; } strcat(lDialogString, "2>>"); strcpy(lDialogFile, getenv("USERPROFILE")); strcat(lDialogFile, "\\AppData\\Local\\Temp\\tinyfd.txt"); strcat(lDialogString, lDialogFile); strcat(lDialogString, " || echo 0 > "); strcat(lDialogString, lDialogFile); /* printf( "lDialogString: %s\n" , lDialogString ) ; */ system( lDialogString ) ; if (!(lIn = fopen(lDialogFile, "r"))) { remove(lDialogFile); aoBuff[0] = '\0'; return 0; } while (fgets(aoBuff, MAX_PATH_OR_CMD, lIn) != NULL) {} fclose(lIn); wipefile(lDialogFile); remove(lDialogFile); if ( aoBuff[strlen( aoBuff ) -1] == '\n' ) { aoBuff[strlen( aoBuff ) -1] = '\0' ; } /* printf( "aoBuff: %s\n" , aoBuff ) ; */ /* printf( "aoBuff: %s len: %lu \n" , aoBuff , strlen(aoBuff) ) ; */ lResult = strncmp( aoBuff , "1" , 1) ? 0 : 1 ; /* printf( "lResult: %d \n" , lResult ) ; */ if ( ! lResult ) { aoBuff[0] = '\0'; return 0 ; } /* printf( "aoBuff+1: %s\n" , aoBuff+1 ) ; */ strcpy(aoBuff, aoBuff+3); return 1; } static char * saveFileDialogWinConsole( char * aoBuff , char const * aTitle , /* NULL or "" */ char const * aDefaultPathAndFile ) /* NULL or "" */ { char lDialogString[MAX_PATH_OR_CMD]; char lPathAndFile[MAX_PATH_OR_CMD] = ""; FILE * lIn; strcpy( lDialogString , "dialog " ) ; if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, "--title \"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\" ") ; } strcat(lDialogString, "--backtitle \"") ; strcat(lDialogString, "tab: focus | /: populate | spacebar: fill text field | ok: TEXT FIELD ONLY") ; strcat(lDialogString, "\" ") ; strcat( lDialogString , "--fselect \"" ) ; if ( aDefaultPathAndFile && strlen(aDefaultPathAndFile) ) { /* dialog.exe uses unix separators even on windows */ strcpy(lPathAndFile, aDefaultPathAndFile); replaceChr( lPathAndFile , '\\' , '/' ) ; } /* dialog.exe needs at least one separator */ if ( ! strchr(lPathAndFile, '/') ) { strcat(lDialogString, "./") ; } strcat(lDialogString, lPathAndFile) ; strcat(lDialogString, "\" 0 60 2>"); strcpy(lPathAndFile, getenv("USERPROFILE")); strcat(lPathAndFile, "\\AppData\\Local\\Temp\\tinyfd.txt"); strcat(lDialogString, lPathAndFile); /* printf( "lDialogString: %s\n" , lDialogString ) ; */ system( lDialogString ) ; if (!(lIn = fopen(lPathAndFile, "r"))) { remove(lPathAndFile); return NULL; } while (fgets(aoBuff, MAX_PATH_OR_CMD, lIn) != NULL) {} fclose(lIn); remove(lPathAndFile); replaceChr( aoBuff , '/' , '\\' ) ; /* printf( "aoBuff: %s\n" , aoBuff ) ; */ getLastName(lDialogString,aoBuff); if ( ! strlen(lDialogString) ) { return NULL; } return aoBuff; } static char * openFileDialogWinConsole( char const * aTitle , /* NULL or "" */ char const * aDefaultPathAndFile ) /* NULL or "" */ { char lFilterPatterns[MAX_PATH_OR_CMD] = ""; char lDialogString[MAX_PATH_OR_CMD] ; FILE * lIn; static char aoBuff[MAX_PATH_OR_CMD]; strcpy( lDialogString , "dialog " ) ; if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, "--title \"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\" ") ; } strcat(lDialogString, "--backtitle \"") ; strcat(lDialogString, "tab: focus | /: populate | spacebar: fill text field | ok: TEXT FIELD ONLY") ; strcat(lDialogString, "\" ") ; strcat( lDialogString , "--fselect \"" ) ; if ( aDefaultPathAndFile && strlen(aDefaultPathAndFile) ) { /* dialog.exe uses unix separators even on windows */ strcpy(lFilterPatterns, aDefaultPathAndFile); replaceChr( lFilterPatterns , '\\' , '/' ) ; } /* dialog.exe needs at least one separator */ if ( ! strchr(lFilterPatterns, '/') ) { strcat(lDialogString, "./") ; } strcat(lDialogString, lFilterPatterns) ; strcat(lDialogString, "\" 0 60 2>"); strcpy(lFilterPatterns, getenv("USERPROFILE")); strcat(lFilterPatterns, "\\AppData\\Local\\Temp\\tinyfd.txt"); strcat(lDialogString, lFilterPatterns); /* printf( "lDialogString: %s\n" , lDialogString ) ; */ system( lDialogString ) ; if (!(lIn = fopen(lFilterPatterns, "r"))) { remove(lFilterPatterns); return NULL; } while (fgets(aoBuff, MAX_PATH_OR_CMD, lIn) != NULL) {} fclose(lIn); remove(lFilterPatterns); replaceChr( aoBuff , '/' , '\\' ) ; /* printf( "aoBuff: %s\n" , aoBuff ) ; */ return aoBuff; } static char * selectFolderDialogWinConsole( char * aoBuff , char const * aTitle , /* NULL or "" */ char const * aDefaultPath ) /* NULL or "" */ { char lDialogString [MAX_PATH_OR_CMD] ; char lString [MAX_PATH_OR_CMD] ; FILE * lIn ; strcpy( lDialogString , "dialog " ) ; if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, "--title \"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\" ") ; } strcat(lDialogString, "--backtitle \"") ; strcat(lDialogString, "tab: focus | /: populate | spacebar: fill text field | ok: TEXT FIELD ONLY") ; strcat(lDialogString, "\" ") ; strcat( lDialogString , "--dselect \"" ) ; if ( aDefaultPath && strlen(aDefaultPath) ) { /* dialog.exe uses unix separators even on windows */ strcpy(lString, aDefaultPath) ; ensureFinalSlash(lString); replaceChr( lString , '\\' , '/' ) ; strcat(lDialogString, lString) ; } else { /* dialog.exe needs at least one separator */ strcat(lDialogString, "./") ; } strcat(lDialogString, "\" 0 60 2>"); strcpy(lString, getenv("USERPROFILE")); strcat(lString, "\\AppData\\Local\\Temp\\tinyfd.txt"); strcat(lDialogString, lString); /* printf( "lDialogString: %s\n" , lDialogString ) ; */ system( lDialogString ) ; if (!(lIn = fopen(lString, "r"))) { remove(lString); return NULL; } while (fgets(aoBuff, MAX_PATH_OR_CMD, lIn) != NULL) {} fclose(lIn); remove(lString); replaceChr( aoBuff , '/' , '\\' ) ; /* printf( "aoBuff: %s\n" , aoBuff ) ; */ return aoBuff; } static void writeUtf8( char const * aUtf8String ) { unsigned long lNum; void * lConsoleHandle; wchar_t * lTmpWChar; lConsoleHandle = GetStdHandle(STD_OUTPUT_HANDLE); lTmpWChar = tinyfd_utf8to16(aUtf8String); (void)WriteConsoleW(lConsoleHandle, lTmpWChar, wcslen(lTmpWChar), &lNum, NULL); } int tinyfd_messageBox( char const * aTitle , /* NULL or "" */ char const * aMessage , /* NULL or "" may contain \n and \t */ char const * aDialogType , /* "ok" "okcancel" "yesno" "yesnocancel" */ char const * aIconType , /* "info" "warning" "error" "question" */ int aDefaultButton ) /* 0 for cancel/no , 1 for ok/yes , 2 for no in yesnocancel */ { char lChar ; UINT lOriginalCP; UINT lOriginalOutputCP; #ifndef TINYFD_NOLIB if ((!tinyfd_forceConsole || !(GetConsoleWindow() || dialogPresent())) && (!getenv("SSH_CLIENT") || getenv("DISPLAY"))) { if (aTitle&&!strcmp(aTitle, "tinyfd_query")){ strcpy(tinyfd_response, "windows"); return 1; } if (tinyfd_winUtf8) { return messageBoxWinGui8( aTitle, aMessage, aDialogType, aIconType, aDefaultButton); } else { return messageBoxWinGuiA( aTitle, aMessage, aDialogType, aIconType, aDefaultButton); } } else #endif /* TINYFD_NOLIB */ if ( dialogPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"dialog");return 0;} return messageBoxWinConsole( aTitle,aMessage,aDialogType,aIconType,aDefaultButton); } else { if (!tinyfd_winUtf8) { lOriginalCP = GetConsoleCP(); lOriginalOutputCP = GetConsoleOutputCP(); (void)SetConsoleCP(GetACP()); (void)SetConsoleOutputCP(GetACP()); } if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"basicinput");return 0;} if (!gWarningDisplayed && !tinyfd_forceConsole ) { gWarningDisplayed = 1; printf("\n\n%s\n", gTitle); printf("%s\n\n", tinyfd_needs); } if ( aTitle && strlen(aTitle) ) { printf("\n"); if (tinyfd_winUtf8) writeUtf8(aTitle); else printf("%s", aTitle); printf("\n\n"); } if ( aDialogType && !strcmp("yesno",aDialogType) ) { do { if ( aMessage && strlen(aMessage) ) { if (tinyfd_winUtf8) writeUtf8(aMessage); else printf("%s",aMessage); printf("\n"); } printf("y/n: "); lChar = (char) tolower( _getch() ) ; printf("\n\n"); } while ( lChar != 'y' && lChar != 'n' ) ; if (!tinyfd_winUtf8) { (void)SetConsoleCP(lOriginalCP); (void)SetConsoleOutputCP(lOriginalOutputCP); } return lChar == 'y' ? 1 : 0 ; } else if ( aDialogType && !strcmp("okcancel",aDialogType) ) { do { if ( aMessage && strlen(aMessage) ) { if (tinyfd_winUtf8) writeUtf8(aMessage); else printf("%s", aMessage); printf("\n"); } printf("[O]kay/[C]ancel: "); lChar = (char) tolower( _getch() ) ; printf("\n\n"); } while ( lChar != 'o' && lChar != 'c' ) ; if (!tinyfd_winUtf8) { (void)SetConsoleCP(lOriginalCP); (void)SetConsoleOutputCP(lOriginalOutputCP); } return lChar == 'o' ? 1 : 0 ; } else if (aDialogType && !strcmp("yesnocancel", aDialogType)) { do { if (aMessage && strlen(aMessage)) { if (tinyfd_winUtf8) writeUtf8(aMessage); else printf("%s", aMessage); printf("\n"); } printf("[Y]es/[N]o/[C]ancel: "); lChar = (char)tolower(_getch()); printf("\n\n"); } while (lChar != 'y' && lChar != 'n' && lChar != 'c'); if (!tinyfd_winUtf8) { (void)SetConsoleCP(lOriginalCP); (void)SetConsoleOutputCP(lOriginalOutputCP); } return (lChar == 'y') ? 1 : (lChar == 'n') ? 2 : 0 ; } else { if ( aMessage && strlen(aMessage) ) { if (tinyfd_winUtf8) writeUtf8(aMessage); else printf("%s", aMessage); printf("\n\n"); } printf("press enter to continue "); lChar = (char) _getch() ; printf("\n\n"); if (!tinyfd_winUtf8) { (void)SetConsoleCP(lOriginalCP); (void)SetConsoleOutputCP(lOriginalOutputCP); } return 1 ; } } } /* return has only meaning for tinyfd_query */ int tinyfd_notifyPopup( char const * aTitle , /* NULL or "" */ char const * aMessage , /* NULL or "" may contain \n \t */ char const * aIconType ) /* "info" "warning" "error" */ { #ifndef TINYFD_NOLIB if ((!tinyfd_forceConsole || !( GetConsoleWindow() || dialogPresent())) && ( !getenv("SSH_CLIENT") || getenv("DISPLAY") ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"windows");return 1;} return notifyWinGui(aTitle, aMessage, aIconType); } else #endif /* TINYFD_NOLIB */ return tinyfd_messageBox(aTitle, aMessage, "ok" , aIconType, 0); } /* returns NULL on cancel */ char * tinyfd_inputBox( char const * aTitle , /* NULL or "" */ char const * aMessage , /* NULL or "" may NOT contain \n nor \t */ char const * aDefaultInput ) /* "" , if NULL it's a passwordBox */ { static char lBuff[MAX_PATH_OR_CMD] = ""; char * lEOF; DWORD mode = 0; HANDLE hStdin = GetStdHandle(STD_INPUT_HANDLE); unsigned long lNum; void * lConsoleHandle; char * lTmpChar; wchar_t lBuffW[1024]; UINT lOriginalCP; UINT lOriginalOutputCP; if (!aTitle && !aMessage && !aDefaultInput) return lBuff; /* now I can fill lBuff from outside */ #ifndef TINYFD_NOLIB mode = 0; hStdin = GetStdHandle(STD_INPUT_HANDLE); if ((!tinyfd_forceConsole || !( GetConsoleWindow() || dialogPresent())) && ( !getenv("SSH_CLIENT") || getenv("DISPLAY") ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"windows");return (char *)1;} lBuff[0]='\0'; if (inputBoxWinGui(lBuff, aTitle, aMessage, aDefaultInput)) return lBuff; else return NULL; } else #endif /* TINYFD_NOLIB */ if ( dialogPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"dialog");return (char *)0;} lBuff[0]='\0'; if (inputBoxWinConsole(lBuff, aTitle, aMessage, aDefaultInput) ) return lBuff; else return NULL; } else { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"basicinput");return (char *)0;} lBuff[0]='\0'; if (!gWarningDisplayed && !tinyfd_forceConsole) { gWarningDisplayed = 1 ; printf("\n\n%s\n", gTitle); printf("%s\n\n", tinyfd_needs); } if (!tinyfd_winUtf8) { lOriginalCP = GetConsoleCP(); lOriginalOutputCP = GetConsoleOutputCP(); (void)SetConsoleCP(GetACP()); (void)SetConsoleOutputCP(GetACP()); } if (aTitle && strlen(aTitle)) { printf("\n"); if (tinyfd_winUtf8) writeUtf8(aTitle); else printf("%s", aTitle); printf("\n\n"); } if ( aMessage && strlen(aMessage) ) { if (tinyfd_winUtf8) writeUtf8(aMessage); else printf("%s", aMessage); printf("\n"); } printf("(ctrl-Z + enter to cancel): "); if ( ! aDefaultInput ) { (void) GetConsoleMode(hStdin, &mode); (void) SetConsoleMode(hStdin, mode & (~ENABLE_ECHO_INPUT)); } if (tinyfd_winUtf8) { lConsoleHandle = GetStdHandle(STD_INPUT_HANDLE); (void) ReadConsoleW(lConsoleHandle, lBuffW, MAX_PATH_OR_CMD, &lNum, NULL); if (!aDefaultInput) { (void)SetConsoleMode(hStdin, mode); printf("\n"); } lBuffW[lNum] = '\0'; if (lBuffW[wcslen(lBuffW) - 1] == '\n') lBuffW[wcslen(lBuffW) - 1] = '\0'; if (lBuffW[wcslen(lBuffW) - 1] == '\r') lBuffW[wcslen(lBuffW) - 1] = '\0'; lTmpChar = tinyfd_utf16to8(lBuffW); if (lTmpChar) { strcpy(lBuff, lTmpChar); return lBuff; } else return NULL; } else { lEOF = fgets(lBuff, MAX_PATH_OR_CMD, stdin); if (!aDefaultInput) { (void)SetConsoleMode(hStdin, mode); printf("\n"); } if (!tinyfd_winUtf8) { (void)SetConsoleCP(lOriginalCP); (void)SetConsoleOutputCP(lOriginalOutputCP); } if (!lEOF) { return NULL; } printf("\n"); if (strchr(lBuff, 27)) { return NULL; } if (lBuff[strlen(lBuff) - 1] == '\n') { lBuff[strlen(lBuff) - 1] = '\0'; } return lBuff; } } } char * tinyfd_saveFileDialog( char const * aTitle , /* NULL or "" */ char const * aDefaultPathAndFile , /* NULL or "" */ int aNumOfFilterPatterns , /* 0 */ char const * const * aFilterPatterns , /* NULL or {"*.jpg","*.png"} */ char const * aSingleFilterDescription ) /* NULL or "image files" */ { static char lBuff [MAX_PATH_OR_CMD] ; char lString[MAX_PATH_OR_CMD] ; char * p ; char * lPointerInputBox; lBuff[0]='\0'; #ifndef TINYFD_NOLIB if ( ( !tinyfd_forceConsole || !( GetConsoleWindow() || dialogPresent() ) ) && ( !getenv("SSH_CLIENT") || getenv("DISPLAY") ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"windows");return (char *)1;} if (tinyfd_winUtf8) { p = saveFileDialogWinGui8(lBuff, aTitle, aDefaultPathAndFile, aNumOfFilterPatterns, aFilterPatterns, aSingleFilterDescription); } else { p = saveFileDialogWinGuiA(lBuff, aTitle, aDefaultPathAndFile, aNumOfFilterPatterns, aFilterPatterns, aSingleFilterDescription); } } else #endif /* TINYFD_NOLIB */ if (dialogPresent()) { if (aTitle&&!strcmp(aTitle, "tinyfd_query")){ strcpy(tinyfd_response, "dialog"); return (char *)0; } p = saveFileDialogWinConsole(lBuff, aTitle, aDefaultPathAndFile); } else { if (aTitle&&!strcmp(aTitle, "tinyfd_query")){ strcpy(tinyfd_response, "basicinput"); return (char *)0; } strcpy(lBuff, "Save file in "); strcat(lBuff, getCurDir()); lPointerInputBox = tinyfd_inputBox(NULL,NULL,NULL); /* obtain a pointer on the current content of tinyfd_inputBox */ if (lPointerInputBox) strcpy(lString, lPointerInputBox); /* preserve the current content of tinyfd_inputBox */ p = tinyfd_inputBox(aTitle, lBuff, ""); if (p) strcpy(lBuff, p); else lBuff[0] = '\0'; if (lPointerInputBox) strcpy(lPointerInputBox, lString); /* restore its previous content to tinyfd_inputBox */ p = lBuff; } if ( ! p || ! strlen( p ) ) { return NULL; } getPathWithoutFinalSlash( lString , p ) ; if ( strlen( lString ) && ! dirExists( lString ) ) { return NULL ; } getLastName(lString,p); if ( ! filenameValid(lString) ) { return NULL; } return p ; } /* in case of multiple files, the separator is | */ char * tinyfd_openFileDialog( char const * aTitle , /* NULL or "" */ char const * aDefaultPathAndFile , /* NULL or "" */ int aNumOfFilterPatterns , /* 0 */ char const * const * aFilterPatterns , /* NULL or {"*.jpg","*.png"} */ char const * aSingleFilterDescription , /* NULL or "image files" */ int aAllowMultipleSelects ) /* 0 or 1 */ { char lString[MAX_PATH_OR_CMD]; char lBuff[MAX_PATH_OR_CMD]; char * p; char * lPointerInputBox; #ifndef TINYFD_NOLIB if ( ( !tinyfd_forceConsole || !( GetConsoleWindow() || dialogPresent() ) ) && ( !getenv("SSH_CLIENT") || getenv("DISPLAY") ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"windows");return (char *)1;} if (tinyfd_winUtf8) { p = openFileDialogWinGui8( aTitle, aDefaultPathAndFile, aNumOfFilterPatterns, aFilterPatterns, aSingleFilterDescription, aAllowMultipleSelects); } else { p = openFileDialogWinGuiA( aTitle, aDefaultPathAndFile, aNumOfFilterPatterns, aFilterPatterns, aSingleFilterDescription, aAllowMultipleSelects); } } else #endif /* TINYFD_NOLIB */ if (dialogPresent()) { if (aTitle&&!strcmp(aTitle, "tinyfd_query")){ strcpy(tinyfd_response, "dialog"); return (char *)0; } p = openFileDialogWinConsole(aTitle, aDefaultPathAndFile); } else { if (aTitle&&!strcmp(aTitle, "tinyfd_query")){ strcpy(tinyfd_response, "basicinput"); return (char *)0; } strcpy(lBuff, "Open file from "); strcat(lBuff, getCurDir()); lPointerInputBox = tinyfd_inputBox(NULL, NULL, NULL); /* obtain a pointer on the current content of tinyfd_inputBox */ if (lPointerInputBox) strcpy(lString, lPointerInputBox); /* preserve the current content of tinyfd_inputBox */ p = tinyfd_inputBox(aTitle, lBuff, ""); if (p) strcpy(lBuff, p); else lBuff[0] = '\0'; if (lPointerInputBox) strcpy(lPointerInputBox, lString); /* restore its previous content to tinyfd_inputBox */ p = lBuff; } if ( ! p || ! strlen( p ) ) { return NULL; } if ( aAllowMultipleSelects && strchr(p, '|') ) { p = ensureFilesExist( (char *) p , p ) ; } else if ( ! fileExists(p) ) { return NULL ; } /* printf( "lBuff3: %s\n" , p ) ; */ return p ; } char * tinyfd_selectFolderDialog( char const * aTitle , /* NULL or "" */ char const * aDefaultPath ) /* NULL or "" */ { static char lBuff[MAX_PATH_OR_CMD]; char * p; char * lPointerInputBox; char lString[MAX_PATH_OR_CMD]; #ifndef TINYFD_NOLIB if ( ( !tinyfd_forceConsole || !( GetConsoleWindow() || dialogPresent() ) ) && ( !getenv("SSH_CLIENT") || getenv("DISPLAY") ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"windows");return (char *)1;} if (tinyfd_winUtf8) { p = selectFolderDialogWinGui8(lBuff, aTitle, aDefaultPath); } else { p = selectFolderDialogWinGuiA(lBuff, aTitle, aDefaultPath); } } else #endif /* TINYFD_NOLIB */ if (dialogPresent()) { if (aTitle&&!strcmp(aTitle, "tinyfd_query")){ strcpy(tinyfd_response, "dialog"); return (char *)0; } p = selectFolderDialogWinConsole(lBuff, aTitle, aDefaultPath); } else { if (aTitle&&!strcmp(aTitle, "tinyfd_query")){ strcpy(tinyfd_response, "basicinput"); return (char *)0; } strcpy(lBuff, "Select folder from "); strcat(lBuff, getCurDir()); lPointerInputBox = tinyfd_inputBox(NULL, NULL, NULL); /* obtain a pointer on the current content of tinyfd_inputBox */ if (lPointerInputBox) strcpy(lString, lPointerInputBox); /* preserve the current content of tinyfd_inputBox */ p = tinyfd_inputBox(aTitle, lBuff, ""); if (p) strcpy(lBuff, p); else lBuff[0] = '\0'; if (lPointerInputBox) strcpy(lPointerInputBox, lString); /* restore its previous content to tinyfd_inputBox */ p = lBuff; } if ( ! p || ! strlen( p ) || ! dirExists( p ) ) { return NULL ; } return p ; } /* returns the hexcolor as a string "#FF0000" */ /* aoResultRGB also contains the result */ /* aDefaultRGB is used only if aDefaultHexRGB is NULL */ /* aDefaultRGB and aoResultRGB can be the same array */ char * tinyfd_colorChooser( char const * aTitle, /* NULL or "" */ char const * aDefaultHexRGB, /* NULL or "#FF0000"*/ unsigned char const aDefaultRGB[3], /* { 0 , 255 , 255 } */ unsigned char aoResultRGB[3]) /* { 0 , 0 , 0 } */ { static char lDefaultHexRGB[16]; int i; char * p ; char * lPointerInputBox; char lString[MAX_PATH_OR_CMD]; lDefaultHexRGB[0] = '\0'; #ifndef TINYFD_NOLIB if ( (!tinyfd_forceConsole || !( GetConsoleWindow() || dialogPresent()) ) && (!getenv("SSH_CLIENT") || getenv("DISPLAY")) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"windows");return (char *)1;} if (tinyfd_winUtf8) { p = colorChooserWinGui8( aTitle, aDefaultHexRGB, aDefaultRGB, aoResultRGB); strcpy(lDefaultHexRGB, p); } else { p = colorChooserWinGuiA( aTitle, aDefaultHexRGB, aDefaultRGB, aoResultRGB); strcpy(lDefaultHexRGB, p); } return lDefaultHexRGB; } else #endif /* TINYFD_NOLIB */ if (dialogPresent()) { if (aTitle&&!strcmp(aTitle, "tinyfd_query")){ strcpy(tinyfd_response, "dialog"); return (char *)0; } } else { if (aTitle&&!strcmp(aTitle, "tinyfd_query")){ strcpy(tinyfd_response, "basicinput"); return (char *)0; } } if (aDefaultHexRGB) { strncpy(lDefaultHexRGB, aDefaultHexRGB,7); lDefaultHexRGB[7]='\0'; } else { RGB2Hex(aDefaultRGB, lDefaultHexRGB); } lPointerInputBox = tinyfd_inputBox(NULL, NULL, NULL); /* obtain a pointer on the current content of tinyfd_inputBox */ if (lPointerInputBox) strcpy(lString, lPointerInputBox); /* preserve the current content of tinyfd_inputBox */ p = tinyfd_inputBox(aTitle, "Enter hex rgb color (i.e. #f5ca20)", lDefaultHexRGB); if ( !p || (strlen(p) != 7) || (p[0] != '#') ) { return NULL ; } for ( i = 1 ; i < 7 ; i ++ ) { if ( ! isxdigit( (int) p[i] ) ) { return NULL ; } } Hex2RGB(p,aoResultRGB); strcpy(lDefaultHexRGB, p); if (lPointerInputBox) strcpy(lPointerInputBox, lString); /* restore its previous content to tinyfd_inputBox */ return lDefaultHexRGB; } #else /* unix */ static char gPython2Name[16]; static char gPython3Name[16]; static char gPythonName[16]; static int isDarwin(void) { static int lsIsDarwin = -1 ; struct utsname lUtsname ; if ( lsIsDarwin < 0 ) { lsIsDarwin = !uname(&lUtsname) && !strcmp(lUtsname.sysname,"Darwin") ; } return lsIsDarwin ; } static int dirExists( char const * aDirPath ) { DIR * lDir ; if ( ! aDirPath || ! strlen( aDirPath ) ) return 0 ; lDir = opendir( aDirPath ) ; if ( ! lDir ) { return 0 ; } closedir( lDir ) ; return 1 ; } static int detectPresence( char const * aExecutable ) { char lBuff [MAX_PATH_OR_CMD] ; char lTestedString [MAX_PATH_OR_CMD] = "which " ; FILE * lIn ; strcat( lTestedString , aExecutable ) ; strcat( lTestedString, " 2>/dev/null "); lIn = popen( lTestedString , "r" ) ; if ( ( fgets( lBuff , sizeof( lBuff ) , lIn ) != NULL ) && ( ! strchr( lBuff , ':' ) ) && ( strncmp(lBuff, "no ", 3) ) ) { /* present */ pclose( lIn ) ; if (tinyfd_verbose) printf("detectPresence %s %d\n", aExecutable, 1); return 1 ; } else { pclose( lIn ) ; if (tinyfd_verbose) printf("detectPresence %s %d\n", aExecutable, 0); return 0 ; } } static char * getVersion( char const * aExecutable ) /*version must be first numeral*/ { static char lBuff [MAX_PATH_OR_CMD] ; char lTestedString [MAX_PATH_OR_CMD] ; FILE * lIn ; char * lTmp ; strcpy( lTestedString , aExecutable ) ; strcat( lTestedString , " --version" ) ; lIn = popen( lTestedString , "r" ) ; lTmp = fgets( lBuff , sizeof( lBuff ) , lIn ) ; pclose( lIn ) ; lTmp += strcspn(lTmp,"0123456789"); /* printf("lTmp:%s\n", lTmp); */ return lTmp ; } static int * getMajorMinorPatch( char const * aExecutable ) { static int lArray [3] ; char * lTmp ; lTmp = (char *) getVersion(aExecutable); lArray[0] = atoi( strtok(lTmp," ,.-") ) ; /* printf("lArray0 %d\n", lArray[0]); */ lArray[1] = atoi( strtok(0," ,.-") ) ; /* printf("lArray1 %d\n", lArray[1]); */ lArray[2] = atoi( strtok(0," ,.-") ) ; /* printf("lArray2 %d\n", lArray[2]); */ if ( !lArray[0] && !lArray[1] && !lArray[2] ) return NULL; return lArray ; } static int tryCommand( char const * aCommand ) { char lBuff [MAX_PATH_OR_CMD] ; FILE * lIn ; lIn = popen( aCommand , "r" ) ; if ( fgets( lBuff , sizeof( lBuff ) , lIn ) == NULL ) { /* present */ pclose( lIn ) ; return 1 ; } else { pclose( lIn ) ; return 0 ; } } static int isTerminalRunning(void) { static int lIsTerminalRunning = -1 ; if ( lIsTerminalRunning < 0 ) { lIsTerminalRunning = isatty(1); if (tinyfd_verbose) printf("isTerminalRunning %d\n", lIsTerminalRunning ); } return lIsTerminalRunning; } static char * dialogNameOnly(void) { static char lDialogName[128] = "*" ; if ( lDialogName[0] == '*' ) { if (!tinyfd_allowCursesDialogs) { strcpy(lDialogName , "" ); } else if ( isDarwin() && * strcpy(lDialogName , "/opt/local/bin/dialog" ) && detectPresence( lDialogName ) ) {} else if ( * strcpy(lDialogName , "dialog" ) && detectPresence( lDialogName ) ) {} else { strcpy(lDialogName , "" ); } } return lDialogName ; } int isDialogVersionBetter09b(void) { char const * lDialogName ; char * lVersion ; int lMajor ; int lMinor ; int lDate ; int lResult ; char * lMinorP ; char * lLetter ; char lBuff[128] ; /*char lTest[128] = " 0.9b-20031126" ;*/ lDialogName = dialogNameOnly() ; if ( ! strlen(lDialogName) || !(lVersion = (char *) getVersion(lDialogName)) ) return 0 ; /*lVersion = lTest ;*/ /*printf("lVersion %s\n", lVersion);*/ strcpy(lBuff,lVersion); lMajor = atoi( strtok(lVersion," ,.-") ) ; /*printf("lMajor %d\n", lMajor);*/ lMinorP = strtok(0," ,.-abcdefghijklmnopqrstuvxyz"); lMinor = atoi( lMinorP ) ; /*printf("lMinor %d\n", lMinor );*/ lDate = atoi( strtok(0," ,.-") ) ; if (lDate<0) lDate = - lDate; /*printf("lDate %d\n", lDate);*/ lLetter = lMinorP + strlen(lMinorP) ; strcpy(lVersion,lBuff); strtok(lLetter," ,.-"); /*printf("lLetter %s\n", lLetter);*/ lResult = (lMajor > 0) || ( ( lMinor == 9 ) && (*lLetter == 'b') && (lDate >= 20031126) ); /*printf("lResult %d\n", lResult);*/ return lResult; } static int whiptailPresentOnly(void) { static int lWhiptailPresent = -1 ; if (!tinyfd_allowCursesDialogs) return 0; if ( lWhiptailPresent < 0 ) { lWhiptailPresent = detectPresence( "whiptail" ) ; } return lWhiptailPresent ; } static char * terminalName(void) { static char lTerminalName[128] = "*" ; char lShellName[64] = "*" ; int * lArray; if ( lTerminalName[0] == '*' ) { if ( detectPresence( "bash" ) ) { strcpy(lShellName , "bash -c " ) ; /*good for basic input*/ } else if ( strlen(dialogNameOnly()) || whiptailPresentOnly() ) { strcpy(lShellName , "sh -c " ) ; /*good enough for dialog & whiptail*/ } else { strcpy(lTerminalName , "" ) ; return NULL ; } if ( isDarwin() ) { if ( * strcpy(lTerminalName , "/opt/X11/bin/xterm" ) && detectPresence( lTerminalName ) ) { strcat(lTerminalName , " -fa 'DejaVu Sans Mono' -fs 10 -title tinyfiledialogs -e " ) ; strcat(lTerminalName , lShellName ) ; } else { strcpy(lTerminalName , "" ) ; } } else if ( * strcpy(lTerminalName,"xterm") /*good (small without parameters)*/ && detectPresence(lTerminalName) ) { strcat(lTerminalName , " -fa 'DejaVu Sans Mono' -fs 10 -title tinyfiledialogs -e " ) ; strcat(lTerminalName , lShellName ) ; } else if ( * strcpy(lTerminalName,"terminator") /*good*/ && detectPresence(lTerminalName) ) { strcat(lTerminalName , " -x " ) ; strcat(lTerminalName , lShellName ) ; } else if ( * strcpy(lTerminalName,"lxterminal") /*good*/ && detectPresence(lTerminalName) ) { strcat(lTerminalName , " -e " ) ; strcat(lTerminalName , lShellName ) ; } else if ( * strcpy(lTerminalName,"konsole") /*good*/ && detectPresence(lTerminalName) ) { strcat(lTerminalName , " -e " ) ; strcat(lTerminalName , lShellName ) ; } else if ( * strcpy(lTerminalName,"kterm") /*good*/ && detectPresence(lTerminalName) ) { strcat(lTerminalName , " -e " ) ; strcat(lTerminalName , lShellName ) ; } else if ( * strcpy(lTerminalName,"tilix") /*good*/ && detectPresence(lTerminalName) ) { strcat(lTerminalName , " -e " ) ; strcat(lTerminalName , lShellName ) ; } else if ( * strcpy(lTerminalName,"xfce4-terminal") /*good*/ && detectPresence(lTerminalName) ) { strcat(lTerminalName , " -x " ) ; strcat(lTerminalName , lShellName ) ; } else if ( * strcpy(lTerminalName,"mate-terminal") /*good*/ && detectPresence(lTerminalName) ) { strcat(lTerminalName , " -x " ) ; strcat(lTerminalName , lShellName ) ; } else if ( * strcpy(lTerminalName,"Eterm") /*good*/ && detectPresence(lTerminalName) ) { strcat(lTerminalName , " -e " ) ; strcat(lTerminalName , lShellName ) ; } else if ( * strcpy(lTerminalName,"evilvte") /*good*/ && detectPresence(lTerminalName) ) { strcat(lTerminalName , " -e " ) ; strcat(lTerminalName , lShellName ) ; } else if ( * strcpy(lTerminalName,"pterm") /*good (only letters)*/ && detectPresence(lTerminalName) ) { strcat(lTerminalName , " -e " ) ; strcat(lTerminalName , lShellName ) ; } else if ( * strcpy(lTerminalName,"gnome-terminal") && detectPresence(lTerminalName) && (lArray = getMajorMinorPatch(lTerminalName)) && ((lArray[0]<3) || (lArray[0]==3 && lArray[1]<=6)) ) { strcat(lTerminalName , " --disable-factory -x " ) ; strcat(lTerminalName , lShellName ) ; } else { strcpy(lTerminalName , "" ) ; } /* bad: koi rxterm guake tilda vala-terminal qterminal aterm Terminal terminology sakura lilyterm weston-terminal roxterm termit xvt rxvt mrxvt urxvt */ } if ( strlen(lTerminalName) ) { return lTerminalName ; } else { return NULL ; } } static char * dialogName(void) { char * lDialogName ; lDialogName = dialogNameOnly( ) ; if ( strlen(lDialogName) && ( isTerminalRunning() || terminalName() ) ) { return lDialogName ; } else { return NULL ; } } static int whiptailPresent(void) { int lWhiptailPresent ; lWhiptailPresent = whiptailPresentOnly( ) ; if ( lWhiptailPresent && ( isTerminalRunning() || terminalName() ) ) { return lWhiptailPresent ; } else { return 0 ; } } static int graphicMode(void) { return !( tinyfd_forceConsole && (isTerminalRunning() || terminalName()) ) && ( getenv("DISPLAY") || (isDarwin() && (!getenv("SSH_TTY") || getenv("DISPLAY") ) ) ) ; } static int pactlPresent(void) { static int lPactlPresent = -1 ; if ( lPactlPresent < 0 ) { lPactlPresent = detectPresence("pactl") ; } return lPactlPresent ; } static int speakertestPresent(void) { static int lSpeakertestPresent = -1 ; if ( lSpeakertestPresent < 0 ) { lSpeakertestPresent = detectPresence("speaker-test") ; } return lSpeakertestPresent ; } static int beepexePresent(void) { static int lBeepexePresent = -1 ; if ( lBeepexePresent < 0 ) { lBeepexePresent = detectPresence("beep.exe") ; } return lBeepexePresent ; } static int xmessagePresent(void) { static int lXmessagePresent = -1 ; if ( lXmessagePresent < 0 ) { lXmessagePresent = detectPresence("xmessage");/*if not tty,not on osxpath*/ } return lXmessagePresent && graphicMode( ) ; } static int gxmessagePresent(void) { static int lGxmessagePresent = -1 ; if ( lGxmessagePresent < 0 ) { lGxmessagePresent = detectPresence("gxmessage") ; } return lGxmessagePresent && graphicMode( ) ; } static int gmessagePresent(void) { static int lGmessagePresent = -1 ; if ( lGmessagePresent < 0 ) { lGmessagePresent = detectPresence("gmessage") ; } return lGmessagePresent && graphicMode( ) ; } static int notifysendPresent(void) { static int lNotifysendPresent = -1 ; if ( lNotifysendPresent < 0 ) { lNotifysendPresent = detectPresence("notify-send") ; } return lNotifysendPresent && graphicMode( ) ; } static int perlPresent(void) { static int lPerlPresent = -1 ; char lBuff [MAX_PATH_OR_CMD] ; FILE * lIn ; if ( lPerlPresent < 0 ) { lPerlPresent = detectPresence("perl") ; if ( lPerlPresent ) { lIn = popen( "perl -MNet::DBus -e \"Net::DBus->session->get_service('org.freedesktop.Notifications')\" 2>&1" , "r" ) ; if ( fgets( lBuff , sizeof( lBuff ) , lIn ) == NULL ) { lPerlPresent = 2 ; } pclose( lIn ) ; if (tinyfd_verbose) printf("perl-dbus %d\n", lPerlPresent); } } return graphicMode() ? lPerlPresent : 0 ; } static int afplayPresent(void) { static int lAfplayPresent = -1 ; char lBuff [MAX_PATH_OR_CMD] ; FILE * lIn ; if ( lAfplayPresent < 0 ) { lAfplayPresent = detectPresence("afplay") ; if ( lAfplayPresent ) { lIn = popen( "test -e /System/Library/Sounds/Ping.aiff || echo Ping" , "r" ) ; if ( fgets( lBuff , sizeof( lBuff ) , lIn ) == NULL ) { lAfplayPresent = 2 ; } pclose( lIn ) ; if (tinyfd_verbose) printf("afplay %d\n", lAfplayPresent); } } return graphicMode() ? lAfplayPresent : 0 ; } static int xdialogPresent(void) { static int lXdialogPresent = -1 ; if ( lXdialogPresent < 0 ) { lXdialogPresent = detectPresence("Xdialog") ; } return lXdialogPresent && graphicMode( ) ; } static int gdialogPresent(void) { static int lGdialoglPresent = -1 ; if ( lGdialoglPresent < 0 ) { lGdialoglPresent = detectPresence( "gdialog" ) ; } return lGdialoglPresent && graphicMode( ) ; } static int osascriptPresent(void) { static int lOsascriptPresent = -1 ; if ( lOsascriptPresent < 0 ) { gWarningDisplayed |= !!getenv("SSH_TTY"); lOsascriptPresent = detectPresence( "osascript" ) ; } return lOsascriptPresent && graphicMode() && !getenv("SSH_TTY") ; } static int qarmaPresent(void) { static int lQarmaPresent = -1 ; if ( lQarmaPresent < 0 ) { lQarmaPresent = detectPresence("qarma") ; } return lQarmaPresent && graphicMode( ) ; } static int matedialogPresent(void) { static int lMatedialogPresent = -1 ; if ( lMatedialogPresent < 0 ) { lMatedialogPresent = detectPresence("matedialog") ; } return lMatedialogPresent && graphicMode( ) ; } static int shellementaryPresent(void) { static int lShellementaryPresent = -1 ; if ( lShellementaryPresent < 0 ) { lShellementaryPresent = 0 ; /*detectPresence("shellementary"); shellementary is not ready yet */ } return lShellementaryPresent && graphicMode( ) ; } static int zenityPresent(void) { static int lZenityPresent = -1 ; if ( lZenityPresent < 0 ) { lZenityPresent = detectPresence("zenity") ; } return lZenityPresent && graphicMode( ) ; } static int zenity3Present(void) { static int lZenity3Present = -1 ; char lBuff [MAX_PATH_OR_CMD] ; FILE * lIn ; int lIntTmp ; if ( lZenity3Present < 0 ) { lZenity3Present = 0 ; if ( zenityPresent() ) { lIn = popen( "zenity --version" , "r" ) ; if ( fgets( lBuff , sizeof( lBuff ) , lIn ) != NULL ) { if ( atoi(lBuff) >= 3 ) { lZenity3Present = 3 ; lIntTmp = atoi(strtok(lBuff,".")+2 ) ; if ( lIntTmp >= 18 ) { lZenity3Present = 5 ; } else if ( lIntTmp >= 10 ) { lZenity3Present = 4 ; } } else if ( ( atoi(lBuff) == 2 ) && ( atoi(strtok(lBuff,".")+2 ) >= 32 ) ) { lZenity3Present = 2 ; } if (tinyfd_verbose) printf("zenity %d\n", lZenity3Present); } pclose( lIn ) ; } } return graphicMode() ? lZenity3Present : 0 ; } static int kdialogPresent(void) { static int lKdialogPresent = -1 ; char lBuff [MAX_PATH_OR_CMD] ; FILE * lIn ; char * lDesktop; if ( lKdialogPresent < 0 ) { if ( zenityPresent() ) { lDesktop = getenv("XDG_SESSION_DESKTOP"); if ( !lDesktop || ( strcmp(lDesktop, "KDE") && strcmp(lDesktop, "lxqt") ) ) { lKdialogPresent = 0 ; return lKdialogPresent ; } } lKdialogPresent = detectPresence("kdialog") ; if ( lKdialogPresent && !getenv("SSH_TTY") ) { lIn = popen( "kdialog --attach 2>&1" , "r" ) ; if ( fgets( lBuff , sizeof( lBuff ) , lIn ) != NULL ) { if ( ! strstr( "Unknown" , lBuff ) ) { lKdialogPresent = 2 ; if (tinyfd_verbose) printf("kdialog-attach %d\n", lKdialogPresent); } } pclose( lIn ) ; if (lKdialogPresent == 2) { lKdialogPresent = 1 ; lIn = popen( "kdialog --passivepopup 2>&1" , "r" ) ; if ( fgets( lBuff , sizeof( lBuff ) , lIn ) != NULL ) { if ( ! strstr( "Unknown" , lBuff ) ) { lKdialogPresent = 2 ; if (tinyfd_verbose) printf("kdialog-popup %d\n", lKdialogPresent); } } pclose( lIn ) ; } } } return graphicMode() ? lKdialogPresent : 0 ; } static int osx9orBetter(void) { static int lOsx9orBetter = -1 ; char lBuff [MAX_PATH_OR_CMD] ; FILE * lIn ; int V,v; if ( lOsx9orBetter < 0 ) { lOsx9orBetter = 0 ; lIn = popen( "osascript -e 'set osver to system version of (system info)'" , "r" ) ; if ( ( fgets( lBuff , sizeof( lBuff ) , lIn ) != NULL ) && ( 2 == sscanf(lBuff, "%d.%d", &V, &v) ) ) { V = V * 100 + v; if ( V >= 1009 ) { lOsx9orBetter = 1 ; } } pclose( lIn ) ; if (tinyfd_verbose) printf("Osx10 = %d, %d = %s\n", lOsx9orBetter, V, lBuff) ; } return lOsx9orBetter ; } static int python3Present(void) { static int lPython3Present = -1 ; int i; if ( lPython3Present < 0 ) { lPython3Present = 0 ; strcpy(gPython3Name , "python3" ) ; if ( detectPresence(gPython3Name) ) lPython3Present = 1; else { for ( i = 9 ; i >= 0 ; i -- ) { sprintf( gPython3Name , "python3.%d" , i ) ; if ( detectPresence(gPython3Name) ) { lPython3Present = 1; break; } } } if (tinyfd_verbose) printf("lPython3Present %d\n", lPython3Present) ; if (tinyfd_verbose) printf("gPython3Name %s\n", gPython3Name) ; } return lPython3Present ; } static int python2Present(void) { static int lPython2Present = -1 ; int i; if ( lPython2Present < 0 ) { lPython2Present = 0 ; strcpy(gPython2Name , "python2" ) ; if ( detectPresence(gPython2Name) ) lPython2Present = 1; else { for ( i = 9 ; i >= 0 ; i -- ) { sprintf( gPython2Name , "python2.%d" , i ) ; if ( detectPresence(gPython2Name) ) { lPython2Present = 1; break; } } } if (tinyfd_verbose) printf("lPython2Present %d\n", lPython2Present) ; if (tinyfd_verbose) printf("gPython2Name %s\n", gPython2Name) ; } return lPython2Present ; } static int tkinter3Present(void) { static int lTkinter3Present = -1 ; char lPythonCommand[256]; char lPythonParams[128] = "-S -c \"try:\n\timport tkinter;\nexcept:\n\tprint(0);\""; if ( lTkinter3Present < 0 ) { lTkinter3Present = 0 ; if ( python3Present() ) { sprintf( lPythonCommand , "%s %s" , gPython3Name , lPythonParams ) ; lTkinter3Present = tryCommand(lPythonCommand) ; } if (tinyfd_verbose) printf("lTkinter3Present %d\n", lTkinter3Present) ; } return lTkinter3Present && graphicMode() && !(isDarwin() && getenv("SSH_TTY") ); } static int tkinter2Present(void) { static int lTkinter2Present = -1 ; char lPythonCommand[256]; char lPythonParams[128] = "-S -c \"try:\n\timport Tkinter;\nexcept:\n\tprint 0;\""; if ( lTkinter2Present < 0 ) { lTkinter2Present = 0 ; if ( python2Present() ) { sprintf( lPythonCommand , "%s %s" , gPython2Name , lPythonParams ) ; lTkinter2Present = tryCommand(lPythonCommand) ; } if (tinyfd_verbose) printf("lTkinter2Present %d\n", lTkinter2Present) ; } return lTkinter2Present && graphicMode() && !(isDarwin() && getenv("SSH_TTY") ); } static int pythonDbusPresent(void) { static int lDbusPresent = -1 ; char lPythonCommand[384]; char lPythonParams[256] = "-c \"try:\n\timport dbus;bus=dbus.SessionBus();\ notif=bus.get_object('org.freedesktop.Notifications','/org/freedesktop/Notifications');\ notify=dbus.Interface(notif,'org.freedesktop.Notifications');\nexcept:\n\tprint(0);\""; if ( lDbusPresent < 0 ) { lDbusPresent = 0 ; if ( python2Present() ) { strcpy(gPythonName , gPython2Name ) ; sprintf( lPythonCommand , "%s %s" , gPythonName , lPythonParams ) ; lDbusPresent = tryCommand(lPythonCommand) ; } if ( ! lDbusPresent && python3Present() ) { strcpy(gPythonName , gPython3Name ) ; sprintf( lPythonCommand , "%s %s" , gPythonName , lPythonParams ) ; lDbusPresent = tryCommand(lPythonCommand) ; } if (tinyfd_verbose) printf("lDbusPresent %d\n", lDbusPresent) ; if (tinyfd_verbose) printf("gPythonName %s\n", gPythonName) ; } return lDbusPresent && graphicMode() && !(isDarwin() && getenv("SSH_TTY") ); } static void sigHandler(int sig) { FILE * lIn ; if ( ( lIn = popen( "pactl unload-module module-sine" , "r" ) ) ) { pclose( lIn ) ; } } void tinyfd_beep(void) { char lDialogString [256] ; FILE * lIn ; if ( osascriptPresent() ) { if ( afplayPresent() >= 2 ) { strcpy( lDialogString , "afplay /System/Library/Sounds/Ping.aiff") ; } else { strcpy( lDialogString , "osascript -e 'tell application \"System Events\" to beep'") ; } } else if ( pactlPresent() ) { signal(SIGINT, sigHandler); /*strcpy( lDialogString , "pactl load-module module-sine frequency=440;sleep .3;pactl unload-module module-sine" ) ;*/ strcpy( lDialogString , "thnum=$(pactl load-module module-sine frequency=440);sleep .3;pactl unload-module $thnum" ) ; } else if ( speakertestPresent() ) { /*strcpy( lDialogString , "timeout -k .3 .3 speaker-test --frequency 440 --test sine > /dev/tty" ) ;*/ strcpy( lDialogString , "( speaker-test -t sine -f 440 > /dev/tty )& pid=$!;sleep .3; kill -9 $pid" ) ; } else if ( beepexePresent() ) { strcpy( lDialogString , "beep.exe 440 300" ) ; } else { strcpy( lDialogString , "printf '\a' > /dev/tty" ) ; } if (tinyfd_verbose) printf( "lDialogString: %s\n" , lDialogString ) ; if ( ( lIn = popen( lDialogString , "r" ) ) ) { pclose( lIn ) ; } if ( pactlPresent() ) { signal(SIGINT, SIG_DFL); } } int tinyfd_messageBox( char const * aTitle , /* NULL or "" */ char const * aMessage , /* NULL or "" may contain \n and \t */ char const * aDialogType , /* "ok" "okcancel" "yesno" "yesnocancel" */ char const * aIconType , /* "info" "warning" "error" "question" */ int aDefaultButton ) /* 0 for cancel/no , 1 for ok/yes , 2 for no in yesnocancel */ { char lBuff [MAX_PATH_OR_CMD] ; char * lDialogString = NULL ; char * lpDialogString; FILE * lIn ; int lWasGraphicDialog = 0 ; int lWasXterm = 0 ; int lResult ; char lChar ; struct termios infoOri; struct termios info; size_t lTitleLen ; size_t lMessageLen ; lBuff[0]='\0'; lTitleLen = aTitle ? strlen(aTitle) : 0 ; lMessageLen = aMessage ? strlen(aMessage) : 0 ; if ( !aTitle || strcmp(aTitle,"tinyfd_query") ) { lDialogString = (char *) malloc( MAX_PATH_OR_CMD + lTitleLen + lMessageLen ); } if ( osascriptPresent( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"applescript");return 1;} strcpy( lDialogString , "osascript "); if ( ! osx9orBetter() ) strcat( lDialogString , " -e 'tell application \"System Events\"' -e 'Activate'"); strcat( lDialogString , " -e 'try' -e 'set {vButton} to {button returned} of ( display dialog \"") ; if ( aMessage && strlen(aMessage) ) { strcat(lDialogString, aMessage) ; } strcat(lDialogString, "\" ") ; if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, "with title \"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\" ") ; } strcat(lDialogString, "with icon ") ; if ( aIconType && ! strcmp( "error" , aIconType ) ) { strcat(lDialogString, "stop " ) ; } else if ( aIconType && ! strcmp( "warning" , aIconType ) ) { strcat(lDialogString, "caution " ) ; } else /* question or info */ { strcat(lDialogString, "note " ) ; } if ( aDialogType && ! strcmp( "okcancel" , aDialogType ) ) { if ( ! aDefaultButton ) { strcat( lDialogString ,"default button \"Cancel\" " ) ; } } else if ( aDialogType && ! strcmp( "yesno" , aDialogType ) ) { strcat( lDialogString ,"buttons {\"No\", \"Yes\"} " ) ; if (aDefaultButton) { strcat( lDialogString ,"default button \"Yes\" " ) ; } else { strcat( lDialogString ,"default button \"No\" " ) ; } strcat( lDialogString ,"cancel button \"No\"" ) ; } else if ( aDialogType && ! strcmp( "yesnocancel" , aDialogType ) ) { strcat( lDialogString ,"buttons {\"No\", \"Yes\", \"Cancel\"} " ) ; switch (aDefaultButton) { case 1: strcat( lDialogString ,"default button \"Yes\" " ) ; break; case 2: strcat( lDialogString ,"default button \"No\" " ) ; break; case 0: strcat( lDialogString ,"default button \"Cancel\" " ) ; break; } strcat( lDialogString ,"cancel button \"Cancel\"" ) ; } else { strcat( lDialogString ,"buttons {\"OK\"} " ) ; strcat( lDialogString ,"default button \"OK\" " ) ; } strcat( lDialogString, ")' ") ; strcat( lDialogString, "-e 'if vButton is \"Yes\" then' -e 'return 1'\ -e 'else if vButton is \"OK\" then' -e 'return 1'\ -e 'else if vButton is \"No\" then' -e 'return 2'\ -e 'else' -e 'return 0' -e 'end if' " ); strcat( lDialogString, "-e 'on error number -128' " ) ; strcat( lDialogString, "-e '0' " ); strcat( lDialogString, "-e 'end try'") ; if ( ! osx9orBetter() ) strcat( lDialogString, " -e 'end tell'") ; } else if ( kdialogPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"kdialog");return 1;} strcpy( lDialogString , "kdialog" ) ; if ( kdialogPresent() == 2 ) { strcat(lDialogString, " --attach=$(xprop -root 32x '\t$0' _NET_ACTIVE_WINDOW | cut -f 2)"); /* contribution: Paul Rouget */ } strcat( lDialogString , " --" ) ; if ( aDialogType && ( ! strcmp( "okcancel" , aDialogType ) || ! strcmp( "yesno" , aDialogType ) || ! strcmp( "yesnocancel" , aDialogType ) ) ) { if ( aIconType && ( ! strcmp( "warning" , aIconType ) || ! strcmp( "error" , aIconType ) ) ) { strcat( lDialogString , "warning" ) ; } if ( ! strcmp( "yesnocancel" , aDialogType ) ) { strcat( lDialogString , "yesnocancel" ) ; } else { strcat( lDialogString , "yesno" ) ; } } else if ( aIconType && ! strcmp( "error" , aIconType ) ) { strcat( lDialogString , "error" ) ; } else if ( aIconType && ! strcmp( "warning" , aIconType ) ) { strcat( lDialogString , "sorry" ) ; } else { strcat( lDialogString , "msgbox" ) ; } strcat( lDialogString , " \"" ) ; if ( aMessage ) { strcat( lDialogString , aMessage ) ; } strcat( lDialogString , "\"" ) ; if ( aDialogType && ! strcmp( "okcancel" , aDialogType ) ) { strcat( lDialogString , " --yes-label Ok --no-label Cancel" ) ; } if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, " --title \"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\"") ; } if ( ! strcmp( "yesnocancel" , aDialogType ) ) { strcat( lDialogString , "; x=$? ;if [ $x = 0 ] ;then echo 1;elif [ $x = 1 ] ;then echo 2;else echo 0;fi"); } else { strcat( lDialogString , ";if [ $? = 0 ];then echo 1;else echo 0;fi"); } } else if ( zenityPresent() || matedialogPresent() || shellementaryPresent() || qarmaPresent() ) { if ( zenityPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"zenity");return 1;} strcpy( lDialogString , "szAnswer=$(zenity" ) ; if ( (zenity3Present() >= 4) && !getenv("SSH_TTY") ) { strcat(lDialogString, " --attach=$(sleep .01;xprop -root 32x '\t$0' _NET_ACTIVE_WINDOW | cut -f 2)"); /* contribution: Paul Rouget */ } } else if ( matedialogPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"matedialog");return 1;} strcpy( lDialogString , "szAnswer=$(matedialog" ) ; } else if ( shellementaryPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"shellementary");return 1;} strcpy( lDialogString , "szAnswer=$(shellementary" ) ; } else { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"qarma");return 1;} strcpy( lDialogString , "szAnswer=$(qarma" ) ; if ( !getenv("SSH_TTY") ) { strcat(lDialogString, " --attach=$(xprop -root 32x '\t$0' _NET_ACTIVE_WINDOW | cut -f 2)"); /* contribution: Paul Rouget */ } } strcat(lDialogString, " --"); if ( aDialogType && ! strcmp( "okcancel" , aDialogType ) ) { strcat( lDialogString , "question --ok-label=Ok --cancel-label=Cancel" ) ; } else if ( aDialogType && ! strcmp( "yesno" , aDialogType ) ) { strcat( lDialogString , "question" ) ; } else if ( aDialogType && ! strcmp( "yesnocancel" , aDialogType ) ) { strcat( lDialogString , "list --column \"\" --hide-header \"Yes\" \"No\"" ) ; } else if ( aIconType && ! strcmp( "error" , aIconType ) ) { strcat( lDialogString , "error" ) ; } else if ( aIconType && ! strcmp( "warning" , aIconType ) ) { strcat( lDialogString , "warning" ) ; } else { strcat( lDialogString , "info" ) ; } if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, " --title=\"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\"") ; } if ( aMessage && strlen(aMessage) ) { strcat(lDialogString, " --no-wrap --text=\"") ; strcat(lDialogString, aMessage) ; strcat(lDialogString, "\"") ; } if ( (zenity3Present() >= 3) || (!zenityPresent() && (shellementaryPresent() || qarmaPresent()) ) ) { strcat( lDialogString , " --icon-name=dialog-" ) ; if ( aIconType && (! strcmp( "question" , aIconType ) || ! strcmp( "error" , aIconType ) || ! strcmp( "warning" , aIconType ) ) ) { strcat( lDialogString , aIconType ) ; } else { strcat( lDialogString , "information" ) ; } } if (tinyfd_silent) strcat( lDialogString , " 2>/dev/null "); if ( ! strcmp( "yesnocancel" , aDialogType ) ) { strcat( lDialogString , ");if [ $? = 1 ];then echo 0;elif [ $szAnswer = \"No\" ];then echo 2;else echo 1;fi"); } else { strcat( lDialogString , ");if [ $? = 0 ];then echo 1;else echo 0;fi"); } } else if ( !gxmessagePresent() && !gmessagePresent() && !gdialogPresent() && !xdialogPresent() && tkinter3Present() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"python3-tkinter");return 1;} strcpy( lDialogString , gPython3Name ) ; strcat( lDialogString , " -S -c \"import tkinter;from tkinter import messagebox;root=tkinter.Tk();root.withdraw();"); strcat( lDialogString ,"res=messagebox." ) ; if ( aDialogType && ! strcmp( "okcancel" , aDialogType ) ) { strcat( lDialogString , "askokcancel(" ) ; if ( aDefaultButton ) { strcat( lDialogString , "default=messagebox.OK," ) ; } else { strcat( lDialogString , "default=messagebox.CANCEL," ) ; } } else if ( aDialogType && ! strcmp( "yesno" , aDialogType ) ) { strcat( lDialogString , "askyesno(" ) ; if ( aDefaultButton ) { strcat( lDialogString , "default=messagebox.YES," ) ; } else { strcat( lDialogString , "default=messagebox.NO," ) ; } } else if ( aDialogType && ! strcmp( "yesnocancel" , aDialogType ) ) { strcat( lDialogString , "askyesnocancel(" ) ; switch ( aDefaultButton ) { case 1: strcat( lDialogString , "default=messagebox.YES," ); break; case 2: strcat( lDialogString , "default=messagebox.NO," ); break; case 0: strcat( lDialogString , "default=messagebox.CANCEL," ); break; } } else { strcat( lDialogString , "showinfo(" ) ; } strcat( lDialogString , "icon='" ) ; if ( aIconType && (! strcmp( "question" , aIconType ) || ! strcmp( "error" , aIconType ) || ! strcmp( "warning" , aIconType ) ) ) { strcat( lDialogString , aIconType ) ; } else { strcat( lDialogString , "info" ) ; } strcat(lDialogString, "',") ; if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, "title='") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "',") ; } if ( aMessage && strlen(aMessage) ) { strcat(lDialogString, "message='") ; lpDialogString = lDialogString + strlen(lDialogString); replaceSubStr( aMessage , "\n" , "\\n" , lpDialogString ) ; strcat(lDialogString, "'") ; } if ( aDialogType && ! strcmp( "yesnocancel" , aDialogType ) ) { strcat(lDialogString, ");\n\ if res is None :\n\tprint(0)\n\ elif res is False :\n\tprint(2)\n\ else :\n\tprint 1\n\"" ) ; } else { strcat(lDialogString, ");\n\ if res is False :\n\tprint(0)\n\ else :\n\tprint(1)\n\"" ) ; } } else if ( !gxmessagePresent() && !gmessagePresent() && !gdialogPresent() && !xdialogPresent() && tkinter2Present() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"python2-tkinter");return 1;} strcpy( lDialogString , "export PYTHONIOENCODING=utf-8;" ) ; strcat( lDialogString , gPython2Name ) ; if ( ! isTerminalRunning( ) && isDarwin( ) ) { strcat( lDialogString , " -i" ) ; /* for osx without console */ } strcat( lDialogString , " -S -c \"import Tkinter,tkMessageBox;root=Tkinter.Tk();root.withdraw();"); if ( isDarwin( ) ) { strcat( lDialogString , "import os;os.system('''/usr/bin/osascript -e 'tell app \\\"Finder\\\" to set \ frontmost of process \\\"Python\\\" to true' ''');"); } strcat( lDialogString ,"res=tkMessageBox." ) ; if ( aDialogType && ! strcmp( "okcancel" , aDialogType ) ) { strcat( lDialogString , "askokcancel(" ) ; if ( aDefaultButton ) { strcat( lDialogString , "default=tkMessageBox.OK," ) ; } else { strcat( lDialogString , "default=tkMessageBox.CANCEL," ) ; } } else if ( aDialogType && ! strcmp( "yesno" , aDialogType ) ) { strcat( lDialogString , "askyesno(" ) ; if ( aDefaultButton ) { strcat( lDialogString , "default=tkMessageBox.YES," ) ; } else { strcat( lDialogString , "default=tkMessageBox.NO," ) ; } } else if ( aDialogType && ! strcmp( "yesnocancel" , aDialogType ) ) { strcat( lDialogString , "askyesnocancel(" ) ; switch ( aDefaultButton ) { case 1: strcat( lDialogString , "default=tkMessageBox.YES," ); break; case 2: strcat( lDialogString , "default=tkMessageBox.NO," ); break; case 0: strcat( lDialogString , "default=tkMessageBox.CANCEL," ); break; } } else { strcat( lDialogString , "showinfo(" ) ; } strcat( lDialogString , "icon='" ) ; if ( aIconType && (! strcmp( "question" , aIconType ) || ! strcmp( "error" , aIconType ) || ! strcmp( "warning" , aIconType ) ) ) { strcat( lDialogString , aIconType ) ; } else { strcat( lDialogString , "info" ) ; } strcat(lDialogString, "',") ; if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, "title='") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "',") ; } if ( aMessage && strlen(aMessage) ) { strcat(lDialogString, "message='") ; lpDialogString = lDialogString + strlen(lDialogString); replaceSubStr( aMessage , "\n" , "\\n" , lpDialogString ) ; strcat(lDialogString, "'") ; } if ( aDialogType && ! strcmp( "yesnocancel" , aDialogType ) ) { strcat(lDialogString, ");\n\ if res is None :\n\tprint 0\n\ elif res is False :\n\tprint 2\n\ else :\n\tprint 1\n\"" ) ; } else { strcat(lDialogString, ");\n\ if res is False :\n\tprint 0\n\ else :\n\tprint 1\n\"" ) ; } } else if ( gxmessagePresent() || gmessagePresent() || (!gdialogPresent() && !xdialogPresent() && xmessagePresent()) ) { if ( gxmessagePresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"gxmessage");return 1;} strcpy( lDialogString , "gxmessage"); } else if ( gmessagePresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"gmessage");return 1;} strcpy( lDialogString , "gmessage"); } else { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"xmessage");return 1;} strcpy( lDialogString , "xmessage"); } if ( aDialogType && ! strcmp("okcancel" , aDialogType) ) { strcat( lDialogString , " -buttons Ok:1,Cancel:0"); switch ( aDefaultButton ) { case 1: strcat( lDialogString , " -default Ok"); break; case 0: strcat( lDialogString , " -default Cancel"); break; } } else if ( aDialogType && ! strcmp("yesno" , aDialogType) ) { strcat( lDialogString , " -buttons Yes:1,No:0"); switch ( aDefaultButton ) { case 1: strcat( lDialogString , " -default Yes"); break; case 0: strcat( lDialogString , " -default No"); break; } } else if ( aDialogType && ! strcmp("yesnocancel" , aDialogType) ) { strcat( lDialogString , " -buttons Yes:1,No:2,Cancel:0"); switch ( aDefaultButton ) { case 1: strcat( lDialogString , " -default Yes"); break; case 2: strcat( lDialogString , " -default No"); break; case 0: strcat( lDialogString , " -default Cancel"); break; } } else { strcat( lDialogString , " -buttons Ok:1"); strcat( lDialogString , " -default Ok"); } strcat( lDialogString , " -center \""); if ( aMessage && strlen(aMessage) ) { strcat( lDialogString , aMessage ) ; } strcat(lDialogString, "\"" ) ; if ( aTitle && strlen(aTitle) ) { strcat( lDialogString , " -title \""); strcat( lDialogString , aTitle ) ; strcat( lDialogString, "\"" ) ; } strcat( lDialogString , " ; echo $? "); } else if ( xdialogPresent() || gdialogPresent() || dialogName() || whiptailPresent() ) { if ( gdialogPresent( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"gdialog");return 1;} lWasGraphicDialog = 1 ; strcpy( lDialogString , "(gdialog " ) ; } else if ( xdialogPresent( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"xdialog");return 1;} lWasGraphicDialog = 1 ; strcpy( lDialogString , "(Xdialog " ) ; } else if ( dialogName( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"dialog");return 0;} if ( isTerminalRunning( ) ) { strcpy( lDialogString , "(dialog " ) ; } else { lWasXterm = 1 ; strcpy( lDialogString , terminalName() ) ; strcat( lDialogString , "'(" ) ; strcat( lDialogString , dialogName() ) ; strcat( lDialogString , " " ) ; } } else if ( isTerminalRunning( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"whiptail");return 0;} strcpy( lDialogString , "(whiptail " ) ; } else { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"whiptail");return 0;} lWasXterm = 1 ; strcpy( lDialogString , terminalName() ) ; strcat( lDialogString , "'(whiptail " ) ; } if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, "--title \"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\" ") ; } if ( !xdialogPresent() && !gdialogPresent() ) { if ( aDialogType && ( !strcmp( "okcancel" , aDialogType ) || !strcmp( "yesno" , aDialogType ) || !strcmp( "yesnocancel" , aDialogType ) ) ) { strcat(lDialogString, "--backtitle \"") ; strcat(lDialogString, "tab: move focus") ; strcat(lDialogString, "\" ") ; } } if ( aDialogType && ! strcmp( "okcancel" , aDialogType ) ) { if ( ! aDefaultButton ) { strcat( lDialogString , "--defaultno " ) ; } strcat( lDialogString , "--yes-label \"Ok\" --no-label \"Cancel\" --yesno " ) ; } else if ( aDialogType && ! strcmp( "yesno" , aDialogType ) ) { if ( ! aDefaultButton ) { strcat( lDialogString , "--defaultno " ) ; } strcat( lDialogString , "--yesno " ) ; } else if (aDialogType && !strcmp("yesnocancel", aDialogType)) { if (!aDefaultButton) { strcat(lDialogString, "--defaultno "); } strcat(lDialogString, "--menu "); } else { strcat( lDialogString , "--msgbox " ) ; } strcat( lDialogString , "\"" ) ; if ( aMessage && strlen(aMessage) ) { strcat(lDialogString, aMessage) ; } strcat(lDialogString, "\" "); if ( lWasGraphicDialog ) { if (aDialogType && !strcmp("yesnocancel", aDialogType)) { strcat(lDialogString,"0 60 0 Yes \"\" No \"\") 2>/tmp/tinyfd.txt;\ if [ $? = 0 ];then tinyfdBool=1;else tinyfdBool=0;fi;\ tinyfdRes=$(cat /tmp/tinyfd.txt);echo $tinyfdBool$tinyfdRes") ; } else { strcat(lDialogString, "10 60 ) 2>&1;if [ $? = 0 ];then echo 1;else echo 0;fi"); } } else { if (aDialogType && !strcmp("yesnocancel", aDialogType)) { strcat(lDialogString,"0 60 0 Yes \"\" No \"\" >/dev/tty ) 2>/tmp/tinyfd.txt;\ if [ $? = 0 ];then tinyfdBool=1;else tinyfdBool=0;fi;\ tinyfdRes=$(cat /tmp/tinyfd.txt);echo $tinyfdBool$tinyfdRes") ; if ( lWasXterm ) { strcat(lDialogString," >/tmp/tinyfd0.txt';cat /tmp/tinyfd0.txt"); } else { strcat(lDialogString, "; clear >/dev/tty") ; } } else { strcat(lDialogString, "10 60 >/dev/tty) 2>&1;if [ $? = 0 ];"); if ( lWasXterm ) { strcat( lDialogString , "then\n\techo 1\nelse\n\techo 0\nfi >/tmp/tinyfd.txt';cat /tmp/tinyfd.txt;rm /tmp/tinyfd.txt"); } else { strcat(lDialogString, "then echo 1;else echo 0;fi;clear >/dev/tty"); } } } } else if ( !isTerminalRunning() && terminalName() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"basicinput");return 0;} strcpy( lDialogString , terminalName() ) ; strcat( lDialogString , "'" ) ; if ( !gWarningDisplayed && !tinyfd_forceConsole) { gWarningDisplayed = 1 ; strcat( lDialogString , "echo \"" ) ; strcat( lDialogString, gTitle) ; strcat( lDialogString , "\";" ) ; strcat( lDialogString , "echo \"" ) ; strcat( lDialogString, tinyfd_needs) ; strcat( lDialogString , "\";echo;echo;" ) ; } if ( aTitle && strlen(aTitle) ) { strcat( lDialogString , "echo \"" ) ; strcat( lDialogString, aTitle) ; strcat( lDialogString , "\";echo;" ) ; } if ( aMessage && strlen(aMessage) ) { strcat( lDialogString , "echo \"" ) ; strcat( lDialogString, aMessage) ; strcat( lDialogString , "\"; " ) ; } if ( aDialogType && !strcmp("yesno",aDialogType) ) { strcat( lDialogString , "echo -n \"y/n: \"; " ) ; strcat( lDialogString , "stty sane -echo;" ) ; strcat( lDialogString , "answer=$( while ! head -c 1 | grep -i [ny];do true ;done);"); strcat( lDialogString , "if echo \"$answer\" | grep -iq \"^y\";then\n"); strcat( lDialogString , "\techo 1\nelse\n\techo 0\nfi" ) ; } else if ( aDialogType && !strcmp("okcancel",aDialogType) ) { strcat( lDialogString , "echo -n \"[O]kay/[C]ancel: \"; " ) ; strcat( lDialogString , "stty sane -echo;" ) ; strcat( lDialogString , "answer=$( while ! head -c 1 | grep -i [oc];do true ;done);"); strcat( lDialogString , "if echo \"$answer\" | grep -iq \"^o\";then\n"); strcat( lDialogString , "\techo 1\nelse\n\techo 0\nfi" ) ; } else if ( aDialogType && !strcmp("yesnocancel",aDialogType) ) { strcat( lDialogString , "echo -n \"[Y]es/[N]o/[C]ancel: \"; " ) ; strcat( lDialogString , "stty sane -echo;" ) ; strcat( lDialogString , "answer=$( while ! head -c 1 | grep -i [nyc];do true ;done);"); strcat( lDialogString , "if echo \"$answer\" | grep -iq \"^y\";then\n\techo 1\n"); strcat( lDialogString , "elif echo \"$answer\" | grep -iq \"^n\";then\n\techo 2\n" ) ; strcat( lDialogString , "else\n\techo 0\nfi" ) ; } else { strcat(lDialogString , "echo -n \"press enter to continue \"; "); strcat( lDialogString , "stty sane -echo;" ) ; strcat( lDialogString , "answer=$( while ! head -c 1;do true ;done);echo 1"); } strcat( lDialogString , " >/tmp/tinyfd.txt';cat /tmp/tinyfd.txt;rm /tmp/tinyfd.txt"); } else if ( !isTerminalRunning() && pythonDbusPresent() && !strcmp("ok" , aDialogType) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"python-dbus");return 1;} strcpy( lDialogString , gPythonName ) ; strcat( lDialogString ," -c \"import dbus;bus=dbus.SessionBus();"); strcat( lDialogString ,"notif=bus.get_object('org.freedesktop.Notifications','/org/freedesktop/Notifications');" ) ; strcat( lDialogString ,"notify=dbus.Interface(notif,'org.freedesktop.Notifications');" ) ; strcat( lDialogString ,"notify.Notify('',0,'" ) ; if ( aIconType && strlen(aIconType) ) { strcat( lDialogString , aIconType ) ; } strcat(lDialogString, "','") ; if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, aTitle) ; } strcat(lDialogString, "','") ; if ( aMessage && strlen(aMessage) ) { lpDialogString = lDialogString + strlen(lDialogString); replaceSubStr( aMessage , "\n" , "\\n" , lpDialogString ) ; } strcat(lDialogString, "','','',5000)\"") ; } else if ( !isTerminalRunning() && (perlPresent() >= 2) && !strcmp("ok" , aDialogType) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"perl-dbus");return 1;} strcpy( lDialogString , "perl -e \"use Net::DBus;\ my \\$sessionBus = Net::DBus->session;\ my \\$notificationsService = \\$sessionBus->get_service('org.freedesktop.Notifications');\ my \\$notificationsObject = \\$notificationsService->get_object('/org/freedesktop/Notifications',\ 'org.freedesktop.Notifications');"); sprintf( lDialogString + strlen(lDialogString), "my \\$notificationId;\\$notificationId = \\$notificationsObject->Notify(shift, 0, '%s', '%s', '%s', [], {}, -1);\" ", aIconType?aIconType:"", aTitle?aTitle:"", aMessage?aMessage:"" ) ; } else if ( !isTerminalRunning() && notifysendPresent() && !strcmp("ok" , aDialogType) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"notifysend");return 1;} strcpy( lDialogString , "notify-send" ) ; if ( aIconType && strlen(aIconType) ) { strcat( lDialogString , " -i '" ) ; strcat( lDialogString , aIconType ) ; strcat( lDialogString , "'" ) ; } strcat( lDialogString , " \"" ) ; if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, aTitle) ; strcat( lDialogString , " | " ) ; } if ( aMessage && strlen(aMessage) ) { replaceSubStr( aMessage , "\n\t" , " | " , lBuff ) ; replaceSubStr( aMessage , "\n" , " | " , lBuff ) ; replaceSubStr( aMessage , "\t" , " " , lBuff ) ; strcat(lDialogString, lBuff) ; } strcat( lDialogString , "\"" ) ; } else { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"basicinput");return 0;} if ( !gWarningDisplayed && !tinyfd_forceConsole) { gWarningDisplayed = 1 ; printf("\n\n%s\n", gTitle); printf("%s\n\n", tinyfd_needs); } if ( aTitle && strlen(aTitle) ) { printf("\n%s\n", aTitle); } tcgetattr(0, &infoOri); tcgetattr(0, &info); info.c_lflag &= ~ICANON; info.c_cc[VMIN] = 1; info.c_cc[VTIME] = 0; tcsetattr(0, TCSANOW, &info); if ( aDialogType && !strcmp("yesno",aDialogType) ) { do { if ( aMessage && strlen(aMessage) ) { printf("\n%s\n",aMessage); } printf("y/n: "); fflush(stdout); lChar = tolower( getchar() ) ; printf("\n\n"); } while ( lChar != 'y' && lChar != 'n' ); lResult = lChar == 'y' ? 1 : 0 ; } else if ( aDialogType && !strcmp("okcancel",aDialogType) ) { do { if ( aMessage && strlen(aMessage) ) { printf("\n%s\n",aMessage); } printf("[O]kay/[C]ancel: "); fflush(stdout); lChar = tolower( getchar() ) ; printf("\n\n"); } while ( lChar != 'o' && lChar != 'c' ); lResult = lChar == 'o' ? 1 : 0 ; } else if ( aDialogType && !strcmp("yesnocancel",aDialogType) ) { do { if ( aMessage && strlen(aMessage) ) { printf("\n%s\n",aMessage); } printf("[Y]es/[N]o/[C]ancel: "); fflush(stdout); lChar = tolower( getchar() ) ; printf("\n\n"); } while ( lChar != 'y' && lChar != 'n' && lChar != 'c' ); lResult = (lChar == 'y') ? 1 : (lChar == 'n') ? 2 : 0 ; } else { if ( aMessage && strlen(aMessage) ) { printf("\n%s\n\n",aMessage); } printf("press enter to continue "); fflush(stdout); getchar() ; printf("\n\n"); lResult = 1 ; } tcsetattr(0, TCSANOW, &infoOri); free(lDialogString); return lResult ; } if (tinyfd_verbose) printf( "lDialogString: %s\n" , lDialogString ) ; if ( ! ( lIn = popen( lDialogString , "r" ) ) ) { free(lDialogString); return 0 ; } while ( fgets( lBuff , sizeof( lBuff ) , lIn ) != NULL ) {} pclose( lIn ) ; /* printf( "lBuff: %s len: %lu \n" , lBuff , strlen(lBuff) ) ; */ if ( lBuff[strlen( lBuff ) -1] == '\n' ) { lBuff[strlen( lBuff ) -1] = '\0' ; } /* printf( "lBuff1: %s len: %lu \n" , lBuff , strlen(lBuff) ) ; */ if (aDialogType && !strcmp("yesnocancel", aDialogType)) { if ( lBuff[0]=='1' ) { if ( !strcmp( lBuff+1 , "Yes" )) strcpy(lBuff,"1"); else if ( !strcmp( lBuff+1 , "No" )) strcpy(lBuff,"2"); } } /* printf( "lBuff2: %s len: %lu \n" , lBuff , strlen(lBuff) ) ; */ lResult = !strcmp( lBuff , "2" ) ? 2 : !strcmp( lBuff , "1" ) ? 1 : 0; /* printf( "lResult: %d\n" , lResult ) ; */ free(lDialogString); return lResult ; } /* return has only meaning for tinyfd_query */ int tinyfd_notifyPopup( char const * aTitle , /* NULL or "" */ char const * aMessage , /* NULL or "" may contain \n and \t */ char const * aIconType ) /* "info" "warning" "error" */ { char lBuff[MAX_PATH_OR_CMD]; char * lDialogString = NULL ; char * lpDialogString ; FILE * lIn ; size_t lTitleLen ; size_t lMessageLen ; if ( getenv("SSH_TTY") ) { return tinyfd_messageBox(aTitle, aMessage, "ok", aIconType, 0); } lTitleLen = aTitle ? strlen(aTitle) : 0 ; lMessageLen = aMessage ? strlen(aMessage) : 0 ; if ( !aTitle || strcmp(aTitle,"tinyfd_query") ) { lDialogString = (char *) malloc( MAX_PATH_OR_CMD + lTitleLen + lMessageLen ); } if ( osascriptPresent( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"applescript");return 1;} strcpy( lDialogString , "osascript "); if ( ! osx9orBetter() ) strcat( lDialogString , " -e 'tell application \"System Events\"' -e 'Activate'"); strcat( lDialogString , " -e 'try' -e 'display notification \"") ; if ( aMessage && strlen(aMessage) ) { strcat(lDialogString, aMessage) ; } strcat(lDialogString, " \" ") ; if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, "with title \"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\" ") ; } strcat( lDialogString, "' -e 'end try'") ; if ( ! osx9orBetter() ) strcat( lDialogString, " -e 'end tell'") ; } else if ( kdialogPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"kdialog");return 1;} strcpy( lDialogString , "kdialog" ) ; if ( aIconType && strlen(aIconType) ) { strcat( lDialogString , " --icon '" ) ; strcat( lDialogString , aIconType ) ; strcat( lDialogString , "'" ) ; } if ( aTitle && strlen(aTitle) ) { strcat( lDialogString , " --title \"" ) ; strcat( lDialogString , aTitle ) ; strcat( lDialogString , "\"" ) ; } strcat( lDialogString , " --passivepopup" ) ; strcat( lDialogString , " \"" ) ; if ( aMessage ) { strcat( lDialogString , aMessage ) ; } strcat( lDialogString , " \" 5" ) ; } else if ( (zenity3Present()>=5) || matedialogPresent() || shellementaryPresent() || qarmaPresent() ) { /* zenity 2.32 & 3.14 has the notification but with a bug: it doesnt return from it */ /* zenity 3.8 show the notification as an alert ok cancel box */ if ( zenity3Present()>=5 ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"zenity");return 1;} strcpy( lDialogString , "zenity" ) ; } else if ( matedialogPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"matedialog");return 1;} strcpy( lDialogString , "matedialog" ) ; } else if ( shellementaryPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"shellementary");return 1;} strcpy( lDialogString , "shellementary" ) ; } else { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"qarma");return 1;} strcpy( lDialogString , "qarma" ) ; } strcat( lDialogString , " --notification"); if ( aIconType && strlen( aIconType ) ) { strcat( lDialogString , " --window-icon '"); strcat( lDialogString , aIconType ) ; strcat( lDialogString , "'" ) ; } strcat( lDialogString , " --text \"" ) ; if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, aTitle) ; strcat(lDialogString, "\n") ; } if ( aMessage && strlen( aMessage ) ) { strcat( lDialogString , aMessage ) ; } strcat( lDialogString , " \"" ) ; } else if ( perlPresent() >= 2 ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"perl-dbus");return 1;} strcpy( lDialogString , "perl -e \"use Net::DBus;\ my \\$sessionBus = Net::DBus->session;\ my \\$notificationsService = \\$sessionBus->get_service('org.freedesktop.Notifications');\ my \\$notificationsObject = \\$notificationsService->get_object('/org/freedesktop/Notifications',\ 'org.freedesktop.Notifications');"); sprintf( lDialogString + strlen(lDialogString) , "my \\$notificationId;\\$notificationId = \\$notificationsObject->Notify(shift, 0, '%s', '%s', '%s', [], {}, -1);\" ", aIconType?aIconType:"", aTitle?aTitle:"", aMessage?aMessage:"" ) ; } else if ( pythonDbusPresent( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"python-dbus");return 1;} strcpy( lDialogString , gPythonName ) ; strcat( lDialogString ," -c \"import dbus;bus=dbus.SessionBus();"); strcat( lDialogString ,"notif=bus.get_object('org.freedesktop.Notifications','/org/freedesktop/Notifications');" ) ; strcat( lDialogString ,"notify=dbus.Interface(notif,'org.freedesktop.Notifications');" ) ; strcat( lDialogString ,"notify.Notify('',0,'" ) ; if ( aIconType && strlen(aIconType) ) { strcat( lDialogString , aIconType ) ; } strcat(lDialogString, "','") ; if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, aTitle) ; } strcat(lDialogString, "','") ; if ( aMessage && strlen(aMessage) ) { lpDialogString = lDialogString + strlen(lDialogString); replaceSubStr( aMessage , "\n" , "\\n" , lpDialogString ) ; } strcat(lDialogString, "','','',5000)\"") ; } else if ( notifysendPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"notifysend");return 1;} strcpy( lDialogString , "notify-send" ) ; if ( aIconType && strlen(aIconType) ) { strcat( lDialogString , " -i '" ) ; strcat( lDialogString , aIconType ) ; strcat( lDialogString , "'" ) ; } strcat( lDialogString , " \"" ) ; if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, aTitle) ; strcat( lDialogString , " | " ) ; } if ( aMessage && strlen(aMessage) ) { replaceSubStr( aMessage , "\n\t" , " | " , lBuff ) ; replaceSubStr( aMessage , "\n" , " | " , lBuff ) ; replaceSubStr( aMessage , "\t" , " " , lBuff ) ; strcat(lDialogString, lBuff) ; } strcat( lDialogString , "\"" ) ; } else { return tinyfd_messageBox(aTitle, aMessage, "ok", aIconType, 0); } if (tinyfd_verbose) printf( "lDialogString: %s\n" , lDialogString ) ; if ( ! ( lIn = popen( lDialogString , "r" ) ) ) { free(lDialogString); return 0 ; } pclose( lIn ) ; free(lDialogString); return 1; } /* returns NULL on cancel */ char * tinyfd_inputBox( char const * aTitle , /* NULL or "" */ char const * aMessage , /* NULL or "" may NOT contain \n nor \t */ char const * aDefaultInput ) /* "" , if NULL it's a passwordBox */ { static char lBuff[MAX_PATH_OR_CMD]; char * lDialogString = NULL; char * lpDialogString; FILE * lIn ; int lResult ; int lWasGdialog = 0 ; int lWasGraphicDialog = 0 ; int lWasXterm = 0 ; int lWasBasicXterm = 0 ; struct termios oldt ; struct termios newt ; char * lEOF; size_t lTitleLen ; size_t lMessageLen ; if (!aTitle && !aMessage && !aDefaultInput) return lBuff; /* now I can fill lBuff from outside */ lBuff[0]='\0'; lTitleLen = aTitle ? strlen(aTitle) : 0 ; lMessageLen = aMessage ? strlen(aMessage) : 0 ; if ( !aTitle || strcmp(aTitle,"tinyfd_query") ) { lDialogString = (char *) malloc( MAX_PATH_OR_CMD + lTitleLen + lMessageLen ); } if ( osascriptPresent( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"applescript");return (char *)1;} strcpy( lDialogString , "osascript "); if ( ! osx9orBetter() ) strcat( lDialogString , " -e 'tell application \"System Events\"' -e 'Activate'"); strcat( lDialogString , " -e 'try' -e 'display dialog \"") ; if ( aMessage && strlen(aMessage) ) { strcat(lDialogString, aMessage) ; } strcat(lDialogString, "\" ") ; strcat(lDialogString, "default answer \"") ; if ( aDefaultInput && strlen(aDefaultInput) ) { strcat(lDialogString, aDefaultInput) ; } strcat(lDialogString, "\" ") ; if ( ! aDefaultInput ) { strcat(lDialogString, "hidden answer true ") ; } if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, "with title \"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\" ") ; } strcat(lDialogString, "with icon note' ") ; strcat(lDialogString, "-e '\"1\" & text returned of result' " ); strcat(lDialogString, "-e 'on error number -128' " ) ; strcat(lDialogString, "-e '0' " ); strcat(lDialogString, "-e 'end try'") ; if ( ! osx9orBetter() ) strcat(lDialogString, " -e 'end tell'") ; } else if ( kdialogPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"kdialog");return (char *)1;} strcpy( lDialogString , "szAnswer=$(kdialog" ) ; if ( kdialogPresent() == 2 ) { strcat(lDialogString, " --attach=$(xprop -root 32x '\t$0' _NET_ACTIVE_WINDOW | cut -f 2)"); /* contribution: Paul Rouget */ } if ( ! aDefaultInput ) { strcat(lDialogString, " --password ") ; } else { strcat(lDialogString, " --inputbox ") ; } strcat(lDialogString, "\"") ; if ( aMessage && strlen(aMessage) ) { strcat(lDialogString, aMessage ) ; } strcat(lDialogString , "\" \"" ) ; if ( aDefaultInput && strlen(aDefaultInput) ) { strcat(lDialogString, aDefaultInput ) ; } strcat(lDialogString , "\"" ) ; if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, " --title \"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\"") ; } strcat( lDialogString , ");if [ $? = 0 ];then echo 1$szAnswer;else echo 0$szAnswer;fi"); } else if ( zenityPresent() || matedialogPresent() || shellementaryPresent() || qarmaPresent() ) { if ( zenityPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"zenity");return (char *)1;} strcpy( lDialogString , "szAnswer=$(zenity" ) ; if ( (zenity3Present() >= 4) && !getenv("SSH_TTY") ) { strcat( lDialogString, " --attach=$(sleep .01;xprop -root 32x '\t$0' _NET_ACTIVE_WINDOW | cut -f 2)"); /* contribution: Paul Rouget */ } } else if ( matedialogPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"matedialog");return (char *)1;} strcpy( lDialogString , "szAnswer=$(matedialog" ) ; } else if ( shellementaryPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"shellementary");return (char *)1;} strcpy( lDialogString , "szAnswer=$(shellementary" ) ; } else { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"qarma");return (char *)1;} strcpy( lDialogString , "szAnswer=$(qarma" ) ; if ( !getenv("SSH_TTY") ) { strcat(lDialogString, " --attach=$(xprop -root 32x '\t$0' _NET_ACTIVE_WINDOW | cut -f 2)"); /* contribution: Paul Rouget */ } } strcat( lDialogString ," --entry" ) ; if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, " --title=\"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\"") ; } if ( aMessage && strlen(aMessage) ) { strcat(lDialogString, " --text=\"") ; strcat(lDialogString, aMessage) ; strcat(lDialogString, "\"") ; } if ( aDefaultInput && strlen(aDefaultInput) ) { strcat(lDialogString, " --entry-text=\"") ; strcat(lDialogString, aDefaultInput) ; strcat(lDialogString, "\"") ; } else { strcat(lDialogString, " --hide-text") ; } if (tinyfd_silent) strcat( lDialogString , " 2>/dev/null "); strcat( lDialogString , ");if [ $? = 0 ];then echo 1$szAnswer;else echo 0$szAnswer;fi"); } else if ( gxmessagePresent() || gmessagePresent() ) { if ( gxmessagePresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"gxmessage");return (char *)1;} strcpy( lDialogString , "szAnswer=$(gxmessage -buttons Ok:1,Cancel:0 -center \""); } else { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"gmessage");return (char *)1;} strcpy( lDialogString , "szAnswer=$(gmessage -buttons Ok:1,Cancel:0 -center \""); } if ( aMessage && strlen(aMessage) ) { strcat( lDialogString , aMessage ) ; } strcat(lDialogString, "\"" ) ; if ( aTitle && strlen(aTitle) ) { strcat( lDialogString , " -title \""); strcat( lDialogString , aTitle ) ; strcat(lDialogString, "\" " ) ; } strcat(lDialogString, " -entrytext \"" ) ; if ( aDefaultInput && strlen(aDefaultInput) ) { strcat( lDialogString , aDefaultInput ) ; } strcat(lDialogString, "\"" ) ; strcat( lDialogString , ");echo $?$szAnswer"); } else if ( !gdialogPresent() && !xdialogPresent() && tkinter3Present( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"python3-tkinter");return (char *)1;} strcpy( lDialogString , gPython3Name ) ; strcat( lDialogString , " -S -c \"import tkinter; from tkinter import simpledialog;root=tkinter.Tk();root.withdraw();"); strcat( lDialogString ,"res=simpledialog.askstring(" ) ; if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, "title='") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "',") ; } if ( aMessage && strlen(aMessage) ) { strcat(lDialogString, "prompt='") ; lpDialogString = lDialogString + strlen(lDialogString); replaceSubStr( aMessage , "\n" , "\\n" , lpDialogString ) ; strcat(lDialogString, "',") ; } if ( aDefaultInput ) { if ( strlen(aDefaultInput) ) { strcat(lDialogString, "initialvalue='") ; strcat(lDialogString, aDefaultInput) ; strcat(lDialogString, "',") ; } } else { strcat(lDialogString, "show='*'") ; } strcat(lDialogString, ");\nif res is None :\n\tprint(0)"); strcat(lDialogString, "\nelse :\n\tprint('1'+res)\n\"" ) ; } else if ( !gdialogPresent() && !xdialogPresent() && tkinter2Present( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"python2-tkinter");return (char *)1;} strcpy( lDialogString , "export PYTHONIOENCODING=utf-8;" ) ; strcat( lDialogString , gPython2Name ) ; if ( ! isTerminalRunning( ) && isDarwin( ) ) { strcat( lDialogString , " -i" ) ; /* for osx without console */ } strcat( lDialogString , " -S -c \"import Tkinter,tkSimpleDialog;root=Tkinter.Tk();root.withdraw();"); if ( isDarwin( ) ) { strcat( lDialogString , "import os;os.system('''/usr/bin/osascript -e 'tell app \\\"Finder\\\" to set \ frontmost of process \\\"Python\\\" to true' ''');"); } strcat( lDialogString ,"res=tkSimpleDialog.askstring(" ) ; if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, "title='") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "',") ; } if ( aMessage && strlen(aMessage) ) { strcat(lDialogString, "prompt='") ; lpDialogString = lDialogString + strlen(lDialogString); replaceSubStr( aMessage , "\n" , "\\n" , lpDialogString ) ; strcat(lDialogString, "',") ; } if ( aDefaultInput ) { if ( strlen(aDefaultInput) ) { strcat(lDialogString, "initialvalue='") ; strcat(lDialogString, aDefaultInput) ; strcat(lDialogString, "',") ; } } else { strcat(lDialogString, "show='*'") ; } strcat(lDialogString, ");\nif res is None :\n\tprint 0"); strcat(lDialogString, "\nelse :\n\tprint '1'+res\n\"" ) ; } else if ( gdialogPresent() || xdialogPresent() || dialogName() || whiptailPresent() ) { if ( gdialogPresent( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"gdialog");return (char *)1;} lWasGraphicDialog = 1 ; lWasGdialog = 1 ; strcpy( lDialogString , "(gdialog " ) ; } else if ( xdialogPresent( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"xdialog");return (char *)1;} lWasGraphicDialog = 1 ; strcpy( lDialogString , "(Xdialog " ) ; } else if ( dialogName( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"dialog");return (char *)0;} if ( isTerminalRunning( ) ) { strcpy( lDialogString , "(dialog " ) ; } else { lWasXterm = 1 ; strcpy( lDialogString , terminalName() ) ; strcat( lDialogString , "'(" ) ; strcat( lDialogString , dialogName() ) ; strcat( lDialogString , " " ) ; } } else if ( isTerminalRunning( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"whiptail");return (char *)0;} strcpy( lDialogString , "(whiptail " ) ; } else { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"whiptail");return (char *)0;} lWasXterm = 1 ; strcpy( lDialogString , terminalName() ) ; strcat( lDialogString , "'(whiptail " ) ; } if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, "--title \"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\" ") ; } if ( !xdialogPresent() && !gdialogPresent() ) { strcat(lDialogString, "--backtitle \"") ; strcat(lDialogString, "tab: move focus") ; if ( ! aDefaultInput && !lWasGdialog ) { strcat(lDialogString, " (sometimes nothing, no blink nor star, is shown in text field)") ; } strcat(lDialogString, "\" ") ; } if ( aDefaultInput || lWasGdialog ) { strcat( lDialogString , "--inputbox" ) ; } else { if ( !lWasGraphicDialog && dialogName() && isDialogVersionBetter09b() ) { strcat( lDialogString , "--insecure " ) ; } strcat( lDialogString , "--passwordbox" ) ; } strcat( lDialogString , " \"" ) ; if ( aMessage && strlen(aMessage) ) { strcat(lDialogString, aMessage) ; } strcat(lDialogString,"\" 10 60 ") ; if ( aDefaultInput && strlen(aDefaultInput) ) { strcat(lDialogString, "\"") ; strcat(lDialogString, aDefaultInput) ; strcat(lDialogString, "\" ") ; } if ( lWasGraphicDialog ) { strcat(lDialogString,") 2>/tmp/tinyfd.txt;\ if [ $? = 0 ];then tinyfdBool=1;else tinyfdBool=0;fi;\ tinyfdRes=$(cat /tmp/tinyfd.txt);echo $tinyfdBool$tinyfdRes") ; } else { strcat(lDialogString,">/dev/tty ) 2>/tmp/tinyfd.txt;\ if [ $? = 0 ];then tinyfdBool=1;else tinyfdBool=0;fi;\ tinyfdRes=$(cat /tmp/tinyfd.txt);echo $tinyfdBool$tinyfdRes") ; if ( lWasXterm ) { strcat(lDialogString," >/tmp/tinyfd0.txt';cat /tmp/tinyfd0.txt"); } else { strcat(lDialogString, "; clear >/dev/tty") ; } } } else if ( ! isTerminalRunning( ) && terminalName() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"basicinput");return (char *)0;} lWasBasicXterm = 1 ; strcpy( lDialogString , terminalName() ) ; strcat( lDialogString , "'" ) ; if ( !gWarningDisplayed && !tinyfd_forceConsole) { gWarningDisplayed = 1 ; tinyfd_messageBox(gTitle,tinyfd_needs,"ok","warning",0); } if ( aTitle && strlen(aTitle) && !tinyfd_forceConsole) { strcat( lDialogString , "echo \"" ) ; strcat( lDialogString, aTitle) ; strcat( lDialogString , "\";echo;" ) ; } strcat( lDialogString , "echo \"" ) ; if ( aMessage && strlen(aMessage) ) { strcat( lDialogString, aMessage) ; } strcat( lDialogString , "\";read " ) ; if ( ! aDefaultInput ) { strcat( lDialogString , "-s " ) ; } strcat( lDialogString , "-p \"" ) ; strcat( lDialogString , "(esc+enter to cancel): \" ANSWER " ) ; strcat( lDialogString , ";echo 1$ANSWER >/tmp/tinyfd.txt';" ) ; strcat( lDialogString , "cat -v /tmp/tinyfd.txt"); } else if ( !gWarningDisplayed && ! isTerminalRunning( ) && ! terminalName() ) { gWarningDisplayed = 1 ; tinyfd_messageBox(gTitle,tinyfd_needs,"ok","warning",0); if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"no_solution");return (char *)0;} free(lDialogString); return NULL; } else { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"basicinput");return (char *)0;} if ( !gWarningDisplayed && !tinyfd_forceConsole) { gWarningDisplayed = 1 ; tinyfd_messageBox(gTitle,tinyfd_needs,"ok","warning",0); } if ( aTitle && strlen(aTitle) ) { printf("\n%s\n", aTitle); } if ( aMessage && strlen(aMessage) ) { printf("\n%s\n",aMessage); } printf("(esc+enter to cancel): "); fflush(stdout); if ( ! aDefaultInput ) { tcgetattr(STDIN_FILENO, & oldt) ; newt = oldt ; newt.c_lflag &= ~ECHO ; tcsetattr(STDIN_FILENO, TCSANOW, & newt); } lEOF = fgets(lBuff, MAX_PATH_OR_CMD, stdin); /* printf("lbuff<%c><%d>\n",lBuff[0],lBuff[0]); */ if ( ! lEOF || (lBuff[0] == '\0') ) { free(lDialogString); return NULL; } if ( lBuff[0] == '\n' ) { lEOF = fgets(lBuff, MAX_PATH_OR_CMD, stdin); /* printf("lbuff<%c><%d>\n",lBuff[0],lBuff[0]); */ if ( ! lEOF || (lBuff[0] == '\0') ) { free(lDialogString); return NULL; } } if ( ! aDefaultInput ) { tcsetattr(STDIN_FILENO, TCSANOW, & oldt); printf("\n"); } printf("\n"); if ( strchr(lBuff,27) ) { free(lDialogString); return NULL ; } if ( lBuff[strlen( lBuff ) -1] == '\n' ) { lBuff[strlen( lBuff ) -1] = '\0' ; } free(lDialogString); return lBuff ; } if (tinyfd_verbose) printf( "lDialogString: %s\n" , lDialogString ) ; lIn = popen( lDialogString , "r" ); if ( ! lIn ) { if ( fileExists("/tmp/tinyfd.txt") ) { wipefile("/tmp/tinyfd.txt"); remove("/tmp/tinyfd.txt"); } if ( fileExists("/tmp/tinyfd0.txt") ) { wipefile("/tmp/tinyfd0.txt"); remove("/tmp/tinyfd0.txt"); } free(lDialogString); return NULL ; } while ( fgets( lBuff , sizeof( lBuff ) , lIn ) != NULL ) {} pclose( lIn ) ; if ( fileExists("/tmp/tinyfd.txt") ) { wipefile("/tmp/tinyfd.txt"); remove("/tmp/tinyfd.txt"); } if ( fileExists("/tmp/tinyfd0.txt") ) { wipefile("/tmp/tinyfd0.txt"); remove("/tmp/tinyfd0.txt"); } /* printf( "len Buff: %lu\n" , strlen(lBuff) ) ; */ /* printf( "lBuff0: %s\n" , lBuff ) ; */ if ( lBuff[strlen( lBuff ) -1] == '\n' ) { lBuff[strlen( lBuff ) -1] = '\0' ; } /* printf( "lBuff1: %s len: %lu \n" , lBuff , strlen(lBuff) ) ; */ if ( lWasBasicXterm ) { if ( strstr(lBuff,"^[") ) /* esc was pressed */ { free(lDialogString); return NULL ; } } lResult = strncmp( lBuff , "1" , 1) ? 0 : 1 ; /* printf( "lResult: %d \n" , lResult ) ; */ if ( ! lResult ) { free(lDialogString); return NULL ; } /* printf( "lBuff+1: %s\n" , lBuff+1 ) ; */ free(lDialogString); return lBuff+1 ; } char * tinyfd_saveFileDialog( char const * aTitle , /* NULL or "" */ char const * aDefaultPathAndFile , /* NULL or "" */ int aNumOfFilterPatterns , /* 0 */ char const * const * aFilterPatterns , /* NULL or {"*.jpg","*.png"} */ char const * aSingleFilterDescription ) /* NULL or "image files" */ { static char lBuff [MAX_PATH_OR_CMD] ; char lDialogString [MAX_PATH_OR_CMD] ; char lString [MAX_PATH_OR_CMD] ; int i ; int lWasGraphicDialog = 0 ; int lWasXterm = 0 ; char * p ; char * lPointerInputBox ; FILE * lIn ; lBuff[0]='\0'; if ( osascriptPresent( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"applescript");return (char *)1;} strcpy( lDialogString , "osascript "); if ( ! osx9orBetter() ) strcat( lDialogString , " -e 'tell application \"Finder\"' -e 'Activate'"); strcat( lDialogString , " -e 'try' -e 'POSIX path of ( choose file name " ); if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, "with prompt \"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\" ") ; } getPathWithoutFinalSlash( lString , aDefaultPathAndFile ) ; if ( strlen(lString) ) { strcat(lDialogString, "default location \"") ; strcat(lDialogString, lString ) ; strcat(lDialogString , "\" " ) ; } getLastName( lString , aDefaultPathAndFile ) ; if ( strlen(lString) ) { strcat(lDialogString, "default name \"") ; strcat(lDialogString, lString ) ; strcat(lDialogString , "\" " ) ; } strcat( lDialogString , ")' " ) ; strcat(lDialogString, "-e 'on error number -128' " ) ; strcat(lDialogString, "-e 'end try'") ; if ( ! osx9orBetter() ) strcat( lDialogString, " -e 'end tell'") ; } else if ( kdialogPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"kdialog");return (char *)1;} strcpy( lDialogString , "kdialog" ) ; if ( kdialogPresent() == 2 ) { strcat(lDialogString, " --attach=$(xprop -root 32x '\t$0' _NET_ACTIVE_WINDOW | cut -f 2)"); /* contribution: Paul Rouget */ } strcat( lDialogString , " --getsavefilename " ) ; if ( aDefaultPathAndFile && strlen(aDefaultPathAndFile) ) { if ( aDefaultPathAndFile[0] != '/' ) { strcat(lDialogString, "$PWD/") ; } strcat(lDialogString, "\"") ; strcat(lDialogString, aDefaultPathAndFile ) ; strcat(lDialogString , "\"" ) ; } else { strcat(lDialogString, "$PWD/") ; } if ( aNumOfFilterPatterns > 0 ) { strcat(lDialogString , " \"" ) ; for ( i = 0 ; i < aNumOfFilterPatterns ; i ++ ) { strcat( lDialogString , aFilterPatterns [i] ) ; strcat( lDialogString , " " ) ; } if ( aSingleFilterDescription && strlen(aSingleFilterDescription) ) { strcat( lDialogString , " | " ) ; strcat( lDialogString , aSingleFilterDescription ) ; } strcat( lDialogString , "\"" ) ; } if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, " --title \"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\"") ; } } else if ( zenityPresent() || matedialogPresent() || shellementaryPresent() || qarmaPresent() ) { if ( zenityPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"zenity");return (char *)1;} strcpy( lDialogString , "zenity" ) ; if ( (zenity3Present() >= 4) && !getenv("SSH_TTY") ) { strcat( lDialogString, " --attach=$(sleep .01;xprop -root 32x '\t$0' _NET_ACTIVE_WINDOW | cut -f 2)"); /* contribution: Paul Rouget */ } } else if ( matedialogPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"matedialog");return (char *)1;} strcpy( lDialogString , "matedialog" ) ; } else if ( shellementaryPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"shellementary");return (char *)1;} strcpy( lDialogString , "shellementary" ) ; } else { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"qarma");return (char *)1;} strcpy( lDialogString , "qarma" ) ; if ( !getenv("SSH_TTY") ) { strcat(lDialogString, " --attach=$(xprop -root 32x '\t$0' _NET_ACTIVE_WINDOW | cut -f 2)"); /* contribution: Paul Rouget */ } } strcat(lDialogString, " --file-selection --save --confirm-overwrite" ) ; if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, " --title=\"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\"") ; } if ( aDefaultPathAndFile && strlen(aDefaultPathAndFile) ) { strcat(lDialogString, " --filename=\"") ; strcat(lDialogString, aDefaultPathAndFile) ; strcat(lDialogString, "\"") ; } if ( aNumOfFilterPatterns > 0 ) { strcat( lDialogString , " --file-filter='" ) ; if ( aSingleFilterDescription && strlen(aSingleFilterDescription) ) { strcat( lDialogString , aSingleFilterDescription ) ; strcat( lDialogString , " | " ) ; } for ( i = 0 ; i < aNumOfFilterPatterns ; i ++ ) { strcat( lDialogString , aFilterPatterns [i] ) ; strcat( lDialogString , " " ) ; } strcat( lDialogString , "' --file-filter='All files | *'" ) ; } if (tinyfd_silent) strcat( lDialogString , " 2>/dev/null "); } else if ( !xdialogPresent() && tkinter3Present( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"python3-tkinter");return (char *)1;} strcpy( lDialogString , gPython3Name ) ; strcat( lDialogString , " -S -c \"import tkinter;from tkinter import filedialog;root=tkinter.Tk();root.withdraw();"); strcat( lDialogString , "res=filedialog.asksaveasfilename("); if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, "title='") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "',") ; } if ( aDefaultPathAndFile && strlen(aDefaultPathAndFile) ) { getPathWithoutFinalSlash( lString , aDefaultPathAndFile ) ; if ( strlen(lString) ) { strcat(lDialogString, "initialdir='") ; strcat(lDialogString, lString ) ; strcat(lDialogString , "'," ) ; } getLastName( lString , aDefaultPathAndFile ) ; if ( strlen(lString) ) { strcat(lDialogString, "initialfile='") ; strcat(lDialogString, lString ) ; strcat(lDialogString , "'," ) ; } } if ( ( aNumOfFilterPatterns > 1 ) || ( (aNumOfFilterPatterns == 1) /* test because poor osx behaviour */ && ( aFilterPatterns[0][strlen(aFilterPatterns[0])-1] != '*' ) ) ) { strcat(lDialogString , "filetypes=(" ) ; strcat( lDialogString , "('" ) ; if ( aSingleFilterDescription && strlen(aSingleFilterDescription) ) { strcat( lDialogString , aSingleFilterDescription ) ; } strcat( lDialogString , "',(" ) ; for ( i = 0 ; i < aNumOfFilterPatterns ; i ++ ) { strcat( lDialogString , "'" ) ; strcat( lDialogString , aFilterPatterns [i] ) ; strcat( lDialogString , "'," ) ; } strcat( lDialogString , "))," ) ; strcat( lDialogString , "('All files','*'))" ) ; } strcat( lDialogString, ");\nif not isinstance(res, tuple):\n\tprint(res)\n\"" ) ; } else if ( !xdialogPresent() && tkinter2Present( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"python2-tkinter");return (char *)1;} strcpy( lDialogString , "export PYTHONIOENCODING=utf-8;" ) ; strcat( lDialogString , gPython2Name ) ; if ( ! isTerminalRunning( ) && isDarwin( )) { strcat( lDialogString , " -i" ) ; /* for osx without console */ } strcat( lDialogString , " -S -c \"import Tkinter,tkFileDialog;root=Tkinter.Tk();root.withdraw();"); if ( isDarwin( ) ) { strcat( lDialogString , "import os;os.system('''/usr/bin/osascript -e 'tell app \\\"Finder\\\" to set\ frontmost of process \\\"Python\\\" to true' ''');"); } strcat( lDialogString , "res=tkFileDialog.asksaveasfilename("); if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, "title='") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "',") ; } if ( aDefaultPathAndFile && strlen(aDefaultPathAndFile) ) { getPathWithoutFinalSlash( lString , aDefaultPathAndFile ) ; if ( strlen(lString) ) { strcat(lDialogString, "initialdir='") ; strcat(lDialogString, lString ) ; strcat(lDialogString , "'," ) ; } getLastName( lString , aDefaultPathAndFile ) ; if ( strlen(lString) ) { strcat(lDialogString, "initialfile='") ; strcat(lDialogString, lString ) ; strcat(lDialogString , "'," ) ; } } if ( ( aNumOfFilterPatterns > 1 ) || ( (aNumOfFilterPatterns == 1) /* test because poor osx behaviour */ && ( aFilterPatterns[0][strlen(aFilterPatterns[0])-1] != '*' ) ) ) { strcat(lDialogString , "filetypes=(" ) ; strcat( lDialogString , "('" ) ; if ( aSingleFilterDescription && strlen(aSingleFilterDescription) ) { strcat( lDialogString , aSingleFilterDescription ) ; } strcat( lDialogString , "',(" ) ; for ( i = 0 ; i < aNumOfFilterPatterns ; i ++ ) { strcat( lDialogString , "'" ) ; strcat( lDialogString , aFilterPatterns [i] ) ; strcat( lDialogString , "'," ) ; } strcat( lDialogString , "))," ) ; strcat( lDialogString , "('All files','*'))" ) ; } strcat( lDialogString, ");\nif not isinstance(res, tuple):\n\tprint res \n\"" ) ; } else if ( xdialogPresent() || dialogName() ) { if ( xdialogPresent( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"xdialog");return (char *)1;} lWasGraphicDialog = 1 ; strcpy( lDialogString , "(Xdialog " ) ; } else if ( isTerminalRunning( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"dialog");return (char *)0;} strcpy( lDialogString , "(dialog " ) ; } else { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"dialog");return (char *)0;} lWasXterm = 1 ; strcpy( lDialogString , terminalName() ) ; strcat( lDialogString , "'(" ) ; strcat( lDialogString , dialogName() ) ; strcat( lDialogString , " " ) ; } if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, "--title \"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\" ") ; } if ( !xdialogPresent() && !gdialogPresent() ) { strcat(lDialogString, "--backtitle \"") ; strcat(lDialogString, "tab: focus | /: populate | spacebar: fill text field | ok: TEXT FIELD ONLY") ; strcat(lDialogString, "\" ") ; } strcat( lDialogString , "--fselect \"" ) ; if ( aDefaultPathAndFile && strlen(aDefaultPathAndFile) ) { if ( ! strchr(aDefaultPathAndFile, '/') ) { strcat(lDialogString, "./") ; } strcat(lDialogString, aDefaultPathAndFile) ; } else if ( ! isTerminalRunning( ) && !lWasGraphicDialog ) { strcat(lDialogString, getenv("HOME")) ; strcat(lDialogString, "/") ; } else { strcat(lDialogString, "./") ; } if ( lWasGraphicDialog ) { strcat(lDialogString, "\" 0 60 ) 2>&1 ") ; } else { strcat(lDialogString, "\" 0 60 >/dev/tty) ") ; if ( lWasXterm ) { strcat( lDialogString , "2>/tmp/tinyfd.txt';cat /tmp/tinyfd.txt;rm /tmp/tinyfd.txt"); } else { strcat(lDialogString, "2>&1 ; clear >/dev/tty") ; } } } else { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){return tinyfd_inputBox(aTitle,NULL,NULL);} strcpy(lBuff, "Save file in "); strcat(lBuff, getCurDir()); lPointerInputBox = tinyfd_inputBox(NULL, NULL, NULL); /* obtain a pointer on the current content of tinyfd_inputBox */ if (lPointerInputBox) strcpy(lString, lPointerInputBox); /* preserve the current content of tinyfd_inputBox */ p = tinyfd_inputBox(aTitle, lBuff, ""); if (p) strcpy(lBuff, p); else lBuff[0] = '\0'; if (lPointerInputBox) strcpy(lPointerInputBox, lString); /* restore its previous content to tinyfd_inputBox */ p = lBuff; getPathWithoutFinalSlash( lString , p ) ; if ( strlen( lString ) && ! dirExists( lString ) ) { return NULL ; } getLastName(lString,p); if ( ! strlen(lString) ) { return NULL; } return p ; } if (tinyfd_verbose) printf( "lDialogString: %s\n" , lDialogString ) ; if ( ! ( lIn = popen( lDialogString , "r" ) ) ) { return NULL ; } while ( fgets( lBuff , sizeof( lBuff ) , lIn ) != NULL ) {} pclose( lIn ) ; if ( lBuff[strlen( lBuff ) -1] == '\n' ) { lBuff[strlen( lBuff ) -1] = '\0' ; } /* printf( "lBuff: %s\n" , lBuff ) ; */ if ( ! strlen(lBuff) ) { return NULL; } getPathWithoutFinalSlash( lString , lBuff ) ; if ( strlen( lString ) && ! dirExists( lString ) ) { return NULL ; } getLastName(lString,lBuff); if ( ! filenameValid(lString) ) { return NULL; } return lBuff ; } /* in case of multiple files, the separator is | */ char * tinyfd_openFileDialog( char const * aTitle , /* NULL or "" */ char const * aDefaultPathAndFile , /* NULL or "" */ int aNumOfFilterPatterns , /* 0 */ char const * const * aFilterPatterns , /* NULL or {"*.jpg","*.png"} */ char const * aSingleFilterDescription , /* NULL or "image files" */ int aAllowMultipleSelects ) /* 0 or 1 */ { char lDialogString [MAX_PATH_OR_CMD] ; char lString [MAX_PATH_OR_CMD] ; int i ; FILE * lIn ; char * p ; char * p2 ; char * lPointerInputBox ; int lWasKdialog = 0 ; int lWasGraphicDialog = 0 ; int lWasXterm = 0 ; size_t lFullBuffLen ; static char * lBuff = NULL; free(lBuff); if (aTitle&&!strcmp(aTitle,"tinyfd_query")) { lBuff = NULL; } else { if (aAllowMultipleSelects) { lFullBuffLen = MAX_MULTIPLE_FILES * MAX_PATH_OR_CMD + 1; lBuff = (char *)(malloc(lFullBuffLen * sizeof(char))); if (!lBuff) { lFullBuffLen = LOW_MULTIPLE_FILES * MAX_PATH_OR_CMD + 1; lBuff = (char *)( malloc( lFullBuffLen * sizeof(char))); } } else { lFullBuffLen = MAX_PATH_OR_CMD + 1; lBuff = (char *)(malloc(lFullBuffLen * sizeof(char))); } if (!lBuff) return NULL; lBuff[0]='\0'; } if ( osascriptPresent( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"applescript");return (char *)1;} strcpy( lDialogString , "osascript "); if ( ! osx9orBetter() ) strcat( lDialogString , " -e 'tell application \"System Events\"' -e 'Activate'"); strcat( lDialogString , " -e 'try' -e '" ); if ( ! aAllowMultipleSelects ) { strcat( lDialogString , "POSIX path of ( " ); } else { strcat( lDialogString , "set mylist to " ); } strcat( lDialogString , "choose file " ); if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, "with prompt \"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\" ") ; } getPathWithoutFinalSlash( lString , aDefaultPathAndFile ) ; if ( strlen(lString) ) { strcat(lDialogString, "default location \"") ; strcat(lDialogString, lString ) ; strcat(lDialogString , "\" " ) ; } if ( aNumOfFilterPatterns > 0 ) { strcat(lDialogString , "of type {\"" ); strcat( lDialogString , aFilterPatterns [0] + 2 ) ; strcat( lDialogString , "\"" ) ; for ( i = 1 ; i < aNumOfFilterPatterns ; i ++ ) { strcat( lDialogString , ",\"" ) ; strcat( lDialogString , aFilterPatterns [i] + 2) ; strcat( lDialogString , "\"" ) ; } strcat( lDialogString , "} " ) ; } if ( aAllowMultipleSelects ) { strcat( lDialogString , "multiple selections allowed true ' " ) ; strcat( lDialogString , "-e 'set mystring to POSIX path of item 1 of mylist' " ); strcat( lDialogString , "-e 'repeat with i from 2 to the count of mylist' " ); strcat( lDialogString , "-e 'set mystring to mystring & \"|\"' " ); strcat( lDialogString , "-e 'set mystring to mystring & POSIX path of item i of mylist' " ); strcat( lDialogString , "-e 'end repeat' " ); strcat( lDialogString , "-e 'mystring' " ); } else { strcat( lDialogString , ")' " ) ; } strcat(lDialogString, "-e 'on error number -128' " ) ; strcat(lDialogString, "-e 'end try'") ; if ( ! osx9orBetter() ) strcat( lDialogString, " -e 'end tell'") ; } else if ( kdialogPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"kdialog");return (char *)1;} lWasKdialog = 1 ; strcpy( lDialogString , "kdialog" ) ; if ( kdialogPresent() == 2 ) { strcat(lDialogString, " --attach=$(xprop -root 32x '\t$0' _NET_ACTIVE_WINDOW | cut -f 2)"); /* contribution: Paul Rouget */ } strcat( lDialogString , " --getopenfilename " ) ; if ( aDefaultPathAndFile && strlen(aDefaultPathAndFile) ) { if ( aDefaultPathAndFile[0] != '/' ) { strcat(lDialogString, "$PWD/") ; } strcat(lDialogString, "\"") ; strcat(lDialogString, aDefaultPathAndFile ) ; strcat(lDialogString , "\"" ) ; } else { strcat(lDialogString, "$PWD/") ; } if ( aNumOfFilterPatterns > 0 ) { strcat(lDialogString , " \"" ) ; for ( i = 0 ; i < aNumOfFilterPatterns ; i ++ ) { strcat( lDialogString , aFilterPatterns [i] ) ; strcat( lDialogString , " " ) ; } if ( aSingleFilterDescription && strlen(aSingleFilterDescription) ) { strcat( lDialogString , " | " ) ; strcat( lDialogString , aSingleFilterDescription ) ; } strcat( lDialogString , "\"" ) ; } if ( aAllowMultipleSelects ) { strcat( lDialogString , " --multiple --separate-output" ) ; } if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, " --title \"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\"") ; } } else if ( zenityPresent() || matedialogPresent() || shellementaryPresent() || qarmaPresent() ) { if ( zenityPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"zenity");return (char *)1;} strcpy( lDialogString , "zenity" ) ; if ( (zenity3Present() >= 4) && !getenv("SSH_TTY") ) { strcat( lDialogString, " --attach=$(sleep .01;xprop -root 32x '\t$0' _NET_ACTIVE_WINDOW | cut -f 2)"); /* contribution: Paul Rouget */ } } else if ( matedialogPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"matedialog");return (char *)1;} strcpy( lDialogString , "matedialog" ) ; } else if ( shellementaryPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"shellementary");return (char *)1;} strcpy( lDialogString , "shellementary" ) ; } else { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"qarma");return (char *)1;} strcpy( lDialogString , "qarma" ) ; if ( !getenv("SSH_TTY") ) { strcat(lDialogString, " --attach=$(xprop -root 32x '\t$0' _NET_ACTIVE_WINDOW | cut -f 2)"); /* contribution: Paul Rouget */ } } strcat( lDialogString , " --file-selection" ) ; if ( aAllowMultipleSelects ) { strcat( lDialogString , " --multiple" ) ; } if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, " --title=\"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\"") ; } if ( aDefaultPathAndFile && strlen(aDefaultPathAndFile) ) { strcat(lDialogString, " --filename=\"") ; strcat(lDialogString, aDefaultPathAndFile) ; strcat(lDialogString, "\"") ; } if ( aNumOfFilterPatterns > 0 ) { strcat( lDialogString , " --file-filter='" ) ; if ( aSingleFilterDescription && strlen(aSingleFilterDescription) ) { strcat( lDialogString , aSingleFilterDescription ) ; strcat( lDialogString , " | " ) ; } for ( i = 0 ; i < aNumOfFilterPatterns ; i ++ ) { strcat( lDialogString , aFilterPatterns [i] ) ; strcat( lDialogString , " " ) ; } strcat( lDialogString , "' --file-filter='All files | *'" ) ; } if (tinyfd_silent) strcat( lDialogString , " 2>/dev/null "); } else if ( tkinter3Present( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"python3-tkinter");return (char *)1;} strcpy( lDialogString , gPython3Name ) ; strcat( lDialogString , " -S -c \"import tkinter;from tkinter import filedialog;root=tkinter.Tk();root.withdraw();"); strcat( lDialogString , "lFiles=filedialog.askopenfilename("); if ( aAllowMultipleSelects ) { strcat( lDialogString , "multiple=1," ) ; } if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, "title='") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "',") ; } if ( aDefaultPathAndFile && strlen(aDefaultPathAndFile) ) { getPathWithoutFinalSlash( lString , aDefaultPathAndFile ) ; if ( strlen(lString) ) { strcat(lDialogString, "initialdir='") ; strcat(lDialogString, lString ) ; strcat(lDialogString , "'," ) ; } getLastName( lString , aDefaultPathAndFile ) ; if ( strlen(lString) ) { strcat(lDialogString, "initialfile='") ; strcat(lDialogString, lString ) ; strcat(lDialogString , "'," ) ; } } if ( ( aNumOfFilterPatterns > 1 ) || ( ( aNumOfFilterPatterns == 1 ) /*test because poor osx behaviour*/ && ( aFilterPatterns[0][strlen(aFilterPatterns[0])-1] != '*' ) ) ) { strcat(lDialogString , "filetypes=(" ) ; strcat( lDialogString , "('" ) ; if ( aSingleFilterDescription && strlen(aSingleFilterDescription) ) { strcat( lDialogString , aSingleFilterDescription ) ; } strcat( lDialogString , "',(" ) ; for ( i = 0 ; i < aNumOfFilterPatterns ; i ++ ) { strcat( lDialogString , "'" ) ; strcat( lDialogString , aFilterPatterns [i] ) ; strcat( lDialogString , "'," ) ; } strcat( lDialogString , "))," ) ; strcat( lDialogString , "('All files','*'))" ) ; } strcat( lDialogString , ");\ \nif not isinstance(lFiles, tuple):\n\tprint(lFiles)\nelse:\ \n\tlFilesString=''\n\tfor lFile in lFiles:\n\t\tlFilesString+=str(lFile)+'|'\ \n\tprint(lFilesString[:-1])\n\"" ) ; } else if ( tkinter2Present( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"python2-tkinter");return (char *)1;} strcpy( lDialogString , "export PYTHONIOENCODING=utf-8;" ) ; strcat( lDialogString , gPython2Name ) ; if ( ! isTerminalRunning( ) && isDarwin( ) ) { strcat( lDialogString , " -i" ) ; /* for osx without console */ } strcat( lDialogString , " -S -c \"import Tkinter,tkFileDialog;root=Tkinter.Tk();root.withdraw();"); if ( isDarwin( ) ) { strcat( lDialogString , "import os;os.system('''/usr/bin/osascript -e 'tell app \\\"Finder\\\" to set \ frontmost of process \\\"Python\\\" to true' ''');"); } strcat( lDialogString , "lFiles=tkFileDialog.askopenfilename("); if ( aAllowMultipleSelects ) { strcat( lDialogString , "multiple=1," ) ; } if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, "title='") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "',") ; } if ( aDefaultPathAndFile && strlen(aDefaultPathAndFile) ) { getPathWithoutFinalSlash( lString , aDefaultPathAndFile ) ; if ( strlen(lString) ) { strcat(lDialogString, "initialdir='") ; strcat(lDialogString, lString ) ; strcat(lDialogString , "'," ) ; } getLastName( lString , aDefaultPathAndFile ) ; if ( strlen(lString) ) { strcat(lDialogString, "initialfile='") ; strcat(lDialogString, lString ) ; strcat(lDialogString , "'," ) ; } } if ( ( aNumOfFilterPatterns > 1 ) || ( ( aNumOfFilterPatterns == 1 ) /*test because poor osx behaviour*/ && ( aFilterPatterns[0][strlen(aFilterPatterns[0])-1] != '*' ) ) ) { strcat(lDialogString , "filetypes=(" ) ; strcat( lDialogString , "('" ) ; if ( aSingleFilterDescription && strlen(aSingleFilterDescription) ) { strcat( lDialogString , aSingleFilterDescription ) ; } strcat( lDialogString , "',(" ) ; for ( i = 0 ; i < aNumOfFilterPatterns ; i ++ ) { strcat( lDialogString , "'" ) ; strcat( lDialogString , aFilterPatterns [i] ) ; strcat( lDialogString , "'," ) ; } strcat( lDialogString , "))," ) ; strcat( lDialogString , "('All files','*'))" ) ; } strcat( lDialogString , ");\ \nif not isinstance(lFiles, tuple):\n\tprint lFiles\nelse:\ \n\tlFilesString=''\n\tfor lFile in lFiles:\n\t\tlFilesString+=str(lFile)+'|'\ \n\tprint lFilesString[:-1]\n\"" ) ; } else if ( xdialogPresent() || dialogName() ) { if ( xdialogPresent( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"xdialog");return (char *)1;} lWasGraphicDialog = 1 ; strcpy( lDialogString , "(Xdialog " ) ; } else if ( isTerminalRunning( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"dialog");return (char *)0;} strcpy( lDialogString , "(dialog " ) ; } else { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"dialog");return (char *)0;} lWasXterm = 1 ; strcpy( lDialogString , terminalName() ) ; strcat( lDialogString , "'(" ) ; strcat( lDialogString , dialogName() ) ; strcat( lDialogString , " " ) ; } if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, "--title \"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\" ") ; } if ( !xdialogPresent() && !gdialogPresent() ) { strcat(lDialogString, "--backtitle \"") ; strcat(lDialogString, "tab: focus | /: populate | spacebar: fill text field | ok: TEXT FIELD ONLY") ; strcat(lDialogString, "\" ") ; } strcat( lDialogString , "--fselect \"" ) ; if ( aDefaultPathAndFile && strlen(aDefaultPathAndFile) ) { if ( ! strchr(aDefaultPathAndFile, '/') ) { strcat(lDialogString, "./") ; } strcat(lDialogString, aDefaultPathAndFile) ; } else if ( ! isTerminalRunning( ) && !lWasGraphicDialog ) { strcat(lDialogString, getenv("HOME")) ; strcat(lDialogString, "/"); } else { strcat(lDialogString, "./") ; } if ( lWasGraphicDialog ) { strcat(lDialogString, "\" 0 60 ) 2>&1 ") ; } else { strcat(lDialogString, "\" 0 60 >/dev/tty) ") ; if ( lWasXterm ) { strcat( lDialogString , "2>/tmp/tinyfd.txt';cat /tmp/tinyfd.txt;rm /tmp/tinyfd.txt"); } else { strcat(lDialogString, "2>&1 ; clear >/dev/tty") ; } } } else { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){return tinyfd_inputBox(aTitle,NULL,NULL);} strcpy(lBuff, "Open file from "); strcat(lBuff, getCurDir()); lPointerInputBox = tinyfd_inputBox(NULL, NULL, NULL); /* obtain a pointer on the current content of tinyfd_inputBox */ if (lPointerInputBox) strcpy(lDialogString, lPointerInputBox); /* preserve the current content of tinyfd_inputBox */ p2 = tinyfd_inputBox(aTitle, lBuff, ""); if (p2) strcpy(lBuff, p2); else lBuff[0] = '\0'; if (lPointerInputBox) strcpy(lPointerInputBox, lDialogString); /* restore its previous content to tinyfd_inputBox */ p2 = lBuff; if ( ! fileExists(p2) ) { free(lBuff); lBuff = NULL; } else { strcpy(lBuff, p2); lBuff = (char *)( realloc( lBuff, (strlen(lBuff)+1) * sizeof(char))); } return lBuff ; } if (tinyfd_verbose) printf( "lDialogString: %s\n" , lDialogString ) ; if ( ! ( lIn = popen( lDialogString , "r" ) ) ) { free(lBuff); lBuff = NULL; return NULL ; } lBuff[0]='\0'; p=lBuff; while ( fgets( p , sizeof( lBuff ) , lIn ) != NULL ) { p += strlen( p ); } pclose( lIn ) ; if ( lBuff[strlen( lBuff ) -1] == '\n' ) { lBuff[strlen( lBuff ) -1] = '\0' ; } /* printf( "lBuff: %s\n" , lBuff ) ; */ if ( lWasKdialog && aAllowMultipleSelects ) { p = lBuff ; while ( ( p = strchr( p , '\n' ) ) ) * p = '|' ; } /* printf( "lBuff2: %s\n" , lBuff ) ; */ if ( ! strlen( lBuff ) ) { free(lBuff); lBuff = NULL; return NULL; } if ( aAllowMultipleSelects && strchr(lBuff, '|') ) { if( ! ensureFilesExist( lBuff , lBuff ) ) { free(lBuff); lBuff = NULL; return NULL; } } else if ( !fileExists(lBuff) ) { free(lBuff); lBuff = NULL; return NULL; } lBuff = (char *)( realloc( lBuff, (strlen(lBuff)+1) * sizeof(char))); /*printf( "lBuff3: %s\n" , lBuff ) ; */ return lBuff ; } char * tinyfd_selectFolderDialog( char const * aTitle , /* "" */ char const * aDefaultPath ) /* "" */ { static char lBuff [MAX_PATH_OR_CMD] ; char lDialogString [MAX_PATH_OR_CMD] ; FILE * lIn ; char * p ; char * lPointerInputBox ; int lWasGraphicDialog = 0 ; int lWasXterm = 0 ; lBuff[0]='\0'; if ( osascriptPresent( )) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"applescript");return (char *)1;} strcpy( lDialogString , "osascript "); if ( ! osx9orBetter() ) strcat( lDialogString , " -e 'tell application \"System Events\"' -e 'Activate'"); strcat( lDialogString , " -e 'try' -e 'POSIX path of ( choose folder "); if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, "with prompt \"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\" ") ; } if ( aDefaultPath && strlen(aDefaultPath) ) { strcat(lDialogString, "default location \"") ; strcat(lDialogString, aDefaultPath ) ; strcat(lDialogString , "\" " ) ; } strcat( lDialogString , ")' " ) ; strcat(lDialogString, "-e 'on error number -128' " ) ; strcat(lDialogString, "-e 'end try'") ; if ( ! osx9orBetter() ) strcat( lDialogString, " -e 'end tell'") ; } else if ( kdialogPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"kdialog");return (char *)1;} strcpy( lDialogString , "kdialog" ) ; if ( kdialogPresent() == 2 ) { strcat(lDialogString, " --attach=$(xprop -root 32x '\t$0' _NET_ACTIVE_WINDOW | cut -f 2)"); /* contribution: Paul Rouget */ } strcat( lDialogString , " --getexistingdirectory " ) ; if ( aDefaultPath && strlen(aDefaultPath) ) { if ( aDefaultPath[0] != '/' ) { strcat(lDialogString, "$PWD/") ; } strcat(lDialogString, "\"") ; strcat(lDialogString, aDefaultPath ) ; strcat(lDialogString , "\"" ) ; } else { strcat(lDialogString, "$PWD/") ; } if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, " --title \"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\"") ; } } else if ( zenityPresent() || matedialogPresent() || shellementaryPresent() || qarmaPresent() ) { if ( zenityPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"zenity");return (char *)1;} strcpy( lDialogString , "zenity" ) ; if ( (zenity3Present() >= 4) && !getenv("SSH_TTY") ) { strcat( lDialogString, " --attach=$(sleep .01;xprop -root 32x '\t$0' _NET_ACTIVE_WINDOW | cut -f 2)"); /* contribution: Paul Rouget */ } } else if ( matedialogPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"matedialog");return (char *)1;} strcpy( lDialogString , "matedialog" ) ; } else if ( shellementaryPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"shellementary");return (char *)1;} strcpy( lDialogString , "shellementary" ) ; } else { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"qarma");return (char *)1;} strcpy( lDialogString , "qarma" ) ; if ( !getenv("SSH_TTY") ) { strcat(lDialogString, " --attach=$(xprop -root 32x '\t$0' _NET_ACTIVE_WINDOW | cut -f 2)"); /* contribution: Paul Rouget */ } } strcat( lDialogString , " --file-selection --directory" ) ; if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, " --title=\"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\"") ; } if ( aDefaultPath && strlen(aDefaultPath) ) { strcat(lDialogString, " --filename=\"") ; strcat(lDialogString, aDefaultPath) ; strcat(lDialogString, "\"") ; } if (tinyfd_silent) strcat( lDialogString , " 2>/dev/null "); } else if ( !xdialogPresent() && tkinter3Present( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"python3-tkinter");return (char *)1;} strcpy( lDialogString , gPython3Name ) ; strcat( lDialogString , " -S -c \"import tkinter;from tkinter import filedialog;root=tkinter.Tk();root.withdraw();"); strcat( lDialogString , "res=filedialog.askdirectory("); if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, "title='") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "',") ; } if ( aDefaultPath && strlen(aDefaultPath) ) { strcat(lDialogString, "initialdir='") ; strcat(lDialogString, aDefaultPath ) ; strcat(lDialogString , "'" ) ; } strcat( lDialogString, ");\nif not isinstance(res, tuple):\n\tprint(res)\n\"" ) ; } else if ( !xdialogPresent() && tkinter2Present( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"python2-tkinter");return (char *)1;} strcpy( lDialogString , "export PYTHONIOENCODING=utf-8;" ) ; strcat( lDialogString , gPython2Name ) ; if ( ! isTerminalRunning( ) && isDarwin( ) ) { strcat( lDialogString , " -i" ) ; /* for osx without console */ } strcat( lDialogString , " -S -c \"import Tkinter,tkFileDialog;root=Tkinter.Tk();root.withdraw();"); if ( isDarwin( ) ) { strcat( lDialogString , "import os;os.system('''/usr/bin/osascript -e 'tell app \\\"Finder\\\" to set \ frontmost of process \\\"Python\\\" to true' ''');"); } strcat( lDialogString , "print tkFileDialog.askdirectory("); if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, "title='") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "',") ; } if ( aDefaultPath && strlen(aDefaultPath) ) { strcat(lDialogString, "initialdir='") ; strcat(lDialogString, aDefaultPath ) ; strcat(lDialogString , "'" ) ; } strcat( lDialogString , ")\"" ) ; } else if ( xdialogPresent() || dialogName() ) { if ( xdialogPresent( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"xdialog");return (char *)1;} lWasGraphicDialog = 1 ; strcpy( lDialogString , "(Xdialog " ) ; } else if ( isTerminalRunning( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"dialog");return (char *)0;} strcpy( lDialogString , "(dialog " ) ; } else { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"dialog");return (char *)0;} lWasXterm = 1 ; strcpy( lDialogString , terminalName() ) ; strcat( lDialogString , "'(" ) ; strcat( lDialogString , dialogName() ) ; strcat( lDialogString , " " ) ; } if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, "--title \"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\" ") ; } if ( !xdialogPresent() && !gdialogPresent() ) { strcat(lDialogString, "--backtitle \"") ; strcat(lDialogString, "tab: focus | /: populate | spacebar: fill text field | ok: TEXT FIELD ONLY") ; strcat(lDialogString, "\" ") ; } strcat( lDialogString , "--dselect \"" ) ; if ( aDefaultPath && strlen(aDefaultPath) ) { strcat(lDialogString, aDefaultPath) ; ensureFinalSlash(lDialogString); } else if ( ! isTerminalRunning( ) && !lWasGraphicDialog ) { strcat(lDialogString, getenv("HOME")) ; strcat(lDialogString, "/"); } else { strcat(lDialogString, "./") ; } if ( lWasGraphicDialog ) { strcat(lDialogString, "\" 0 60 ) 2>&1 ") ; } else { strcat(lDialogString, "\" 0 60 >/dev/tty) ") ; if ( lWasXterm ) { strcat( lDialogString , "2>/tmp/tinyfd.txt';cat /tmp/tinyfd.txt;rm /tmp/tinyfd.txt"); } else { strcat(lDialogString, "2>&1 ; clear >/dev/tty") ; } } } else { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){return tinyfd_inputBox(aTitle,NULL,NULL);} strcpy(lBuff, "Select folder from "); strcat(lBuff, getCurDir()); lPointerInputBox = tinyfd_inputBox(NULL, NULL, NULL); /* obtain a pointer on the current content of tinyfd_inputBox */ if (lPointerInputBox) strcpy(lDialogString, lPointerInputBox); /* preserve the current content of tinyfd_inputBox */ p = tinyfd_inputBox(aTitle, lBuff, ""); if (p) strcpy(lBuff, p); else lBuff[0] = '\0'; if (lPointerInputBox) strcpy(lPointerInputBox, lDialogString); /* restore its previous content to tinyfd_inputBox */ p = lBuff; if ( !p || ! strlen( p ) || ! dirExists( p ) ) { return NULL ; } return p ; } if (tinyfd_verbose) printf( "lDialogString: %s\n" , lDialogString ) ; if ( ! ( lIn = popen( lDialogString , "r" ) ) ) { return NULL ; } while ( fgets( lBuff , sizeof( lBuff ) , lIn ) != NULL ) {} pclose( lIn ) ; if ( lBuff[strlen( lBuff ) -1] == '\n' ) { lBuff[strlen( lBuff ) -1] = '\0' ; } /* printf( "lBuff: %s\n" , lBuff ) ; */ if ( ! strlen( lBuff ) || ! dirExists( lBuff ) ) { return NULL ; } return lBuff ; } /* returns the hexcolor as a string "#FF0000" */ /* aoResultRGB also contains the result */ /* aDefaultRGB is used only if aDefaultHexRGB is NULL */ /* aDefaultRGB and aoResultRGB can be the same array */ char * tinyfd_colorChooser( char const * aTitle , /* NULL or "" */ char const * aDefaultHexRGB , /* NULL or "#FF0000"*/ unsigned char const aDefaultRGB[3] , /* { 0 , 255 , 255 } */ unsigned char aoResultRGB[3] ) /* { 0 , 0 , 0 } */ { static char lDefaultHexRGB[16]; char lBuff [128] ; char lTmp [128] ; #if !((defined(__cplusplus ) && __cplusplus >= 201103L) || (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || defined(__clang__)) char * lTmp2 ; #endif char lDialogString [MAX_PATH_OR_CMD] ; unsigned char lDefaultRGB[3]; char * p; char * lPointerInputBox; FILE * lIn ; int i ; int lWasZenity3 = 0 ; int lWasOsascript = 0 ; int lWasXdialog = 0 ; lBuff[0]='\0'; if (aDefaultHexRGB) { Hex2RGB(aDefaultHexRGB, lDefaultRGB); } else { lDefaultRGB[0] = aDefaultRGB[0]; lDefaultRGB[1] = aDefaultRGB[1]; lDefaultRGB[2] = aDefaultRGB[2]; } if ( osascriptPresent( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"applescript");return (char *)1;} lWasOsascript = 1 ; strcpy( lDialogString , "osascript"); if ( ! osx9orBetter() ) { strcat( lDialogString , " -e 'tell application \"System Events\"' -e 'Activate'"); strcat( lDialogString , " -e 'try' -e 'set mycolor to choose color default color {"); } else { strcat( lDialogString , " -e 'try' -e 'tell app (path to frontmost application as Unicode text) \ to set mycolor to choose color default color {"); } sprintf(lTmp, "%d", 256 * lDefaultRGB[0] ) ; strcat(lDialogString, lTmp ) ; strcat(lDialogString, "," ) ; sprintf(lTmp, "%d", 256 * lDefaultRGB[1] ) ; strcat(lDialogString, lTmp ) ; strcat(lDialogString, "," ) ; sprintf(lTmp, "%d", 256 * lDefaultRGB[2] ) ; strcat(lDialogString, lTmp ) ; strcat(lDialogString, "}' " ) ; strcat( lDialogString , "-e 'set mystring to ((item 1 of mycolor) div 256 as integer) as string' " ); strcat( lDialogString , "-e 'repeat with i from 2 to the count of mycolor' " ); strcat( lDialogString , "-e 'set mystring to mystring & \" \" & ((item i of mycolor) div 256 as integer) as string' " ); strcat( lDialogString , "-e 'end repeat' " ); strcat( lDialogString , "-e 'mystring' "); strcat(lDialogString, "-e 'on error number -128' " ) ; strcat(lDialogString, "-e 'end try'") ; if ( ! osx9orBetter() ) strcat( lDialogString, " -e 'end tell'") ; } else if ( kdialogPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"kdialog");return (char *)1;} strcpy( lDialogString , "kdialog" ) ; if ( kdialogPresent() == 2 ) { strcat(lDialogString, " --attach=$(xprop -root 32x '\t$0' _NET_ACTIVE_WINDOW | cut -f 2)"); /* contribution: Paul Rouget */ } sprintf( lDialogString + strlen(lDialogString) , " --getcolor --default '%s'" , lDefaultHexRGB ) ; if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, " --title \"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\"") ; } } else if ( zenity3Present() || matedialogPresent() || shellementaryPresent() || qarmaPresent() ) { lWasZenity3 = 1 ; if ( zenity3Present() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"zenity3");return (char *)1;} strcpy( lDialogString , "zenity" ); if ( (zenity3Present() >= 4) && !getenv("SSH_TTY") ) { strcat( lDialogString, " --attach=$(sleep .01;xprop -root 32x '\t$0' _NET_ACTIVE_WINDOW | cut -f 2)"); /* contribution: Paul Rouget */ } } else if ( matedialogPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"matedialog");return (char *)1;} strcpy( lDialogString , "matedialog" ) ; } else if ( shellementaryPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"shellementary");return (char *)1;} strcpy( lDialogString , "shellementary" ) ; } else { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"qarma");return (char *)1;} strcpy( lDialogString , "qarma" ) ; if ( !getenv("SSH_TTY") ) { strcat(lDialogString, " --attach=$(xprop -root 32x '\t$0' _NET_ACTIVE_WINDOW | cut -f 2)"); /* contribution: Paul Rouget */ } } strcat( lDialogString , " --color-selection --show-palette" ) ; sprintf( lDialogString + strlen(lDialogString), " --color=%s" , lDefaultHexRGB ) ; if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, " --title=\"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\"") ; } if (tinyfd_silent) strcat( lDialogString , " 2>/dev/null "); } else if ( xdialogPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"xdialog");return (char *)1;} lWasXdialog = 1 ; strcpy( lDialogString , "Xdialog --colorsel \"" ) ; if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, aTitle) ; } strcat(lDialogString, "\" 0 60 ") ; #if (defined(__cplusplus ) && __cplusplus >= 201103L) || (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || defined(__clang__) sprintf(lTmp,"%hhu %hhu %hhu",lDefaultRGB[0],lDefaultRGB[1],lDefaultRGB[2]); #else sprintf(lTmp,"%hu %hu %hu",lDefaultRGB[0],lDefaultRGB[1],lDefaultRGB[2]); #endif strcat(lDialogString, lTmp) ; strcat(lDialogString, " 2>&1"); } else if ( tkinter3Present( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"python3-tkinter");return (char *)1;} strcpy( lDialogString , gPython3Name ) ; strcat( lDialogString , " -S -c \"import tkinter;from tkinter import colorchooser;root=tkinter.Tk();root.withdraw();"); strcat( lDialogString , "res=colorchooser.askcolor(color='" ) ; strcat(lDialogString, lDefaultHexRGB ) ; strcat(lDialogString, "'") ; if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, ",title='") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "'") ; } strcat( lDialogString , ");\ \nif res[1] is not None:\n\tprint(res[1])\"" ) ; } else if ( tkinter2Present( ) ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"python2-tkinter");return (char *)1;} strcpy( lDialogString , "export PYTHONIOENCODING=utf-8;" ) ; strcat( lDialogString , gPython2Name ) ; if ( ! isTerminalRunning( ) && isDarwin( ) ) { strcat( lDialogString , " -i" ) ; /* for osx without console */ } strcat( lDialogString , " -S -c \"import Tkinter,tkColorChooser;root=Tkinter.Tk();root.withdraw();"); if ( isDarwin( ) ) { strcat( lDialogString , "import os;os.system('''osascript -e 'tell app \\\"Finder\\\" to set \ frontmost of process \\\"Python\\\" to true' ''');"); } strcat( lDialogString , "res=tkColorChooser.askcolor(color='" ) ; strcat(lDialogString, lDefaultHexRGB ) ; strcat(lDialogString, "'") ; if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, ",title='") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "'") ; } strcat( lDialogString , ");\ \nif res[1] is not None:\n\tprint res[1]\"" ) ; } else { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){return tinyfd_inputBox(aTitle,NULL,NULL);} lPointerInputBox = tinyfd_inputBox(NULL, NULL, NULL); /* obtain a pointer on the current content of tinyfd_inputBox */ if (lPointerInputBox) strcpy(lDialogString, lPointerInputBox); /* preserve the current content of tinyfd_inputBox */ p = tinyfd_inputBox(aTitle, "Enter hex rgb color (i.e. #f5ca20)", lDefaultHexRGB); if ( !p || (strlen(p) != 7) || (p[0] != '#') ) { return NULL ; } for ( i = 1 ; i < 7 ; i ++ ) { if ( ! isxdigit( (int) p[i] ) ) { return NULL ; } } Hex2RGB(p,aoResultRGB); strcpy(lDefaultHexRGB, p); if (lPointerInputBox) strcpy(lPointerInputBox, lDialogString); /* restore its previous content to tinyfd_inputBox */ return lDefaultHexRGB; } if (tinyfd_verbose) printf( "lDialogString: %s\n" , lDialogString ) ; if ( ! ( lIn = popen( lDialogString , "r" ) ) ) { return NULL ; } while ( fgets( lBuff , sizeof( lBuff ) , lIn ) != NULL ) { } pclose( lIn ) ; if ( ! strlen( lBuff ) ) { return NULL ; } /* printf( "len Buff: %lu\n" , strlen(lBuff) ) ; */ /* printf( "lBuff0: %s\n" , lBuff ) ; */ if ( lBuff[strlen( lBuff ) -1] == '\n' ) { lBuff[strlen( lBuff ) -1] = '\0' ; } if ( lWasZenity3 ) { if ( lBuff[0] == '#' ) { if ( strlen(lBuff)>7 ) { lBuff[3]=lBuff[5]; lBuff[4]=lBuff[6]; lBuff[5]=lBuff[9]; lBuff[6]=lBuff[10]; lBuff[7]='\0'; } Hex2RGB(lBuff,aoResultRGB); } else if ( lBuff[3] == '(' ) { #if (defined(__cplusplus ) && __cplusplus >= 201103L) || (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || defined(__clang__) sscanf(lBuff,"rgb(%hhu,%hhu,%hhu", & aoResultRGB[0], & aoResultRGB[1],& aoResultRGB[2]); #else aoResultRGB[0] = strtol(lBuff+4, & lTmp2, 10 ); aoResultRGB[1] = strtol(lTmp2+1, & lTmp2, 10 ); aoResultRGB[2] = strtol(lTmp2+1, NULL, 10 ); #endif RGB2Hex(aoResultRGB,lBuff); } else if ( lBuff[4] == '(' ) { #if (defined(__cplusplus ) && __cplusplus >= 201103L) || (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || defined(__clang__) sscanf(lBuff,"rgba(%hhu,%hhu,%hhu", & aoResultRGB[0], & aoResultRGB[1],& aoResultRGB[2]); #else aoResultRGB[0] = strtol(lBuff+5, & lTmp2, 10 ); aoResultRGB[1] = strtol(lTmp2+1, & lTmp2, 10 ); aoResultRGB[2] = strtol(lTmp2+1, NULL, 10 ); #endif RGB2Hex(aoResultRGB,lBuff); } } else if ( lWasOsascript || lWasXdialog ) { /* printf( "lBuff: %s\n" , lBuff ) ; */ #if (defined(__cplusplus ) && __cplusplus >= 201103L) || (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || defined(__clang__) sscanf(lBuff,"%hhu %hhu %hhu", & aoResultRGB[0], & aoResultRGB[1],& aoResultRGB[2]); #else aoResultRGB[0] = strtol(lBuff, & lTmp2, 10 ); aoResultRGB[1] = strtol(lTmp2+1, & lTmp2, 10 ); aoResultRGB[2] = strtol(lTmp2+1, NULL, 10 ); #endif RGB2Hex(aoResultRGB,lBuff); } else { Hex2RGB(lBuff,aoResultRGB); } /* printf("%d %d %d\n", aoResultRGB[0],aoResultRGB[1],aoResultRGB[2]); */ /* printf( "lBuff: %s\n" , lBuff ) ; */ strcpy(lDefaultHexRGB,lBuff); return lDefaultHexRGB ; } /* not cross platform - zenity only */ /* contributed by Attila Dusnoki */ char * tinyfd_arrayDialog( char const * aTitle , /* "" */ int aNumOfColumns , /* 2 */ char const * const * aColumns , /* {"Column 1","Column 2"} */ int aNumOfRows , /* 2 */ char const * const * aCells ) /* {"Row1 Col1","Row1 Col2","Row2 Col1","Row2 Col2"} */ { static char lBuff [MAX_PATH_OR_CMD] ; char lDialogString [MAX_PATH_OR_CMD] ; FILE * lIn ; int i ; lBuff[0]='\0'; if ( zenityPresent() || matedialogPresent() || shellementaryPresent() || qarmaPresent() ) { if ( zenityPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"zenity");return (char *)1;} strcpy( lDialogString , "zenity" ) ; if ( (zenity3Present() >= 4) && !getenv("SSH_TTY") ) { strcat( lDialogString, " --attach=$(sleep .01;xprop -root 32x '\t$0' _NET_ACTIVE_WINDOW | cut -f 2)"); /* contribution: Paul Rouget */ } } else if ( matedialogPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"matedialog");return (char *)1;} strcpy( lDialogString , "matedialog" ) ; } else if ( shellementaryPresent() ) { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"shellementary");return (char *)1;} strcpy( lDialogString , "shellementary" ) ; } else { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"qarma");return (char *)1;} strcpy( lDialogString , "qarma" ) ; if ( !getenv("SSH_TTY") ) { strcat(lDialogString, " --attach=$(xprop -root 32x '\t$0' _NET_ACTIVE_WINDOW | cut -f 2)"); /* contribution: Paul Rouget */ } } strcat( lDialogString , " --list --print-column=ALL" ) ; if ( aTitle && strlen(aTitle) ) { strcat(lDialogString, " --title=\"") ; strcat(lDialogString, aTitle) ; strcat(lDialogString, "\"") ; } if ( aColumns && (aNumOfColumns > 0) ) { for ( i = 0 ; i < aNumOfColumns ; i ++ ) { strcat( lDialogString , " --column=\"" ) ; strcat( lDialogString , aColumns [i] ) ; strcat( lDialogString , "\"" ) ; } } if ( aCells && (aNumOfRows > 0) ) { strcat( lDialogString , " " ) ; for ( i = 0 ; i < aNumOfRows*aNumOfColumns ; i ++ ) { strcat( lDialogString , "\"" ) ; strcat( lDialogString , aCells [i] ) ; strcat( lDialogString , "\" " ) ; } } } else { if (aTitle&&!strcmp(aTitle,"tinyfd_query")){strcpy(tinyfd_response,"");return (char *)0;} return NULL ; } if (tinyfd_verbose) printf( "lDialogString: %s\n" , lDialogString ) ; if ( ! ( lIn = popen( lDialogString , "r" ) ) ) { return NULL ; } while ( fgets( lBuff , sizeof( lBuff ) , lIn ) != NULL ) {} pclose( lIn ) ; if ( lBuff[strlen( lBuff ) -1] == '\n' ) { lBuff[strlen( lBuff ) -1] = '\0' ; } /* printf( "lBuff: %s\n" , lBuff ) ; */ if ( ! strlen( lBuff ) ) { return NULL ; } return lBuff ; } #endif /* _WIN32 */ /* int main( int argc , char * argv[] ) { char const * lTmp; char const * lTheSaveFileName; char const * lTheOpenFileName; char const * lTheSelectFolderName; char const * lTheHexColor; char const * lWillBeGraphicMode; unsigned char lRgbColor[3]; FILE * lIn; char lBuffer[1024]; char lString[1024]; char const * lFilterPatterns[2] = { "*.txt", "*.text" }; tinyfd_verbose = argc - 1; tinyfd_silent = 1; lWillBeGraphicMode = tinyfd_inputBox("tinyfd_query", NULL, NULL); strcpy(lBuffer, "v"); strcat(lBuffer, tinyfd_version); if (lWillBeGraphicMode) { strcat(lBuffer, "\ngraphic mode: "); } else { strcat(lBuffer, "\nconsole mode: "); } strcat(lBuffer, tinyfd_response); strcat(lBuffer, "\n"); strcat(lBuffer, tinyfd_needs+78); strcpy(lString, "tinyfiledialogs"); tinyfd_messageBox(lString, lBuffer, "ok", "info", 0); tinyfd_notifyPopup("the title", "the message\n\tfrom outer-space", "info"); if (lWillBeGraphicMode && !tinyfd_forceConsole) { tinyfd_forceConsole = ! tinyfd_messageBox("Hello World", "graphic dialogs [yes] / console mode [no]?", "yesno", "question", 1); } lTmp = tinyfd_inputBox( "a password box", "your password will be revealed", NULL); if (!lTmp) return 1; strcpy(lString, lTmp); lTheSaveFileName = tinyfd_saveFileDialog( "let us save this password", "passwordFile.txt", 2, lFilterPatterns, NULL); if (!lTheSaveFileName) { tinyfd_messageBox( "Error", "Save file name is NULL", "ok", "error", 1); return 1; } lIn = fopen(lTheSaveFileName, "w"); if (!lIn) { tinyfd_messageBox( "Error", "Can not open this file in write mode", "ok", "error", 1); return 1; } fputs(lString, lIn); fclose(lIn); lTheOpenFileName = tinyfd_openFileDialog( "let us read the password back", "", 2, lFilterPatterns, NULL, 0); if (!lTheOpenFileName) { tinyfd_messageBox( "Error", "Open file name is NULL", "ok", "error", 1); return 1; } lIn = fopen(lTheOpenFileName, "r"); if (!lIn) { tinyfd_messageBox( "Error", "Can not open this file in read mode", "ok", "error", 1); return(1); } lBuffer[0] = '\0'; fgets(lBuffer, sizeof(lBuffer), lIn); fclose(lIn); tinyfd_messageBox("your password is", lBuffer, "ok", "info", 1); lTheSelectFolderName = tinyfd_selectFolderDialog( "let us just select a directory", NULL); if (!lTheSelectFolderName) { tinyfd_messageBox( "Error", "Select folder name is NULL", "ok", "error", 1); return 1; } tinyfd_messageBox("The selected folder is", lTheSelectFolderName, "ok", "info", 1); lTheHexColor = tinyfd_colorChooser( "choose a nice color", "#FF0077", lRgbColor, lRgbColor); if (!lTheHexColor) { tinyfd_messageBox( "Error", "hexcolor is NULL", "ok", "error", 1); return 1; } tinyfd_messageBox("The selected hexcolor is", lTheHexColor, "ok", "info", 1); tinyfd_beep(); return 0; } */ #ifdef _MSC_VER #pragma warning(default:4996) #pragma warning(default:4100) #pragma warning(default:4706) #endif ================================================ FILE: src/utilities/TINYFILEDIALOGS/tinyfiledialogs.h ================================================ /*_________ / \ tinyfiledialogs.h v3.6.4 [Sep 14, 2020] zlib licence |tiny file| Unique header file created [November 9, 2014] | dialogs | Copyright (c) 2014 - 2020 Guillaume Vareille http://ysengrin.com \____ ___/ http://tinyfiledialogs.sourceforge.net \| git clone http://git.code.sf.net/p/tinyfiledialogs/code tinyfd ____________________________________________ | | | email: tinyfiledialogs at ysengrin.com | |____________________________________________| _________________________________________________________________________________ | | | the windows only wchar_t UTF-16 functions are at the bottom of this header file | |_________________________________________________________________________________| _________________________________________________________ | | | on windows: - since v3.6 char is UTF-8 by default | | - if you want MBCS set tinyfd_winUtf8 to 0 | | - functions like fopen expect MBCS | |_________________________________________________________| If you like tinyfiledialogs, please upvote my stackoverflow answer https://stackoverflow.com/a/47651444 tiny file dialogs (cross-platform C C++) InputBox PasswordBox MessageBox ColorPicker OpenFileDialog SaveFileDialog SelectFolderDialog Native dialog library for WINDOWS MAC OSX GTK+ QT CONSOLE & more SSH supported via automatic switch to console mode or X11 forwarding one C file + a header (add them to your C or C++ project) with 8 functions: - beep - notify popup (tray) - message & question - input & password - save file - open file(s) - select folder - color picker Complements OpenGL Vulkan GLFW GLUT GLUI VTK SFML TGUI SDL Ogre Unity3d ION OpenCV CEGUI MathGL GLM CPW GLOW Open3D IMGUI MyGUI GLT NGL STB & GUI less programs NO INIT NO MAIN LOOP NO LINKING NO INCLUDE The dialogs can be forced into console mode Windows (XP to 10) ASCII MBCS UTF-8 UTF-16 - native code & vbs create the graphic dialogs - enhanced console mode can use dialog.exe from http://andrear.altervista.org/home/cdialog.php - basic console input Unix (command line calls) ASCII UTF-8 - applescript, kdialog, zenity - python (2 or 3) + tkinter + python-dbus (optional) - dialog (opens a console if needed) - basic console input The same executable can run across desktops & distributions C89/C18 & C++98/C++20 compliant: tested with C & C++ compilers VisualStudio MinGW-gcc GCC Clang TinyCC OpenWatcom-v2 BorlandC SunCC ZapCC on Windows Mac Linux Bsd Solaris Minix Raspbian using Gnome Kde Enlightenment Mate Cinnamon Budgie Unity Lxde Lxqt Xfce WindowMaker IceWm Cde Jds OpenBox Awesome Jwm Xdm Cwm Bindings for LUA and C# dll, Haskell, Fortran Included in LWJGL(java), Rust, Allegrobasic - License - This software is provided 'as-is', without any express or implied warranty. In no event will the authors be held liable for any damages arising from the use of this software. Permission is granted to anyone to use this software for any purpose, including commercial applications, and to alter it and redistribute it freely, subject to the following restrictions: 1. The origin of this software must not be misrepresented; you must not claim that you wrote the original software. If you use this software in a product, an acknowledgment in the product documentation would be appreciated but is not required. 2. Altered source versions must be plainly marked as such, and must not be misrepresented as being the original software. 3. This notice may not be removed or altered from any source distribution. */ #ifndef TINYFILEDIALOGS_H #define TINYFILEDIALOGS_H #ifdef __cplusplus extern "C" { /* if tinydialogs.c is compiled as C++ code rather than C code, you may need to comment this out and the corresponding closing bracket near the end of this file. */ #endif /******************************************************************************************************/ /**************************************** UTF-8 on Windows ********************************************/ /******************************************************************************************************/ #ifdef _WIN32 /* On windows, if you want to use UTF-8 ( instead of the UTF-16/wchar_t functions at the end of this file ) Make sure your code is really prepared for UTF-8 (on windows, functions like fopen() expect MBCS and not UTF-8) */ extern int tinyfd_winUtf8; /* on windows char strings can be 1:UTF-8(default) or 0:MBCS */ /* for MBCS change this to 0, in tinyfiledialogs.c or in your code */ /* Here are some functions to help you convert between UTF-16 UTF-8 MBSC */ char * tinyfd_utf8toMbcs(char const * aUtf8string); wchar_t * tinyfd_utf8to16(char const * aUtf8string); char * tinyfd_utf16to8(wchar_t const * aUtf16string); void tinyfd_setWinUtf8(int aIsUtf8); /* made to be used from C# to set the global variable tinyfd_winUtf8 to 1 or 0 */ #endif /******************************************************************************************************/ /******************************************************************************************************/ /******************************************************************************************************/ extern char const tinyfd_version[8]; /* contains tinyfd current version number */ extern char const tinyfd_needs[]; /* info about requirements */ extern int tinyfd_verbose; /* 0 (default) or 1 : on unix, prints the command line calls */ extern int tinyfd_silent; /* 1 (default) or 0 : on unix, hide errors and warnings from called dialogs */ /* Curses dialogs are difficult to use, on windows they are only ascii */ /* int const tinyfd_allowCursesDialogs; 0 (default) or 1 : you can change this in tinyfiledialogs.c */ extern int tinyfd_forceConsole; /* 0 (default) or 1 */ /* for unix & windows: 0 (graphic mode) or 1 (console mode). 0: try to use a graphic solution, if it fails then it uses console mode. 1: forces all dialogs into console mode even when an X server is present, if the package dialog (and a console is present) or dialog.exe is installed. on windows it only make sense for console applications */ extern char tinyfd_response[1024]; /* if you pass "tinyfd_query" as aTitle, the functions will not display the dialogs but will return 0 for console mode, 1 for graphic mode. tinyfd_response is then filled with the retain solution. possible values for tinyfd_response are (all lowercase) for graphic mode: windows_wchar windows applescript kdialog zenity zenity3 matedialog qarma python2-tkinter python3-tkinter python-dbus perl-dbus gxmessage gmessage xmessage xdialog gdialog for console mode: dialog whiptail basicinput no_solution */ void tinyfd_beep(void); int tinyfd_notifyPopup( char const * aTitle, /* NULL or "" */ char const * aMessage, /* NULL or "" may contain \n \t */ char const * aIconType); /* "info" "warning" "error" */ /* return has only meaning for tinyfd_query */ int tinyfd_messageBox( char const * aTitle , /* NULL or "" */ char const * aMessage , /* NULL or "" may contain \n \t */ char const * aDialogType , /* "ok" "okcancel" "yesno" "yesnocancel" */ char const * aIconType , /* "info" "warning" "error" "question" */ int aDefaultButton ) ; /* 0 for cancel/no , 1 for ok/yes , 2 for no in yesnocancel */ char * tinyfd_inputBox( char const * aTitle , /* NULL or "" */ char const * aMessage , /* NULL or "" may NOT contain \n \t on windows */ char const * aDefaultInput ) ; /* "" , if NULL it's a passwordBox */ /* returns NULL on cancel */ char * tinyfd_saveFileDialog( char const * aTitle , /* NULL or "" */ char const * aDefaultPathAndFile , /* NULL or "" */ int aNumOfFilterPatterns , /* 0 */ char const * const * aFilterPatterns , /* NULL | {"*.jpg","*.png"} */ char const * aSingleFilterDescription ) ; /* NULL | "text files" */ /* returns NULL on cancel */ char * tinyfd_openFileDialog( char const * aTitle , /* NULL or "" */ char const * aDefaultPathAndFile , /* NULL or "" */ int aNumOfFilterPatterns , /* 0 */ char const * const * aFilterPatterns , /* NULL | {"*.jpg","*.png"} */ char const * aSingleFilterDescription , /* NULL | "image files" */ int aAllowMultipleSelects ) ; /* 0 or 1 */ /* in case of multiple files, the separator is | */ /* returns NULL on cancel */ char * tinyfd_selectFolderDialog( char const * aTitle , /* NULL or "" */ char const * aDefaultPath ) ; /* NULL or "" */ /* returns NULL on cancel */ char * tinyfd_colorChooser( char const * aTitle , /* NULL or "" */ char const * aDefaultHexRGB , /* NULL or "#FF0000" */ unsigned char const aDefaultRGB[3] , /* { 0 , 255 , 255 } */ unsigned char aoResultRGB[3] ) ; /* { 0 , 0 , 0 } */ /* returns the hexcolor as a string "#FF0000" */ /* aoResultRGB also contains the result */ /* aDefaultRGB is used only if aDefaultHexRGB is NULL */ /* aDefaultRGB and aoResultRGB can be the same array */ /* returns NULL on cancel */ /************ NOT CROSS PLATFORM SECTION STARTS HERE ************************/ #ifdef _WIN32 /* windows only - utf-16 version */ int tinyfd_notifyPopupW( wchar_t const * aTitle, /* NULL or L"" */ wchar_t const * aMessage, /* NULL or L"" may contain \n \t */ wchar_t const * aIconType); /* L"info" L"warning" L"error" */ /* windows only - utf-16 version */ int tinyfd_messageBoxW( wchar_t const * aTitle , /* NULL or L"" */ wchar_t const * aMessage, /* NULL or L"" may contain \n \t */ wchar_t const * aDialogType, /* L"ok" L"okcancel" L"yesno" */ wchar_t const * aIconType, /* L"info" L"warning" L"error" L"question" */ int aDefaultButton ); /* 0 for cancel/no , 1 for ok/yes */ /* returns 0 for cancel/no , 1 for ok/yes */ /* windows only - utf-16 version */ wchar_t * tinyfd_inputBoxW( wchar_t const * aTitle, /* NULL or L"" */ wchar_t const * aMessage, /* NULL or L"" may NOT contain \n nor \t */ wchar_t const * aDefaultInput ); /* L"" , if NULL it's a passwordBox */ /* windows only - utf-16 version */ wchar_t * tinyfd_saveFileDialogW( wchar_t const * aTitle, /* NULL or L"" */ wchar_t const * aDefaultPathAndFile, /* NULL or L"" */ int aNumOfFilterPatterns, /* 0 */ wchar_t const * const * aFilterPatterns, /* NULL or {L"*.jpg",L"*.png"} */ wchar_t const * aSingleFilterDescription); /* NULL or L"image files" */ /* returns NULL on cancel */ /* windows only - utf-16 version */ wchar_t * tinyfd_openFileDialogW( wchar_t const * aTitle, /* NULL or L"" */ wchar_t const * aDefaultPathAndFile, /* NULL or L"" */ int aNumOfFilterPatterns , /* 0 */ wchar_t const * const * aFilterPatterns, /* NULL {L"*.jpg",L"*.png"} */ wchar_t const * aSingleFilterDescription, /* NULL or L"image files" */ int aAllowMultipleSelects ) ; /* 0 or 1 */ /* in case of multiple files, the separator is | */ /* returns NULL on cancel */ /* windows only - utf-16 version */ wchar_t * tinyfd_selectFolderDialogW( wchar_t const * aTitle, /* NULL or L"" */ wchar_t const * aDefaultPath); /* NULL or L"" */ /* returns NULL on cancel */ /* windows only - utf-16 version */ wchar_t * tinyfd_colorChooserW( wchar_t const * aTitle, /* NULL or L"" */ wchar_t const * aDefaultHexRGB, /* NULL or L"#FF0000" */ unsigned char const aDefaultRGB[3] , /* { 0 , 255 , 255 } */ unsigned char aoResultRGB[3] ) ; /* { 0 , 0 , 0 } */ /* returns the hexcolor as a string L"#FF0000" */ /* aoResultRGB also contains the result */ /* aDefaultRGB is used only if aDefaultHexRGB is NULL */ /* aDefaultRGB and aoResultRGB can be the same array */ /* returns NULL on cancel */ #else /*_WIN32*/ /* unix zenity only */ char * tinyfd_arrayDialog( char const * aTitle , /* NULL or "" */ int aNumOfColumns , /* 2 */ char const * const * aColumns, /* {"Column 1","Column 2"} */ int aNumOfRows, /* 2 */ char const * const * aCells); /* {"Row1 Col1","Row1 Col2","Row2 Col1","Row2 Col2"} */ #endif /*_WIN32 */ #ifdef __cplusplus } /*extern "C"*/ #endif #endif /* TINYFILEDIALOGS_H */ /* - This is not for ios nor android (it works in termux though). - The code is pure C, perfectly compatible with C++. - the windows only wchar_t (utf-16) prototypes are in the header file - windows is fully supported from XP to 10 (maybe even older versions) - C# & LUA via dll, see files in the folder EXTRAS - OSX supported from 10.4 to latest (maybe even older versions) - Avoid using " and ' in titles and messages. - There's one file filter only, it may contain several patterns. - If no filter description is provided, the list of patterns will become the description. - char const * filterPatterns[3] = { "*.obj" , "*.stl" , "*.dxf" } ; - On windows char defaults to UTF-8, set tinyfd_winUtf8=0 to use MBCS - On windows link against Comdlg32.lib and Ole32.lib (on windows the no linking claim is a lie) This linking is not compulsary for console mode (see header file). - On unix: it tries command line calls, so no such need (NO LINKING). - On unix you need one of the following: applescript, kdialog, zenity, matedialog, shellementary, qarma, python (2 or 3)/tkinter/python-dbus (optional), Xdialog or dialog (opens terminal if running without console) or xterm. - One of those is already included on most (if not all) desktops. - In the absence of those it will use gdialog, gxmessage or whiptail with a textinputbox. - If nothing is found, it switches to basic console input, it opens a console if needed (requires xterm + bash). - Use windows separators on windows and unix separators on unix. - String memory is preallocated statically for all the returned values. - File and path names are tested before return, they are valid. - If you pass only a path instead of path + filename, make sure it ends with a separator. - tinyfd_forceConsole=1; at run time, forces dialogs into console mode. - On windows, console mode only make sense for console applications. - On windows, Console mode is not implemented for wchar_T UTF-16. - Mutiple selects are not allowed in console mode. - The package dialog must be installed to run in enhanced console mode. It is already installed on most unix systems. - On osx, the package dialog can be installed via http://macappstore.org/dialog or http://macports.org - On windows, for enhanced console mode, dialog.exe should be copied somewhere on your executable path. It can be found at the bottom of the following page: http://andrear.altervista.org/home/cdialog.php - If dialog is missing, it will switch to basic console input. - You can query the type of dialog that will be use (pass "tinyfd_query" as aTitle) */ ================================================ FILE: src/utilities/TINYFILEDIALOGS/tinyopen.c ================================================ /*_________ / \ tinyfiledialogs v3.5.0 [Apr 13, 2020] zlib licence |tiny file| | dialogs | Copyright (c) 2014 - 2020 Guillaume Vareille http://ysengrin.com \____ ___/ http://tinyfiledialogs.sourceforge.net \| git clone http://git.code.sf.net/p/tinyfiledialogs/code tinyfd - License - This software is provided 'as-is', without any express or implied warranty. In no event will the authors be held liable for any damages arising from the use of this software. Permission is granted to anyone to use this software for any purpose, including commercial applications, and to alter it and redistribute it freely, subject to the following restrictions: 1. The origin of this software must not be misrepresented; you must not claim that you wrote the original software. If you use this software in a product, an acknowledgment in the product documentation would be appreciated but is not required. 2. Altered source versions must be plainly marked as such, and must not be misrepresented as being the original software. 3. This notice may not be removed or altered from any source distribution. this fortran code for tinyfiledialogs was contributed by Bo Sundman */ /* dummy C routine that returns a legal filename */ #include #include #include "tinyfiledialogs.h" char const * tinyopen( int const typ) { char const * lFilterPatterns1[1] = {"*.TDB"}; char const * lFilterPatterns2[1] = {"*.OCU"}; char const * lFilterPatterns3[1] = {"*.OCM"}; char const * lFilterPatterns4[1] = {"*.OCD"}; char const * lFilterPatterns5[1] = {"*.PLT"}; char const * p2; //printf("start of tinydummy \n"); //printf("input value of typ: %i \n",typ); //printf("now copy the string \n"); //strcpy(filename,"C:\\User\\Bosse\\Document\\Software\\openfile\\test.TDB"); if(typ<0) { //lTheOpenFileName = tinyfd_openFileDialog( //p2 = tinyfd_openFileDialog( p2 = tinyfd_saveFileDialog( "Output file name", "", 0, NULL, NULL); // lFilterPatterns1, // NULL, // 0); } else if(typ==1) { //lTheOpenFileName = tinyfd_openFileDialog( p2 = tinyfd_openFileDialog( "Input file name", "", 1, lFilterPatterns1, NULL, 0); } else if(typ==2) { //lTheOpenFileName = tinyfd_openFileDialog( p2 = tinyfd_openFileDialog( "Input file name", "", 1, lFilterPatterns2, NULL, 0); //p2="C:\\User\\Bosse\\Document\\Software\\openfile\\test.UNF"; } else if(typ==3) { //lTheOpenFileName = tinyfd_openFileDialog( p2 = tinyfd_openFileDialog( "Input file name", "", 1, lFilterPatterns3, NULL, 0); //p2="C:\\User\\Bosse\\Document\\Software\\openfile\\test.UNF"; } else if(typ==4) { //lTheOpenFileName = tinyfd_openFileDialog( p2 = tinyfd_openFileDialog( "Input file name", "", 1, lFilterPatterns3, NULL, 0); //p2="C:\\User\\Bosse\\Document\\Software\\openfile\\test.UNF"; } else { //no default extension p2 = tinyfd_openFileDialog( "Input file name", "", 0, NULL, NULL, 0); //p2="C:\\User\\Bosse\\Document\\Software\\openfile\\test.DAT"; } //if (! lTheOpenFileName) if (! p2) { tinyfd_messageBox( "Error", "Open file name is NULL", "ok", "error", 1); return NULL ; } //printf("return name: %s \n",p2); //printf("end of tinydummy \n"); //return lTheOpenFileName; return p2; } ================================================ FILE: src/utilities/metlib4.F90 ================================================ ! ! general utilities in Fortran 95 a la METLIB upgraded 2015-2019 to ! eliminate most specific F77 features ! 1. All ENTRY removed. GPARxyz and MACRO routines seems OK ! 2. Problems with getkey developed by John S. Urban has been fixed, ! It has been renamed getkex in the iso-C interface. ! 3. IMPLICT NONE introduced in the whole module. ! 4. A revised online help system using HTML \hypertarget in user guide ! ! To be done: !CCI done in ocparam.F90 ! - move constants ZERO, ONE here (from gtp3) !CCI ! - use same error code system as in gtp ! - revise the online help system ! MODULE METLIB ! ! Copyright 1980-2022, Bo Sundman bo.sundman@gmail.com ! ! This program is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 2 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this program; if not, write to the Free Software ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! !-------------------------------------------------------------------------- #ifdef lixed ! LINUX: For character by character input allowing emacs editing use M_getkey #endif ! #ifdef tinyfd ! use tinyfiledialogs to browse for files use ftinyopen #endif ! ocparam is in models/ocparam.F90 !CCI use OCPARAM !CCI ! !-------------------------------------------------------------------------- ! ! Error codes (buperr) ! 1001 Too small stack for sorting integers ! 1002 Too small workspace ! 1003 Pointer outside workspace ! 1004 Free areas not in increasing order ! 1005 Too small or too big free area ! 1006 No space available ! 1007 Free workspace destroyed ! 1008 Attempt to reserve one word or less ! 1009 Released area inside free area ! 1010 Too large character or real arrays in LOADC/STORC or LOADRN/STORRN ! 1030 NO SUCH TYPE OPTION ! 1031 Empty line, expected number ! 1032 PARAMETER VALUE MISSING ! 1033 Decimal point but no digits ! 1034 No digits ! 1035 Positive sign but no digits ! 1036 Negative sign but no digits ! 1037 No sign and no digits ! 1038 NO DIGITS AFTER EXPONENTIAL E ! 1039 Exponent larget then 99 ! 1040 NO HELP FOR ! 1041 NO SUCH QUESTION FOR ! 1042 TOO LARGE INTEGER VALUE ! 1057 Too long input line ! 1060 illegal bit number ! 1070 Margin error in wrice ! 1083 Too deeply nested macros ! 1100 Not enough space to write number in text ! 1101 Name does not start with letter A-Z ! 1235 too many ( ! 1236 too few ) ! 1237 error with parenthesis ! 1332 Illegal option ! 1333 Missing option value delimiter ! 1334 Missing option value ! 1350 File system error ! 1360 Missing column number for substitution ! !---------------------------------------------------------- ! ! global variables and constants ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) ! implicit none ! ! Using open MP parallelization !$ use OMP_LIB ! ! GLOBAL ERROR CODE moved from gtp3 !\begin{verbatim} TYPE gtp_parerr ! This record contains the global error code. In parallel processing each ! parallel processes has its own error code copied to this if nonzero ! it should be replaced by gtperr for separate errors in treads INTEGER :: bmperr END TYPE gtp_parerr TYPE(gtp_parerr) :: gx ! ! needed to have error code as private in threads !$OMP threadprivate(gx) !\end{verbatim} ! !---------------------------------------------------------- ! ! Data structures for putfun below (no change 190802) !\begin{verbatim} ! Data structures in METLIB TYPE putfun_node ! all nodes of function stored as part of a binary tree ! kod is operation kod (0 datanod), links is how many links to this node integer kod,links ! this is the sequential order the node is allocated (for debugging) integer debug ! each node has a left and a right link. If the left node is empty the ! right is normally a data node TYPE(putfun_node), pointer :: left,right ! A data node can have a numeric value and/or a link to another function double precision value ! this is an identification of external symbols integer dataid end TYPE putfun_node ! ! BEWARE entering putfuns cannot be made in parallel processing ! but one may evaluate them in different threads ! ! PUTFUNNVAR is associated with external symbols in the LOKV array integer, private :: putfunvar TYPE PUTFUN_STACK type(putfun_node), pointer ::savetop, savebin, saveuni type(putfun_stack), pointer :: previous end TYPE PUTFUN_STACK type(putfun_stack), pointer :: stacktop ! topnod is the current top node ! lastopnod is last binary opkod node ! datanod is last data node TYPE(putfun_node), private, pointer :: topnod,datanod,lastopnod integer pfnerr,debuginc ! ! end data structures for PUTFUN !\end{verbatim} ! !\begin{verbatim} ! data structures for history and help ! integer, parameter :: histlines=100 ! TYPE CHISTORY ! to save the last 20 lines of commands character*80 hline(histlines) integer :: hpos=0 END TYPE CHISTORY type(chistory) :: myhistory ! integer, parameter :: maxhelplevel=15 ! A help structure used in new on-line help system ! this was designed for both LaTeX and HTML help, now only HTML TYPE help_str integer :: okinit=0 character*128 filename character*8 type integer level character*32, dimension(maxhelplevel) :: cpath END TYPE help_str ! this record is used to file the appropriate help text type(help_str), save :: helprec ! this is useful to add %\section and %\subsection in helpfile logical :: helptrace=.FALSE. ! ! using browser and html files for on-line help type onlinehelp ! if htmlhelp is TRUE then browser is the path/name of browser ! htmlfile is full path/name of html file ! target is used to find the relevant text the html file ! values of browser and htmlfile set by the main program (and htmlhelp=.TRUE.) ! The value of target is found searching the original LaTeX file!! ! In this file there are \hypertarget{target} which can be searched in the ! html file as ! Searching the LaTeX file the help system will find a section ! matching the history of commands/questions the user has given ! and the target in the first \hypertarget {target} found within these lines ! will be used for the help displayed in the browser window logical :: htmlhelp=.FALSE. character*128 browser character*128 htmlfile character*128 latexfile character*64 target end type onlinehelp type(onlinehelp) :: ochelp save ochelp ! end data structures for history and help !\end{verbatim} ! ! ! default units for command output, input, error message, list ! and default language integer, parameter :: koud=6,kiud=5,keud=6,lutd=6,lerd=6,langd=1 ! representation of the numerical value "none" double precision, parameter :: RNONE=-1.0D-36,FLTSML=1.0D-36,FLTPRS=1.0D-14 integer, parameter :: NONE=-2147483647,MAXINT=2147483647,MININT=-2147483646 character*4, parameter :: CNONE='NONE' ! initiate i/o and error code integer :: kou=koud,kiu=kiud,keu=keud,lut=lutd,ler=lerd,lang=langd integer :: buperr=0,iox(10) ! LSTCMD is the last command given. Saved by NCOMP, used by help routines character, private :: lstcmd*40 ! LUN unsed for macros and SAVE files integer :: lun=50 ! LOGFIL is nonzero if a log file is set integer, private :: logfil=0 ! global values for history CHARACTER, private :: HIST(20)*80 integer, private :: LHL=0,LHM=0,LHP=0 ! terminal charcterististics, koltrm is number of columns, default 80 integer :: KOLTRM=80 ! ECHO on/off integer :: JECHO=0 ! no idea what is in KFLAGS, has to do with VT200 terminals. Not needed?? ! integer KFLAGS(24) ! ! This is for environment variables used in MACROs character, private :: ENVIR(9)*60 ! character*3, parameter :: MACEXT='OCM' ! !----------- some added things 190802/BoS ! prevent use of popup windows for open/save file ! logical nopopup logical :: NOPENPOPUP=.FALSE. ! character for PATH to macro file in order to open files inside macro character macropath(5)*256 ! the working directory character workingdir*256 ! for macros integer IUMACLEVL,MACROUNIT(5) !\begin{verbatim} ! >>>>>>>>>> SYSTEM DEPENDENT <<<<<<<<<< ! nbpw is number if bytes per INTEGER, nwpr number of words per (double) real ! nbitpw number of bits per word ! USED when WPACK routines store data in integer workspace integer, parameter :: nbpw=4,nwpr=2,nbitpw=32 ! >>>>>>>>>> SYSTEM DEPENDENT <<<<<<<<<< !\end{verbatim} ! ! some constants !CCI Comment the next line because of already defined in ocparam.F90 !CCI double precision, parameter, private :: ZERO=0.0D0,ONE=1.0D0,TEN=1.0D1 ! ! ------------------------------------------------------------------- ! GPARxyz routines parameter transfer of integer, real and logical values ! ! integer GPARIDEF,GPARITYP ! double precision GPARRDEF ! logical GPARWDEF,GPARENTES ! character GPARCH2*1 ! ! added private to avoid problem with modules using metlib integer, private :: GPARIDEF,GPARITYP double precision, private :: GPARRDEF logical, private :: GPARWDEF,GPARENTES character, private :: GPARCH2*1 ! !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ CONTAINS !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ ! ! >>>> subsection ! SORTING SUBROUTINES FOR INTEGERS, REALS AND CHARACTERS ! QUICKSORT ENL KNUTH ALGORTIM Q ! THE ART OF COMPUTER PROGRAMMING, VOL 3, P 117 ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine sortrd & Sorting reals !\begin{verbatim} SUBROUTINE SORTRD(ARR,N,IX) ! ...SORTING REAL NUMBERS IN ASCENDING ORDER ! INPUT: ! ARR ARRAY TO BE SORTED ! N NUMBER OF ELEMENTS TO BE SORTED >1 ! IX INTEGER ARRAY WITH DIMENSION N ! EXIT: ! ARR SORTED ARRAY ! IX ARRAY WHERE IX(I) IS THE PREVIOS INDEX OF ARR(I) implicit none real ARR(*) integer n,ix(*) !\end{verbatim} %+ integer, parameter :: MSTACK=20 real part,val integer LOW(MSTACK),IGH(MSTACK) integer i,is,j,k,m,min,max ! LOW AND IGH IS USED TO STORE THE LOWER AND HIGHER PARTION BOUNDARIES IF(N.LT.1) GOTO 900 ! IX IS ORIGINAL INDEX OF ELEMENT I IN ARR DO I=1,N IX(I)=I enddo IF(N.EQ.1) GOTO 900 ! M IS THE PARTION SIZE THAT IS SORTED WITH STRIGHT INSERTION ! IS POINTS TO FREE STACK, MSTACK IS SIZE OF STACK M=1 IS=1 !******STEP Q1, INITIATING IF(N.LE.M) GOTO 900 MIN=1 MAX=N !******STEP Q2, NEW STAGE ! MIN AND MAX ARE LOWER AND UPPER LIMITS FOR THE PARTION 100 PART=ARR(MIN) I=MIN J=MAX+1 !******STEP Q3, INCREASE I UNTIL I>J OR ARR(I)>PART 110 I=I+1 IF(I.GE.J) GOTO 200 IF(ARR(I).LE.PART) GOTO 110 !******STEP Q4, DECREASE J UNTIL JM IF(MAX-J.LE.M) GOTO 360 ! BOTH PARTITIONS ARE GREATER THAN M, THE GREATEST IS PUSHED IF(IS.GT.MSTACK) GOTO 910 LOW(IS)=MIN IGH(IS)=J-1 IS=IS+1 ! CONTINUE TO PARTITION THE SMALLEST 310 MIN=J+1 GOTO 100 ! MAX-J GREATEST 350 IF(MAX-J.LE.M) GOTO 400 ! PUSH ONLY IF J-MIN>M IF(J-MIN.LE.M) GOTO 310 ! BOTH PARTITIONS ARE GREATER THAN M, PUSH THE GREATEST IF(IS.GT.MSTACK) GOTO 910 LOW(IS)=J+1 IGH(IS)=MAX IS=IS+1 ! CONTINUE TO PARTITION THE SMALLEST 360 MAX=J-1 GOTO 100 !******STEP Q8, POP FROM STACK 400 IS=IS-1 IF(IS.LT.1) GOTO 500 MIN=LOW(IS) MAX=IGH(IS) GOTO 100 !******STEP Q9, STRIGHT INSERTION, ONLY NECESSARY IF M>1 500 CONTINUE 900 RETURN 910 buperr=1051 GOTO 900 end SUBROUTINE SORTRD !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine sortrdd & Sorting doubles !\begin{verbatim} SUBROUTINE SORTRDD(ARR,N,IX) ! ...SORTING DOUBLE PRECISION NUMBERS IN DECENDING ORDER ! INPUT: ! ARR ARRAY TO BE SORTED ! N NUMBER OF ELEMENTS TO BE SORTED >1 ! IX INTEGER ARRAY WITH DIMENSION N ! EXIT: ! ARR SORTED ARRAY ! IX ARRAY WHERE IX(I) IS THE PREVIOS INDEX OF ARR(I) ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none double precision ARR(*) integer n,ix(*) !\end{verbatim} %+ integer, parameter :: MSTACK=20 double precision part,val integer LOW(MSTACK),IGH(MSTACK) integer i,is,j,k,m,min,max ! LOW AND IGH IS USED TO STORE THE LOWER AND HIGHER PARTION BOUNDARIES IF(N.LT.1) GOTO 900 ! IX IS ORIGINAL INDEX OF ELEMENT I IN ARR DO I=1,N IX(I)=I enddo IF(N.EQ.1) GOTO 900 ! M IS THE PARTION SIZE THAT IS SORTED WITH STRIGHT INSERTION ! IS POINTS TO FREE STACK, MSTACK IS SIZE OF STACK M=1 IS=1 !******STEP Q1, INITIATING IF(N.LE.M) GOTO 900 MIN=1 MAX=N !******STEP Q2, NEW STAGE ! MIN AND MAX ARE LOWER AND UPPER LIMITS FOR THE PARTION 100 PART=ARR(MIN) I=MIN J=MAX+1 !******STEP Q3, INCREASE I UNTIL I>J OR ARR(I)>PART 110 I=I+1 IF(I.GE.J) GOTO 200 ! IF(ARR(I).LE.PART) GOTO 110 IF(ARR(I).GE.PART) GOTO 110 !******STEP Q4, DECREASE J UNTIL JM IF(MAX-J.LE.M) GOTO 360 ! BOTH PARTITIONS ARE GREATER THAN M, THE GREATEST IS PUSHED IF(IS.GT.MSTACK) GOTO 910 LOW(IS)=MIN IGH(IS)=J-1 IS=IS+1 ! CONTINUE TO PARTITION THE SMALLEST 310 MIN=J+1 GOTO 100 ! MAX-J GREATEST 350 IF(MAX-J.LE.M) GOTO 400 ! PUSH ONLY IF J-MIN>M IF(J-MIN.LE.M) GOTO 310 ! BOTH PARTITIONS ARE GREATER THAN M, PUSH THE GREATEST IF(IS.GT.MSTACK) GOTO 910 LOW(IS)=J+1 IGH(IS)=MAX IS=IS+1 ! CONTINUE TO PARTITION THE SMALLEST 360 MAX=J-1 GOTO 100 !******STEP Q8, POP FROM STACK 400 IS=IS-1 IF(IS.LT.1) GOTO 500 MIN=LOW(IS) MAX=IGH(IS) GOTO 100 !******STEP Q9, STRIGHT INSERTION, ONLY NECESSARY IF M>1 500 CONTINUE 900 RETURN 910 buperr=1051 GOTO 900 end SUBROUTINE SORTRDD !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine sortin & Sorting integers !\begin{verbatim} SUBROUTINE SORTIN(IARR,N,IX) ! ...SORTING INTEGERS IN ASCENDING ORDER ! INPUT: ! IARR ARRAY TO BE SORTED ! N NUMBER OF ELEMENTS TO BE SORTED >1 ! IX INTEGER ARRAY WITH DIMENSION N ! EXIT: ! IARR SORTED ARRAY ! IX ARRAY WHERE IX(I) IS THE PREVIOS INDEX OF IARR(I) implicit none integer IARR(*),n,ix(*) !\end{verbatim} %+ integer, parameter :: MSTACK=20 integer ipart,ival integer LOW(MSTACK),IGH(MSTACK) integer i,is,j,k,m,min,max ! PARAMETER (MSTACK=20) ! DIMENSION IARR(*),IX(*),LOW(MSTACK),IGH(MSTACK) ! LOW AND IGH IS USED TO STORE THE LOWER AND HIGHER PARTISION BOUNDARIES IF(N.LT.1) GOTO 900 ! IX IS ORIGINAL INDEX OF ELEMENT I IN IARR DO I=1,N IX(I)=I endDO IF(N.EQ.1) GOTO 900 ! M IS THE PARTITION SIZE THAT IS SORTED WITH STRIGHT INSERTION ! IS POINTS TO FREE STACK, MSTACK IS SIZE OF STACK M=1 IS=1 !******STEP Q1, INITIATING IF(N.LE.M) GOTO 900 MIN=1 MAX=N !******STEP Q2, NEW STAGE ! MIN AND MAX ARE LOWER AND UPPER LIMITS FOR THE PARTISION 100 IPART=IARR(MIN) I=MIN J=MAX+1 !******STEP Q3, INCREASE I UNTIL I>J OR IARR(I)>IPART 110 I=I+1 IF(I.GE.J) GOTO 200 IF(IARR(I).LE.IPART) GOTO 110 !******STEP Q4, DECREASE J UNTIL JM IF(MAX-J.LE.M) GOTO 360 ! BOTH PARTITIONS ARE GREATER THAN M, THE GREATEST IS PUSHED IF(IS.GT.MSTACK) GOTO 910 LOW(IS)=MIN IGH(IS)=J-1 IS=IS+1 ! CONTINUE TO PARTITION THE SMALLEST 310 MIN=J+1 GOTO 100 ! MAX-J GREATEST 350 IF(MAX-J.LE.M) GOTO 400 ! PUSH ONLY IF J-MIN>M IF(J-MIN.LE.M) GOTO 310 ! BOTH PARTITIONS ARE GREATER THAN M, PUSH THE GREATEST IF(IS.GT.MSTACK) GOTO 910 LOW(IS)=J+1 IGH(IS)=MAX IS=IS+1 ! CONTINUE TO PARTITION THE SMALLEST 360 MAX=J-1 GOTO 100 !******STEP Q8, POP FROM STACK 400 IS=IS-1 IF(IS.LT.1) GOTO 500 MIN=LOW(IS) MAX=IGH(IS) GOTO 100 !******STEP Q9, STRIGHT INSERTION, ONLY NECESSARY IF M>1 500 CONTINUE buperr=0 900 RETURN 910 buperr=1001 GOTO 900 END SUBROUTINE SORTIN !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine ssort DOES NOT WORK !\begin{verbatim} SUBROUTINE SSORT(CMD,NS,INDEX) !...SORTING a character array, max 40 characters long ! THIS DOES NOT WORK !!! implicit none CHARACTER CMD(*)*(*) integer ns,index(*) !\end{verbatim} CHARACTER STR*40 integer l,itop,j,j1,j2,k ! L=LEN(CMD(1)) ITOP=1 INDEX(ITOP)=1 100 ITOP=ITOP+1 IF(ITOP.GT.NS) GOTO 900 STR=CMD(ITOP) IF(STR(1:L).GE.CMD(INDEX(ITOP-1))) THEN INDEX(ITOP)=ITOP GOTO 100 ENDIF J1=1 J2=ITOP J=(J1+J2)/2 200 IF(STR(1:L).LT.CMD(INDEX(J))) THEN J2=J ELSEIF(J.GT.J1) THEN J1=J ELSE J=J2 GOTO 300 ENDIF IF(J1.NE.J2) THEN K=J J=(J1+J2)/2 IF(K.NE.J) GOTO 200 J=J2 ENDIF !...PLACE FOUND 300 CONTINUE MOVE: DO K=ITOP-1,J,-1 INDEX(K+1)=INDEX(K) enddo MOVE INDEX(J)=ITOP GOTO 100 900 RETURN END SUBROUTINE SSORT !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine ssort & Sorting characters !\begin{verbatim} SUBROUTINE SSORT2(CMD,NS,INDX) !...SORTING a character array, max 40 characters long ! it does not change the position of the texts in CMD but return order in ORDER implicit none CHARACTER CMD(*)*(*) integer ns,indx(*) !\end{verbatim} ! CHARACTER STR*40 ! integer j1,j2,first,previous,next,limit integer j1,first,previous,next,limit integer, allocatable, dimension(:) :: order ! ! links has the the index of the CMD in the increasing order if(ns.le.0) then write(*,*)'SSORT called with no arguments to sort' buperr=1100; goto 900 endif allocate(order(ns)) do j1=1,ns order(j1)=-j1 enddo ! write(*,'(a,20i4)')'SSORT ',ns,(order(j1),j1=1,ns) next=1 first=1 ! write(*,*)'SSORT first quad ',next,': ',trim(cmd(next)) all: do j1=2,ns previous=-1 next=first limit=0 ! write(*,'(a,i3,a,i3,a,a)')'SSORT loop from ',first,' to ',j1,& ! ' to find place for ',trim(cmd(j1)) find: do while(next.le.j1) limit=limit+1; if(limit.gt.2*ns) stop 'ininite loop' if(next.lt.0) then ! there are no more to compare with, this is the last order(previous)=j1 ! write(*,'(a,i3,2x,20i3)')'SSORT insert last at ',& ! previous,(order(j2),j2=1,ns) ! do not change sign or order(j1) cycle all endif ! write(*,'(a,3i3,1x,a,1x,a,1x,a,1x,a)')'SSORT 1:',previous,j1,next,& ! ' compare ',trim(cmd(j1)),' and ',trim(cmd(next)) if(cmd(j1).lt.cmd(next)) then ! insert this after previous, copy link to next to order(j1) if(previous.lt.0) then ! write(*,'(a,a,3i3)')'SSORT 2: insert first before ',& ! trim(cmd(next)),previous,j1,next order(j1)=first; first=j1 else ! write(*,'(a,a,"< ",a," >",a,3i3)')'SSORT 2: insert between ',& ! trim(cmd(previous)),trim(cmd(j1)),trim(cmd(next)),& ! previous,j1,next order(j1)=order(previous); order(previous)=j1 endif ! write(*,'(a,2i3,2x,20i3)')'SSORT 3:',first,j1,(order(j2),j2=1,ns) exit find endif ! write(*,'(a,2i3,2x,20i3)')'SSORT 5:',next,j1,(order(j2),j2=1,ns) ! compare with next previous=next next=order(next) enddo find ! write(*,'(a,2i3,2x,20i3)')'SSORT 6:',first,0,(order(j2),j2=1,ns) enddo all ! write(*,'(a,2i3,2x,20i3)')'SSORT 7:',first,ns,(order(j2),j2=1,ns) ! ! next=first ! limit=1 ! do while(next.gt.0) ! write(*,*)limit,' ',cmd(next) ! next=order(next) ! limit=limit+1 ! enddo ! convert to positions ... next=first limit=1 do while(next.gt.0) j1=next next=order(next) indx(j1)=limit limit=limit+1 enddo ! write(*,'(a,2i3,2x,20i3)')'SSORT 9:',first,ns,(order(j2),j2=1,ns) ! stop 'ssol' 900 continue return end SUBROUTINE SSORT2 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine mqsort & Sorting MQMQA constituents !\begin{verbatim} SUBROUTINE MQSORT(CMD,NS,INDX) !...SORTING a character array, max 40 characters long BUBLESORT ! it does not change the position of the texts in CMD but return order in ORDER implicit none CHARACTER CMD(*)*(*) integer ns,indx(*) !\end{verbatim} CHARACTER STR*40 integer j1,j2,bytt ! integer, allocatable, dimension(:) :: order ! ! links has the the index of the CMD in the increasing order if(ns.le.0) then write(*,*)'QSORT called with no arguments to sort' buperr=1100; goto 900 endif do j1=1,ns indx(j1)=j1 enddo bytt=1 do while(bytt.gt.0) bytt=0 ! write(*,*)'QSORT loop ',trim(cmd(indx(1))),' ',trim(cmd(indx(ns))) all: do j1=2,ns if(cmd(indx(j1)).lt.cmd(indx(j1-1))) then j2=indx(j1) indx(j1)=indx(j1-1) indx(j1-1)=j2 ! write(*,*)'M4 QSORT: ',trim(cmd(indx(j1-1))),' < ',& ! trim(cmd(indx(j1))) bytt=bytt+1 endif enddo all enddo ! write(*,10)'QSORT done: ',ns,(indx(j1),j1=1,ns) !10 format(a,i3,2x,20i3) 900 continue return end SUBROUTINE MQSORT !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ ! ! >>>> subsection ! Routines for manipulation of characters ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable logical function ucletter & Check if character is UPPER case !\begin{verbatim} LOGICAL FUNCTION ucletter(ch1) ! returns TRUE if the character is A to Z implicit none character ch1*1 !\end{verbatim} %+ if(lge(ch1,'A') .and. lle(ch1,'Z')) then ucletter=.TRUE. else ucletter=.FALSE. endif END FUNCTION ucletter !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable character function biglet & Convert one character to UPPER case !\begin{verbatim} CHARACTER FUNCTION BIGLET(CHA) !...CONVERTS ONE CHARACTER FROM LOWER TO UPPER CASE implicit none CHARACTER*1 CHA !\end{verbatim} %+ CHARACTER*1 CHLAST PARAMETER (CHLAST='z') IF(CHA.GE.'a' .AND. CHA.LE.CHLAST) THEN BIGLET=CHAR(ICHAR(CHA)+ICHAR('A')-ICHAR('a')) ELSE BIGLET=CHA ENDIF RETURN END FUNCTION BIGLET !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine capson & Convert character to UPPER case !\begin{verbatim} SUBROUTINE capson(text) ! converts lower case ASCII a-z to upper case A-Z, no other changes implicit none character text*(*) !\end{verbatim} integer, parameter :: lowa=ichar('a'),lowz=ichar('z'),& iup=ICHAR('A')-ICHAR('a') integer i,ich1 DO i=1,len(text) ich1=ichar(text(i:i)) IF(ich1.ge.lowa .and. ich1.le.lowz) THEN text(i:i)=char(ich1+iup) ENDIF ENDDO END SUBROUTINE capson !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable logical function eolch & TRUE is character is empty after ip !\begin{verbatim} LOGICAL FUNCTION EOLCH(STR,IP) !...End of Line CHeck, TO SKIP SPACES FROM IP. RETURNS .TRUE. IF ONLY SPACES !....MODIFIED TO SKIP TAB CHARACTERS ALSO implicit none CHARACTER STR*(*) integer ip integer, parameter :: ITAB=9 !\end{verbatim} ! EOLCH=.FALSE. IF(IP.LE.0) IP=1 100 IF(IP.GT.LEN(STR)) GOTO 110 IF(STR(IP:IP).NE.' ' .AND. ICHAR(STR(IP:IP)).NE.ITAB) GOTO 900 IP=IP+1 GOTO 100 110 EOLCH=.TRUE. 900 RETURN END FUNCTION EOLCH !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine getrel & Extrtact real or double !\begin{verbatim} SUBROUTINE GETREL(SVAR,LAST,VALUE) ! extract a real from a character implicit none character svar*(*) integer last double precision value !\end{verbatim} %+ integer isig call getrels(svar,last,value,isig) return END SUBROUTINE GETREL !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine getrem & Extract real skipping trailing ; !\begin{verbatim} SUBROUTINE GETREM(SVAR,LAST,VAL) ! ...IDENTICAL TO GETREL EXCEPT THAT A TERMINATING COMMA "," IS SKIPPED ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none CHARACTER SVAR*(*) integer last double precision val !\end{verbatim} %+ CALL GETREL(SVAR,LAST,VAL) IF(BUPERR.NE.0) RETURN IF(SVAR(LAST:LAST).EQ.',') LAST=LAST+1 RETURN END SUBROUTINE GETREM !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine getrels & Extract real !\begin{verbatim} SUBROUTINE GETRELS(SVAR,LAST,VALUE,ISIG) !...DECODES A REAL NUMBER FROM A TEXT ! IT MAY BE PRECEEDED BY SPACES AND A + OR - ! THERE MUST BE AT LEAST ONE NUMBER BEFORE OR AFTER A PERIOD ! THERE MUST BE AT LEAST ONE NUMBER BEFORE AN "E" OR "D" ! AFTER AN "E" OR "D" THERE MAY BE A + OR - AND MUST BE ONE OR TWO NUMBERS ! 840310 CHANGE TO ALLOW SPACES AFTER A SIGN I.E. + 2.2 IS ALLOWED ! 860201 EXPONENTIAL D ACCEPTED ! 100910 F95 version ! ISIG is zero if no sign, needed to separte terms inside expressions ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none character svar*(*) integer last,isig double precision value !\end{verbatim} %+ ! EOLCH is declared as logical function in this module so not needed here ! LOGICAL EOLCH CHARACTER CH*1 integer i,ierr,jerr double precision hel,dec,expo ! INTEGER GPS,GPN CONTINUE letter: IF(EOLCH(SVAR,LAST)) THEN buperr=1031 GOTO 9000 ELSEIF(LAST.LT.LEN(SVAR)-2) THEN IF(SVAR(LAST:LAST+3).EQ.'NONE') THEN VALUE=RNONE buperr=0 GOTO 9000 ENDIF ENDIF letter CH=SVAR(LAST:LAST) isig=0 sign: IF(CH.EQ.'-') THEN LAST=LAST+1 ISIG=-1 IERR=1036 ELSE ISIG=1 IF(CH.EQ.'+') THEN IERR=1035 LAST=LAST+1 ELSE IERR=0 ENDIF ENDIF sign ! 840310 NEXT LINE ADDED TO ALLOW FOR SPACES AFTER A SIGN IF(EOLCH(SVAR,LAST)) THEN ! if nothing after sign return error buperr=IERR; GOTO 9000 ENDIF CH=SVAR(LAST:LAST) continue ! CCI HEL=ZERO nodot: IF(CH.NE.'.') THEN JERR=GPN(SVAR,LAST,HEL) IF(JERR.NE.0) THEN ! keep error code meaning nagative or positive sign if(ierr.eq.0) then buperr=jerr else buperr=ierr endif GOTO 9000 ELSE !... REMOVE POSSIBLE ERROR CODE SET BY NEGATIVE SIGN IERR=0 ENDIF ELSE !... MARK THAT THERE WHERE NO DIGITS BEFORE THE DECIMAL POINT IF(IERR.EQ.0) IERR=1037 HEL=ZERO ENDIF nodot !...If the next character is a period then decode the decimal part. ! If there is no numbers after the period, JERR is nonzero. ! Then check if IERR is nonzero otherwise there is no numbers at all ! before or after the period. If so return with error code. continue decimalpoint: if(last.ge.len(svar)) then dec=zero elseIF(SVAR(LAST:LAST).EQ.'.') THEN LAST=LAST+1 I=LAST JERR=GPN(SVAR,LAST,DEC) IF(JERR.EQ.0) THEN IERR=0 I=LAST-I DEC=DEC/(TEN**I) ELSEIF(IERR.EQ.0) THEN DEC=ZERO ELSE !... NO DIGITS BEFORE OR AFTER A DECIMAL POINT buperr=1033 GOTO 9000 ENDIF ELSE DEC=ZERO ENDIF decimalpoint EXPO=ONE exponent: if(last.lt.len(svar)) then IF(BIGLET(SVAR(LAST:LAST)).EQ.'E' & .OR. BIGLET(SVAR(LAST:LAST)).EQ.'D') THEN LAST=LAST+1 IERR=GPS(SVAR,LAST,EXPO) if(ierr.ne.0) then buperr=ierr GOTO 9000 ENDIF IF(INT(ABS(EXPO)).GT.99) THEN buperr=1039 GOTO 9000 ENDIF I=INT(EXPO) EXPO=TEN**I ENDIF endif exponent VALUE=DBLE(ISIG)*(HEL+DEC)*EXPO 9000 continue RETURN END SUBROUTINE GETRELS !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable integer function gps & Extract real !\begin{verbatim} INTEGER FUNCTION GPS(SVAR,LAST,VALUE) !...DECODES A NUMBER WITH OR WITHOUT A SIGN implicit none DOUBLE PRECISION VALUE CHARACTER SVAR*(*) integer last !\end{verbatim} %+ integer ierr,jerr,isig CHARACTER SIG*1 SIG=SVAR(LAST:LAST) IF(SIG.EQ.'-') THEN LAST=LAST+1 ISIG=-1 IERR=1036 ELSE ISIG=1 IF(SIG.EQ.'+') THEN LAST=LAST+1 IERR=1035 ELSE IERR=1037 ENDIF ENDIF JERR=GPN(SVAR,LAST,VALUE) IF(JERR.EQ.0) IERR=0 GPS=IERR VALUE=DBLE(ISIG)*VALUE RETURN END FUNCTION GPS !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable integer function gpn & Extract real without sign !\begin{verbatim} INTEGER FUNCTION GPN(SVAR,LAST,VALUE) !...DECODES A NUMBER WITHOUT SIGN ! DOUBLE PRECISION VALUE implicit none CHARACTER SVAR*(*) integer last double precision value !\end{verbatim} ! DOUBLE PRECISION, parameter :: ZERO=0.0D0,TEN=1.0D1 integer l,ierr,n L=LEN_TRIM(SVAR) VALUE=ZERO IERR=1034 digits: DO LAST=LAST,L N=ICHAR(SVAR(LAST:LAST))-ICHAR('0') IF(N.LT.0 .OR. N.GT.9) GOTO 800 IERR=0 VALUE=TEN*VALUE+DBLE(N) enddo digits 800 GPN=IERR RETURN END FUNCTION GPN !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine getint & Extract integer !\begin{verbatim} SUBROUTINE GETINT(SVAR,LAST,IVAL) !...DECODES AN INTEGER FROM A TEXT ! IT MAY BE PRECCEDED BY SPACES AND A + OR - ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none CHARACTER SVAR*(*) integer last,ival !\end{verbatim} %+ integer ierr double precision value ! IF(EOLCH(SVAR,LAST)) THEN ! CALL ST2ERR(1031,'GETINT','LINE EMPTY') buperr=1031 ELSEIF(SVAR(LAST:MIN(LEN(SVAR),LAST+3)).EQ.'NONE') THEN IVAL=NONE IERR=0 ELSE IERR=GPS(SVAR,LAST,VALUE) IF(IERR.EQ.0) THEN ! IF(VALUE.GT.FLOAT(MAXINT) .OR. VALUE.LT.FLOAT(MININT)) THEN IF(VALUE.GT.DBLE(MAXINT) .OR. VALUE.LT.DBLE(MININT)) THEN ! CALL ST2ERR(1033,'GETINT','TOO LARGE INTEGER VALUE') buperr=1042 IVAL=0 ELSE IVAL=INT(VALUE) ENDIF ELSE ! CALL ST2ERR(IERR,'GETINT','NO DIGIT') buperr=ierr IVAL=0 ENDIF ENDIF RETURN END SUBROUTINE GETINT !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine getinm & Extract integer and trailing , !\begin{verbatim} SUBROUTINE GETINM(SVAR,LAST,IVAL) ! ...IDENTICAL TO GETINT EXCEPT THAT A TERMINATING COMMA ",", IS SKIPPED ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none CHARACTER SVAR*(*) integer last,ival !\end{verbatim} %+ CALL GETINT(SVAR,LAST,IVAL) IF(BUPERR.NE.0) RETURN IF(SVAR(LAST:LAST).EQ.',') LAST=LAST+1 RETURN END SUBROUTINE GETINM !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine getoct & Extract octal number !\begin{verbatim} SUBROUTINE GETOCT(LINE,IP,IVAL) !...DECODE AN OCTAL NUMBER implicit none CHARACTER LINE*(*) integer ip,ival !\end{verbatim} %+ integer ierr,j IERR=0 IF(EOLCH(LINE,IP)) THEN ! CALL ST2ERR(1031,'GETOCT','LINE EMPTY') buperr=1031 ELSEIF(LINE(IP:IP+3).EQ.'NONE') THEN IVAL=NONE ELSE IERR=1038 IVAL=0 100 J=ICHAR(LINE(IP:IP))-ICHAR('0') IF(J.GE.0 .AND. J.LE.7) THEN IERR=0 IVAL=8*IVAL+J ELSE GOTO 800 ENDIF IP=IP+1 GOTO 100 ENDIF !800 IF(IERR.NE.0) CALL ST2ERR(IERR,'GETOCT','NO DIGIT') 800 continue RETURN END SUBROUTINE GETOCT !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gethex & Extract hexadecimal number !\begin{verbatim} SUBROUTINE GETHEX(LINE,IP,IVAL) !...DECODE A HEXADECIMAL NUMBER implicit none CHARACTER LINE*(*) integer ip,ival !\end{verbatim} integer bug,ierr,isign,idig,maxdig,j CHARACTER CH1*1 ! IERR=0 ISIGN=0 IF(EOLCH(LINE,IP)) THEN ! CALL ST2ERR(1031,'GETHEX','LINE EMPTY') buperr=1031 ELSEIF(LINE(IP:IP+3).EQ.'NONE') THEN IVAL=NONE ELSE IERR=1038 IVAL=0 IDIG=0 MAXDIG=NBITPW/4 100 CH1=LINE(IP:IP) IF(LGE(CH1,'0') .AND. LLE(CH1,'9')) THEN J=ICHAR(CH1)-ICHAR('0') IERR=0 ELSEIF(LGE(CH1,'A') .AND. LLE(CH1,'F')) THEN J=ICHAR(CH1)-ICHAR('A')+10 IERR=0 ELSE GOTO 800 ENDIF IDIG=IDIG+1 IF(IDIG.EQ.1 .AND. J.GE.8) THEN ISIGN=1 J=J-8 ENDIF IVAL=16*IVAL+J IP=IP+1 GOTO 100 ENDIF !800 IF(IERR.NE.0) CALL ST2ERR(IERR,'GETHEX','NO DIGIT') 800 continue ! IF(ISIGN.EQ.1) CALL SETB(1,IVAL) bug=ival ! wow, set sign bit of an integer? Assume 32 bits ... IF(ISIGN.EQ.1) ival=ibset(ival,31) ! write(*,*)'In metlib4 GETHEX: ',ival,bug RETURN END SUBROUTINE GETHEX !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine getname & Extract a species name !\begin{verbatim} subroutine getname(text,ip,name,mode,ch1) ! reading a species name, this should be incorporated in metlib, implicit none character text*(*),name*(*),ch1*1 integer ip,mode !\end{verbatim} %+ ! Always a letter A-Z as first character ! mode=0 is normal, letters, numbers, "." and "_" allowed ?? should . be allowed ! mode=1 used for species names with "/", "+" and "-" allowed also integer jp ch1=biglet(text(ip:ip)) if(ch1.lt.'A' .or. ch1.gt.'Z') then write(*,17)ichar(ch1),ch1,text(1:24),ip 17 format('GETNAME error: ',i5,' "',a,'" in "',a,'" at ',i4) buperr=1101; goto 1000 endif jp=ip do while(ip.lt.len(text)) ip=ip+1 ch1=biglet(text(ip:ip)) if(ch1.ge.'A' .and. ch1.le.'Z') goto 100 if(ch1.ge.'0' .and. ch1.le.'9') goto 100 if(ch1.eq.'_' .or. ch1.eq.'.') goto 100 if(mode.eq.1) then ! special for species names if(ch1.eq.'/' .or. ch1.eq.'+' .or. ch1.eq.'-') goto 100 endif goto 200 100 continue enddo 200 continue name=text(jp:ip-1) 1000 continue return end subroutine getname !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine getext & Extact a text item !\begin{verbatim} SUBROUTINE GETEXT(SVAR,LAST,JTYP,STRING,CDEF,LENC) !...SVAR SHALL CONTAIN A TEXT. SCAN STARTS AT POSITION LAST. ! STRING IS SET TO THE FIRST NONBLANK CHARACTER UP TO THE TERMINATOR. ! CDEF IS A DEFAULT VAUE IF SVAR IS EMPTY. ! LENC IS THE LENGTH OF THE TEXT IN STRING ! JTYP DEFINES THE TERMINATION OF A STRING ! 1 TEXT TERMINATED BY SPACE OR "," ! 2 TEXT TERMINATED BY SPACE ! 3 TEXT TERMINATED BY ";" OR "." ! 4 TEXT TERMINATED BY ";" ! 5 TEXT UP TO END-OF-LINE ! 6 TEXT UP TO AND INCLUDING ";" ! 7 text terminated by space but if first char is ', " up to next ' or " ! 8 text terminated by space but if first char is (, {, [ or < all text ! until matching ), }, ] or >. Possibly including more ( ) etc. ! >31, THE CHAR(JTYP) IS USED AS TERMINATING CHARACTER implicit none ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) CHARACTER SVAR*(*),CDEF*(*),STRING*(*) integer last,jtyp,lenc !\end{verbatim} ! CHARACTER CH1*1,CH2*1 character*1, parameter :: par(4)=['(','{','[','<'] character*1, parameter :: ipar(4)=[')','}',']','>'] integer i,j,k,l1,l2,level,ityp ! LOGICAL EOLCH,SG2ERR IF(JTYP.LE.0) THEN ! CALL ST2ERR(1030,'GETEXT','NO SUCH TYPE OPTION') buperr=1030 GOTO 900 ENDIF IF(JTYP.LE.6) THEN ITYP=JTYP+3 ELSE ITYP=10 CH2=CHAR(JTYP) ENDIF !...INCREMENT LAST BY ONE TO BYPASS TERMINATOR OF COMMAND OR PREVIOUS ! ANSWER LAST=LAST+1 IF(LAST.LT.1 .OR. LAST.GT.LEN(SVAR)) LAST=LEN(SVAR)+1 !...SKIP BLANKS STARTING FROM THE POSITION AFTER LAST ! IF LAST OUTSIDE SVAR THEN ASK QUESTION I=LAST CONTINUE IF(EOLCH(SVAR,I)) GOTO 910 ! STRING=CDEF ! LENC=LEN(CDEF) ! LAST=I ! GOTO 900 ! ENDIF CH1=SVAR(I:I) !...IF FIRST CHARACTER IS "," PUT DEFAULT VALUE IF ANY IF(CH1.EQ.',') GOTO 910 ! handle ITYP=7 and 8 separately if(jtyp.eq.7) then if(ch1.eq."'") then j=index(svar(i+1:),"'") if(j.eq.0) then ! no matching ', return whole string, position after last character string=svar(i:len_trim(svar)) last=len_trim(svar) lenc=last-i buperr=1032 else ! return string without ', position after last ' string=svar(i+1:i+j-1) last=i+j+1 lenc=j-1 endif elseif(ch1.eq.'"') then j=index(svar(i+1:),'"') if(j.eq.0) then ! no matching ", return whole string, position after last character string=svar(i:len_trim(svar)) last=len_trim(svar) lenc=last-i buperr=1032 else ! return string without ", position after last " string=svar(i+1:i+j-1) last=i+j+1 lenc=j-1 endif endif goto 900 elseif(jtyp.eq.8) then ! check if first character is ( { or [ do j=1,4 if(ch1.eq.par(j)) goto 17 enddo write(*,*)'no open parenthesis ',ch1 ! if not ( { [ or < continue with original code goto 33 ! we must scan svar character by character until matching ipar(j) 17 continue level=1 k=i write(*,*)'jtyp 8, found ',par(j),', in position: ',k 20 k=k+1 if(k.gt.len(svar)) goto 920 ch1=svar(k:k) if(ch1.eq.par(j)) then ! if we find a new ( { [ or < increase level level=level+1 elseif(ch1.eq.ipar(j)) then level=level-1 if(level.eq.0) then ! we have found matching ) } ] or > string=svar(i+1:k-1) last=k+1 lenc=k-i-2 goto 900 endif endif goto 20 endif !------------------------------- ! here original code continue 33 continue !...FETCH THE VALUE FROM SVAR LAST=I L1=0 L2=0 GOTO(40,50,60,70,80,70,100),ITYP-3 40 L1=INDEX(SVAR(LAST:),',') 50 L2=INDEX(SVAR(LAST:),' ') GOTO 400 !... 60 L1=INDEX(SVAR(LAST:),'.') 70 L2=INDEX(SVAR(LAST:),';') !...STRING INCLUDING THE ; IF(ITYP.EQ.9 .AND. L2.GT.0) L2=L2+1 GOTO 400 !... 80 L1=LEN(SVAR) GOTO 400 100 L2=INDEX(SVAR(LAST:),CH2) 400 IF(L1.GT.0 .AND. L2.GT.0) THEN L1=LAST+MIN(L1,L2)-1 ELSEIF(L1.LE.0 .AND. L2.LE.0) THEN L1=LEN(SVAR)+1 ELSE L1=LAST+MAX(L1,L2)-1 ENDIF IF(L1.GT.LAST) THEN STRING=SVAR(LAST:MIN(LEN(SVAR),L1-1)) LENC=L1-LAST ELSE STRING=' ' LENC=0 ENDIF LAST=L1 ! 900 RETURN !...SET DEFAULT VALUE 910 IF(CDEF.NE.CNONE) THEN STRING=CDEF LENC=LEN(CDEF) !...SET POSITION IN STRING TO POSITION OF , LAST=I GOTO 900 ENDIF !...NO ANSWER AND NO DEFAULT VALUE, ERROR RETURN !920 CALL ST2ERR(1032,'GETEXT','TEXT VALUE MISSING') 920 continue buperr=1032 GOTO 900 END SUBROUTINE GETEXT !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine wrinum & Write a double left justified !\begin{verbatim} SUBROUTINE WRINUM(STR,IP,NNW,JSIGN,VALUE) !...EDITS A REAL NUMBER INTO STR WITH LEAST NUMBER OF DIGITS ! NNW IS MAXIMUM NUMBER OF SIGNIFICANT DIGITS (00 INDICATES THAT + SIGN SHOULD BE WRITTEN ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none CHARACTER STR*(*) integer ip,nnw,jsign double precision value !\end{verbatim} %+ CHARACTER CSTR*21,CFRMT*12 ! double precision, parameter :: ZERO=0.0D0,TEN=1.0D1,EPS=1.0D-7 double precision, parameter :: EPS=1.0D-7 double precision cc,xx integer nw,jj,k,nwd CSTR=' ' NW=NNW IF(NW.LE.0) NW=1 IF(NW.GT.15) NW=15 IF(IP+NW.GT.LEN(STR)) then buperr=1100 goto 9000 endif IF(VALUE.EQ.ZERO) THEN IF(JSIGN.GT.0) THEN STR(IP:IP+1)='+0' IP=IP+2 ELSE STR(IP:IP)='0' IP=IP+1 ENDIF GOTO 9000 ELSEIF(VALUE.LT.ZERO) THEN STR(IP:IP)='-' IP=IP+1 ELSEIF(JSIGN.GT.0) THEN STR(IP:IP)='+' IP=IP+1 ENDIF CC=ABS(VALUE) XX=LOG10(CC+MAX(CC*EPS,EPS)) ! K=INT(XX) K=INT(XX)+1 IF(XX.GT.ZERO) K=K+1 ! some problems writing 81000000000 as fixed format ... ! This should be handelled by checking the number of zeroes at the end !! ! write(*,27)k,nw,cc !27 format('wrinum: ',2i5,1pe20.12) IF(NW.GT.2 .AND. (K.GE.NW .OR. K.LT.-2)) THEN !...FLOATING FORMAT WRITE(CFRMT,100)NW+5,NW-1 100 FORMAT('(1P,E',I2,'.',I2,')') WRITE(CSTR,CFRMT)CC JJ=NW+1 150 IF(CSTR(JJ:JJ).EQ.'0') THEN JJ=JJ-1 GOTO 150 ENDIF IF(CSTR(JJ:JJ).EQ.'.') JJ=JJ-1 STR(IP:IP+JJ-1)=CSTR(1:JJ) STR(IP+JJ:IP+JJ+3)=CSTR(NW+2:NW+5) IP=IP+JJ+4 ELSE !...FIXED FORMAT NWD=NW-K WRITE(CFRMT,200)MAX(NW,NWD)+1,NWD 200 FORMAT('(F',I2,'.',I2,') ') WRITE(CSTR,CFRMT)CC JJ=MAX(NW,NWD)+1 250 IF(CSTR(JJ:JJ).EQ.'0') THEN JJ=JJ-1 GOTO 250 ENDIF IF(CSTR(JJ:JJ).EQ.'.') JJ=JJ-1 if(CSTR(1:1).eq.' ') then ! supress any initial space in CSTR, adjust lenght!! CSTR(1:)=CSTR(2:) jj=jj-1 endif STR(IP:IP+JJ-1)=CSTR(1:JJ) IP=IP+JJ ENDIF 9000 continue RETURN END SUBROUTINE WRINUM !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine wriint & Write an inter left justified !\begin{verbatim} subroutine wriint(text,ipos,int) ! write an integer in text from position ipos (left adjusted) implicit none character text*(*),number*16 integer ipos,int,jp !\end{verbatim} %+ if(int.lt.0) then buperr=1200; text(ipos:ipos)='*'; ipos=ipos+1 elseif(int.eq.0) then text(ipos:ipos)='0'; ipos=ipos+1 else write(number,20)int 20 format(i16) jp=1 if(eolch(number,jp)) then buperr=1201; goto 1000 else text(ipos:)=number(jp:) ! write(*,22)'wriint: ',jp,number(jp:),text(ipos:ipos+16-jp) !22 format(a,i3,'>',a,'< >',a,'<') ipos=ipos+17-jp ! write(*,30)'wriint: ',ipos,jp,' >'//text(1:ipos+5)//'<' !30 format(a,2i3,a) endif endif 1000 continue return end subroutine wriint !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine wrihex & Write a hexadecimal !\begin{verbatim} SUBROUTINE WRIHEX(STR,IVAL) !...TO WRITE AN INTEGER AS HEXADECIMAL ! LOGICAL TESTB implicit none CHARACTER STR*(*) integer ival !\end{verbatim} %+ integer j,ip,k J=IVAL IP=0 10 IP=IP+1 K=0 write(*,*)'calling testb from wrihex' ! IF(TESTB(4*IP-3,J)) K=8 ! IF(TESTB(4*IP-2,J)) K=K+4 ! IF(TESTB(4*IP-1,J)) K=K+2 ! IF(TESTB(4*IP,J)) K=K+1 IF(btest(4*IP-3,J)) K=8 IF(btest(4*IP-2,J)) K=K+4 IF(btest(4*IP-1,J)) K=K+2 IF(btest(4*IP,J)) K=K+1 IF(K.GT.9) THEN STR(IP:IP)=CHAR(K-10+ICHAR('A')) ELSE STR(IP:IP)=CHAR(K+ICHAR('0')) ENDIF IF(IP.LT.LEN(STR)) GOTO 10 RETURN END SUBROUTINE WRIHEX !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine wrice & Write a long text !\begin{verbatim} subroutine wrice(lut,margl1,margl2,maxl,str) ! writes str on unit lut with left margin largl1 for first line, margl2 for all ! following lines, max length maxl characters (assuming typewriter font) implicit none integer lut,margl1,margl2,maxl character str*(*) !\end{verbatim} %+ ! ! character margx*40 integer lbreak lbreak=0 call wrice2(lut,margl1,margl2,maxl,lbreak,str) continue return end subroutine wrice !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine wrice2 & Write a long text !\begin{verbatim} subroutine wrice2(lut,margl1,margl2,maxl,lbreak,str) ! writes str on unit lut with left margin largl1 for first line, margl2 for all ! following lines, max length maxl characters (assuming typewriter font) ! lbreak>0 for writing math expression, with stricter linebreak rules ! lbreak<0 for breaking only at space implicit none character str*(*) integer lut,margl1,margl2,maxl,lbreak !\end{verbatim} %+ ! character margx*40 integer lend,nend,lbeg ! nend=len_trim(str) margx=' ' lbeg=1 lend=maxl-margl1 if(margl1.lt.0.or.margl2.lt.0 .or. maxl.lt.margl1.or.maxl.lt.margl2) then buperr=1070; goto 1000 endif if(nend.lt.lend) then if(margl1.eq.0) then write(lut,10)str(1:nend) 10 format(A) else write(lut,11)margx(1:margl1),str(1:nend) 11 format(A,A) endif else call cwricend(str,lbeg,lend,lbreak) if(margl1.eq.0) then write(lut,10)str(1:lend) else write(lut,11)margx(1:margl1),str(1:lend) endif do while(lend.lt.nend) lbeg=lend+1 lend=min(lbeg+maxl-margl2-1,nend) if(lend.lt.nend) call cwricend(str,lbeg,lend,lbreak) if(margl2.eq.0) then write(lut,10)str(lbeg:lend) else write(lut,11)margx(1:margl2),str(lbeg:lend) endif enddo endif 1000 continue return end subroutine wrice2 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine cwicend & Find a possible place for linebreak !\begin{verbatim} subroutine cwricend(str,lbeg,lend,lbreak) ! find a possible place for a newline in str going back from lend ! but not bypassing lbeg. str is a numerical expression. ! lbreak>0 means stricter rules (mathematical expression) ! lbreak<0 means break only at space implicit none character str*(*) integer lbeg,lend,lbreak !\end{verbatim} ! character ch1*1,ch2*1 integer ip ! lbreak=0 means ! newline possible at space, ;, +, - (but not sign in exponents like E+02) findpos: do ip=lend,lbeg,-1 ch1=str(ip:ip) if(ch1.eq.' ' .or. ch1.eq.';') then lend=ip goto 1000 elseif(lbreak.ge.0 .and. (ch1.eq.'+' .or. ch1.eq.'-')) then ch2=str(ip-1:ip-1) ! write(*,*)'cwriceend 3: ',ch2,ch1 if(ch2.eq.'e' .or. ch2.eq.'E' .or. ch2.eq.'d' .or. ch2.eq.'D' .or. & ch2.eq.'(' ) then continue else ! we cannot find a good breakpoint, break the line here lend=ip-1 goto 1000 endif endif enddo findpos ! no position found, just cut at lend 1000 continue return end subroutine cwricend !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable logical function isabbr !\begin{verbatim} INTEGER FUNCTION ISABBR(LONG,SHORT,NC) ! This is for comparing user provided phase names with database phase names ! LONG is a phase name read from database file ! SHORT is an array with abbreviated phase names that should be selected ! Seach array SHORT for any that is an abbreviation of LONG ! Abbreviations between each _ allowed ! NOTE: Any - (minus) in SHORT should have been converted to _ implicit none integer nc CHARACTER LONG*(*),SHORT(NC)*(*) !\end{verbatim} % character chs integer j1,k1,k2,ltrim,fit,slen fit=0 ltrim=len_trim(long) ! write(*,*)'M4 ISABBR ***********: ',trim(long),nc,ltrim ! loop to compare LONG with all abbreviations in short find: do k1=1,nc slen=len_trim(short(k1)) j1=1 ! write(*,*)'M4 abbr: ',trim(short(k1)),slen letter: do k2=1,slen ! this is a loop for all characters in short chs=short(k1)(k2:k2) uscore: if(chs.eq.'-' .or. chs.eq.'_') then ! write(*,*)'M4 Found "-" in short, skipping to "-" in long',j1 long1: do j1=j1,ltrim if(long(j1:j1).eq.'-' .or. long(j1:j1).eq.'_') exit long1 enddo long1 ! write(*,*)'M4 Looking for "-": ',j1,ltrim j1=j1+1 ! there is no _ or - in long, skip this abbreviation if(j1.gt.ltrim) cycle find ! found a - in long, compare letter after - in short and long cycle letter endif uscore ! accept if next character in short is blank (also if first!) if(k2.gt.1 .and. chs.eq.' ') then fit=k1; exit find endif ! compare letter in short(k1)(k2:k2) with long(j1:j1) ! write(*,*)'M4 Letter: "',chs,'" and "',long(j1:j1),k2,j1 if(chs.ne.long(j1:j1)) cycle find j1=j1+1 enddo letter ! accept as all slen letters in SHORT match corresponding leters in LONG fit=k1 exit find enddo find !1000 continue ! if(fit.gt.0) then ! write(*,*)'Accept abbreviation ',trim(short(fit)),' for ',trim(long),fit ! endif isabbr=fit return end FUNCTION ISABBR !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ ! ! >>>> subsection ! command interpreters ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable integer function ncomp & Top command interpreter !\begin{verbatim} INTEGER FUNCTION NCOMP(SVAR,COMM,NC,NEXT) ! SUBROUTINE NCOMP implicit none integer nc,next,ient CHARACTER SVAR*(*),COMM(NC)*(*) !\end{verbatim} %+ IENT=1 ncomp=ncompx(svar,comm,nc,next,ient) return end FUNCTION NCOMP !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable integer function ncomp2 & Level 1 subcommand !\begin{verbatim} INTEGER FUNCTION NCOMP2(SVAR,COMM,NC,NEXT) ! SUBROUTINE NCOMP2 implicit none integer nc,next,ient CHARACTER SVAR*(*),COMM(NC)*(*) !\end{verbatim} %+ IENT=2 ncomp2=ncompx(svar,comm,nc,next,ient) return end FUNCTION NCOMP2 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable integer function ncomp3 & Level 2 subcommand !\begin{verbatim} INTEGER FUNCTION NCOMP3(SVAR,COMM,NC,NEXT) ! SUBROUTINE NCOMP3 implicit none integer nc,next,ient CHARACTER SVAR*(*),COMM(NC)*(*) !\end{verbatim} %+ IENT=3 ncomp3=ncompx(svar,comm,nc,next,ient) return end FUNCTION NCOMP3 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable integer function ncompx & Actual command interpreter !\begin{verbatim} INTEGER FUNCTION NCOMPX(SVAR,COMM,NC,NEXT,IENT) ! ...TO DECODE A COMMAND implicit none CHARACTER SVAR*(*),COMM(NC)*(*) integer nc,next,ient !\end{verbatim} character LINE*80 CHARACTER*1 CH1,CHSEP,CHLAST,CHSYS,CHSEP2,CH2,CHHELP CHARACTER*1 CHHIST,CHMAC LOGICAL EXAKT,YESLOG PARAMETER (CHSEP='_',CHSEP2='-',CHLAST='Z',CHSYS='@',CHHELP='?') PARAMETER (CHHIST='!',CHMAC='#') integer ls,lc,lika,klik,i,j,last,n,nmatc ! if(ient.eq.1) then YESLOG=.TRUE. last=1 elseif(ient.eq.2) then last=1 else LAST=NEXT+1 endif 3 LS=LEN(SVAR) LC=LEN(COMM(1)) LIKA=0 KLIK=0 IF(EOLCH(SVAR,LAST)) GOTO 300 IF(LAST.GT.LEN(SVAR)) GOTO 300 !...SPECIAL TREATMENT IF FIRST CHARACTER IS CHSYS OR CHHELP CH1=SVAR(LAST:LAST) IF(CH1.EQ.CHSYS) GOTO 800 IF(IENT.EQ.1 .AND. CH1.EQ.CHHELP) THEN LAST=LAST+1 HELP: DO LIKA=1,NC IF(COMM(LIKA)(1:5).EQ.'HELP ') THEN !... SKIP QUESTION FOR COMMAND IF LINE EMPTY IF(SVAR(LAST+1:LAST+1).EQ.' ') SVAR(LAST+1:LAST+2)=',,' GOTO 300 ENDIF enddo HELP LAST=LAST-1 ENDIF LIKA=0 IF(IENT.EQ.1 .AND. CH1.EQ.CHHIST) THEN !... A HISTORY COMMAND. RETURN TO 3 IF A PREVIOUS COMMAND SHALL BE EXEC CALL NGHIST(SVAR,LAST) IF(LAST.EQ.0) GOTO 3 NCOMPX=0 NEXT=0 GOTO 900 ENDIF ! FIND LAST CHARACTER IN SVAR THAT IS LEGAL IN A COMMAND ! CONVERT TO CAPITAL LETTERS AT THE SAME TIME IF(IENT.EQ.1) LHP=LAST LS=LS-LAST+1 L20: DO N=1,LS CH1=BIGLET(SVAR(N+LAST-1:N+LAST-1)) IF(LGE(CH1,'A') .AND. LLE(CH1,CHLAST)) GOTO 15 IF(LGE(CH1,'0') .AND. LLE(CH1,'9')) GOTO 15 IF(CH1.EQ.CHSEP .OR. CH1.EQ.CHSEP2) GOTO 15 GOTO 50 15 LINE(N:N)=CH1 enddo L20 !...N UNDEFINED AFTER LOOP? N=LS+1 50 LS=N-1 KLIK=0 NMATC=0 IF(N.EQ.1) GOTO 300 COMPERE: DO N=1,NC EXAKT=.TRUE. J=0 LETTER: DO I=1,LS CH1=LINE(I:I) J=J+1 IF(CH1.EQ.CHSEP .OR. CH1.EQ.CHSEP2) THEN !... PREPARE FOR A "-" JOINING COMMAND AND ARGUMENT IF(I.GT.NMATC) THEN KLIK=N NMATC=I ELSEIF(I.EQ.NMATC) THEN KLIK=-1 ENDIF 90 CH2=COMM(N)(J:J) IF(CH2.EQ.CHSEP .OR. CH2.EQ.CHSEP2) GOTO 100 EXAKT=.FALSE. J=J+1 IF(J.GT.LC) GOTO 200 GOTO 90 ENDIF IF(CH1.NE.COMM(N)(J:J)) GOTO 200 100 CONTINUE enddo LETTER !...A COMMAND THAT CAN FIT, IF EXACTLY EQUAL FINISH IF(EXAKT) THEN IF(J.EQ.LC) GOTO 500 IF(COMM(N)(J+1:J+1).EQ.' ') GOTO 500 ENDIF !...IF LIKA>0 THE COMMAND IS AMBIGUOUS IF(LIKA.GT.0) GOTO 910 LIKA=N LAST=I+LAST-1 200 CONTINUE enddo COMPERE !...ALL COMMANDS COMPERED, IF LIKA=0 THERE WAS NO SUCH COMMAND 300 NEXT=LAST IF(LIKA.EQ.0 .AND. KLIK.GT.0) THEN !... NO MATCHING COMMAND BUT PART BEFORE A - MATCHES LIKA=-(NC+KLIK) NEXT=NMATC ENDIF GOTO 510 500 NEXT=I+LAST-1 YESLOG=.FALSE. LIKA=N 510 CONTINUE !...RETURN FUNCTION VALUE IF(IENT.EQ.1) THEN NCOMPX=LIKA IF(LIKA.GT.0) THEN LSTCMD=COMM(LIKA) IF(LOGFIL.GT.0 .AND. YESLOG) WRITE(KOU,517)LSTCMD 517 FORMAT(' ... the command in full is ',A) CALL CAPSON(LSTCMD) ENDIF !...SAVE HISTORY, do not save empty lines IF(LHP.LE.0)LHP=1 IF(LEN_TRIM(SVAR(LHP:)).GT.0)THEN LHL=LHL+1 IF(LHL.GT.20) THEN LHL=1 LHM=LHM+20 ENDIF HIST(LHL)=SVAR(LHP:) ENDIF ELSEIF(IENT.EQ.2) THEN NCOMPX=LIKA ELSE NCOMPX=LIKA ENDIF GOTO 900 !...A SYSTEM COMMAND OR COMMENT, UPDATE ACCOUNT RECORD BEFORE EXECUTION ! TWO CHSYS means skip this line (comment) ! CHSYS followed by CHMAC means macro line, skip it 800 IF(SVAR(LAST+1:LAST+1).EQ.CHSYS) GOTO 810 IF(SVAR(LAST+1:LAST+1).EQ.CHMAC) GOTO 810 LINE(1:)=SVAR(LAST+1:) ! CALL CAPSON(LINE) ! CALL WPAC2 ! CALL UECOM(LINE) write(*,*)'Hit return to continue' read(*,808)ch1 808 format(a) ! CALL COMND(LINE) 810 NEXT=0 LIKA=0 GOTO 510 900 RETURN !...AMBIGUOUS 910 LIKA=-LIKA GOTO 510 END FUNCTION NCOMPX !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ ! ! >>>> subsection ! Extracting command arguments from a character ! ! There are two groups, those new finishing with x ! the old without final x (which are listed first) ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gparid & Superceeded by gparidx !\begin{verbatim} SUBROUTINE GPARID(PROMT,SVAR,LAST,IVAL,IDEF,HELP) ! ask for integer value with default ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none CHARACTER PROMT*(*),SVAR*(*) integer last,ival,idef EXTERNAL HELP !\end{verbatim} %+ CHARACTER SLIN*512 integer iflag ! chcek for environment variables CALL GQXENV(SVAR) 100 CALL GQARID(PROMT,SVAR,LAST,IVAL,IDEF,HELP) CALL GPTCM1(IFLAG,SVAR,LAST,SLIN) IF (IFLAG.NE.0) GOTO 100 RETURN END SUBROUTINE GPARID !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gpari !\begin{verbatim} SUBROUTINE GPARI_old(PROMT,SVAR,LAST,IVAL,IDEF,HELP) ! ask for integer value woth no default ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) CHARACTER PROMT*(*),SVAR*(*) integer last,ival,idef EXTERNAL HELP !\end{verbatim} %+ CHARACTER SLIN*80 integer iflag ! check for environment variables CALL GQXENV(SVAR) 100 CALL GQARI(PROMT,SVAR,LAST,IVAL,IDEF,HELP) CALL GPTCM1(IFLAG,SVAR,LAST,SLIN) IF (IFLAG.NE.0) GOTO 100 RETURN END SUBROUTINE GPARI_OLD !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gparr !\begin{verbatim} SUBROUTINE GPARR_old(PROMT,SVAR,LAST,VAL,RDEF,HELP) ! asks for a double with no default ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none CHARACTER PROMT*(*),SVAR*(*) integer last double precision val,rdef EXTERNAL HELP !\end{verbatim} %+ CHARACTER SLIN*80 integer iflag ! check for environment variables CALL GQXENV(SVAR) 100 CALL GQARR(PROMT,SVAR,LAST,VAL,RDEF,HELP) ! CALL GPTCM1(IFLAG,SVAR,LAST,SLIN,ENVIR) CALL GPTCM1(IFLAG,SVAR,LAST,SLIN) IF (IFLAG.NE.0) GOTO 100 RETURN END SUBROUTINE GPARR_OLD !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gparrd !\begin{verbatim} SUBROUTINE GPARRD_old(PROMT,SVAR,LAST,VAL,RDEF,HELP) ! ask for a double with default provided ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none CHARACTER PROMT*(*),SVAR*(*) integer last EXTERNAL HELP double precision val,rdef !\end{verbatim} %+ CHARACTER SLIN*80 integer iflag ! ths checks for environment variables CALL GQXENV(SVAR) 100 CALL GQARRD(PROMT,SVAR,LAST,VAL,RDEF,HELP) CALL GPTCM1(IFLAG,SVAR,LAST,SLIN) IF (IFLAG.NE.0) GOTO 100 RETURN END SUBROUTINE GPARRD_OLD !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gparc !\begin{verbatim} SUBROUTINE GPARC_old(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,HELP) ! read a character without default implicit none ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) CHARACTER PROMT*(*),SVAR*(*),CDEF*(*),SVAL*(*) integer last,jtyp EXTERNAL HELP !\end{verbatim} %+ CHARACTER SLIN*80 integer iflag ! this call handles environment variables CALL GQXENV(SVAR) 100 CALL GQARC(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,HELP) IF(BUPERR.NE.0) GOTO 900 SLIN=SVAL(1:max(1,LEN_TRIM(sval))) ! CALL GPTCM2(IFLAG,SVAR,LAST,SLIN,ENVIR) CALL GPTCM2(IFLAG,SVAR,LAST,SLIN) IF (IFLAG.NE.0) GOTO 100 900 RETURN END SUBROUTINE GPARC_OLD !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gparcd !\begin{verbatim} SUBROUTINE GPARCD_old(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,HELP) ! read a character with default provided implicit none ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) CHARACTER PROMT*(*),SVAR*(*),CDEF*(*),SVAL*(*) integer last,jtyp EXTERNAL HELP !\end{verbatim} %+ ! CHARACTER SLIN*80 integer iflag ! this call exchanges environment variables for actual variables CALL GQXENV(SVAR) ! this is the real interactive call 100 CALL GQARCD(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,HELP) IF(BUPERR.NE.0) GOTO 900 SLIN=SVAL CALL GPTCM2(IFLAG,SVAR,LAST,SLIN) !...the next line was missing ... IF (IFLAG.NE.0) GOTO 100 900 RETURN END SUBROUTINE GPARCD_OLD !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gqarrd !\begin{verbatim} subroutine GQARRD(PROMT,SVAR,LAST,VAL,RDEF,HELP) ! read real with default implicit none CHARACTER PROMT*(*),SVAR*(*) integer last,ival character*1 str,cdef double precision val,rdef EXTERNAL HELP !\end{verbatim} %+ GPARITYP=3 GPARWDEF=.TRUE. GPARRDEF=RDEF call gparall(PROMT,SVAR,LAST,IVAL,val,str,cdef,HELP) return end SUBROUTINE GQARRD !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gqarr !\begin{verbatim} subroutine GQARR(PROMT,SVAR,LAST,VAL,RDEF,HELP) ! read real without default implicit none CHARACTER PROMT*(*),SVAR*(*) integer last,ival EXTERNAL HELP double precision val,rdef character*1 str,cdef !\end{verbatim} %+ GPARITYP=3 GPARWDEF=.FALSE. GPARRDEF=RDEF call gparall(PROMT,SVAR,LAST,IVAL,val,str,cdef,HELP) return end SUBROUTINE GQARR !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gqarid !\begin{verbatim} SUBROUTINE GQARID(PROMT,SVAR,LAST,IVAL,IDEF,HELP) ! previously subroutine GPARID !...SVAR SHALL CONTAIN A PARAMETER VALUE. IF EMPTY THE PARAMETER IS ASKED FOR ! USING PROMT AS OUTPUT STRING. IF NO ANSWER THE VALUE IN DEF IS RETURNED ! INTEGER VALUES. THE DEFAULT VALUE IS DISPLAYED IN THE PROMT WITHIN ! SLASHES. THE SAME ROUTINES WITHOUT THE FINAL D DOES NOT DISPALY THE ! DEFAULT VALUE ! HELP IS A ROUTINE THAT WRITES AN EXPLAINING MESSAGE. ! LAST IS THE POSITION OF THE TERMINATOR OF THE FORMER PARAMETER OR ! COMMAND, DECODING STARTS FROM THE POSITION AFTER LAST implicit none CHARACTER PROMT*(*),SVAR*(*) integer last,ival,idef character*1 str,cdef double precision val EXTERNAL HELP !\end{verbatim} %+ GPARITYP=1 GPARWDEF=.TRUE. GPARIDEF=IDEF call gparall(PROMT,SVAR,LAST,IVAL,val,str,cdef,HELP) return end SUBROUTINE GQARID !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gqari !\begin{verbatim} subroutine GQARI(PROMT,SVAR,LAST,IVAL,IDEF,HELP) ! read integer with no default implicit none CHARACTER PROMT*(*),SVAR*(*) integer last,ival,idef character*1 str,cdef double precision val EXTERNAL HELP !\end{verbatim} %+ GPARITYP=1 GPARWDEF=.FALSE. GPARIDEF=IDEF call gparall(PROMT,SVAR,LAST,IVAL,val,str,cdef,HELP) return end SUBROUTINE GQARI !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gqarcd !\begin{verbatim} subroutine GQARCD(PROMT,SVAR,LAST,JTYP,STR,CDEF,HELP) ! TO READ A STRING VALUE with default implicit none CHARACTER PROMT*(*),SVAR*(*),str*(*),cdef*(*) integer last,jtyp EXTERNAL HELP !\end{verbatim} %+ !...SUBROUTINE GQARCD ! JTYP DEFINES THE TERMINATION OF A STRING ! 1 TEXT TERMINATED BY SPACE OR "," ! 2 TEXT TERMINATED BY SPACE ! 3 TEXT TERMINATED BY ";" OR "." ! 4 TEXT TERMINATED BY ";" ! 5 TEXT UP TO END-OF-LINE ! 6 TEXT UP TO AND INCLUDING ";" ! 7 TEXT TERMINATED BY SPACE OR "," BUT IGNORING SUCH INSIDE ( ) ! >31, THE CHAR(JTYP) IS USED AS TERMINATING CHARACTER integer ival double precision val GPARWDEF=.TRUE. IF(JTYP.LE.0) THEN ! CALL ST2ERR(1030,'GPARC','NO SUCH TYPE OPTION') buperr=1030 GOTO 900 ENDIF IF(JTYP.EQ.7) THEN GPARENTES=.TRUE. GPARITYP=4 ELSE GPARENTES=.FALSE. IF(JTYP.LE.6) THEN ! NOTE GPARITYP 1 and 3 used for integer and double precision !!! GPARITYP=JTYP+3 ELSE GPARITYP=10 GPARCH2=CHAR(JTYP) ENDIF ENDIF call gparall(PROMT,SVAR,LAST,IVAL,val,str,cdef,HELP) return 900 continue end SUBROUTINE GQARCD !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gparall !\begin{verbatim} SUBROUTINE gparall(PROMT,SVAR,LAST,IVAL,val,string,cdef,HELP) ! previously subroutine GPARID !...SVAR SHALL CONTAIN A PARAMETER VALUE. IF EMPTY THE PARAMETER IS ASKED FOR ! USING PROMT AS OUTPUT STRING. IF NO ANSWER THE VALUE IN DEF IS RETURNED ! INTEGER VALUES. THE DEFAULT VALUE IS DISPLAYED IN THE PROMT WITHIN ! SLASHES. THE SAME ROUTINES WITHOUT THE FINAL D DOES NOT DISPALY THE ! DEFAULT VALUE ! HELP IS A ROUTINE THAT WRITES AN EXPLAINING MESSAGE. ! LAST IS THE POSITION OF THE TERMINATOR OF THE FORMER PARAMETER OR ! COMMAND, DECODING STARTS FROM THE POSITION AFTER LAST ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none CHARACTER PROMT*(*),SVAR*(*),CH1*1,CDEF*(*),STRING*(*),SSD*30 CHARACTER PPROMT*132,CH2*1 ! LOGICAL EOLCH,SG2ERR,WDEF,MATP LOGICAL WDEF,MATP EXTERNAL HELP !\end{verbatim} %+ integer last,ival double precision val ! local variables integer i,ijp,j,jjp,l1,l2,llq,llp,llz,m,kxy,iqq,ityp,idef double precision rdef,x ! All routines converge here, update command level and save promt ! for use by help routines CONTINUE ! check if promt already in path, otherwise increase level do iqq=2,helprec%level kxy=min(len_trim(promt),12) if(promt(1:kxy).eq.helprec%cpath(iqq)(1:kxy)) then helprec%level=iqq goto 991 endif enddo if(helprec%level.lt.maxhelplevel) then helprec%level=helprec%level+1 helprec%cpath(helprec%level)=promt ! write(*,*)'Help level increased to: ',helprec%level else ! write(*,*)'Warning, too many levels in help path' ! This can happen when asking for constitution including the constituent ! just save the last questions helprec%cpath(helprec%level)=promt endif 991 continue !------------------------------- ! extract values from calling routines stored in GPARxyz wdef=gparwdef if(gparityp.eq.1) then ! calling routine wants an integer value ityp=1 ! if(wdef) idef=gparidef ! always set the default, it may be used anyway!! idef=gparidef elseif(gparityp.eq.3) then ! calling routine wants a double precision value ityp=3 ! if(wdef) rdef=gparrdef rdef=gparrdef else ! calling routine wants a string, ityp>3, ityp=gparityp matp=gparentes ch2=' ' if(ityp.eq.10) ch2=gparch2 endif !------------------------------------------------------- !...INCREMENT LAST BY ONE TO BYPASS TERMINATOR OF COMMAND OR PREVIOUS ANSWER LAST=LAST+1 IF(LAST.LT.1 .OR. LAST.GT.LEN(SVAR)) LAST=LEN(SVAR)+1 !...SKIP BLANKS STARTING FROM THE POSITION AFTER LAST ! IF LAST OUTSIDE SVAR THEN ASK QUESTION I=LAST 10 CONTINUE IF(EOLCH(SVAR,I)) THEN !... EMPTY STRING, IF NO BYTES IN PROMT TAKE DEFAULT VALUES M=LEN_TRIM(PROMT) IF(M.LT.1) GOTO 910 IF(WDEF) THEN PPROMT=PROMT(1:M)//' /' JJP=M+3 !... INSERT DEFAULT VALUE INTO PROMT IF(ITYP.EQ.1) THEN X=REAL(IDEF) CALL WRINUM(PPROMT,JJP,10,0,X) ELSEIF(ITYP.EQ.3) THEN ! IF(RDEF.NE.RNONE) CALL WRINUM(PPROMT,JJP,10,0,RDEF) ! to avoid getting values as 0.0250000004 rather than 0.025 ... ! IF(RDEF.NE.RNONE) CALL WRINUM(PPROMT,JJP,8,0,RDEF) CALL WRINUM(PPROMT,JJP,8,0,RDEF) ELSE PPROMT(JJP:)=CDEF I=LEN_TRIM(CDEF) JJP=JJP+I ENDIF IF(LEN_TRIM(PPROMT).GT.M+2) THEN PPROMT(JJP:)='/: ' JJP=JJP+2 ELSE !... TO AVOID AN EMPTY STRING BETWEEN SLASHES ! PPROMT(M+1:M+2)=': ' PPROMT(M+1:)=': ' JJP=len_trim(ppromt) ENDIF CALL BOUTXT(KOU,PPROMT(1:JJP)) IJP=JJP ELSE PPROMT=PROMT JJP=LEN_TRIM(PPROMT) CALL BOUTXT(KOU,PPROMT(1:MAX(1,JJP))) ENDIF SVAR=' ' CALL BINTXT(KIU,SVAR(1:MIN(LEN(SVAR),130))) if(jecho.ne.0) then ! echo .... j=len_trim(svar) if(j.gt.0) then write(kou,77)svar(1:len_trim(svar)) 77 format('... echo: ',a) endif endif !...WRITE INPUT ON LOG FILE IF ANY IF(LOGFIL.GT.0) THEN !...write on logfile only if question asked !!! I=LEN_TRIM(SVAR) IF(I.LE.0 .AND. WDEF) THEN IF(IJP-3.GE.M+3) THEN !...WRITE THE DEFAULT ANSWER IF USER INPUT IS EMPTY WRITE(LOGFIL,17)PPROMT(M+3:IJP-3) ELSE WRITE(LOGFIL,17)' ' ENDIF ELSE WRITE(LOGFIL,17)SVAR(1:MAX(1,I)) ENDIF 17 FORMAT(A) ENDIF I=1 IF(EOLCH(SVAR,I)) GOTO 910 ENDIF !...DECODE THE ANSWER IN SVAR CH1=SVAR(I:I) !...IF FIRST CHARACTER IS "," PUT DEFAULT VALUE IF ANY IF(CH1.EQ.',') GOTO 910 !...IF FIRST CHARACTER IS '?' WRITE HELP MESSAGE IF(CH1.EQ.'?') THEN M=LEN_TRIM(PROMT) CALL HELP(PROMT(1:M),SVAR(I:)) IF(SVAR(I:I+1).EQ.'?!') THEN !... THE SPECIAL ROUTINE TOPHLP SHOULD BE USED WHEN HELP IS ! PROVIDED INSIDE THE CALLING ROUTINE! A ? IS RETURNED SVAR(I+1:I+1)=' ' if (ityp.gt.3) STRING=SVAR(I:) GOTO 900 ENDIF I=LEN(SVAR) GOTO 10 ENDIF !...FETCH THE VALUE FROM SVAR LAST=I IF(ITYP.EQ.1) THEN CALL GETINT(SVAR,LAST,IVAL) ELSEIF(ITYP.EQ.3) THEN CALL GETREL(SVAR,LAST,VAL) ELSEIF(ITYP.LE.10) THEN !...THE PART HERE IS GLITCHY AS ICE ... handling character input L1=0 L2=0 ! ITYP= 4 5 6 7 8 9 10 GOTO( 40, 50, 60, 70, 80, 70,100),ITYP-3 ! terminate with space or , 40 L1=INDEX(SVAR(LAST:),',') ! terminate with space 50 L2=INDEX(SVAR(LAST:),' ') ! handle if space or , inside parenthesis should be ignored, like x(fcc,cr) IF(MATP) THEN !...A , OR SPACE INSIDE PARENTHESIS SHOULD BE IGNORED LLQ=MIN(L1,L2) IF(LLQ.EQ.0) LLQ=MAX(L1,L2) LLP=INDEX(SVAR(LAST:),'(') IF(LLP.GT.0 .AND. LLP.LT.LLQ) THEN !... LLP SHALL BE POSITION OF (, FDMTP UPDATES LLP TO POSITION AFTER ) 51 CALL FDMTP(SVAR(LAST:),LLP,SSD) IF(BUPERR.NE.0) GOTO 900 IF(ITYP.EQ.4) L1=INDEX(SVAR(LAST+LLP-1:),',') L2=INDEX(SVAR(LAST+LLP-1:),' ') IF(L1.GT.0) L1=L1+LLP-1 IF(L2.GT.0) L2=L2+LLP-1 LLQ=MIN(L1,L2) IF(LLQ.EQ.0) LLQ=MAX(L1,L2) LLZ=INDEX(SVAR(LAST+LLP-1:),'(') IF(LLZ.GT.0 .AND. LLP+LLZ.LT.LLQ) THEN !... WE HAVE MORE THAN ONE ( BEFORE , OR SPACE LLP=LLP+LLZ-1 GOTO 51 ENDIF ENDIF ENDIF GOTO 400 ! terminale with period 60 L1=INDEX(SVAR(LAST:),'.') ! terminate with semicolon 70 L2=INDEX(SVAR(LAST:),';') !...STRING INCLUDING THE ; IF(ITYP.EQ.9 .AND. L2.GT.0) L2=L2+1 GOTO 400 !...WHOLE STRING 80 L1=LEN(SVAR) GOTO 400 ! terminate with provided character >31 100 L2=INDEX(SVAR(LAST:),CH2) 400 IF(L1.GT.0 .AND. L2.GT.0) THEN L1=LAST+MIN(L1,L2)-1 ELSEIF(L1.LE.0 .AND. L2.LE.0) THEN L1=LEN(SVAR)+1 ELSE !... BUG FOUND HERE: IF L1 IS LEN(SVAR) AND LAST>1 L1 SET >LEN(SVAR)+1 L1=MIN(LAST+MAX(L1,L2)-1,LEN(SVAR)+1) ENDIF IF(L1.GT.LAST) THEN STRING=SVAR(LAST:L1-1) ELSE STRING=' ' ENDIF LAST=L1 ELSE ! CALL ST2ERR(1030,'GPAR','NO SUCH TYPE OPTION') buperr=1030 ENDIF 900 RETURN !...SET DEFAULT VALUE 910 continue IF(ITYP.EQ.1) THEN IF(IDEF.EQ.NONE) GOTO 920 IVAL=IDEF ELSEIF(ITYP.EQ.3) THEN IF(RDEF.EQ.RNONE) GOTO 920 VAL=RDEF ELSE ! write(*,911)'ML gparqall: ',trim(cdef),trim(cnone),wdef !911 format(a,a,' - ',a,l2) IF(CDEF.NE.CNONE) THEN STRING=CDEF !! endif ELSE GOTO 920 endif ENDIF !...SET POSITION IN STRING TO POSITION OF , LAST=I GOTO 900 !...NO ANSWER AND NO DEFAULT VALUE, ERROR RETURN !920 CALL ST2ERR(1032,'GPAR','PARAMETER VALUE MISSING') 920 buperr=1032 GOTO 900 END SUBROUTINE GPARALL !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gqarc !\begin{verbatim} subroutine GQARC(PROMT,SVAR,LAST,JTYP,STR,CDEF,HELP) ! read a string without default implicit none CHARACTER PROMT*(*),SVAR*(*) integer last,ival,jtyp EXTERNAL HELP double precision val character str*(*),cdef*(*) !\end{verbatim} %+ GPARWDEF=.FALSE. IF(JTYP.LE.0) THEN ! CALL ST2ERR(1030,'GPARC','NO SUCH TYPE OPTION') buperr=1030 GOTO 900 ENDIF IF(JTYP.EQ.7) THEN GPARENTES=.TRUE. GPARITYP=4 ELSE GPARENTES=.FALSE. IF(JTYP.LE.6) THEN GPARITYP=JTYP+3 ELSE GPARITYP=10 GPARCH2=CHAR(JTYP) ENDIF ENDIF call gparall(PROMT,SVAR,LAST,IVAL,val,str,cdef,HELP) 900 continue return end SUBROUTINE GQARC !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gparfile !\begin{verbatim} SUBROUTINE GPARFILE(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,TYP,HELP) ! to ask for a file name using command line or external window ! prompt is question ! svar is a character variable which may already contain an answer ! last is position in svar to start searching for an answer ! JTYP DEFINES THE TERMINATION OF A STRING ! 1 TEXT TERMINATED BY SPACE OR "," ! 2 TEXT TERMINATED BY SPACE ! 3 TEXT TERMINATED BY ";" OR "." ! 4 TEXT TERMINATED BY ";" ! 5 TEXT UP TO END-OF-LINE ! 6 TEXT UP TO AND INCLUDING ";" ! 7 TEXT TERMINATED BY SPACE OR "," BUT IGNORING SUCH INSIDE ( ) ! >31, THE CHAR(JTYP) IS USED AS TERMINATING CHARACTER ! sval is the answer either extracted from SVAR or obtained by user input ! cdef is a default answer ! typ is default file extenion, at present only: ! 1=".TDB", 2=".UNF", 3=".OCM" ! help is a help routine implicit none ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) CHARACTER PROMT*(*),SVAR*(*),CDEF*(*),SVAL*(*) integer last,jtyp EXTERNAL HELP !\end{verbatim} CHARACTER SLIN*80 integer typ,typeahead,kk,iflag logical beware #ifdef tinyfd ! only if we use tinyfiledialogs, check if any character after last+1 typeahead=last+1 beware=.FALSE. ! beware set to TRUE if no typeahead (there are non-blanks after positon last+1) beware=eolch(svar,typeahead) ! write(*,*)'M3 gparfile: ',kou,koud,last,eolch(svar,last) if(nopenpopup .or. kiu.ne.kiud .or. .not.beware) then #endif ! If we are not connected to a terminal (reading a macro file) use line input ! Also if there are "type ahead" use the line input ! This call exchanges any macro variables in SVAR for defined macro values CALL GQXENV(SVAR) ! If interactive if(kiu.eq.kiud .and. beware) write(kou,"(a)") & 'Beware: you must give the full path unless the file '//& 'is in working directory!' 100 CALL GQARC(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,HELP) IF(BUPERR.NE.0) GOTO 900 SLIN=SVAL(1:max(1,LEN_TRIM(sval))) ! This call handles ? @ and other things in SVAR CALL GPTCM2(IFLAG,SVAR,LAST,SLIN) IF (IFLAG.NE.0) GOTO 100 if(IUMACLEVL.ge.1) then if(sval(1:2).eq.'./') then ! we are running a macro and if SVAL(1:2) is './' replace this with MACROPATH' sval=trim(macropath(IUMACLEVL))//sval(3:) elseif(sval(1:3).eq.'../') then ! we are running a macro and if SVAL(1:3) is '../' prefix with MACROPATH' sval=trim(macropath(IUMACLEVL))//sval ! write(*,*)'M3 add path: ',trim(sval),IUMACLEVL ! else ! write(*,*)'M3 assuming full path or in working directory: ' endif endif #ifdef tinyfd else ! open a popup window to browse directories and files using tinyfiledialogs ! typ<0 means new or old file; 0 old file no filer, ! typ >0 means old file with filter: ! typ=1 TDB, 2=OCU, 3=OCM, 4=OCD, 5=plt, 6=XTDB, 7=DAT ! these are defined in pmon6.F90 also !!!!!!!!!!!!!!!!!!!!!!!!! ! getfilename is in utilities/TINYFILEDIALOGS/ftinyopen call getfilename(typ,sval) ! write(*,333)trim(sval),typ 333 format('METLIB: Back from getfilename 1: "',a,'" typ: ',i3) if(sval(1:1).eq.' ') then buperr=1020 elseif(typ.eq.-7) then ! this is for output and file created, if no extension add DAT kk=index(sval,'.DAT ') if(kk.eq.0) then sval(len_trim(sval)+1:)='.DAT' endif endif endif #endif 900 RETURN END SUBROUTINE GPARFILE !/!\!/!\!/!\!/!\!/!\!/!\! new X routines /!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ ! ! >>>> subsection ! Extracting command arguments from a character ! ! This is second group with new routines ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gparidx & Ask for integer with default !\begin{verbatim} SUBROUTINE GPARIDx(PROMT,SVAR,LAST,IVAL,IDEF,hyper) ! ask for integer value with default ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none CHARACTER PROMT*(*),SVAR*(*),hyper*(*) integer last,ival,idef ! EXTERNAL HELP !\end{verbatim} %+ CHARACTER SLIN*512 integer iflag ! chcek for environment variables CALL GQXENV(SVAR) 100 CALL GQARIDx(PROMT,SVAR,LAST,IVAL,IDEF,hyper) CALL GPTCM1(IFLAG,SVAR,LAST,SLIN) IF (IFLAG.NE.0) GOTO 100 RETURN END SUBROUTINE GPARIDX !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gparix & Ask for integer no default !\begin{verbatim} SUBROUTINE GPARIx(PROMT,SVAR,LAST,IVAL,IDEF,hyper) ! ask for integer value woth no default implicit none CHARACTER PROMT*(*),SVAR*(*),hyper*(*) integer last,ival,idef ! EXTERNAL HELP !\end{verbatim} %+ CHARACTER SLIN*80 integer iflag ! check for environment variables CALL GQXENV(SVAR) 100 CALL GQARIx(PROMT,SVAR,LAST,IVAL,IDEF,hyper) CALL GPTCM1(IFLAG,SVAR,LAST,SLIN) IF (IFLAG.NE.0) GOTO 100 RETURN END SUBROUTINE GPARIX !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gparrx & Ask for double no default !\begin{verbatim} SUBROUTINE GPARRx(PROMT,SVAR,LAST,VAL,RDEF,hyper) ! asks for a double with no default ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none CHARACTER PROMT*(*),SVAR*(*),hyper*(*) integer last double precision val,rdef ! EXTERNAL HELP !\end{verbatim} %+ CHARACTER SLIN*80 integer iflag ! check for environment variables CALL GQXENV(SVAR) 100 CALL GQARRx(PROMT,SVAR,LAST,VAL,RDEF,hyper) ! CALL GPTCM1(IFLAG,SVAR,LAST,SLIN,ENVIR) CALL GPTCM1(IFLAG,SVAR,LAST,SLIN) IF (IFLAG.NE.0) GOTO 100 RETURN END SUBROUTINE GPARRX !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gparrdx & Ask for double with default !\begin{verbatim} SUBROUTINE GPARRDx(PROMT,SVAR,LAST,VAL,RDEF,hyper) ! ask for a double with default provided ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none CHARACTER PROMT*(*),SVAR*(*),hyper*(*) integer last ! EXTERNAL HELP double precision val,rdef !\end{verbatim} %+ CHARACTER SLIN*80 integer iflag ! ths checks for environment variables CALL GQXENV(SVAR) 100 CALL GQARRDx(PROMT,SVAR,LAST,VAL,RDEF,hyper) CALL GPTCM1(IFLAG,SVAR,LAST,SLIN) IF (IFLAG.NE.0) GOTO 100 RETURN END SUBROUTINE GPARRDX !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gparcdx & Ask for character with default !\begin{verbatim} SUBROUTINE GPARCDx(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,hyper) ! read a character with default provided implicit none ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) CHARACTER PROMT*(*),SVAR*(*),CDEF*(*),SVAL*(*),hyper*(*) integer last,jtyp EXTERNAL HELP !\end{verbatim} %+ ! CHARACTER SLIN*80 integer iflag ! this call exchanges environment variables for actual variables CALL GQXENV(SVAR) ! this is the real interactive call 100 continue ! CALL GQARCDX(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,HELP,hyper) CALL GQARCDX(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,hyper) IF(BUPERR.NE.0) GOTO 900 SLIN=SVAL CALL GPTCM2(IFLAG,SVAR,LAST,SLIN) !...the next line was missing ... IF (IFLAG.NE.0) GOTO 100 900 RETURN END SUBROUTINE GPARCDX !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gparcx & Ask for character no default !\begin{verbatim} SUBROUTINE GPARCX(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,hyper) ! read a character with default provided and hypertarget implicit none ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) CHARACTER PROMT*(*),SVAR*(*),CDEF*(*),SVAL*(*),hyper*(*) integer last,jtyp ! EXTERNAL HELP now always use Q4HELP !\end{verbatim} %+ ! CHARACTER SLIN*80 integer iflag ! this call exchanges environment variables for actual variables CALL GQXENV(SVAR) ! this is the real interactive call ... well no longer ... !100 CALL GQARCX(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,HELP,hyper) 100 continue CALL GQARCX(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,hyper) IF(BUPERR.NE.0) GOTO 900 SLIN=SVAL CALL GPTCM2(IFLAG,SVAR,LAST,SLIN) !...the next line was missing ... IF (IFLAG.NE.0) GOTO 100 900 RETURN END SUBROUTINE GPARCX !\addtotable subroutine gqaridx & Ask for integer with default !\begin{verbatim} SUBROUTINE GQARIDX(PROMT,SVAR,LAST,IVAL,IDEF,hyper) !...SVAR SHALL CONTAIN A PARAMETER VALUE. IF EMPTY THE PARAMETER IS ASKED FOR ! USING PROMT AS OUTPUT STRING. IF NO ANSWER THE VALUE IN DEF IS RETURNED ! INTEGER VALUES. THE DEFAULT VALUE IS DISPLAYED IN THE PROMT WITHIN ! SLASHES. THE SAME ROUTINES WITHOUT THE FINAL D DOES NOT DISPALY THE ! DEFAULT VALUE ! hyper is a hypertarget for online help ! LAST IS THE POSITION OF THE TERMINATOR OF THE FORMER PARAMETER OR ! COMMAND, DECODING STARTS FROM THE POSITION AFTER LAST implicit none CHARACTER PROMT*(*),SVAR*(*),hyper*(*) integer last,ival,idef character*1 str,cdef double precision val !\end{verbatim} %+ GPARITYP=1 GPARWDEF=.TRUE. GPARIDEF=IDEF call gparallx(PROMT,SVAR,LAST,IVAL,val,str,cdef,hyper) return end SUBROUTINE GQARIDX !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gqarix & Ask for integer no default !\begin{verbatim} subroutine GQARIx(PROMT,SVAR,LAST,IVAL,IDEF,hyper) ! read integer with no default implicit none CHARACTER PROMT*(*),SVAR*(*),hyper*(*) integer last,ival,idef ! EXTERNAL HELP !\end{verbatim} %+ ! dummy variables for gparallx character*1 str,cdef double precision val GPARITYP=1 GPARWDEF=.FALSE. GPARIDEF=IDEF call gparallx(PROMT,SVAR,LAST,IVAL,val,str,cdef,hyper) return end SUBROUTINE GQARIX !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gqarrdx & Ask for double with default !\begin{verbatim} subroutine GQARRDx(PROMT,SVAR,LAST,VAL,RDEF,hyper) ! read real with default implicit none CHARACTER PROMT*(*),SVAR*(*),hyper*(*) integer last double precision val,rdef EXTERNAL HELP !\end{verbatim} %+ character*1 str,cdef integer ival GPARITYP=3 GPARWDEF=.TRUE. GPARRDEF=RDEF call gparallx(PROMT,SVAR,LAST,IVAL,val,str,cdef,hyper) return end SUBROUTINE GQARRDX !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gqarrx & Ask for double no default !\begin{verbatim} subroutine GQARRx(PROMT,SVAR,LAST,VAL,RDEF,hyper) ! read real without default implicit none CHARACTER PROMT*(*),SVAR*(*),hyper*(*) integer last double precision val,rdef !\end{verbatim} %+ character*1 str,cdef integer ival GPARITYP=3 GPARWDEF=.FALSE. GPARRDEF=RDEF call gparallx(PROMT,SVAR,LAST,IVAL,val,str,cdef,hyper) return end SUBROUTINE GQARRX !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gqarcdx & Ask for character with default !\begin{verbatim} subroutine GQARCDX(PROMT,SVAR,LAST,JTYP,STR,CDEF,hyper) ! TO READ A STRING VALUE with default implicit none CHARACTER PROMT*(*),SVAR*(*),str*(*),cdef*(*),hyper*(*) integer last,jtyp ! EXTERNAL HELP no longer needed !\end{verbatim} %+ !...SUBROUTINE GQARCDX ! JTYP DEFINES THE TERMINATION OF A STRING ! 1 TEXT TERMINATED BY SPACE OR "," ! 2 TEXT TERMINATED BY SPACE ! 3 TEXT TERMINATED BY ";" OR "." ! 4 TEXT TERMINATED BY ";" ! 5 TEXT UP TO END-OF-LINE ! 6 TEXT UP TO AND INCLUDING ";" ! 7 TEXT TERMINATED BY SPACE OR "," BUT IGNORING SUCH INSIDE ( ) ! >31, THE CHAR(JTYP) IS USED AS TERMINATING CHARACTER integer ival double precision val GPARWDEF=.TRUE. IF(JTYP.LE.0) THEN ! CALL ST2ERR(1030,'GPARC','NO SUCH TYPE OPTION') buperr=1030 GOTO 900 ENDIF IF(JTYP.EQ.7) THEN GPARENTES=.TRUE. GPARITYP=4 ELSE GPARENTES=.FALSE. IF(JTYP.LE.6) THEN ! NOTE GPARITYP 1 and 3 used for integer and double precision !!! GPARITYP=JTYP+3 ELSE GPARITYP=10 GPARCH2=CHAR(JTYP) ENDIF ENDIF ! call gparallx(PROMT,SVAR,LAST,IVAL,val,str,cdef,HELP,hyper) call gparallx(PROMT,SVAR,LAST,IVAL,val,str,cdef,hyper) return 900 continue end SUBROUTINE GQARCDX !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gqarcx & Ask for character no default !\begin{verbatim} subroutine GQARCX(PROMT,SVAR,LAST,JTYP,STR,CDEF,hyper) ! TO READ A STRING VALUE with default user hypertext implicit none CHARACTER PROMT*(*),SVAR*(*),str*(*),cdef*(*),hyper*(*) integer last,jtyp ! EXTERNAL HELP no longer needed !\end{verbatim} %+ !...SUBROUTINE GQARCx ! JTYP DEFINES THE TERMINATION OF A STRING ! 1 TEXT TERMINATED BY SPACE OR "," ! 2 TEXT TERMINATED BY SPACE ! 3 TEXT TERMINATED BY ";" OR "." ! 4 TEXT TERMINATED BY ";" ! 5 TEXT UP TO END-OF-LINE ! 6 TEXT UP TO AND INCLUDING ";" ! 7 TEXT TERMINATED BY SPACE OR "," BUT IGNORING SUCH INSIDE ( ) ! >31, THE CHAR(JTYP) IS USED AS TERMINATING CHARACTER integer ival double precision val GPARWDEF=.TRUE. IF(JTYP.LE.0) THEN ! CALL ST2ERR(1030,'GPARC','NO SUCH TYPE OPTION') buperr=1030 GOTO 900 ENDIF IF(JTYP.EQ.7) THEN GPARENTES=.TRUE. GPARITYP=4 ELSE GPARENTES=.FALSE. IF(JTYP.LE.6) THEN ! NOTE GPARITYP 1 and 3 used for integer and double precision !!! GPARITYP=JTYP+3 ELSE GPARITYP=10 GPARCH2=CHAR(JTYP) ENDIF ENDIF ! write(*,*)'In GQARCX calling gparallx: ',trim(hyper) ! call gparallx(PROMT,SVAR,LAST,IVAL,val,str,cdef,HELP,hyper) call gparallx(PROMT,SVAR,LAST,IVAL,val,str,cdef,hyper) return 900 continue end SUBROUTINE GQARCX !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gparallx & Ask for anything !\begin{verbatim} SUBROUTINE gparallx(PROMT,SVAR,LAST,IVAL,val,string,cdef,hyper) ! this is the focal routine for all variants of GPARxyz !...SVAR shall contain an answer or command. If EMPTY THE answer IS ASKED FOR ! USING PROMT AS OUTPUT STRING. IF NO ANSWER THE VALUE IN DEF (default) ! is returned if a provided. The routine can return integer, double or ! character variables. THE DEFAULT VALUE IS DISPLAYED IN THE PROMT WITHIN ! SLASHES. if no answer and no defualt an error is returned. ! HELP is no longer a parameter Q4HELP is always used ! as hypertarget in a HTML file ! If hyper contains the character ?TOPHLP and the user has typed a single ? ! the routine returns with this ? and the calling routine can display ! a menu. If the user types two ?? the PROMT is used as hypertarget. ! LAST IS THE current POSITION IN SVAR, it is incremented by one ! before looking for an answer (skipping the terminator of any previous ! input. ! REPEAT: ! when called on top level or from a submenu then hyper='?TOPHLP' ! if user types a single ? only menu listed, with ?? use PROMT as target implicit none CHARACTER PROMT*(*),SVAR*(*),CH1*1,CDEF*(*),STRING*(*),hyper*(*) integer ival double precision val ! EXTERNAL HELP !\end{verbatim} CHARACTER PPROMT*132,CH2*1,ssd*30 LOGICAL WDEF,MATP integer last,unused ! local variables ! integer i,ijp,j,jjp,l1,l2,llq,llp,llz,m,kxy,iqq,ityp,idef,kk,nw,kl integer i,ijp,j,jjp,l1,l2,llq,llp,llz,m,ityp,idef,kk,nw,kl,qz double precision rdef,x character hypertarget*(40) logical once ! All input routines converge here, update command level and save promt ! for use by help routines once=.TRUE. CONTINUE ! write(*,*)'In gparallx: ',trim(promt),' & ',trim(hyper) ! check if promt already in path, otherwise increase level unused=0 ! skip old helprec stuff ... ! do iqq=2,helprec%level ! save first 12 characters in helprec%path (obsolete now?) ! kxy=min(len_trim(promt),12) ! if(promt(1:kxy).eq.helprec%cpath(iqq)(1:kxy)) then ! helprec%level=iqq ! goto 991 ! endif ! enddo ! if(helprec%level.lt.maxhelplevel) then ! helprec%level=helprec%level+1 ! helprec%cpath(helprec%level)=promt ! write(*,*)'Help level increased to: ',helprec%level ! else ! write(*,*)'Warning, too many levels in help path' ! This can happen when asking for constitution including the constituent ! just save the last questions ! helprec%cpath(helprec%level)=promt ! endif !991 continue !------------------------------- ! extract values from calling routines stored in GPARxyz ! gparityp is a GLOBAL private variable to transfer type of value to return ! Assuming this is not run in parallel... wdef=gparwdef if(gparityp.eq.1) then ! calling routine wants an integer value ityp=1 ! if(wdef) idef=gparidef ! always set the default, it may be used anyway!! idef=gparidef elseif(gparityp.eq.3) then ! calling routine wants a double precision value ityp=3 ! if(wdef) rdef=gparrdef rdef=gparrdef else ! calling routine wants a string, ityp>3, ityp=gparityp matp=gparentes ch2=' ' if(ityp.eq.10) ch2=gparch2 endif !------------------------------------------------------- !...INCREMENT LAST BY ONE TO BYPASS TERMINATOR OF COMMAND OR PREVIOUS ANSWER LAST=LAST+1 IF(LAST.LT.1 .OR. LAST.GT.LEN(SVAR)) LAST=LEN(SVAR)+1 !...SKIP BLANKS STARTING FROM THE POSITION AFTER LAST ! IF LAST OUTSIDE SVAR THEN ASK QUESTION I=LAST 10 CONTINUE ! write(*,*)'GPARALLX 10: ',trim(promt) IF(EOLCH(SVAR,I)) THEN !... EMPTY STRING, IF PROMT empty TAKE DEFAULT VALUES M=LEN_TRIM(PROMT) IF(M.LT.1) GOTO 910 ! avoid promt with double :: ! if(M.GT.2 .and. promt(M:M).eq.promt(M-1:M-1)) M=M-1 if(M.GT.2 .and. promt(M:M).eq.':') M=M-1 ijp=0 IF(WDEF) THEN PPROMT=PROMT(1:M)//' /' JJP=M+3 !... INSERT DEFAULT VALUE INTO PROMT IF(ITYP.EQ.1) THEN X=REAL(IDEF) CALL WRINUM(PPROMT,JJP,10,0,X) ELSEIF(ITYP.EQ.3) THEN ! IF(RDEF.NE.RNONE) CALL WRINUM(PPROMT,JJP,10,0,RDEF) ! to avoid getting values as 0.0250000004 rather than 0.025 ... ! IF(RDEF.NE.RNONE) CALL WRINUM(PPROMT,JJP,8,0,RDEF) CALL WRINUM(PPROMT,JJP,8,0,RDEF) ELSE PPROMT(JJP:)=CDEF I=LEN_TRIM(CDEF) JJP=JJP+I ENDIF IF(LEN_TRIM(PPROMT).GT.M+2) THEN PPROMT(JJP:)='/: ' JJP=JJP+2 ELSE !... TO AVOID AN EMPTY STRING BETWEEN SLASHES ! PPROMT(M+1:M+2)=': ' PPROMT(M+1:)=': ' JJP=len_trim(ppromt) ENDIF CALL BOUTXT(KOU,PPROMT(1:JJP)) IJP=JJP ELSE PPROMT=PROMT JJP=LEN_TRIM(PPROMT) CALL BOUTXT(KOU,PPROMT(1:MAX(1,JJP))) ENDIF SVAR=' ' CALL BINTXT(KIU,SVAR(1:MIN(LEN(SVAR),130))) ! THIS IS USER INPUT ! write(*,*)'GPARALLX 77: ',trim(svar) ! if(hyper.eq.'TOPHLP') write(*,*)'gparallx input: ',trim(svar) if(jecho.ne.0) then ! echo .... j=len_trim(svar) if(j.gt.0) then write(kou,77)svar(1:len_trim(svar)) 77 format('... echo: ',a) endif endif !...WRITE INPUT ON LOG FILE IF ANY IF(LOGFIL.GT.0) THEN !...write on logfile only if question asked !!! I=LEN_TRIM(SVAR) IF(I.LE.0 .AND. WDEF) THEN IF(IJP-3.GE.M+3) THEN !...WRITE THE DEFAULT ANSWER IF USER INPUT IS EMPTY and there is a default WRITE(LOGFIL,17)PPROMT(M+3:IJP-3) ELSE WRITE(LOGFIL,17)' ' ENDIF ELSE WRITE(LOGFIL,17)SVAR(1:MAX(1,I)) ENDIF 17 FORMAT(A) ENDIF I=1 IF(EOLCH(SVAR,I)) GOTO 910 ENDIF !...DECODE THE ANSWER IN SVAR ! write(*,*)'GPARALLX 17: ',trim(svar),i CH1=SVAR(I:I) !...IF FIRST CHARACTER IS "," PUT DEFAULT VALUE IF ANY IF(CH1.EQ.',') GOTO 910 !...IF FIRST CHARACTER IS '?' WRITE HELP MESSAGE IF(CH1.EQ.'?') THEN if(hyper.eq.'?TOPHLP') then if(SVAR(I+1:I+1).ne.'?') then ! if the user types a single ? then just display the menu, no browserhelp! last=i string=svar(i:) ! The menu is displayed in calling routine, just return here ! write(*,*)'GPARALLX quick help exit!',trim(string),i goto 900 else ! user types two ??, generate the hypertarget from prompt if(promt(1:2).eq.'--') then ! this is ?? typed at top level hypertarget='?All commands' else ! when prompting for commands the default must be a character write(*,*)'gparallx extract: "',trim(promt),'" and "',& trim(cdef),'"' ! extract part of the promt as hypertarget, ! for a promt "Amend for phase LIQUID what?" extract "Amend for phase" ! to use as hypertarget. Use only the 3 first words kl=1 kk=1 nw=0 max3: do while(kk.gt.0) ! a subsub command should always have 3 fixed words in the promt!!! ! the last word of a subcommand, "what?", has no " " at the end kk=index(promt(kl:),' ') if(kk.gt.0) then kl=kl+kk nw=nw+1 else kl=kl-1 exit max3 endif if(nw.eq.3) then kl=kl-1 exit max3 endif enddo max3 if(kl.le.1) kl=len_trim(promt) hypertarget='?'//promt(1:kl) ! to handle help when user types two ?? for the promt "amend what? /phase/:" ! then include the default answer "phase" in the hypertarget !! ! A single ? already gives the submenu for "amend phase" if(cdef(1:1).ne.' ') then hypertarget(kl+2:)=trim(cdef) endif ! convert prompt to lower case except first letter ! qz=len_trim(hypertarget) call lowercase1(hypertarget) ! write(*,*)'gparallx hypertarget: "',& ! trim(hypertarget),'" and "',trim(cdef),'"',nw,kl endif ! write(*,*)'GPARALLX hypertarget: ',trim(hypertarget) endif else ! normal questions have the hypretarget in hyper to provide help hypertarget=hyper endif ! if two ?? or a real question (not menu) provide more advanced help M=LEN_TRIM(PROMT) ! using q4help the arguments should be hyper and an (so far) unused integer ! CALL HELP(PROMT(1:M),SVAR(I:)) ! CALL HELP(hypertarget,unused) write(*,*)'Calling Q4HELP: "',trim(hypertarget),'"',unused CALL q4help(hypertarget,unused) if(unused.ne.0) then ! return a ? to calling routine ... why? SVAR(I+1:I+1)='?' if (ityp.gt.3) STRING=SVAR(I:) GOTO 900 ENDIF I=LEN(SVAR) if(once) then once=.false.; GOTO 10 else ! A ? more than once as answer, quit with error goto 920 endif ENDIF !...FETCH THE VALUE FROM SVAR LAST=I IF(ITYP.EQ.1) THEN CALL GETINT(SVAR,LAST,IVAL) ELSEIF(ITYP.EQ.3) THEN CALL GETREL(SVAR,LAST,VAL) ELSEIF(ITYP.LE.10) THEN !...THE PART HERE IS GLITCHY AS ICE ... handling character input L1=0 L2=0 ! ITYP= 4 5 6 7 8 9 10 GOTO( 40, 50, 60, 70, 80, 70,100),ITYP-3 ! terminate with space or , 40 L1=INDEX(SVAR(LAST:),',') ! terminate with space 50 L2=INDEX(SVAR(LAST:),' ') ! handle if space or , inside parenthesis should be ignored, like x(fcc,cr) IF(MATP) THEN !...A , OR SPACE INSIDE PARENTHESIS SHOULD BE IGNORED LLQ=MIN(L1,L2) IF(LLQ.EQ.0) LLQ=MAX(L1,L2) LLP=INDEX(SVAR(LAST:),'(') IF(LLP.GT.0 .AND. LLP.LT.LLQ) THEN !... LLP SHALL BE POSITION OF (, FDMTP UPDATES LLP TO POSITION AFTER ) 51 CALL FDMTP(SVAR(LAST:),LLP,SSD) IF(BUPERR.NE.0) GOTO 900 IF(ITYP.EQ.4) L1=INDEX(SVAR(LAST+LLP-1:),',') L2=INDEX(SVAR(LAST+LLP-1:),' ') IF(L1.GT.0) L1=L1+LLP-1 IF(L2.GT.0) L2=L2+LLP-1 LLQ=MIN(L1,L2) IF(LLQ.EQ.0) LLQ=MAX(L1,L2) LLZ=INDEX(SVAR(LAST+LLP-1:),'(') IF(LLZ.GT.0 .AND. LLP+LLZ.LT.LLQ) THEN !... WE HAVE MORE THAN ONE ( BEFORE , OR SPACE LLP=LLP+LLZ-1 GOTO 51 ENDIF ENDIF ENDIF GOTO 400 ! input terminates with period 60 L1=INDEX(SVAR(LAST:),'.') ! input terminates with semicolon 70 L2=INDEX(SVAR(LAST:),';') !...STRING INCLUDING THE ; IF(ITYP.EQ.9 .AND. L2.GT.0) L2=L2+1 GOTO 400 !...WHOLE STRING 80 L1=LEN(SVAR) GOTO 400 ! input terminates with provided character >31 100 L2=INDEX(SVAR(LAST:),CH2) 400 IF(L1.GT.0 .AND. L2.GT.0) THEN L1=LAST+MIN(L1,L2)-1 ELSEIF(L1.LE.0 .AND. L2.LE.0) THEN L1=LEN(SVAR)+1 ELSE !... BUG FOUND HERE: IF L1 IS LEN(SVAR) AND LAST>1 L1 SET >LEN(SVAR)+1 L1=MIN(LAST+MAX(L1,L2)-1,LEN(SVAR)+1) ENDIF IF(L1.GT.LAST) THEN STRING=SVAR(LAST:L1-1) ELSE STRING=' ' ENDIF LAST=L1 ELSE ! CALL ST2ERR(1030,'GPAR','NO SUCH TYPE OPTION') buperr=1030 ENDIF 900 RETURN !...SET DEFAULT VALUE 910 continue IF(ITYP.EQ.1) THEN IF(IDEF.EQ.NONE) GOTO 920 IVAL=IDEF ELSEIF(ITYP.EQ.3) THEN IF(RDEF.EQ.RNONE) GOTO 920 VAL=RDEF ELSE ! write(*,911)'ML gparqall: ',trim(cdef),trim(cnone),wdef !911 format(a,a,' - ',a,l2) IF(CDEF.NE.CNONE) THEN STRING=CDEF !! endif ELSE GOTO 920 endif ENDIF !...SET POSITION IN STRING TO POSITION OF , LAST=I GOTO 900 !...NO ANSWER AND NO DEFAULT VALUE, ERROR RETURN !920 CALL ST2ERR(1032,'GPAR','PARAMETER VALUE MISSING') 920 buperr=1032 GOTO 900 END SUBROUTINE GPARALLX !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine lowercase1 & convert character to lower case !\begin{verbatim} subroutine lowercase1(text) character text*(*) !\end{verbatim} ! integer ip,jp,kp,ichA,ichZ,chlower,ich1 integer ip,ichA,ichZ,chlower,ich1 ichA=ichar('A') ichZ=ichar('Z') ! cha = chA+chlower chlower=ichar('a')-ichA ! write(*,*)'ML text: "',trim(text),'"' ! do not convert first 2 characters or any character not between chA and chZ do ip=3,len(text) ich1=ichar(text(ip:ip)) if(ich1.ge.ichA .and. ich1.le.ichZ) then text(ip:ip)=char(ich1+chlower) endif enddo ! write(*,*)'ML text: "',trim(text),'"' !900 return end subroutine lowercase1 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gparfilex & Ask for file name !\begin{verbatim} SUBROUTINE GPARFILEx(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,TYP,hyper) ! to ask for a file name using command line or external window ! prompt is question ! svar is a character variable which may already contain an answer ! last is position in svar to start searching for an answer ! JTYP DEFINES THE TERMINATION OF A STRING (maybe redundant??) ! 1 TEXT TERMINATED BY SPACE OR "," ! 2 TEXT TERMINATED BY SPACE ! 3 TEXT TERMINATED BY ";" OR "." ! 4 TEXT TERMINATED BY ";" ! 5 TEXT UP TO END-OF-LINE ! 6 TEXT UP TO AND INCLUDING ";" ! 7 TEXT TERMINATED BY SPACE OR "," BUT IGNORING SUCH INSIDE ( ) ! >31, THE CHAR(JTYP) IS USED AS TERMINATING CHARACTER ! sval is the answer either extracted from SVAR or obtained by user input ! cdef is a default answer ! typ is default file extenion in OpenCalphad (OC), at present only: ! 1=".TDB", 2=".OCU", 3=".OCM", 4=OCD , 5=".PLT" , 6=XTDB , 7=".DAT" , 8=".LOG" ! 1 TDB is old TDB format ! 2 OCU is unformatted file (works) ! 3 OCM is macro file (not implemented) ! 4 OCD is unformatted direct files (not implemented) ! 5 PLT is GNUPLOT graphics format (OK) ! 6 XTDB is XML format ! 7 DAT is unspecified data file ! 8 LOG is not used ?? ! negative value for writing ... ! hyper is a hypertext target for help implicit none ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) CHARACTER PROMT*(*),SVAR*(*),CDEF*(*),SVAL*(*),hyper*(*) ! type is cnaged inside this rooutine, must be a variable when called integer last,jtyp,typ ! EXTERNAL HELP !\end{verbatim} CHARACTER SLIN*256 integer typeahead,kk,iflag logical beware sval=' ' slin=cdef ! write(*,10)'M4 in gparfilex: ',typ,trim(cdef),trim(sval),trim(slin) !10 format(a,i3,' "',a,'" "',a,'" "',a,'"') #ifdef tinyfd ! only if we use tinyfiledialogs, check if any character after last+1 typeahead=last+1 beware=.FALSE. ! beware set to TRUE if no typeahead (there are non-blanks after positon last+1) beware=eolch(svar,typeahead) ! write(*,*)'M3 gparfile: ',kou,koud,last,eolch(svar,last) if(nopenpopup .or. kiu.ne.kiud .or. .not.beware) then continue #endif ! If we are not connected to a terminal (reading a macro file) use line input ! Also if there are "type ahead" use the line input ! This call exchanges any macro variables in SVAR for defined macro values CALL GQXENV(SVAR) ! If interactive if(kiu.eq.kiud .and. beware) write(kou,"(a)") & 'Beware: you must give the full path unless the file '//& 'is in working directory!' 100 CALL GQARCx(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,hyper) IF(BUPERR.NE.0) GOTO 900 SLIN=SVAL(1:max(1,LEN_TRIM(sval))) ! This call handles ? @ and other things in SVAR CALL GPTCM2(IFLAG,SVAR,LAST,SLIN) IF (IFLAG.NE.0) GOTO 100 if(IUMACLEVL.ge.1) then if(sval(1:2).eq.'./') then ! we are running a macro and if SVAL(1:2) is './' replace this with MACROPATH' sval=trim(macropath(IUMACLEVL))//sval(3:) elseif(sval(1:3).eq.'../') then ! we are running a macro and if SVAL(1:3) is '../' then prefix with MACROPATH' sval=trim(macropath(IUMACLEVL))//sval ! write(*,*)'M3 add path: ',trim(sval),IUMACLEVL ! else ! write(*,*)'M3 assuming full path or in working directory: ' endif endif #ifdef tinyfd else ! open a popup window to browse directories and files using tinyfiledialogs ! typ<0 means new or old file; 0 old file no filter, ! typ >0 means old file with filter: ! typ=1 TDB, 2=OCU, 3=OCM, 4=OCD, 5=plt, 6=XTDB, 7=DAT, 8=LOG ! these are defined in pmon6.F90 also !!!!!!!!!!!!!!!!!!!!!!!!! ! write(*,*)'M4 opening popup window',typ ! getfilename is in utilities/TINYFILEDIALOGS/ftinyopen call getfilename(typ,sval) ! write(*,*)'M4 From getfilename: "',trim(sval),'"',typ if(sval(1:1).eq.' ') then buperr=1020 elseif(typ.eq.-1) then ! this is for writing a TDB file kk=index(sval,'.TDB ') if(kk.eq.0) then sval(len_trim(sval)+1:)='.TDB' endif elseif(typ.eq.-7) then ! this is for output and file created, if no extension add DAT kk=index(sval,'.DAT ') if(kk.eq.0) then sval(len_trim(sval)+1:)='.DAT' endif elseif(typ.eq.-8) then ! this is for output and file created(?), if no extension add LOG ! Check if last 4 letters are none kk=len_trim(sval) if(kk.ge.4) then if(sval(kk-3:kk).eq.'none') then sval='NONE' goto 300 endif endif kk=index(sval,'.LOG ') ! write(*,*)'gparfilex: ',trim(sval),kk,trim(cdef) if(kk.eq.0) then iflag=len_trim(sval) sval(iflag+1:)='.LOG' endif 300 continue ! write(*,*)'gparfilex: ',trim(sval),kk endif ! write(*,*)'M4 file: "',trim(sval),'"' endif #endif ! Can the rather odd ifdef/endif cause problems ??? ! if there is a segmentation fault it is after this write statement ... SUCK ! write(*,*)'M4 exit gparfilex: ',trim(sval) ! In 2021.10.04 the program dies after this without error message at all SUCK 900 RETURN END SUBROUTINE GPARFILEX !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ ! ! >>>> subsection ! A new set of on-line help routines using browser ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine init_help & Initiate help and history !\begin{verbatim} subroutine init_help(browser,htmlfile) ! This routine is called from oc_command_monitor to inititate ! the on-line help system. It saves the name of the browser and HTML file implicit none character*(*) htmlfile,browser !\end{verbatim} %+ character noquotes*128 integer kk logical logok ! the latex file no longer used for help ochelp%latexfile=' ' ! test that file exists inquire(file=browser,exist=logok) ! write(*,*)'m4A: ',trim(browser),logok if(.not.logok) then ! This is emergency use of explorer if no Firefox ! browser='C:\PROGRA~1\INTERN~1\iexplore.exe ' noquotes=browser kk=index(noquotes,'"') do while(kk.gt.0) noquotes(kk:)=noquotes(kk+1:) kk=index(noquotes,'"') enddo inquire(file=noquotes,exist=logok) ! write(*,*)'m4C: ',trim(noquotes),logok endif allok: if(logok) then ochelp%browser=browser inquire(file=htmlfile,exist=logok) ! write(*,*)'m4B: ',trim(htmlfile),logok if(logok) then helprec%okinit=1 helprec%type='html' ochelp%htmlhelp=.TRUE. ochelp%htmlfile=htmlfile goto 1000 endif endif allok helprec%okinit=0 helprec%type=' ' ochelp%htmlhelp=.FALSE. ochelp%htmlfile=' ' ochelp%browser=' ' 1000 continue return end subroutine init_help !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine helplevel & Redundant !\begin{verbatim} subroutine helplevel1(line) ! This routine is called from the monitor for the top level command ! It initiates the path to find the correct help text ! In all gparx routines the help level in increased and the question saved implicit none character*(*) line !\end{verbatim} %+ helprec%level=1 helprec%cpath(1)=line return end subroutine helplevel1 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine q1help & Old help routine 1 !\begin{verbatim} subroutine q1help(prompt,line) ! This routine is called from all gparx routines ! when the user types a ? ! prompt is never used ... implicit none character*(*) prompt,line character hline*80,mtext*12 integer, parameter :: maxlevel=20 !\end{verbatim} %+ ! character subsec(5)*10,saved(maxlevel)*24 character subsec(5)*10 character htmlhelp*256 integer nsaved(maxlevel) ! integer izz,jj,kk,kkk,level,nl,l2,np1,np2,nsub,zz integer izz,jj,kk,level,nl,np1,np2,nsub,zz logical foundall ! nsaved=0 subsec(1)='%\section{' subsec(2)='%\subsecti' subsec(3)='%\subsubse' subsec(4)='%\subsubsu' subsec(5)='%\question' if(helprec%okinit.eq.0) then if(helptrace) write(kou,*)'Sorry no help file' goto 1000 endif ! USEFUL for helptraceging list current search path: if(helptrace) then do nl=1,helprec%level write(*,17)'Search level: ',nl,trim(helprec%cpath(nl)) 17 format(a,i3,2x,a) enddo endif ! open(31,file=ochelp%latexfile,status='old',access='sequential') nl=0 level=2 np1=0 np2=0 nsub=1 foundall=.false. ochelp%target=' ' if(helprec%type.ne.'latex ') then write(*,*)'Sorry only help based on LaTeX implemented' goto 900 endif ! plain LaTeX file. The questions the OC software asks are saved from the ! top level in helprec%cpath(1..level). This makes it possible to compare ! the these commands with comment lines in the help file to find the relevant ! helptext. The comment lines are structured as the LaTeX sections ! %\subsection{question1}, %\subsubse..{questione} etc ! for each match the sublevel is increased and when we find match ! with the last helprec%cpath(helprec%level) we assume the text until ! the next %\sub.... can be provided as help ! If there is an additional HTML help file the text can instead be displayed ! in a browser using \hypertarget{label} from the LaTeX file found after ! the last matching sublevel ! Only first 12 characters in helprec%cpath and %\section{ sublevel are used ! return here when we found match at level 100 continue level=level+1 if(helptrace) write(*,*)'At label 100: ',level,helprec%level,nl if(level.gt.helprec%level) then foundall=.true. if(helptrace) write(*,*)'Foundall 1',nl goto 200 elseif(level.eq.helprec%level .and.& helprec%cpath(level)(1:2).eq.'? ') then ! this is when help is asked in a submenue with two ?? ! with just one ? the menue is displayed, with ?? the helpfile is used foundall=.TRUE. if(helptrace) write(*,*)'Foundall 2',nl goto 200 endif 110 continue ! skip cpath levels that contain COMMAND: or WHAT? ! if last level and cpath contain ? we have found all if(index(helprec%cpath(level),'COMMAND: ').gt.0 .or. & index(helprec%cpath(level),' WHAT? ').gt.0) then level=level+1 if(level.gt.helprec%level) then foundall=.TRUE. if(helptrace) write(*,*)'Foundall 2',nl goto 200 endif goto 110 endif if(helptrace) write(*,*)'Searching for: ',trim(helprec%cpath(level)),level ! return here when last line did not contain any matching subsec ! we can arrive here with np1=0 and foundall==true ! for help at first command level 200 continue read(31,210,end=700)hline 210 format(a) nl=nl+1 if(np1.gt.0) then ! np1 is nonzero if we have found a line matching one helprec%cpath ! We will save all hypertarget labels to have some idea what help text ! to provide if we do not find all %cpath ! If we found the helprec%cpath(helprec%level) foundall is set TRUE ! but we continue until we find the following %\section at the same ! or higher sublevel kk=index(hline,'\hypertarget{') if(kk.gt.0) then ochelp%target=hline(kk+13:) endif if(foundall) then ! terminate at a line with any sublevel izz=0 do kk=1,5 if(hline(1:10).eq.subsec(6-kk)) izz=1 enddo if(izz.gt.0) then np2=nl-1 goto 700 endif goto 200 endif elseif(foundall) then ! this should give help from user guide for section %\section{All commands} ! write(*,*)'M3 "All commands"',hline(1:24),nl if(hline(1:23).eq.'%\section{All commands}') then np1=nl np2=nl+20 ! next line should be hypertarget read(31,210)hline ! write(*,*)'next line: ',trim(hline),nl kk=index(hline,'\hypertarget{') if(kk.gt.0) then ochelp%target=hline(kk+13:) kk=index(ochelp%target,'}') ochelp%target(kk:)=' ' goto 700 else ! the help file is messed up ... ochelp%target='All commands' goto 700 endif endif goto 200 ! else ! here we now have np1>0 and use the rest of this routine as usual endif ! we are searching for a subsec on the sublevel nsub ! Check if we have a %\section of this sublevel on the line kk=index(hline,subsec(nsub)) section: if(kk.eq.0) then ! if there is none but we already found one sublevel check if we find the same ! write(*,*)'no subsec: ',nsub prevsub: if(nsub.gt.2) then kk=index(hline,subsec(nsub-2)) if(kk.gt.0) then ! we have found a sublevel 2 levels up ... we are out of scope if(helptrace) write(*,*)'Found subsec two levels up!' np2=nl goto 700 elseif(nsub.gt.1) then kk=index(hline,subsec(nsub-1)) if(kk.gt.0) then ! we have found a subsec at the same sublevel we already found ! check if we have match with the helprec%cpath, only 12 first characters! jj=index(hline,'{') if(jj.le.0) then write(*,*)'LaTeX helpfil missing { on line:',nl goto 200 endif mtext=hline(jj+1:) kk=index(mtext,'}') if(kk.gt.0) mtext(kk:)=' ' call capson(mtext) zz=len_trim(mtext) if(helptrace) write(*,300)'same: ',helprec%cpath(level)(1:zz),& ' =?= ',mtext(1:zz),level,nsub,nl if(helprec%cpath(level)(1:zz).eq.mtext(1:zz)) then ! we have found match with the next level of user path on same sublevel goto 100 endif endif endif endif prevsub ! just read another line goto 200 else ! we have found a %\sub... for next level, check if it is %cpath(level) jj=index(hline,'{') if(jj.le.0) then write(*,*)'LaTeX helpfil missing { on line:',nl goto 200 endif mtext=hline(jj+1:) kk=index(mtext,'}') if(kk.gt.0) mtext(kk:)=' ' call capson(mtext) zz=len_trim(mtext) if(helptrace) write(*,300)'next: ',helprec%cpath(level)(1:zz),' =?= ',& mtext(1:zz),level,nsub,nl 300 format(a,a,a,a,5i5) if(helprec%cpath(level)(1:zz).eq.mtext(1:zz)) then ! we have found match with the next level of user path if(helptrace) write(*,*)'Match: ',level,nsub,nl nsub=nsub+1 np1=nl goto 100 endif goto 200 endif section ! jump here if we do not search any more ! we should write lines from np1 to np2 from help file or HTML file 700 continue if(np1.gt.0) then if(np2.le.np1) then ! we found no obvious end of help text write(*,*)'Help text range error: ',np1,np2 endif ! if htmlhelp is true open a browser window and place text at target htmlfil: if(ochelp%htmlhelp .and. ochelp%target(1:1).ne.' ') then ! the user has to close the help window to continue ... spawn?? ! write(*,711)np1,np2 !711 format(/' *** You must close the browser window to continue OC',2i5/) ! the \hypertaget should be finished by a } kk=index(ochelp%target,'}')-1 if(kk.le.0) kk=len_trim(ochelp%target) #ifdef lixhlp ! on linux just ' "file:" as ochelp#htmlfile start with a / ! The & at the end spawns the browser window and furter ? creates new tags !! htmlhelp=trim(ochelp%browser)//' "file:'//& trim(ochelp%htmlfile)//'#'//ochelp%target(1:kk)//'" &' #else ! on Windows we need the / after file ! the initial start spawns a new window with the browser, each ? a new browser htmlhelp='start '//trim(ochelp%browser)//' "file:/'//& trim(ochelp%htmlfile)//'#'//ochelp%target(1:kk)//'"' #endif if(helptrace) write(*,*)'MM: ',trim(htmlhelp) call execute_command_line(htmlhelp) goto 900 else ! help in user terminal screen: write a blank line write(kou,*) write(*,798)np1,np2 798 format(' >>> We should open a help window to display text: ',2i5) rewind(31) nl=0 800 continue read(31,210)hline nl=nl+1 if(nl.ge.np2) then goto 900 elseif(nl.ge.np1) then if(hline(1:1).ne.'%') then ! ignore LaTeX comment lines and replace \item with a - if(hline(2:5).eq.'item') then write(*,811)trim(hline(6:)) 811 format('- ',a) else write(*,210)trim(hline) endif endif endif goto 800 endif htmlfil else write(*,*)'No help found' endif 900 continue close(31) ! 1000 continue return end subroutine q1help !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine q2help & Old help routine 2 !\begin{verbatim} subroutine q2help(prompt,line) ! This routine is called from submenu ! when the user types a ? implicit none character*(*) prompt,line !\end{verbatim} %+ character helpquest*32 integer savedlevel,kk,ip ! savedlevel=helprec%level-1 ! If the ? is followed by a text push that text on the helprec%cpath ip=2 ! This is to force q2help to work ... otherwise segmentation fault ??!!! if(ip.lt.0) write(*,*)'q2help: ',savedlevel,line(1:20) if(.not.eolch(line,ip)) then ! write(*,*)'q2help: ',helprec%level,ip,helprec%cpath(helprec%level) helpquest=line(ip:) helpquest=prompt call capson(helpquest) ! remove any WHAT? as such levels will be ignored by q1help kk=index(helpquest,'WHAT?') if(kk.gt.0) then helpquest(kk:)='COMMAND ' if(helptrace) write(*,*)'MM hepquest: ',kk,trim(helpquest) endif ! use the saved helprec%level helprec%level=savedlevel helprec%cpath(helprec%level)=helpquest ! always upper case ... call capson(helprec%cpath(helprec%level)) ! if(helptrace) write(*,11)helprec%level,& ! (trim(helprec%cpath(i)),i=1,helprec%level) !11 format('q2help: ',i3,10(', ',a)) else ! when we are here we have just a ? from user, return to submenu with that ! with two ?? or anything else q1help is called (I hope ...) line='?!' if(ochelp%htmlhelp) then write(*,17) 17 format(/'By typing two ?? you will open the browser') endif goto 1000 endif ! this is a dummy line needed to force the MacOS linker to find this routine !?? if(savedlevel.eq.helprec%level) write(*,*)'Inside q2help: ',trim(prompt) if(ip.lt.0) write(*,*)'in q2help calling q1help' ! write help text from help file and then return with ?! to get submenu if(helptrace) write(*,*)'q2help calling q1help: ',trim(helpquest) call q1help(prompt,line) line='?!' 1000 continue return end subroutine q2help !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine q3help & Old help routine 3 !\begin{verbatim} SUBROUTINE Q3HELP(LINE,LAST,COMM,NC) ! used in submeny when user gives "? 'command' " taken as "help 'command'" !...EXECUTES A HELP COMMAND implicit none CHARACTER LINE*(*),COMM(NC)*(*) integer last !\end{verbatim} %+ CHARACTER CMD*40 integer, parameter :: MC=100 integer INDX(MC) integer nkpl,nc,nlfk,nbk,i,j,k ! To avoid storing "COMMAND" in the helprec%cpath ! if(helprec%level.gt.2) helprec%level=helprec%level-1 !.. HELP HELP not OK if(helprec%level.gt.3) helprec%level=helprec%level-1 ! write(*,*)'q3help: asking for help for command: "',trim(line),'"',last,nc CALL GPARC_old('Help for which command? ',LINE,LAST,1,CMD,'*',tophlp) ! write(*,*)'q3help: command: "',trim(cmd),'"' IF(CMD(1:1).EQ.'*' .or. cmd(1:1).eq.'?') THEN !...LIST ALL COMMANDS IN UNIX ALPHABETICAL ORDER NKPL=80/(LEN(COMM(1))+1) IF(NKPL*(LEN(COMM(1))+1).GE.80) NKPL=NKPL-1 IF(NC.LT.MC) THEN CALL SSORT(COMM,NC,INDX) ALLCOM: DO NBK=1,NC IF(COMM(INDX(NBK))(1:1).NE.' ') GOTO 301 enddo ALLCOM 301 NLFK=(NC+NKPL-NBK)/NKPL NBK=NBK-1 COMLIST: DO I=1,NLFK WRITE(KOU,320)(COMM(INDX(NBK+J)),J=I,NC-NBK,NLFK) enddo COMLIST 320 FORMAT(10(1X,A)) ELSE !... TOO MANY COMMANDS TO SORT NLFK=(NC+NKPL-1)/NKPL UNSORTED: DO I=1,NLFK WRITE(KOU,320)(COMM(J),J=I,NC,NLFK) enddo UNSORTED ENDIF ELSE !...HELP ! IF UNIQUE LIST DESCRIPTION ON HELP FILE. OTHERWISE ! ALL COMMANDS THAT MATCHES K=NCOMP2(CMD,COMM,NC,I) IF(K.GT.0) THEN ! we have to replace HELP by CMD on the stack of commands ! to get the correct help text CALL CAPSON(CMD) helprec%level=helprec%level-1 helprec%cpath(helprec%level)=CMD(1:32) ! write(*,11)helprec%level,(helprec%cpath(i)(1:8),i=1,helprec%level) !11 format('q3help: ',i3,10(', ',a)) ! write(*,*)helprec%level ! do ii=1,helprec%level ! write(*,*)helprec%cpath(ii) ! enddo call q1help(' ',CMD) ELSEIF(K.EQ.0 .OR. K.LT.-NC) THEN WRITE(KOU,*)'No matching command, use HELP * or ?' ELSE 500 WRITE(KOU,*)COMM(-K) IF(NC+K.LE.0) GOTO 900 J=NCOMP2(CMD,COMM(1-K),NC+K,I) ! ...bugfix for "help s-i" in poly IF(j .LT. -(NC+K) ) GOTO 900 IF(K.EQ.-NC .OR. J.EQ.0) GOTO 900 K=K-ABS(J) GOTO 500 ENDIF ENDIF 900 RETURN END SUBROUTINE Q3HELP !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine q3helpx & New help routine 3 !\begin{verbatim} SUBROUTINE Q3HELPx(LINE,LAST,COMM,NC) ! used in submeny when user gives "? 'command' " taken as "help 'command'" !...EXECUTES A HELP COMMAND implicit none CHARACTER LINE*(*),COMM(NC)*(*) integer last !\end{verbatim} %+ CHARACTER CMD*40 integer, parameter :: MC=100 integer INDX(MC) integer nkpl,nc,nlfk,nbk,i,j,k ! To avoid storing "COMMAND" in the helprec%cpath ! if(helprec%level.gt.2) helprec%level=helprec%level-1 !.. HELP HELP not OK if(helprec%level.gt.3) helprec%level=helprec%level-1 ! write(*,*)'q3help: asking for help for command: "',trim(line),'"',last,nc CALL GPARCx('Help for which command? ',LINE,LAST,1,CMD,'*','?TOPHLP') ! write(*,*)'q3help: command: "',trim(cmd),'"' IF(CMD(1:1).EQ.'*' .or. cmd(1:1).eq.'?') THEN !...LIST ALL COMMANDS IN UNIX ALPHABETICAL ORDER NKPL=80/(LEN(COMM(1))+1) IF(NKPL*(LEN(COMM(1))+1).GE.80) NKPL=NKPL-1 IF(NC.LT.MC) THEN CALL SSORT(COMM,NC,INDX) ALLCOM: DO NBK=1,NC IF(COMM(INDX(NBK))(1:1).NE.' ') GOTO 301 enddo ALLCOM 301 NLFK=(NC+NKPL-NBK)/NKPL NBK=NBK-1 COMLIST: DO I=1,NLFK WRITE(KOU,320)(COMM(INDX(NBK+J)),J=I,NC-NBK,NLFK) enddo COMLIST 320 FORMAT(10(1X,A)) ELSE !... TOO MANY COMMANDS TO SORT NLFK=(NC+NKPL-1)/NKPL UNSORTED: DO I=1,NLFK WRITE(KOU,320)(COMM(J),J=I,NC,NLFK) enddo UNSORTED ENDIF ELSE !...HELP ! IF UNIQUE LIST DESCRIPTION ON HELP FILE. OTHERWISE ! ALL COMMANDS THAT MATCHES K=NCOMP2(CMD,COMM,NC,I) IF(K.GT.0) THEN ! we have to replace HELP by CMD on the stack of commands ! to get the correct help text CMD=COMM(K) ! CALL CAPSON(CMD) ! helprec%level=helprec%level-1 ! helprec%cpath(helprec%level)=CMD ! write(*,11)helprec%level,(helprec%cpath(i)(1:8),i=1,helprec%level) !11 format('q3help: ',i3,10(', ',a)) ! write(*,*)helprec%level ! do ii=1,helprec%level ! write(*,*)helprec%cpath(ii) ! enddo write(*,*)'Calling q4help from q3helpx: ',trim(cmd) call q4help(cmd,0) ! call q1help(' ',CMD) ELSEIF(K.EQ.0 .OR. K.LT.-NC) THEN WRITE(KOU,*)'No matching command, use HELP * or ?' ELSE 500 WRITE(KOU,*)COMM(-K) IF(NC+K.LE.0) GOTO 900 J=NCOMP2(CMD,COMM(1-K),NC+K,I) ! ...bugfix for "help s-i" in poly IF(j .LT. -(NC+K) ) GOTO 900 IF(K.EQ.-NC .OR. J.EQ.0) GOTO 900 K=K-ABS(J) GOTO 500 ENDIF ENDIF 900 RETURN END SUBROUTINE Q3HELPx !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine q4help & New help routine 4 !\begin{verbatim} subroutine q4help(hypertarget,extra) ! This routine is adapted to provide help from webrowsers using hypertarget ! when the user types a ? or ?? implicit none integer extra character*(*) hypertarget !\end{verbatim} %+ ! this routine independent of the command history. The GPARX routines ! call this with the hypertarget provided in the call to GPARX routine ! and searches this target in the HTML file ! if extra=0 help has been provided, otherwise the calling routine try to do it character htmlhelp*256 if(helprec%okinit.eq.0) then if(helptrace) write(kou,*)'Sorry no help file' goto 1000 endif if(helprec%type.ne.'html ') then write(*,*)'Sorry only help based on HTML implemented' goto 1000 endif ! if(helptrace) then ! helptrace help debugging ... ! write(*,*)'q4help: ',trim(hypertarget),extra ! endif if(hypertarget(1:1).eq.' ') then write(*,*)'Sorry, the software provides no help for this question' goto 1000 endif ! ! we have tested this file exists when initating help ! write(*,*)'Q4HELP: ',trim(hypertarget),extra ! open(31,file=ochelp%latexfile,status='old',access='sequential') ! if first character in hypertarget is ? remove that ! in OC I try to use a ? in all calls for gparxyz to find hypertargets in ! the source code. Seach for "'?" in the source code! ! This ? is not needed or used in the LaTeX file. if(hypertarget(1:1).eq.'?') then ochelp%target=hypertarget(2:) else ochelp%target=hypertarget endif ! The help system depends on 3 files: ! 1: a plain LaTeX file is the base. The \hypertarget{target}{text} feature ! is are used to find a specific help text in the user guide. ! 2: a html file is generated from this LaTeX file with the hypertargets. ! this allows to locate the text inside the html file and display ! in a separate windows in a browser. The user can scroll this ! while running the program. ! 3: the same LaTeX can also be used to generate a PDF. But no one reads ! the manual. ! For each command and question the software asks it uses a GPARX routine. ! in the call this subroutine and a hypertarget text is provided. ! When inside this routine the user has typed ? or ?? to get help. ! The browser used depend on compiler options ... #ifdef winhlp ! on Windows we need the / after file ! the initial start spawns a new window with the browser, each ? a new browser htmlhelp='start '//trim(ochelp%browser)//' "file:/'//& trim(ochelp%htmlfile)//'#'//ochelp%target//'"' #else ! on linux or Mac just ' "file:" as ochelp#htmlfile start with a / ! The & at the end spawns the browser window and furter ? creates new tags !! htmlhelp=trim(ochelp%browser)//' "file:'//& trim(ochelp%htmlfile)//'#'//ochelp%target//'" &' #endif if(helptrace) write(*,*)'QZ: ',trim(htmlhelp) call execute_command_line(htmlhelp) close(31) ! 1000 continue return end subroutine q4help !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine nohelp & No help !\begin{verbatim} SUBROUTINE NOHELP(PROMT,LINE) ! no help available implicit none CHARACTER PROMT*(*),LINE*(*) !\end{verbatim} %+ RETURN END SUBROUTINE NOHELP !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine tophlp & Help from top level !\begin{verbatim} SUBROUTINE TOPHLP(PROMPT,LINE) ! return to calling routine for help, do not save the current command ... implicit none CHARACTER PROMPT*(*),LINE*(*) !\end{verbatim} %+ ! helprec%level=helprec%level-1 ! write(*,11)helprec%level,(helprec%cpath(i)(1:8),i=1,helprec%level) !11 format('tophlp: ',i3,10(', ',a)) LINE(2:2)='!' RETURN END SUBROUTINE TOPHLP !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable logical function yeschk & Check for Y or y !\begin{verbatim} LOGICAL FUNCTION YESCHK(CH1) ! returns TRUE if CH1 is Y or y CHARACTER CH1*1 !\end{verbatim} YESCHK=.FALSE. IF(CH1.EQ.'Y' .OR. CH1.EQ.'y') YESCHK=.TRUE. RETURN END FUNCTION YESCHK !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ ! ! >>>> subsection ! History of commands ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine nghist & Execute history caommand !\begin{verbatim} SUBROUTINE NGHIST(LINE,LAST) !...EXECUTES A HISTORY COMMAND ! LAST IS SET TO 0 IF LINE IS SET TO A COMMAND FROM HISTORY LIST ! CHARACTER HIST*80,LINE*(*),CH1*1 implicit none CHARACTER LINE*(*) integer last !\end{verbatim} %+ CHARACTER CH1*1 LOGICAL IED ! LHL, LHM,LHP are prive global variables integer LOW,KADD,K,IDIG ! CHARACTER*1 CHHIST,CHHELP,CHEDIT PARAMETER (CHHIST='!',CHHELP='?',CHEDIT='*') LAST=LAST+1 CH1=LINE(LAST:LAST) IF(CH1.EQ.CHHELP) THEN WRITE(KOU,100) 100 FORMAT(' History commands are useful when the same command ', & ' shall'/' be executed several times. It is also possible to',& ' amend or correct'/' a command before it is executed again.'//& ' A history command always begins with an !'/& ' !? gives this help'/& ' !! gives a list of the history'/& ' ! executes the command in the history',& ' list'/& ' ! executes the most recent command starting with',& ' '/& ' !* or !* makes the command available for',& ' editing before execution'//& ' NOTE the < > around digit and text should not be typed!') ELSEIF(CH1.EQ.CHHIST) THEN !... A LIST OF THE HISTORY IF(LHM.GT.0) THEN LOW=LHL KADD=-20 ELSEIF(LHL.EQ.0) THEN WRITE(KOU,*)'No history yet!' GOTO 900 ELSE LOW=0 KADD=0 ENDIF !... LOOP 200 LOW=LOW+1 IF(LOW.GT.20) THEN LOW=1 KADD=KADD+20 ENDIF K=LEN_TRIM(HIST(LOW)) IF(K.GT.0)WRITE(KOU,210)LHM+LOW+KADD,HIST(LOW)(1:K) 210 FORMAT(I5,'> ',A) IF(LOW.NE.LHL) GOTO 200 ELSE !... A COMMAND TO BE EXECUTED OR EDITED SHOULD BE FOUND IF(CH1.EQ.CHEDIT) THEN LAST=LAST+1 IED=.TRUE. ELSE IED=.FALSE. ENDIF CALL GETINT(LINE,LAST,IDIG) IF(BUPERR.NE.0) THEN BUPERR=0 K=LEN_TRIM(LINE) LOW=LHL IF(K.GT.LAST) THEN 400 CONTINUE IF(HIST(LOW)(1:K-LAST+1).NE.LINE(LAST:K)) THEN LOW=LOW-1 IF(LOW.EQ.0) LOW=20 IF(LOW.NE.LHL) GOTO 400 WRITE(KOU,*)'No matching command' GOTO 900 ENDIF ENDIF ELSE IF(IDIG.GE.-20 .AND. IDIG.LT.0) IDIG=LHM+LHL+IDIG+1 IF(IDIG.LE.MAX(0,LHM+LHL-20) .OR. IDIG.GT.LHM+LHL) THEN WRITE(KOU,*)'Number outside history' GOTO 900 ENDIF LOW=MOD(IDIG,20) IF(LOW.EQ.0) LOW=20 ENDIF LINE=HIST(LOW) em1: IF(IED) THEN ENDIF em1 LAST=0 ENDIF 900 RETURN END SUBROUTINE NGHIST !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine openlogfile & Opem log file !\begin{verbatim} subroutine openlogfile(name,text,lun) ! opens a logfile for commands, if exits it will overwrite implicit none character name*(*),text*(*) integer lun !\end{verbatim} %+ integer kkp,ierr if(lun.le.0) then if(logfil.gt.0) close(logfil) goto 1000 endif ! write(*,*)'METLIB: opening logfile: "',trim(name),'"' if(len_trim(name).le.0) then name='OCLOG.LOG' write(*,*)'No logfile name, using default: ',trim(name) else ! it seems tinyfiledialogs return working directory ... kkp=index(name,'.') if(kkp.le.0) then kkp=len_trim(name) name(kkp+1:)='./OCLOG.LOG' write(*,*)'No logfile extention, using: ',trim(name) endif endif open(lun,file=name,access='sequential',status='unknown',& err=1100,iostat=ierr) write(lun,10)text(1:len_trim(text)) 10 format('Logfile title: ',a) logfil=lun 1000 continue return ! error opening 1100 continue buperr=ierr goto 1000 end subroutine openlogfile !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine set_echo & Set/reet echo of commands !\begin{verbatim} subroutine set_echo(ion) ! set echo of command input, does this really work? implicit none integer ion !\end{verbatim} jecho=ion return end subroutine set_echo !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ ! ! >>>> subsection ! output of promt for command ! and input of command including command line editing on Linux ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine boutxt & Write a text noadvance !\begin{verbatim} subroutine boutxt(lut,line) ! writes the text on line on unit lut without CR/LF implicit none integer lut character line*(*) !\end{verbatim} %+ ! write(*,*)'boutxt; ',lut,line write(lut,10,advance='no')line 10 format(a) return end subroutine boutxt !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine bintxt & Read a text !\begin{verbatim} subroutine bintxt(lin,cline) ! read a command line with or without arguments. On LINUX command line editing implicit none character cline*(*) integer lin !\end{verbatim} %+ #ifdef lixed ! LINUX: to have command line editing uncomment the line above and comment the ! line with the call bintxt_nogetkey call bintxt_getkey(lin,cline) #else ! On Windows command line editing is provided by the OS call bintxt_nogetkey(lin,cline) #endif return end subroutine bintxt !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine bintxt_getkey & Read a text with editing !\begin{verbatim} subroutine bintxt_getkey(lin,cline) ! LINUX subroutine to read a line with history and editing a la emacs ! implicit none character cline*(*) integer lin !\end{verbatim} %+ !-------------------- ! CONTROL CHARACTERS FROM KEYBOARD ! DEL delete curret character integer, parameter :: ctrla=1 ! CTRLA move cursor to first position integer, parameter :: backspace2=2 ! CTRLB move cursor one step left integer, parameter :: ctrlc=3 ! CTRLC terminate program integer, parameter :: ctrld=4 ! CTRLD delete char at cursor integer, parameter :: ctrle=5 ! CTRLE move cursor to last position integer, parameter :: forward=6 ! CTRLF move cursor one step right integer, parameter :: HELP=8 ! CTRLH give coordinates and update integer, parameter :: TAB=9 ! CTRLI end of input integer, parameter :: ctrlk=11 ! CTRLK delete to end of line integer, parameter :: return=13 ! CTRLM end of input integer, parameter :: DEL=127 ! DEL delete char left of cursor integer, parameter :: mode=17 ! CTRLQ toggle insert/replace ! on MAC same as UP DOWN FORWARD suck integer, parameter :: backspace=27 ! CTRL[ previous in history !-------------------- ! UP previous history line (if any) ! DOWN and LF next history line (if any) integer, parameter :: CTRLP=16 ! CTRLP previous in history ! integer, parameter :: UP=27 ! uparrow previous in history integer, parameter :: LF=10 ! CTRLJ next in history integer, parameter :: ctrln=14 ! CTRLN next in history !-------------------- ! backspace on a MAC screen integer, parameter :: tbackspace=8 !----------- ! ! ip is cursor position (>=1), lastp is last character on line (>=0) integer ip,lastp,kiud,jj,kou,size,hlast character line*128,ch1*1 ! character getkey logical endoftext ! global structure myhistory ! type(chistory) :: myhistory logical insert ! kiud=5; kou=6 size=1 ! ! write(*,*)'Reading input using getkey',lin,kiud if(lin.ne.kiud) then ! reading macro from file read(lin,10)cline 10 format(a) goto 1000 endif ! ! input trom terminal with editing ! insert=.TRUE. ip=1 lastp=0 line=' ' endoftext=.true. hlast=myhistory%hpos+1 ! read one character at a time without echo 100 continue #ifdef lixed ! LINUX: read one character at a time without echo and allow editing history ch1=getkex() ! write(*,*)'got from getkey: ',ichar(ch1) ! on MAC all the arrow keys just generate integer 27 once, then input ignored ! OC reacts in cntrl-P 16 previous line (history) ! cntrl-N 14 next line (history) ! cntrl-A 1 move to first character on line ! cntrl-B 2 move back one character ! cntrl-D 4 delete one character ar cursor ! cntrl-E 5 move to after last character ! cntrl-F 6 move forward one character ! cntrl-K 11 delete from cursor to end of line ! all of this is like emacs ,,, ! #endif 110 continue ! write(*,*)'got from getkey: ',ichar(ch1) ! handle control character if(ichar(ch1).ge.32 .and. ichar(ch1).lt.127) then ! printable character, write on screen and store inline if(ip.eq.lastp+1 .or. .not.insert) then write(kou,10,advance='no')ch1 line(ip:ip)=ch1 if(ip.eq.lastp+1) lastp=lastp+1 ip=ip+1 else ! insert a character inside a text line(ip+1:)=line(ip:) line(ip:ip)=ch1 lastp=lastp+1 ! write(kou,10,advance='no')tbackspace write(kou,10,advance='no')line(ip:lastp) do jj=ip,lastp-1 write(kou,10,advance='no')tbackspace enddo ip=ip+1 endif goto 100 endif !======================= ! write(*,*)'control character: ',ichar(ch1) 120 continue select case(ichar(ch1)) case default ! ignore ! write(*,*)'Ignoring ',ichar(ch1) goto 100 !............. OK case(ctrla) ! move cursor to first character do jj=1,ip-1 write(kou,10,advance='no')tbackspace enddo ip=1 #ifdef lixed !............. NEW handle arrow key on Linix/Mac case(backspace) ! try to handle arrow keys sequence of 27, 91, A/B/C/D ch1=getkex() if(ichar(ch1).ne.91) goto 110 ch1=getkex() if(ch1.eq.'A') then ! write(*,*)'Arrow up' ch1=char(ctrlp) elseif(ch1.eq.'B') then ! write(*,*)'Arrow down' ch1=char(ctrln) elseif(ch1.eq.'C') then ! write(*,*)'Arrow forward' ch1=char(forward) elseif(ch1.eq.'D') then ! write(*,*)'Arrow backward' ch1=char(backspace2) else !page up/down which has similar sequences etc ignored goto 100 ! write(*,*)'Input messed up ...' endif goto 120 !...............OK ! case(backspace,backspace2) ! ctrlb leftarrow (also up/down/right arrow) case(backspace2) ! ctrlb leftarrow (also up/down/right arrow) ! move cursor one step back if(ip.gt.1) then write(kou,10,advance='no')tbackspace ip=ip-1 endif #else ! this rooutine is never called on Windows case(backspace,backspace2) ! ctrlb leftarrow (also up/down/right arrow) ! move cursor one step back if(ip.gt.1) then write(kou,10,advance='no')tbackspace ip=ip-1 endif #endif !............. OK case(ctrlc) ! terminate the program stop 'User break' case(ctrle) ! move cursor after last character ! if(ip.eq.1) then ! jj=ip+1 ! else ! jj=ip ! endif jj=ip do jj=jj,lastp write(kou,10,advance='no')line(jj:jj) enddo ip=lastp+1 !............. OK case(ctrld) ! delete character at cursor (ctrld) if(ip.gt.lastp .or. lastp.eq.0) goto 100 jj=ip ! remove the character at position jj and write the whole line from jj to end line(jj:)=line(jj+1:) write(kou,10,advance='no')line(jj:lastp) do jj=lastp,ip,-1 write(kou,10,advance='no')tbackspace enddo lastp=lastp-1 !............. OK case(del) ! delete character to the left of cursor (del), if ip=1 ignore if(ip.eq.1) goto 100 write(kou,10,advance='no')tbackspace ! remove the character at position jj and write the whole line from jj to end jj=ip-1 line(jj:)=line(jj+1:) write(kou,10,advance='no')line(jj:lastp) ip=ip-1 lastp=lastp-1 ! NOTE lastp can be zero here ! otherwise we should backspace lastp-ip positions do jj=lastp+1,ip,-1 write(kou,10,advance='no')tbackspace enddo !............. OK case(ctrlk) ! delete all characters from cursor to end of line if(ip.le.lastp) then line(ip:)=' ' ! write(kou,10,advance='no')tbackspace write(kou,10,advance='no')line(ip:lastp) do jj=ip,lastp write(kou,10,advance='no')tbackspace enddo lastp=ip-1 endif !............. case(help) ! ctrlh write(kou,77, advance='no')ip,lastp,line(1:lastp+1) 77 format(/'Current local values are: ',2i4/a) ! write(kou,10,advance='no')'xyz' do jj=lastp,ip,-1 write(kou,10,advance='no')tbackspace enddo !............. case(mode) ! crtlQ ! change inset mode if(insert) then insert=.FALSE. else insert=.TRUE. endif !............. case(return,tab) ! save line (if not empty) finish editing and return current line cline=line if(len_trim(line).eq.0) then continue ! write(*,*)'Not saving empty line' elseif(myhistory%hpos.le.0) then ! saving the first line as myhistory%hpos=1 myhistory%hline(myhistory%hpos)=line(1:80) elseif(line(1:ip+1).eq.myhistory%hline(myhistory%hpos)(1:ip+1)) then continue ! write(*,*)'Not saving same line' else if(myhistory%hpos.ge.histlines) then ! history full, the oldest history line deleted do jj=2,histlines myhistory%hline(jj-1)=myhistory%hline(jj) enddo else myhistory%hpos=myhistory%hpos+1 endif myhistory%hline(myhistory%hpos)=line(1:80) endif ! write a CR on screen ... maybe also LF ?? NO!! if(ichar(ch1).eq.return) write(kou,*) goto 1000 !............. OK case(forward) ! move cursor one step right if we are not at lastp if(ip.le.lastp) then write(kou,10,advance='no')line(ip:ip) ip=ip+1 ! if(ip.eq.lastp) endoftext=.true. ! elseif(.not.endoftext) then ! write(kou,10,advance='no')line(ip:ip) ! endoftext=.true. endif !............. case(ctrlp) ! copy previous history line to current ! first remove anything on the line (not the question ...) if(hlast.gt.1) then do jj=1,ip-1 write(kou,10,advance='no')tbackspace enddo line=' ' write(kou,10,advance='no')line(1:lastp) do jj=1,lastp write(kou,10,advance='no')tbackspace enddo hlast=hlast-1 line=myhistory%hline(hlast) lastp=len_trim(line) ip=lastp+1 write(kou,10,advance='no')line(1:lastp) endif !.............CTRLJ and CTRLN case(lf,ctrln) ! copy next history line to current if(hlast.lt.myhistory%hpos) then do jj=1,ip-1 write(kou,10,advance='no')tbackspace enddo line=' ' write(kou,10,advance='no')line(1:lastp) do jj=1,lastp write(kou,10,advance='no')tbackspace enddo hlast=hlast+1 line=myhistory%hline(hlast) lastp=len_trim(line) ip=lastp+1 write(kou,10,advance='no')line(1:lastp) endif end select !----------------- goto 100 !================= 1000 continue return end subroutine bintxt_getkey !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine bintxt_nogetkey & Read a text !\begin{verbatim} subroutine bintxt_nogetkey(lin,line) ! Reading a command line on Windows with editing provided by the OS implicit none character line*(*) integer lin !\end{verbatim} integer iostatus read(lin,10,iostat=iostatus)line 10 format(a) if(iostatus.lt.0) then ! reading a macro beyond EOL/EOF ?? write(*,*)' *** WARNING: MACRO ENDS WITHOUT SET INTERACTIVE!' line='set inter ' endif return end subroutine bintxt_nogetkey !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ ! ! >>>> subsection ! command line macros ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine macbeg & Start a maro !\begin{verbatim} SUBROUTINE MACBEG(LINE,LAST,OK) !....subroutine to execute set-interactive allowing nesting of macros ! ! IDEA: addera lablar i macro sa man kan ange MACRO fil LABEL ! och vid stop som @? eller @& man kan interaktivt ange GOTO label ! Ocksa en generisk subrutin som gor att man kan fa fram ett variabelvarde ! call macsymval(package,symbol,ival,rval,cval) ! implicit none CHARACTER LINE*(*) LOGICAL OK integer last !\end{verbatim} %+ ! ! CHARACTER MACFIL*256,FIL*256,CH1*1 CHARACTER MACFIL*256,FIL*256 LOGICAL FIRST character*3 USEEXT character*1 dirsep,backslash character dummy*256 integer ll,kk,ierr SAVE FIRST DATA FIRST/.TRUE./ IF(FIRST) THEN FIRST=.FALSE. IUMACLEVL=0 ! lun=50 ENDIF MACFIL=' ' useext=macext ! ipos=index(line(max(1,last):),'.') ! if (ipos.gt.0) then ! if (LEN_TRIM(line(ipos:)).gt.1) then ! useext=' ' ! endif ! endif ! write(*,*)'In MACBEG: ',trim(line),last ! added that extension should be OCM by the argument "3" CALL GPARFILEx('Macro filename: ',LINE,LAST,1,FIL,MACFIL,3,'?MACRO file') ! CALL GPARC('Macro filename: ',LINE,LAST,1,FIL,MACFIL,nohelp) ! add default extension if needed CALL FXDFLT(FIL,MACEXT) IF(BUPERR.NE.0) GOTO 910 ! write(*,*)'open macro: ',lun,IUMACLEVL ! LUN=50 OPEN(LUN,FILE=FIL,ACCESS='SEQUENTIAL',STATUS='OLD', & FORM='FORMATTED',IOSTAT=IERR,ERR=910) ! we can have macros nested 5 livels deep IF(IUMACLEVL.LT.5) THEN IUMACLEVL=IUMACLEVL+1 MACROUNIT(IUMACLEVL)=KIU ELSE ! CALL ST2ERR(1083,'MACBEG','TOO DEEPLY NESTED MACRO FILES') buperr=1083 OK=.FALSE. GOTO 900 ENDIF ! extract the PATH to this macro file, needed to open files inside the macro backslash=char(92) ! write(*,*)'M3 macro file: ',trim(fil),' bacslash: ',backslash if(index(fil,backslash).gt.0) then ! this is on Windows dirsep=backslash else ! this is on UNIX type systems dirsep='/' endif ! write(*,*)'M3 macro file: ',trim(fil),' backslash: ',backslash,IUMACLEVL ll=1 kk=0 do while(ll.gt.0) kk=ll+kk dummy=fil(kk:) ll=index(dummy,dirsep) ! ll=index(fil(kk:),dirsep) enddo ! we have found the position of the actual filename. Save the path incl dirsep if(kk.gt.1) then macropath(IUMACLEVL)=fil(1:kk-1) else macropath(IUMACLEVL)=' ' endif ! write(*,*)'Macro path saved: ',IUMACLEVL,': ',trim(macropath(IUMACLEVL)) ! write(*,*)'Command input set: ',kiu,IUMACLEVL ! this is to suprees "press return to continue" but not implemented ... OK=.TRUE. KIU=LUN LUN=LUN+1 ! write(*,*)'Command input is: ',kiu 900 continue return 910 OK=.FALSE. write(*,*)'Error ',ierr,' opening macro file: ',trim(fil) buperr=1000+ierr GOTO 900 end SUBROUTINE MACBEG !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine macend & End a macro !\begin{verbatim} SUBROUTINE MACEND(LINE,LAST,OK) ! end of macro detected, close file and return to upper level implicit none CHARACTER LINE*(*) LOGICAL OK integer last !\end{verbatim} %+ ! set interactive gives back control to calling macro if any IF(KIU.NE.KIUD) THEN IF(KIU.NE.0) CLOSE(KIU) ! write(*,*)'end of macro: ',kiu,kiud,IUMACLEVL IF(IUMACLEVL.GT.0) THEN ! write(*,*)'calling macro: ',macrounit(IUMACLEVL) KIU=MACROUNIT(IUMACLEVL) IUMACLEVL=IUMACLEVL-1 ELSE ! write(*,*)'terminal: ',kiud KIU=KIUD ENDIF ENDIF ! write(*,*)'Output: ',kou,koud IF(KOU.NE.KOUD) THEN IF(KOU.NE.0) CLOSE(KOU) KOU=KOUD ENDIF !...ANYTHING AFTER A SET_INTERACTIVE IS TAKEN AS A MODULE NAME OK=.FALSE. IF(EOLCH(LINE,LAST)) GOTO 900 OK=.TRUE. LAST=LAST-1 900 continue ! write(*,*)'Leaving macbeg/macend' RETURN END SUBROUTINE MACEND !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gptcm1 & Replace macro variables with value 1 !\begin{verbatim} SUBROUTINE GPTCM1(IFLAG,SVAR,LAST,SLIN) !...handling of MACRO directives like @& @? and @# etc ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none CHARACTER SVAR*(*),slin*(*) integer iflag,last !\end{verbatim} %+ ! CHARACTER PP*30,CH1*1 ! CHARACTER ENVIR(9)*60,LABEL*8,LABLIN*60,SYMBOL*60 ! CHARACTER LABEL*8,LABLIN*60,SYMBOL*60 ! LOGICAL SG2ERR,TESTB,EOLCH ! IFLAG=0 !...IF NO ERROR RETURN IF(.NOT.BUPERR.NE.0) GOTO 900 IF(LAST.LE.0 .OR. LAST.GE.LEN(SVAR)) GOTO 900 SLIN=SVAR(LAST:) !...IF FIRST CHARACTER NOT A @ RETURN call gptcm2(iflag,svar,last,slin) 900 continue return end SUBROUTINE GPTCM1 ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine gptcm2 & Replace a macro variable with value 2 !\begin{verbatim} subroutine GPTCM2(IFLAG,SVAR,LAST,SLIN) ! handling of macro variables ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none CHARACTER SVAR*(*),slin*(*) integer iflag,last !\end{verbatim} %+ ! CHARACTER ENVIR(9)*60,LABEL*8,LABLIN*60,SYMBOL*60 CHARACTER PP*30,CH1*1 ! CHARACTER LABEL*8,LABLIN*60,SYMBOL*60 CHARACTER LABLIN*60 ! double precision, parameter :: ZERO=0.0D0,ONE=1.0D0 integer ienv ! LOGICAL SG2ERR,TESTB,EOLCH IFLAG=0 IF(SLIN(1:1).NE.'@') GOTO 900 !...A @ MEANS THAT THE FOLLOWING CHARACTER MAY HAVE SPECIAL MEANING ! (many of these not implemented) ! @$ MEANS A COMMENT LINE ! @& MEANS PAUSE ! @?text MEANS QUEARY, value supplied entered to program ! @#itext MEANS DEFINING MACRO VARIABLE i, queary is "text", 0',a) GOTO 100 ENDIF 900 RETURN END SUBROUTINE GQXENV !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\! ! ! >>>> subsection ! PUTFUN can parse a fortran like expression and create a binary tree ! It cannot calculate derivatives. Used for state variable symbols in OC ! Rather final version of PUTFUN below ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\! !\addtotable subroutine putfun & Enter an expression !\begin{verbatim} SUBROUTINE PUTFUN(STRING,L,MAXS,SYMBOL,LOKV,LROT,ALLOWCH,NV) !...READS AN EXPRESSION FROM STRING POSITION L AND CREATES AN BINARY TREE ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none CHARACTER STRING*(*),SYMBOL(*)*(*) integer LOKV(*) integer maxs,allowch,nv ! type(putfun_symlink) :: symlist LOGICAL NOTPP TYPE(putfun_node), pointer :: LROT !\end{verbatim} CHARACTER CH*1 ! double precision, parameter :: ZERO=0.0D0 integer l,i,ipn,lab,lq,negmark,iopuni double precision val TYPE(putfun_node), pointer :: nynod,nonod ! these dummy pointers seem to be redundant ... ??? TYPE(putfun_node), pointer :: dummy,dummy2 ! INPUT: ! STRING CHARACTER WITH EXPRESSION ! L POSITION WHERE THE EXPRESSION STARTS ! MAXS NUMBER OF SYMBOLIC VARIABLES THAT MAY BE USED. ! MAXS=0 NO VARIABLES ALLOWED ! MAXS>0 INDICATES THAT MAXS ALLOWED NAMES ARE IN SYMBOL. ! MAXS<0 INDICATES THAT ABS(MAXS) USERDEFINED NAMES ARE ALLOWED. ! NOTE! SYMBOL AND LOKV MUST HAVE THE DIMENSION ABS(MAXS) ! SYMBOL CHARACTER ARRAY OF DIMENSION ABS(MAXS) ! LOKV ARRAY FOR LOCAL USE OF DIMENSION ABS(MAXS) ! EXIT: ! L POSITION AFTER LAST CHARACTER IN THE EXPRESSION ! LROT POINTER TO ROOT (MAY BE ZERO IF NO TREE) ! NV NUMBER OF SYMBOLIC VARIABLES DEFINED BY USER !...THE FOLLOWING NODES ARE USED ! 1. OPKOD,LLINK,MLINK BIN[R OPERATOR ! 2. OPKOD,LLINK,0 UNIT[R OPERATOR ! 3. OPKOD,0,0,VALUE DATA ELLER VARIABEL ! The following binary opcodes: ! 1 + ! 2 - ! 3 * ! 4 / ! 5 ** (EXPONENTIERING) ! The following unary functions: ! 1 - (should not be used) ! 2 SQRT ! 3 EXP ! 4 LOG (Natural log, e-log) ! 5 LOG10 (logaritm bas 10) ! 6 SIN ! 7 COS ! 8 ATAN (Arctangent) ! 9 ERF (Error function) ! 10 IVAN (Ivantsof function) ! The following data codes ! -1 Whole number (stored as real in node) ! 0 Real constant stored in node ! >0 Symbol variable, INT(value) is the index ???? !..INITIERA PUTFUNVAR=0 NOTPP=.TRUE. debuginc=0 ! IPN associated with the LEVEL array IPN=0 NEGMARK=0 LAB=1 nullify(topnod); nullify(datanod); nullify(lastopnod); nullify(nonod) !...initiate external symbolik links ! write(*,*)'putfun: ',maxs do i=1,abs(maxs) LOKV(i)=0 enddo ! I cannot make it work to have one node for all occurence of one symbol ! allocate(symlist%symnod(20)) nullify(stacktop) if(eolch(string,l)) then ! expected function, found nothing pfnerr=1059; goto 880 endif !..IF FIRST CHARACTER ; THEN EXIT with function zero IF(STRING(L:L).EQ.';') GOTO 800 L=L-1 ! write(*,*)'PUTFUN: ',lab,l GOTO(100,100,200),LAB ! if(lab.gt.0) goto 200 ! ******* Expecting variable ********* > Expecting next ! Allowed characters ! ? > Give hekptext ! - (make negative) > Expect variable ! Variabele or constant > Binary operator ! Unary operator (includ. '(') > Expect variable ! ( > Expect variable 100 L=L+1 if(pfnerr.ne.0) goto 900 IF(L.GT.len(string)) then pfnerr=1052; GOTO 900 endif CH=STRING(L:L) IF(CH.EQ.' ') GOTO 100 IF(CH.EQ.'-') THEN ! treat negative sign special as one can have a symbol afterwards NEGMARK=-1 110 continue L=L+1 IF(L.GT.len(string)) then pfnerr=1052; GOTO 900 endif ! allow spaces after sign CH=STRING(L:L) IF(CH.EQ.' ') GOTO 110 else NEGMARK=0 endif IF(CH.EQ.'(') THEN CALL NYLP(nonod,IPN,NOTPP) GOTO 100 endif LQ=L CALL GETREL(STRING,L,VAL) if(buperr.ne.0) then buperr=0 ! not a number, it must be a symbol or unary operator L=LQ ! write(*,*)'PUTFUN buperror: ',l CALL NYVAR(STRING,L,IOPUNI,negmark,MAXS,SYMBOL,LOKV,allowch,dummy2) IF(pfnerr.ne.0) GOTO 900 ! write(*,*)'After nyvar: ',iopuni,symbol(1) IF(IOPUNI.GT.0) THEN CALL NYUNI(IOPUNI,negmark,NYNOD,IPN,NOTPP) GOTO 100 ENDIF ! write(*,*)'PUTFUN buperror: nyvar return iopuni=0, look for operator' ELSE ! we have found a symbol CALL NYDAT(0,VAL,dummy,negmark) if(pfnerr.ne.0) goto 900 L=L-1 ENDIF LAB=3 ! ****** Expecting binary operator **** > Expected next ! Allowed characters ! +,-,*,**,/ > Expect variable for right tree, LAB=2 ! ) > Binary operator ! ; > This means end of expression 200 L=L+1 IF(L.GT.len(string)) GOTO 800 CH=STRING(L:L) IF(CH.EQ.' ') GOTO 200 IF(CH.EQ.';') GOTO 800 binop: IF(CH.EQ.'+') THEN CALL NYBIN(1,NYNOD,NOTPP) ELSEIF(CH.EQ.'-') THEN CALL NYBIN(2,NYNOD,NOTPP) ELSEIF(CH.EQ.'*') THEN IF(STRING(L+1:L+1).EQ.'*') THEN ! exponentiation ** L=L+1 CALL NYBIN(5,NYNOD,NOTPP) ELSE CALL NYBIN(3,NYNOD,NOTPP) ENDIF ELSEIF(CH.EQ.'/') THEN CALL NYBIN(4,NYNOD,NOTPP) ELSEIF(CH.EQ.')') THEN CALL NYRP(IPN,NOTPP) GOTO 200 ELSE write(*,*)'putfun error: "',ch,'" position ',L pfnerr=1051; GOTO 900 ENDIF binop NEGMARK=0 LAB=2 GOTO 100 ! we have evaluated the expression, IPN is parenthesis level 800 L=L+1 ! write(*,*)'PUTFUN: label 800' IF(IPN.NE.0) THEN pfnerr=1050; GOTO 900 endif ! expression finished, set lrot if(associated(topnod)) then if(topnod%kod.ne.0) then lrot=>topnod else ! topnode has no binary operation, return datanod if any if(.not.associated(datanod)) then nullify(lrot) elseif(datanod%value.eq.zero) then ! single value equal to zero, do not return any node. A symbol would have 1.0 nullify(lrot) else lrot=>datanod endif endif else ! there is no topnod ! write(*,*)'PUTFUN: no topnode' if(associated(datanod)) then if(datanod%value.eq.zero) then ! write(*,*)'PUTFUN: datanode with zero' nullify(lrot) else ! write(*,*)'PUTFUN: datanode with non-zero' lrot=>datanod endif ! else ! no topnode and no datanode, empty function ! write(*,*)'PUTFUN: no datanode' endif endif 880 continue ! return number of external variables used NV=PUTFUNVAR 900 RETURN END SUBROUTINE PUTFUN !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\! !\addtotable subroutine nybin & Found a binary operator + - * / !\begin{verbatim} SUBROUTINE NYBIN(kod,binnod,NOTPP) !...INSERTS A NEW OPNODE IN THE TREE implicit none integer kod TYPE(putfun_node), pointer :: binnod LOGICAL NOTPP !\end{verbatim} %+ ! TYPE(putfun_node), pointer :: temp ! double precision, parameter :: zero=0.0d0 ! INPUT: ! KOD IS OPERATION CODE: 1 +, 2 -, 3 *, 4 /, 5 ** ! EXIT: ! LOKBIN IS NEW BINARY NODE WITH NEW OPERATION ! 1. IF THERE IS NO TOP NODE: ! INSERT THIS NODE AS TOP NODE ! 2. IF THE NEW NODE IS + OR -: ! THE PREVIOUS TOP NODE IS SET AS LEFT SUBTREE OF NEW NODE ! THE NEW NODE IS SET AS TOP NODE ! 3. IF THE NEW NODE IS * OR /: ! IF THE PREVIOUS TOP NODE IS * OR / OR ** DO AS 2. ! ELSE THE RIGHT SUBTREE OF THE TOP NODE IS SET AS LEFT SUBTREE ! OF NEW NODE. NEW NODE IS SET AS RIGHT SUBTREE OF THE TOP NODE ! 4. IF THE NEW NODE IS **: ! THE RIGHT SUBTREE OF THE TOP NODE IS SET AS LEFT SUBTREE ! OF NEW NODE. NEW NODE IS SET AS RIGHT SUBTREE OF THE TOP NODE ! IF(KOD.LE.0) then pfnerr=1058; goto 900 endif ! one may get error "already allocated??" allocate(binnod) debuginc=debuginc+1 binnod%debug=debuginc nullify(binnod%left); nullify(binnod%right); binnod%value=zero binnod%kod=kod; binnod%links=0 lastopnod=>binnod !...arrange binary opnodes according to priorities binop: IF(.not.associated(topnod)) THEN ! set this as topnod and link the datanod as left subtree topnod=>binnod topnod%left=>datanod ELSEIF(KOD.LE.2) THEN ! + OR - binnod%left=>topnod topnod=>binnod ELSEIF(KOD.LE.4) THEN ! * OR / one has to consider priorities of operators if(topnod%kod.gt.2) then binnod%left=>topnod topnod=>binnod else binnod%left=>topnod%right topnod%right=>binnod endif NOTPP=.TRUE. ELSEIF(KOD.EQ.5 .AND. NOTPP) THEN ! ** (TWO ** IN A ROW ILLEGAL) if(topnod%kod.gt.2) then binnod%left=topnod%right topnod%right=binnod else ! rearrange temp=>topnod%right if(associated(temp)) then binnod%left=>temp%right temp%right=>binnod else binnod%left=>topnod%right topnod%right=>binnod endif endif NOTPP=.FALSE. ELSE pfnerr=1058 ENDIF binop 900 RETURN END SUBROUTINE NYBIN !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\! !\addtotable subroutine nyuni & Found a unary operator LOG EXP ... !\begin{verbatim} SUBROUTINE NYUNI(KOD,negmark,uninod,IPN,NOTPP) ! Creates a node with a unary operator ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none TYPE(putfun_node), pointer :: UNINOD LOGICAL NOTPP integer kod,negmark,ipn !\end{verbatim} %+ ! double precision, parameter :: one=1.0D0 allocate(uninod) debuginc=debuginc+1 uninod%debug=debuginc nullify(uninod%left); nullify(uninod%right); uninod%value=zero uninod%kod=-kod; uninod%links=0 ! write(*,*)'creating unary node ',kod,debuginc if(negmark.lt.0) then uninod%value=-one else uninod%value=one endif ! if there is a previous binary operator if(associated(lastopnod)) then ! write(*,*)'linking unary node as right link: ',lastopnod%debug lastopnod%right=>uninod elseif(.not.associated(topnod)) then datanod=>uninod else ! this should nover happen pfnerr=1064 endif CALL NYLP(uninod,IPN,NOTPP) RETURN END SUBROUTINE NYUNI !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\! !\addtotable subroutine nylp & Found a left ( !\begin{verbatim} SUBROUTINE NYLP(uninod,IPN,NOTPP) !...OPENING PARENTHESIS, push links on LEVEL. Also after unary operator implicit none TYPE(putfun_node), pointer :: uninod integer ipn LOGICAL NOTPP !\end{verbatim} %+ type(putfun_stack), pointer :: temp ! IPN=IPN+1 IF(IPN.GT.20) THEN pfnerr=1055; goto 1000 endif if(associated(stacktop)) then allocate(temp) temp%previous=>stacktop stacktop=>temp else allocate(stacktop) endif stacktop%savetop=>topnod stacktop%savebin=>lastopnod stacktop%saveuni=>uninod ! NSTACK(1,IPN)=>topnod ! NSTACK(2,IPN)=>lastopnod ! uninod is null if not ( after unary operator ! NSTACK(3,IPN)=>uninod ! start new expression after ( NOTPP=.TRUE. nullify(topnod) nullify(lastopnod) 1000 continue return end SUBROUTINE NYLP !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\! !\addtotable subroutine nyrp & Found a ) !\begin{verbatim} subroutine NYRP(IPN,NOTPP) !...CLOSING PARENTHESIS ! implicit double precision (a-h,o-z) implicit none integer ipn LOGICAL NOTPP !\end{verbatim} %+ TYPE(putfun_node), pointer :: uninod,subtree ! IF(IPN.LE.0) then pfnerr=1056; goto 1000 endif ! save link to expression inside parenthesis if(.not.associated(topnod)) then subtree=>datanod else subtree=>topnod endif ! POP previous nstack ! topnod=>NSTACK(1,IPN) ! lastopnod=>NSTACK(2,IPN) ! uninod=>nstack(3,IPN) topnod=>stacktop%savetop lastopnod=>stacktop%savebin uninod=>stacktop%saveuni stacktop=>stacktop%previous IPN=IPN-1 ! write(*,*)'right ): ',topnod%debug,lastopnod%debug,subtree%debug ! I do not understand why this IF is not related to those following IF(associated(uninod)) THEN ! write(*,*)'right ) after unary function: ',uninod%debug uninod%left=>subtree endif if(associated(lastopnod)) then if(.not.associated(lastopnod%right)) then lastopnod%right=>subtree else datanod=>subtree endif elseif(associated(uninod)) then datanod=>uninod else !...PARENTHESISED EXPRESSION IS LEFT SUBTREE OF EMPTY BINARY NODE. datanod=>subtree endif NOTPP=.TRUE. 1000 continue RETURN END SUBROUTINE NYRP !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine nyvar & Found a symbol !\begin{verbatim} SUBROUTINE NYVAR(TEXT,L,IOPUNI,negmark,MAXS,SYMBOL,LOKV,allowch,dummy2) ! inserts a symbol in an expression ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none CHARACTER TEXT*(*),SYMBOL(*)*(*) integer LOKV(*) integer iopuni,negmark,maxs,allowch type(putfun_node), pointer :: dummy2 !\end{verbatim} %+ ! integer, parameter :: NOPER=14 CHARACTER CH*1,NAME*16 ! double precision, parameter :: ZERO=0.0D0,ONE=1.0D0 LOGICAL DEL2 integer l,k,ln,i ! type(putfun_symlink) :: symlist character*6, dimension(noper) :: OPER=& ['SQRT ','EXP ','LOG ','LOG10 ','SIN ','COS ','ATAN ',& 'SIGN ','ERF ','IVAN ','BSUM ','ABS ','HS ','LN '] ! IOPUNI=0 DEL2=.FALSE. 70 NAME=' ' K=1 100 CH=BIGLET(TEXT(L:L)) L=L+1 IF(K.GT.1 .AND. ((CH.GE.'0' .AND. CH.LE.'9') .or. CH.eq.'_')) THEN NAME(K:K)=CH K=K+1 ELSE ! first letter must be A-Z IF(CH.GE.'A' .AND. CH.LE.'Z') THEN NAME(K:K)=CH K=K+1 ELSEIF(K.GT.1 .AND. allowch.EQ.1) THEN ! allowch=1 means allow & and # in symbol names if(ch.eq.'#' .or. ch.eq.'&') then name(k:k)=ch k=k+1 else goto 200 endif ELSE GOTO 200 ENDIF ENDIF GOTO 100 !..DEL2 is true if it is the second part of a symbol with a dot 200 IF(DEL2) GOTO 315 !.. if character is ( it must be a unary operator IF(CH.EQ.'(') GOTO 300 !..If character is "." it is an external derivative (like H.T) IF(CH.EQ.'.') GOTO 311 ! IF(MAXS.LE.0 .AND. PUTFUNVAR.EQ.0) GOTO 220 !..compare with existing variable symbols ! If maxs>0 no new symbols allowed, only those in symbol(1..maxs) IF(MAXS.GT.0) PUTFUNVAR=MAXS ! exact match required, include final space in name, max 15 characters ln=len_trim(name)+1 if(ln.gt.16) then pfnerr=1062; goto 900 endif DO I=1,PUTFUNVAR IF(NAME(1:ln).EQ.SYMBOL(I)(1:ln)) GOTO 230 enddo !..New symbol, error if MAXS>0, if not add it to SYMBOL and increment PUTFUNVAR 220 IF(MAXS.GT.0) GOTO 910 IF(PUTFUNVAR.GE.ABS(MAXS)) GOTO 920 PUTFUNVAR=PUTFUNVAR+1 SYMBOL(PUTFUNVAR)=NAME ! if this is never set each occurence of the same symbol will have a node ! LOKV(PUTFUNVAR)=1 ! jump here from several places below 224 continue I=PUTFUNVAR 225 continue CALL NYDAT(I,one,dummy2,negmark) ! write(*,*)'nyvar assigning symnod: ',dummy2%debug,dummy2%value ! symlist%symnod(i)=>dummy2 GOTO 800 !..Known symbol, with index I ! If LOKV(I)=0 it is a predefined symbol without node and one must created 230 continue IF(LOKV(I).EQ.0) GOTO 225 ! CALL SETADS(symnod(I)) ! write(*,*)'nyvar 230: ',i ! IF(associated(lastopnod)) THEN ! lastopnod%right=>symlist%symnod(i) ! ELSE ! datanod=>symlist%symnod(i) ! ENDIF !...Keep track of number of links to this node ! symlist%symnod(i)%links=symlist%symnod(i)%links-1 ! write(*,*)'nyvar 230: ',i,symlist%symnod(i)%links,symlist%symnod(i)%debug ! return ! GOTO 800 !======================================= !..A unary OPERATOR 300 continue ! write(*,*)'nyvar found unary operator: ',name DO I=1,NOPER IF(NAME(1:6).EQ.OPER(I)(1:6)) GOTO 330 enddo !..IF USERDEFINED UNARY OPERATORS (OR ARRAYS) ALLOWED (MAXS<0) 311 IF(MAXS.GT.0) GOTO 910 IF(PUTFUNVAR.GE.ABS(MAXS)) GOTO 920 PUTFUNVAR=PUTFUNVAR+1 IF(CH.EQ.'.') THEN SYMBOL(PUTFUNVAR)=NAME(1:K-1) L=L-1 ELSE SYMBOL(PUTFUNVAR)=NAME(1:K-1)//'(' L=L-1 ! FDMTP extracts text within parenthesis CALL FDMTP(TEXT,L,SYMBOL(PUTFUNVAR)(K+1:)) K=LEN_trim(SYMBOL(PUTFUNVAR)) SYMBOL(PUTFUNVAR)(K+1:K+1)=')' CH=TEXT(L:L) !... this line I do not understand IF(CH.NE.'.') L=L+1 ENDIF CALL CAPSON(SYMBOL(PUTFUNVAR)) !...check if an external symbol with dot (derivative like H.T) IF(CH.NE.'.') GOTO 224 L=L+1 DEL2=.TRUE. GOTO 70 ! !...Second part of symbolic derivative after a "." 315 K=LEN_TRIM(SYMBOL(PUTFUNVAR)) SYMBOL(PUTFUNVAR)(K+1:)='.'//NAME IF(CH.EQ.'(') THEN K=LEN_TRIM(SYMBOL(PUTFUNVAR)) SYMBOL(PUTFUNVAR)(K+1:K+1)='(' L=L-1 CALL FDMTP(TEXT,L,SYMBOL(PUTFUNVAR)(K+2:)) K=LEN_TRIM(SYMBOL(PUTFUNVAR)) SYMBOL(PUTFUNVAR)(K+1:K+1)=')' L=L+1 ENDIF CALL CAPSON(SYMBOL(PUTFUNVAR)) GOTO 224 ! !...note unary opcode is one larger than opcode index! 330 continue IOPUNI=I+1 L=L+1 800 L=L-2 900 RETURN 910 continue pfnerr=1053; GOTO 900 920 continue pfnerr=1054; GOTO 900 END SUBROUTINE NYVAR !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\! !\addtotable subroutine nydat & Found a numeric value !\begin{verbatim} SUBROUTINE NYDAT(KOD,VAL,nynod,negmark) ! store a constant or symbol. The address to the node is returned in lok ! which is used if the symbol is used several times. ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none integer kod,negmark TYPE(putfun_node), pointer :: nynod double precision val !\end{verbatim} ! write(*,*)'nydat 1: ',kod,negmark allocate(nynod) nynod%kod=kod; nynod%links=0 nullify(nynod%left); nullify(nynod%right) debuginc=debuginc+1 nynod%debug=debuginc if(negmark.lt.0) then nynod%value=-val else nynod%value=val endif ! write(*,*)'nydat 2: ',nynod%kod,debuginc,nynod%value if(associated(lastopnod)) then if(.not.associated(lastopnod%right)) then lastopnod%right=>nynod else ! this should never happen write(*,*)'PUTFUN never never error 1' pfnerr=7777 endif ! write(*,*)'nydat 4A: ',lastopnod%kod,lastopnod%value ! write(*,*)'nydat 4B: ',lastopnod%right%kod,lastopnod%right%value ! write(*,*)'nydat 4C: ',lastopnod%left%kod,lastopnod%left%value else datanod=>nynod ! write(*,*)'nydat 5: ',datanod%kod,datanod%value endif return end SUBROUTINE NYDAT !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\! !\addtotable double precision evalf & Evaluate a function !\begin{verbatim} double precision function evalf(LROT,VAR) ! Calculates the value of an expression MEMORY LEAK ! ?? I do not know what is the difference with evalf_x ??/BoS 190804 ! ! VAR is array with values of symbols that can be referenced implicit none ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) double precision VAR(*) type(putfun_node), pointer :: lrot !\end{verbatim} %+ ! character ch1*1 double precision STACK(20) ! type(putfun_node), pointer :: llink,current,mlink type(putfun_node), pointer :: current,mlink TYPE PUTFUN_SAVE integer right type(putfun_node), pointer :: savecurrent type(putfun_save), pointer :: previous end TYPE PUTFUN_SAVE ! these pointers are allocated creating memory leaks type(putfun_save), pointer :: topsave,temp ! double precision, parameter :: ZERO=0.0D0 integer last,lstp,kod ! !...If LROT<=0 there is no expression, return sero STACK(1)=ZERO IF(.not.associated(LROT)) THEN GOTO 800 ENDIF !..INITIATE LAST=0 LSTP=0 current=>LROT nullify(topsave) ! read(*,72)ch1 !72 format(a) !71 format(a,5i5,1pe16.6) !..New node, take is left link if any 100 continue ! if(associated(current%right)) then ! write(*,71)'>>>> evalf 100A1: ',current%debug,current%kod,& ! current%left%debug,current%right%debug,current%links,current%value ! elseif(associated(current%left)) then ! write(*,71)'>>>> evalf 100A2: ',current%debug,current%kod,& ! current%left%debug,0,current%links,current%value ! else ! write(*,71)'>>>> evalf 100A3: ',current%debug,current%kod,& ! 0,0,current%links,current%value ! endif ! ERROR if I first set llink=>current%left and then tested llink if associated if(associated(current%left)) then ! write(*,*)'Taking the left link and pushing current' LAST=LAST+1 if(associated(topsave)) then allocate(temp) temp%previous=>topsave topsave=>temp else allocate(topsave) nullify(topsave%previous) endif topsave%savecurrent=>current ! write(*,71)'evalf 100D: ',topsave%savecurrent%debug,current%left%debug ! mark that right link not visited topsave%right=1 current=>current%left ELSE !..If no left link the right link must be a data or unary negation KOD=current%kod LSTP=LSTP+1 IF(KOD.GT.0) then ! unary operator, store the operation as a real STACK(LSTP)=VAR(KOD) else stack(lstp)=current%value endif ! write(*,71)'evalf 100X: ',current%debug,kod,lstp,0,0,stack(lstp) !..When coming here with LAST=0 the expression has been evaluated. ! If not check if right link of current node has been visited 200 IF(LAST.LE.0) GOTO 800 current=>topsave%savecurrent ! write(*,71)'evalf 100YA: ',current%debug,topsave%right,current%kod IF(topsave%right.gt.0) THEN !..Follow the right link if(associated(current%right)) then MLINK=>current%right ! write(*,71)'evalf 100YB: ',mlink%debug,mlink%kod !..Follow the left link of the right link but first mark that the right ! link of current has been visited topsave%right=-1 current=>MLINK ! write(*,71)'evalf 100Z: ',current%debug,current%kod,topsave%right GOTO 100 ELSE !..unary operator, in some cases it can have a sign CALL EUNARY(current%kod,STACK(LSTP)) STACK(LSTP)=current%value*STACK(LSTP) ! write(*,71)'evalf U: ',current%debug,current%kod,& ! lstp,0,0,stack(lstp) ENDIF ELSE !..Binary operator with both left and right links evaluated LSTP=LSTP-1 ! write(*,73)'evalf B: ',current%debug,current%kod,lstp,& ! stack(lstp),stack(lstp+1) !73 format(a,3i3,2(1pe14.5)) CALL EBINRY(current%kod,STACK(LSTP),STACK(LSTP+1)) ENDIF LAST=LAST-1 topsave=>topsave%previous IF(LAST.LT.0) goto 900 IF(LAST.EQ.0) goto 800 goto 200 ENDIF ! write(*,*)'evalf 799: ',current%debug,current%kod,lstp,current%value GOTO 100 !..KLAR 800 EVALF=STACK(1) 900 RETURN END FUNCTION EVALF !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\! !\addtotable double precision function evalf_x & Evaluate a function !\begin{verbatim} double precision FUNCTION EVALF_X(LROT,VAR) ! Calculates the value of an expression ! ?? I do not know what is the difference with evalf ??/BoS 190804 ! ! VAR is array with values of symbols that can be referenced ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none type(putfun_node), pointer :: lrot double precision VAR(*) !\end{verbatim} %+ double precision STACK(20) ! character ch1*1 ! type(putfun_node), pointer :: llink,current,mlink type(putfun_node), pointer :: current,mlink TYPE PUTFUN_SAVE integer right type(putfun_node), pointer :: savecurrent type(putfun_save), pointer :: previous end TYPE PUTFUN_SAVE ! memory leak allocating pointers ! type(putfun_save), target :: saverec type(putfun_save), pointer :: topsave,temp ! double precision, parameter :: ZERO=0.0D0 integer last,lstp,kod ! !...If LROT<=0 there is no expression, return sero IF(.not.associated(LROT)) THEN STACK(1)=ZERO GOTO 800 ENDIF !..INITIATE LAST=0 LSTP=0 current=>LROT nullify(topsave) ! read(*,72)ch1 !72 format(a) !71 format(a,5i5,1pe16.6) !..New node, take is left link if any 100 continue ! if(associated(current%right)) then ! write(*,71)'>>>> evalf 100A1: ',current%debug,current%kod,& ! current%left%debug,current%right%debug,current%links,current%value ! elseif(associated(current%left)) then ! write(*,71)'>>>> evalf 100A2: ',current%debug,current%kod,& ! current%left%debug,0,current%links,current%value ! else ! write(*,71)'>>>> evalf 100A3: ',current%debug,current%kod,& ! 0,0,current%links,current%value ! endif ! ERROR if I first set llink=>current%left and then tested llink if associated if(associated(current%left)) then ! write(*,*)'Taking the left link and pushing current' LAST=LAST+1 if(associated(topsave)) then allocate(temp) temp%previous=>topsave topsave=>temp else allocate(topsave) nullify(topsave%previous) endif topsave%savecurrent=>current ! write(*,71)'evalf 100D: ',topsave%savecurrent%debug,current%left%debug ! mark that right link not visited topsave%right=1 current=>current%left ELSE !..If no left link the right link must be a data or unary negation KOD=current%kod LSTP=LSTP+1 IF(KOD.GT.0) then ! unary operator, store the operation as a real STACK(LSTP)=VAR(KOD) else stack(lstp)=current%value endif ! write(*,71)'evalf 100X: ',current%debug,kod,lstp,0,0,stack(lstp) !..When coming here with LAST=0 the expression has been evaluated. ! If not check if right link of current node has been visited 200 IF(LAST.LE.0) GOTO 800 current=>topsave%savecurrent ! write(*,71)'evalf 100YA: ',current%debug,topsave%right,current%kod IF(topsave%right.gt.0) THEN !..Follow the right link if(associated(current%right)) then MLINK=>current%right ! write(*,71)'evalf 100YB: ',mlink%debug,mlink%kod !..Follow the left link of the right link but first mark that the right ! link of current has been visited topsave%right=-1 current=>MLINK ! write(*,71)'evalf 100Z: ',current%debug,current%kod,topsave%right GOTO 100 ELSE !..unary operator, in some cases it can have a sign CALL EUNARY(current%kod,STACK(LSTP)) STACK(LSTP)=current%value*STACK(LSTP) ! write(*,71)'evalf U: ',current%debug,current%kod,& ! lstp,0,0,stack(lstp) ENDIF ELSE !..Binary operator with both left and right links evaluated LSTP=LSTP-1 ! write(*,73)'evalf B: ',current%debug,current%kod,lstp,& ! stack(lstp),stack(lstp+1) !73 format(a,3i3,2(1pe14.5)) CALL EBINRY(current%kod,STACK(LSTP),STACK(LSTP+1)) ENDIF LAST=LAST-1 topsave=>topsave%previous IF(LAST.LT.0) goto 900 IF(LAST.EQ.0) goto 800 goto 200 ENDIF ! write(*,*)'evalf 799: ',current%debug,current%kod,lstp,current%value GOTO 100 !..KLAR 800 EVALF_X=STACK(1) 900 RETURN END FUNCTION EVALF_X !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\! !\addtotable subroutine eunary & Evaluate a unary function !\begin{verbatim} SUBROUTINE EUNARY(KOD,X) ! calculates a unary function such as LOG, EXP etc ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none integer kod double precision X !\end{verbatim} %+ double precision, parameter :: ONE=1.0D0 ! y=x IF(KOD.EQ.-1) X=-X IF(KOD.EQ.-2) X=SQRT(X) IF(KOD.EQ.-3) X=EXP(X) IF(KOD.EQ.-4) X=LOG(X) IF(KOD.EQ.-5) X=LOG10(X) IF(KOD.EQ.-6) X=SIN(X) IF(KOD.EQ.-7) X=COS(X) IF(KOD.EQ.-8) X=ATAN(X) IF(KOD.EQ.-9) X=SIGN(ONE,X) IF(KOD.EQ.-10) X=ERF(X) IF(KOD.EQ.-11) X=AIVAN(X) IF(KOD.EQ.-12) X=PF_BSUM(X) IF(KOD.EQ.-13) X=ABS(X) IF(KOD.EQ.-14) X=PF_HS(X) ! this is LN same as LOG, 10th log is LOG10 IF(KOD.EQ.-15) X=LOG(X) ! write(*,*)'eunary: ',y,x RETURN END SUBROUTINE EUNARY !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\! !\addtotable subroutine ebinary & Evaluate a binary operator !\begin{verbatim} SUBROUTINE EBINRY(KOD,X,Y) ! Calculates the value of a binary node with two data nodes ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none integer kod double precision X,Y !\end{verbatim} %+ integer nn ! IF(KOD.EQ.1) X=X+Y IF(KOD.EQ.2) X=X-Y IF(KOD.EQ.3) X=X*Y IF(KOD.EQ.4) THEN IF(Y.ne.zero) then X=X/Y else pfnerr=1063 endif endif IF(KOD.EQ.5) THEN NN=INT(Y) IF(ABS(X).LE.0.1D-30) THEN X=0.0D0 ELSEIF(ABS(DBLE(NN)-Y).LT.1.0D-30) THEN X=X**NN ELSEIF(X.GT.0.1D-30) THEN X=EXP(Y*LOG(X)) ELSE X=0.0D0 ENDIF ENDIF RETURN END SUBROUTINE EBINRY !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\! !\addtotable double precision function aivan & Evaluate Ivantsov's function !\begin{verbatim} double precision FUNCTION AIVAN(PECN) ! CALCULATES THE DIMENSIONLESS SUPERCOOLING OF DIFFUSION BY ! IVANTSOV'S SOLUTION !...added by Zikui and also an updated ERF ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none double precision PECN ! APPROXIMATIVE FORMULA FOR ERROR FUNCTION GIVEN BY: ! ABRAMOWITZ AND STEGUN: HANDBOOK OF MATHEMATICAL FUNCTIONS, ! NATIONAL BUREAU OF STANDARDS, 9TH EDITION, 1970 !\end{verbatim} %+ !CCI Comment the next line because of already defined in ocparam.F90 !CCI double precision, parameter :: ONE=1.0D0,TWO=2.0D0,PI=3.141592654D0 !CCI double precision A,C,Q integer i IF(PECN.LE.8.5D0) THEN AIVAN=DSQRT(PI*PECN)*DEXP(PECN)*(ONE-ERF(DSQRT(PECN))) ELSE A=ONE C=ONE Q=ONE DO I=1,9 A=A*(TWO*DBLE(I)-ONE)/TWO/PECN C=-C Q=Q+A*C enddo AIVAN=Q ENDIF RETURN END FUNCTION AIVAN !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable double precision function pf_bsum & Evaluate BSUM !\begin{verbatim} double precision FUNCTION PF_BSUM(FA) !.. 1993-10-06 20:10:56 /BJ ! ! ( sin(n*pi*f) )^2 ! Calc. the infinit sum B = sum(-------------------) ! (n*pi)^3 ! !.. If we truncate the sum at N=200 the relative error is ! less than ?% for 0.01 < F < 0.99 ! ! implicit none ! IMPLICIT DOUBLE PRECISION(A-H,O-Z) double precision FA !\end{verbatim} %+ ! value of PI not very accurate .... ! double precision, parameter :: ZERO=0.0D+00,PI=3.14159D0 !CCI Comment the next line because of already defined in ocparam.F90 !CCI double precision, parameter :: PI=3.14159D0 double precision, parameter :: PI3=PI*PI*PI ! integer loopmx double precision val,a,b integer i ! LOOPMX=1000 VAL=ZERO DO I=1,LOOPMX A=DBLE(I) B=SIN(A*PI*FA) VAL=VAL+B*B/(A*A*A*PI3) enddo ! PF_BSUM=VAL RETURN END FUNCTION PF_BSUM !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\! !\addtotable double precision function pf_hs & Evaluate Heaviside !\begin{verbatim} double precision FUNCTION PF_HS(X) ! Calculates Heaviside function ! IMPLICIT DOUBLE PRECISION(A-H,O-Z) implicit none double precision X !\end{verbatim} %+ ! double precision, parameter :: ZERO=0.0D+00,ONE=1.0D+00 ! BUG!!!! ! HS=ZERO PF_HS=ZERO IF (X.GE.ZERO) PF_HS=ONE RETURN END FUNCTION PF_HS !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\! !\addtotable double precision function pf_erf & Evaluate ERF !\begin{verbatim} double precision FUNCTION PF_ERF(X0) ! CALCULATES ERROR-FUNCTION OF X, USING AN ! APPROXIMATIVE FORMULA GIVEN BY: ! ABRAMOWITZ AND STEGUN: HANDBOOK OF MATHEMATICAL FUNCTIONS, ! NATIONAL BUREAU OF STANDARDS, 9TH EDITION, 1970 implicit none double precision X0 ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) !\end{verbatim} !CCI Comment the next line because of already defined in ocparam.F90 !CCI double precision, parameter :: ONE=1.0D0,TWO=2.0D0 double precision P,A1,A2,A3,A4,A5,PI,S,X,T,Q DATA P,A1,A2,A3,A4,A5,PI/.3275911D0,.254829592D0,-.284496736D0, & 1.421413741D0,-1.453152027D0,1.061405429D0,3.141592654D0/ S=DSIGN(ONE,X0) X=DABS(X0) T=ONE/(ONE+P*X) Q=T*(A1+T*(A2+T*(A3+T*(A4+T*A5)))) Q=(ONE-Q*DEXP(-X*X))*S PF_ERF=Q RETURN END FUNCTION PF_ERF !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\! !\addtotable subroutine wrtfun & Write the function !\begin{verbatim} SUBROUTINE WRTFUN(STRING,IPOS,LROT,SYMBOL) ! Writes a PUTFUN expression ! ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none CHARACTER STRING*(*),SYMBOL(*)*(*) integer ipos type(putfun_node), pointer :: lrot,current,lnode,rnode,tnode !\end{verbatim} %+ TYPE PUTFUN_SAVE integer right type(putfun_node), pointer :: savecurrent type(putfun_save), pointer :: previous end TYPE PUTFUN_SAVE type(putfun_save), pointer :: topsave,temp,bug integer last,noneg,negmark double precision val ! type(putfun_node), dimension(20) :: link ! integer doneboth(20) ! string=' ' ! ipos=1 ! write(*,*)'wrtfun: ',trim(symbol(1)) !...Quick return if no expression IF(.not.associated(LROT)) THEN CALL CONS(STRING,IPOS,'0') GOTO 900 ENDIF !..INITIATE LAST=0 current=>LROT ! write(*,*)'wrtfun 1: ',current%kod nullify(topsave) IF(current%kod.LT.0) then !..start with a unary operator noneg=1 if(current%value.lt.zero) noneg=-1 CALL WRTLPQ(STRING,IPOS,0,0,current%kod,noneg) ! write(*,76)'wrtfun 99: ',current%kod,current%debug,current%value ! write(*,77)'wrtfun 100A: ',ipos,string(1:ipos) endif !..new node, visit its left link 100 continue lnode=>current%left ! write(*,76)'wrtfun 99: ',current%debug,current%kod,current%value if(associated(topsave)) then endif bigif: IF(associated(LNODE)) THEN !..PUSH LINK IF(associated(LNODE%left)) & CALL WRTLPQ(STRING,IPOS,1,current%kod,lnode%kod,1) if(associated(topsave)) then allocate(temp) temp%previous=>topsave topsave=>temp else allocate(topsave) nullify(topsave%previous) endif topsave%savecurrent=>current ! write all saved links bug=>topsave 55 continue if(associated(bug%previous)) then bug=>bug%previous goto 55 endif ! ! mark that right link not visited LAST=LAST+1 topsave%right=1 current=>LNODE ! write(*,77)'wrtfun 100A: ',ipos,string(1:ipos) !77 format(a,i3,' "',a,'"') ELSE !bigif !..If no left link node must be data val=current%value negmark=0 if(last.gt.0) then ! surround a negative value by ( ) if this data in a right link if(topsave%right.lt.0) negmark=-1 endif CALL WRTDAQ(STRING,IPOS,current%kod,VAL,SYMBOL,negmark) ! write(*,77)'wrtfun 100B: ',ipos,string(1:ipos) IF(LAST.EQ.0) GOTO 800 !..check if right link has been visited 200 continue current=>topsave%savecurrent smallif: IF(topsave%right.gt.0) THEN !..follow right link RNODE=>current%right hlink: IF(associated(RNODE)) THEN !..there is a right link, follow its left link ! mark first the the right link of current has been visited topsave%right=-1 ! check if ) is needed ! then write the operator and possibly a ( TNODE=>current%left IF(associated(tnode%left)) & CALL WRTRPQ(STRING,IPOS,1,current%kod,tnode%kod) CALL WRTBIQ(STRING,IPOS,current%kod) ! write(*,77)'wrtfun 200A: ',ipos,string(1:ipos) TNODE=>current%right IF(associated(tnode%left)) then noneg=1 if(current%kod.lt.0 .and. & current%value.lt.zero) noneg=-1 CALL WRTLPQ(STRING,IPOS,2,current%kod,tnode%kod,noneg) ! write(*,77)'wrtfun 200B: ',ipos,string(1:ipos) endif current=>RNODE GOTO 100 ELSE !..unary operator, write ) if necessary IF(current%kod.LT.-1) CALL CONS(STRING,IPOS,')') ! write(*,77)'wrtfun 200C: ',ipos,string(1:ipos) ENDIF hlink else !smallif !..binary operator and both links visited, check if ) needed ! IT WAS A DIFFICULT BUG TO FIND WHEN tnode=topsave%savecurrent ..... tnode=>topsave%savecurrent if(associated(tnode%right%left)) & call WRTRPQ(STRING,IPOS,2,tnode%kod,tnode%right%kod) ! write(*,77)'wrtfun 200D: ',ipos,string(1:ipos) ENDIF smallif LAST=LAST-1 topsave=>topsave%previous ! IF(LAST) 900,800,200 ! write(*,*)'wrtfun 798: ',last IF(LAST.lt.0) goto 900 IF(LAST.eq.0) goto 800 goto 200 ENDIF bigif ! write(*,*)'wrtfun 799: ',current%kod,last GOTO 100 !..KLAR 800 continue string(ipos:ipos)=';' ipos=ipos+1 900 RETURN END SUBROUTINE WRTFUN !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\! !\addtotable subroutine wrtlpq & Write a keft ( !\begin{verbatim} SUBROUTINE WRTLPQ(STRING,IPOS,LINK,KOD,LOD,negmark) ! write a left ( or unary operator followed by ( ! the unary operator is in LOD ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none CHARACTER STRING*(*) integer ipos,link,kod,lod,negmark !\end{verbatim} %+ ! IF(LOD) 10,90,20 IF(LOD.eq.0) goto 90 if(LOD.gt.0) goto 20 !..unary operator IF(LOD.EQ.-1) THEN IF(KOD.LE.0) THEN CALL CONS(STRING,IPOS,'-') ELSE IF(LINK.EQ.1) CALL CONS(STRING,IPOS,'-(') IF(LINK.EQ.2) CALL CONS(STRING,IPOS,'(-') ENDIF ELSE ! this is a sign for a unary function if(negmark.eq.-1) then CALL CONS(STRING,IPOS,'-') endif IF(LOD.EQ. -2) CALL CONS(STRING,IPOS,'SQRT(') IF(LOD.EQ. -3) CALL CONS(STRING,IPOS,'EXP(') IF(LOD.EQ. -4) CALL CONS(STRING,IPOS,'LOG(') IF(LOD.EQ. -5) CALL CONS(STRING,IPOS,'LOG10(') IF(LOD.EQ. -6) CALL CONS(STRING,IPOS,'SIN(') IF(LOD.EQ. -7) CALL CONS(STRING,IPOS,'COS(') IF(LOD.EQ. -8) CALL CONS(STRING,IPOS,'ATAN(') IF(LOD.EQ. -9) CALL CONS(STRING,IPOS,'SIGN(') IF(LOD.EQ.-10) CALL CONS(STRING,IPOS,'ERF(') IF(LOD.EQ.-11) CALL CONS(STRING,IPOS,'IVAN(') IF(LOD.EQ.-12) CALL CONS(STRING,IPOS,'BSUM(') IF(LOD.EQ.-13) CALL CONS(STRING,IPOS,'ABS(') IF(LOD.EQ.-14) CALL CONS(STRING,IPOS,'HS(') IF(LOD.EQ.-15) CALL CONS(STRING,IPOS,'LN(') ENDIF GOTO 90 !..one must check LOD if left ( 20 continue IF(KOD.GE.3 .AND. LOD.LT.3) CALL CONS(STRING,IPOS,'(') IF(KOD.EQ.5 .AND. LOD.GE.3) CALL CONS(STRING,IPOS,'(') !..if LINK=2, i.e. a right link, write ( of KOD is - or / IF(LINK.EQ.2) THEN IF(KOD.EQ.2 .AND. LOD.EQ.1) CALL CONS(STRING,IPOS,'(') IF(KOD.EQ.4 .AND. LOD.EQ.3) CALL CONS(STRING,IPOS,'(') ENDIF 90 RETURN END SUBROUTINE WRTLPQ !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\! !\addtotable subroutine wrtrpq & Write a right ) !\begin{verbatim} SUBROUTINE WRTRPQ(STRING,IPOS,LINK,KOD,LOD) ! write a right ) but if LOD<-1 do not write ( ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none CHARACTER STRING*(*) integer ipos,link,kod,lod !\end{verbatim} %+ ! IF(LOD+1) 90,10,20 IF(LOD+1.lt.0) goto 90 if(LOD+1.gt.0) goto 20 !..negation need ) if KOD>0 IF(KOD.GT.0) CALL CONS(STRING,IPOS,')') GOTO 90 20 IF(KOD.GE.3 .AND. LOD.LT.3) CALL CONS(STRING,IPOS,')') IF(KOD.EQ.5 .AND. LOD.GE.3) CALL CONS(STRING,IPOS,')') IF(LINK.EQ.2) THEN IF(KOD.EQ.2 .AND. LOD.EQ.1) CALL CONS(STRING,IPOS,')') IF(KOD.EQ.4 .AND. LOD.EQ.3) CALL CONS(STRING,IPOS,')') ENDIF 90 RETURN END SUBROUTINE WRTRPQ !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\! !\addtotable subroutine wrtbiq & Write a binary operator !\begin{verbatim} SUBROUTINE WRTBIQ(STRING,IPOS,KOD) ! write a binary operator implicit none ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) CHARACTER STRING*(*) integer ipos,kod !\end{verbatim} %+ ! write a binary operator ! write(*,*)'wrtbiq 1: ',ipos,kod IF(KOD.EQ.1) CALL CONS(STRING,IPOS,'+') IF(KOD.EQ.2) CALL CONS(STRING,IPOS,'-') IF(KOD.EQ.3) CALL CONS(STRING,IPOS,'*') IF(KOD.EQ.4) CALL CONS(STRING,IPOS,'/') IF(KOD.EQ.5) CALL CONS(STRING,IPOS,'**') RETURN END SUBROUTINE WRTBIQ !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\! !\addtotable subroutine wrtdaq & Write a number !\begin{verbatim} SUBROUTINE WRTDAQ(STRING,IPOS,KOD,VAL,SYMBOL,negmark) ! write a number, if KOD<0 a whole number ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none ! CHARACTER NAME*8,SYMBOL(*)*(*) CHARACTER SYMBOL(*)*(*) CHARACTER STRING*(*) integer ipos,kod,negmark double precision val !\end{verbatim} %+ ! double precision, PARAMETER :: ZERO=0.0D0 IF(KOD.EQ.0) THEN IF(VAL.GT.ZERO .or. negmark.eq.0) then CALL WRINUM(STRING,IPOS,12,0,VAL) elseif(VAL.LT.ZERO) then CALL CONS(STRING,IPOS,'(') CALL WRINUM(STRING,IPOS,12,0,VAL) CALL CONS(STRING,IPOS,')') endif ELSE !..a name of a variable, the name is in SYMBOL(KOD), skip trailing spaces ! if negated surround by ( ) ! CALL CONS(STRING,IPOS,SYMBOL(KOD)) ! write(*,*)'wrtdaq symbol: ',kod,trim(symbol(kod)) if(val.lt.zero) then CALL CONS(STRING,IPOS,'(') CALL CONS(STRING,IPOS,SYMBOL(KOD)) CALL CONS(STRING,IPOS,')') else CALL CONS(STRING,IPOS,SYMBOL(KOD)) endif ENDIF RETURN END SUBROUTINE WRTDAQ !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\! !\addtotable subroutine cons & Concatinate !\begin{verbatim} SUBROUTINE CONS(STR1,IPOS,STR2) ! used in PUTFUN but should be replaced by // implicit none CHARACTER STR1*(*),STR2*(*) integer ipos !\end{verbatim} ! CONS. TWO STRINGS, RESULT IN PARAMETER STR1 ! IPOS = POSITION IN STR1 WHERE STR2 SHOULD BE PUT ! IPOS IS UPPDATED TO THE FIRST FREE POSITION AT THE END ! OF STR1. TRAILING SPACES ARE STRIPPED OFF. ! IF STR2 CONTAINES ONLY SPACES ONE SPACE IS WRITTEN ! IN TO STR1. CHARACTER SPC*(1) PARAMETER (SPC=' ') integer ilen,k,i ILEN=LEN(STR2) !...FIND THE LENGHT OF STR2 K=ILEN DO I=K,1,-1 IF(STR2(ILEN:ILEN).EQ.SPC) ILEN=ILEN-1 enddo IF(ILEN.EQ.0)ILEN=1 STR1(IPOS:IPOS+ILEN-1)=STR2(1:ILEN) IPOS=IPOS+ILEN RETURN END SUBROUTINE CONS !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\! !\addtotable subroutine exphlp & Provide help !\begin{verbatim} ! SUBROUTINE EXPHLP(PROMPT,SVAR) SUBROUTINE EXPHLP ! writes help to enter a PUTFUN expression implicit none ! CHARACTER PROMPT*(*),SVAR*(*) !\end{verbatim} %+ WRITE(KOU,10) 10 FORMAT(' You are expected to give a formula that shall be', & ' evaluated or manipulated.'/ & ' The formula shall be written as a FORTRAN statement with the', & ' following rules:'/ & ' A variable must begin with a letter', & ' and a number with a number (not a dot).'/' A real number must', & ' have a dot or an exponent (E).'/ & ' The operators + , - , , / , ** (exponentiation) can be used'/ & ' and any level of parenthesis.'/ & ' SQRT(X) is the square root'/ & ' EXP(X) is the exponential'/ & ' LOG(X) or LN(X) is the natural logarithm'/ & ' LOG10(X) is the base 10 logarithm'/ & ' SIN(X), COS(X), ATAN(X)'/ & ' SIGN(X)'/ & ' ERF(X) is the error function'/ & ' IVAN(X) Ivantsof function'/ & ' BSUM(X) is sum(sin(n*pi*f)**2/(n*pi)**3)'/ & ' ABS(X) is absolute value'/ & ' HS(X) is the Heaviside function'/ & ' Notice that these operators must be followed by a (.'// & ' The statement must be terminated by a ;'/) RETURN END SUBROUTINE EXPHLP !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\! !\addtotable subroutine putprp & Asking for a function !\begin{verbatim} SUBROUTINE PUTPRP(NAMN,MAXS,SYMBOL,PROMPT,ILEN) !...CREATES A PROMPT asking for a putfun expression with formal arguments implicit none CHARACTER NAMN*(*),PROMPT*(*),SYMBOL(*)*(*) integer ilen,maxs !...write a prompt with name of all variables !\end{verbatim} %+ integer i,j ILEN=1 PROMPT=' ' CALL CONS(PROMPT,ILEN,NAMN) IF(MAXS.LE.0) THEN CALL CONS(PROMPT,ILEN,'=') GOTO 900 ENDIF CALL CONS(PROMPT,ILEN,'(') I=1 11 IF(I.GT.MAXS) GOTO 12 J=LEN_trim(SYMBOL(I)) IF(LEN(SYMBOL(I)).GT.J) THEN J=J+1 SYMBOL(I)(J:J)=' ' ENDIF CALL CONS(PROMPT,ILEN,SYMBOL(I)(1:J)) IF(I.NE.MAXS) CALL CONS(PROMPT,ILEN,',') I=I+1 GOTO 11 12 CONTINUE CALL CONS(PROMPT,ILEN,')= ') ILEN=ILEN-1 900 RETURN END SUBROUTINE PUTPRP !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\! !\addtotable subroutine delfun & Delete a function !\begin{verbatim} SUBROUTINE DELFUN(LROT,IWS) ! delete a putfun expression :: not converted to structures ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none integer IWS(*) integer lrot !\end{verbatim} integer link(20) integer nod,last,lnode ! DIMENSION LINK(20) ! LOGICAL SG2ERR NOD=LROT IF(NOD.LE.2 .OR. NOD.GT.IWS(2)) GOTO 800 IF(NOD.LE.0) GOTO 900 LAST=0 !..visit left link 100 LNODE=IWS(NOD+1) IF(LNODE.LE.0) GOTO 110 LAST=LAST+1 LINK(LAST)=NOD NOD=LNODE GOTO 100 !..data record at bottom 110 IF(IWS(NOD).EQ.0 .OR. IWS(NOD+3).EQ.1) THEN ! CALL WRELS(NOD,3+NWPR,IWS) ! IF(SG2ERR(KERR)) GOTO 900 ! call release_pnode(nod) if(pfnerr.ne.0) goto 900 ELSE IWS(NOD+3)=IWS(NOD+3)-1 ENDIF !..visit right link 200 IF(LAST.LE.0) GOTO 800 NOD=LINK(LAST) IF(NOD.LT.0) THEN !..right link visited, remove binary operator, CHECK CODE HERE ... ! CALL WRELS(-NOD,3,IWS) ! IF(SG2ERR(KERR)) GOTO 900 ELSE !..mark right link is now visited LINK(LAST)=-NOD IF(IWS(NOD+2).LE.0) THEN !..remove unary operator ! CALL WRELS(NOD,3,IWS) ! IF(SG2ERR(KERR)) GOTO 900 ELSE !..set node to this and visit its left link NOD=IWS(NOD+2) GOTO 100 ENDIF ENDIF LAST=LAST-1 IF(LAST.GT.0) GOTO 200 800 LROT=0 900 RETURN END SUBROUTINE DELFUN !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ ! ! >>>> subsection ! HPCALC is a screen HP calculator ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine hpcalc & HP calculator !\begin{verbatim} SUBROUTINE HPCALC !...EMULATES A HP CALCULATOR ON SCREEN implicit none ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) !\end{verbatim} %+ integer, parameter :: NOP=40,MAXPRG=100 double precision stk(4),reg(0:9) ! DIMENSION STK(4),REG(0:9) CHARACTER LINE*80,INPUT*80,OPER(NOP)*10,CH1*1,CH2*2 CHARACTER PROG(MAXPRG+1)*20 LOGICAL PROGT,OK,RUN,TRACE SAVE STK,REG,PROG integer naxop,lprog,kprog,ip,iback,k,next,i,jprog,last double precision ss,val DATA STK/0.0,0.0,0.0,0.0/ DATA REG/0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0/ DATA & OPER( 1)/'BACK '/,OPER( 2)/'HELP '/, & OPER( 3)/'SHOW_STACK'/,OPER( 4)/'EXP '/, & OPER( 5)/'LN '/,OPER( 6)/'LOG '/, & OPER( 7)/'SIN '/,OPER( 8)/'COS '/, & OPER( 9)/'TAN '/,OPER(10)/'[ASIN '/, & OPER(11)/'[ACOS '/,OPER(12)/'[ATAN '/, & OPER(13)/'SQRT '/,OPER(14)/'ROT_STACK '/, & OPER(15)/'SWITCH_XY '/,OPER(16)/'POWER_2 '/, & OPER(17)/'CLX '/,OPER(18)/'CLSTACK '/, & OPER(19)/'STO_REG '/,OPER(20)/'RCL_REG '/ DATA & OPER(21)/'CLEAR_REG '/,OPER(22)/'CHSIGN '/, & OPER(23)/'DISPLAYREG'/,OPER(24)/' '/, & OPER(25)/'_STOP '/,OPER(26)/'_GOTO '/, & OPER(27)/'_IF '/,OPER(28)/'_PROGRAM '/, & OPER(29)/'ENTER_PUSH'/,OPER(30)/'_LIST '/, & OPER(31)/'_ERASE_PRO'/,OPER(32)/'_STEP '/, & OPER(33)/'_EDIT '/,OPER(34)/'_BACK '/, & OPER(35)/'_NOOP '/,OPER(36)/'_TRACE '/, & OPER(37)/'_END '/,OPER(38)/'_RUN '/, & OPER(39)/'QUIT '/,OPER(40)/'FIN '/ ! WRITE(*,*)'REVERSE POLISH CALCULATOR' ! uninitiated in original? jprog=0 NAXOP=24 PROGT=.FALSE. RUN=.FALSE. OK=.FALSE. LPROG=0 PROG(MAXPRG+1)='_END' LAST=LEN(LINE) 100 CONTINUE IF(PROGT .AND. OK) THEN !...SAVE PROGRAM STEP LPROG=LPROG+1 IF(LPROG.GT.MAXPRG) THEN WRITE(*,*)'TOO MANY PROGRAM STEPS, MAXIMUM IS ',MAXPRG ELSE PROG(LPROG)=INPUT(1:20) WRITE(*,98)LPROG,INPUT(1:LEN_TRIM(INPUT)) 98 FORMAT(' STEP',I4,': ',A) ENDIF ENDIF IF(RUN) THEN KPROG=KPROG+1 IF(KPROG.GT.MAXPRG) THEN WRITE(*,*)'ILLEGAL STEP' RUN=.FALSE. GOTO 100 ENDIF INPUT=PROG(KPROG) IF(TRACE)WRITE(*,*)KPROG,STK(1),INPUT ELSEIF(PROGT) THEN ! CALL GPARC('HPP>',LINE,LAST,1,INPUT,' ',HPHLP) CALL GPARC_old('HPP>',LINE,LAST,1,INPUT,' ',HPHLP) CALL CAPSON(INPUT) IF(INPUT(1:1).EQ.' ') GOTO 100 OK=.FALSE. ELSE WRITE(*,101)STK(1) 101 FORMAT(1PE15.7) CALL GPARC_old('HPC>',LINE,LAST,1,INPUT,' ',HPHLP) CALL CAPSON(INPUT) IF(INPUT(1:1).EQ.' ') GOTO 100 OK=.FALSE. ENDIF !...MATH OP CH1=INPUT(1:1) IF(CH1.EQ.'+') THEN STK(1)=STK(1)+STK(2) GOTO 102 ELSEIF(CH1.EQ.'-') THEN STK(1)=STK(2)-STK(1) GOTO 102 ELSEIF(CH1.EQ.'*') THEN STK(1)=STK(1)*STK(2) GOTO 102 ELSEIF(CH1.EQ.'/') THEN STK(1)=STK(2)/STK(1) GOTO 102 ELSEIF(CH1.EQ.'^') THEN STK(1)=STK(2)**STK(1) GOTO 102 ENDIF GOTO 109 !...SHIFT STACK DOWN 102 STK(2)=STK(3) STK(3)=STK(4) OK=.TRUE. GOTO 100 !...NUMBER OR OPCODE 109 IP=0 buperr=0 ! write(*,*)'number 1: ',input(1:10),ip CALL GETREL(INPUT,IP,VAL) ! write(*,*)'number 2: ',input(1:10),ip,buperr,val IF(buperr.eq.0) THEN !... NUMBER, SAVE ON STACK STK(4)=STK(3) STK(3)=STK(2) STK(2)=STK(1) STK(1)=VAL OK=.TRUE. ! write(*,*)'pushed: ',ip IF(INPUT(IP:IP).NE.' ') THEN !...to allow input like 3000 3 4 5*/+ IBACK=LEN_TRIM(INPUT)-IP+1 LAST=LAST-IBACK-1 ENDIF ! write(*,*)'pushed: ',ip GOTO 100 ENDIF ! CALL RESERR K=NCOMP2(INPUT,OPER,NOP,NEXT) IF(K.EQ.0) THEN WRITE(*,*)'NO SUCH OPCODE' RUN=.FALSE. GOTO 100 ELSEIF(K.LT.0) THEN WRITE(*,*)'AMBIGUOUS OPCODE' RUN=.FALSE. GOTO 100 ELSE OK=.TRUE. GOTO(110,120,130,140,150,160,170,180,190,200, & 210,220,230,240,250,260,270,280,290,300, & 310,320,380,340,350,360,370,330,390,400, & 410,420,430,440,450,460,470,480,490,500),K ENDIF !...EXIT 110 RETURN !...HELP 120 INPUT(NEXT:NEXT+1)=',,' ! CALL NGHELP(INPUT,NEXT,OPER,NAXOP) routine removed OK=.FALSE. GOTO 100 !...SHOW STACK 130 WRITE(*,131)STK 131 FORMAT(4(1PE15.7)) GOTO 100 !...EXP 140 STK(1)=EXP(STK(1)) GOTO 100 !...LN 150 STK(1)=LOG(STK(1)) GOTO 100 !...LOG10 160 STK(1)=LOG10(STK(1)) GOTO 100 !...SIN 170 STK(1)=SIN(STK(1)) GOTO 100 !...COS 180 STK(1)=COS(STK(1)) GOTO 100 !...TAN 190 STK(1)=SIN(STK(1))/COS(STK(1)) GOTO 100 !...ASIN 200 CONTINUE !...ACOS 210 CONTINUE !...ATAN 220 CONTINUE WRITE(*,*)'NOT IMPLEMENTED' GOTO 100 !...SQRT 230 STK(1)=SQRT(STK(1)) GOTO 100 !...ROT 240 CONTINUE SS=STK(4) STK(4)=STK(3) STK(3)=STK(2) STK(2)=STK(1) STK(1)=SS GOTO 100 !...SWITCH_XY 250 CONTINUE SS=STK(2) STK(2)=STK(1) STK(1)=SS GOTO 100 !...POWER_2 260 CONTINUE STK(1)=STK(1)**2 GOTO 100 !...CLX 270 STK(1)=0.0 GOTO 100 !...CLEAR 280 STK(1)=0.0 STK(2)=0.0 STK(3)=0.0 STK(4)=0.0 GOTO 100 !...STO_REG 290 IF(RUN) THEN CALL GETINT(INPUT,NEXT,I) ELSE CALL GPARI_old('REG#',LINE,LAST,I,-1,NOHELP) ENDIF IF(I.LT.0 .OR. I.GT.9) THEN WRITE(*,*)'REGISTER NUMBER MUST BE 0..9' ELSE REG(I)=STK(1) IF(PROGT) INPUT(NEXT+1:NEXT+1)=CHAR(I+ICHAR('0')) ENDIF GOTO 100 !...RCL_REG 300 IF(RUN) THEN CALL GETINT(INPUT,NEXT,I) ELSE CALL GPARI_old('REG#',LINE,LAST,I,-1,NOHELP) ENDIF IF(I.LT.0 .OR. I.GT.9) THEN WRITE(*,*)'REGISTER NUMBER MUST BE 0..9' ELSE STK(1)=REG(I) IF(PROGT) INPUT(NEXT+1:NEXT+1)=CHAR(I+ICHAR('0')) ENDIF GOTO 100 !...CLR_REG 310 DO I=0,9 REG(I)=0.0 ENDDO GOTO 100 !...CHSIGN 320 STK(1)=-STK(1) GOTO 100 !...PROGRAM 330 IF(PROGT)THEN WRITE(*,*)'ALREDAY SET' ELSE PROGT=.TRUE. LPROG=0 RUN=.FALSE. ENDIF OK=.FALSE. GOTO 100 !... 340 CONTINUE GOTO 100 !...STOP 350 IF(RUN) THEN RUN=.FALSE. WRITE(*,*)'PROGRAM STOP AT ',KPROG ELSEIF(PROGT) THEN PROGT=.FALSE. LPROG=LPROG+1 PROG(LPROG)='STOP' WRITE(*,*)'PROGRAM STOP AT ',LPROG ENDIF GOTO 100 !...GOTO 360 IF(RUN) THEN CALL GETINT(INPUT,NEXT,IP) IF(IP.EQ.0) THEN WRITE(*,*)'PROGRAM STOP AT 0' RUN=.FALSE. ELSEIF(IP.LE.0 .OR. IP.GT.100 .OR. IP.EQ.KPROG) THEN WRITE(*,*)'ILLEGAL GOTO ADDRESS IN STEP ',KPROG RUN=.FALSE. ELSE KPROG=IP-1 ENDIF ELSE CALL GPARI_old('STEP ',LINE,LAST,IP,0,NOHELP) IF(IP.LT.0 .OR. IP.GT.MAXPRG) THEN WRITE(*,*)'ILLEGAL ADDRESS' OK=.FALSE. ELSE WRITE(INPUT(NEXT+1:NEXT+3),365)IP 365 FORMAT(I3) ENDIF ENDIF GOTO 100 !...IF >=< 370 IF(RUN) THEN IF(INPUT(NEXT+1:NEXT+1).EQ.'>') THEN IF(STK(1).GT.STK(2)) KPROG=KPROG+1 ELSEIF(INPUT(NEXT+1:NEXT+1).EQ.'=') THEN IF(ABS(STK(1)-STK(2)).LT.1.0D-16) KPROG=KPROG+1 ELSEIF(INPUT(NEXT+1:NEXT+1).EQ.'<') THEN IF(STK(1).LT.STK(2)) KPROG=KPROG+1 ELSE WRITE(*,*)'ILLEGAL CONDITION IN STEP',KPROG RUN=.FALSE. ENDIF OK=.TRUE. ELSE CALL GPARC_old('CONDITION ( > = OR < )',LINE,LAST,1, & CH2,'NONE',NOHELP) IF(CH2.EQ.'> ' .OR. CH2.EQ.'= ' .OR. CH2.EQ.'< ') THEN INPUT(NEXT+1:)=CH2 ELSE WRITE(*,*)'ILLEGAL CONDITION' OK=.FALSE. ENDIF ENDIF GOTO 100 !...DISPLAY_REG 380 WRITE(*,381)REG 381 FORMAT(5(1PE15.7)/5(1PE15.7)/) GOTO 100 !...ENTER, PUSH STACK 390 STK(4)=STK(3) STK(3)=STK(2) STK(2)=STK(1) GOTO 100 !...LIST 400 WRITE(*,401)(I,PROG(I)(1:LEN_TRIM(PROG(I))),I=1,LPROG) 401 FORMAT(I4,': ',A) OK=.FALSE. GOTO 100 !...ERASE 410 LPROG=0 OK=.FALSE. GOTO 100 !...STEP 420 WRITE(*,*)'NOT IMPLEMENTED' GOTO 100 KPROG=KPROG+1 IF(KPROG.GT.LPROG) THEN WRITE(*,*)'PROGRAM ENDS AT ',LPROG ELSE WRITE(*,401)KPROG,PROG(KPROG) ENDIF OK=.FALSE. GOTO 100 !...EDIT 430 IF(JPROG.EQ.0) JPROG=LPROG-2 CALL GPARI_old('STEP ',LINE,LAST,I,JPROG+1,NOHELP) WRITE(*,*)'NO SUCH STEP' OK=.FALSE. GOTO 100 !...BACK 440 WRITE(*,*)'NOT IMPLEMENTED' RETURN ! GOTO 100 WRITE(*,401)KPROG,PROG(KPROG) IF(KPROG.GT.1) KPROG=KPROG-2 OK=.FALSE. !...NOOP 450 GOTO 100 !...TRACE 460 CONTINUE IF(TRACE) THEN TRACE=.FALSE. ELSE TRACE=.TRUE. ENDIF GOTO 100 !...END 470 PROGT=.FALSE. LPROG=LPROG+1 PROG(LPROG)='STOP' OK=.FALSE. GOTO 100 !...RUN 480 IF(LPROG.EQ.0) THEN WRITE(*,*)'NO PROGRAM' ELSE RUN=.TRUE. PROGT=.FALSE. KPROG=0 ENDIF OK=.FALSE. GOTO 100 !...QUIT 490 CONTINUE RETURN !...FIN 500 CONTINUE RETURN ! GOTO 100 END SUBROUTINE HPCALC !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine hphelp & Help to HP calculator !\begin{verbatim} SUBROUTINE HPHLP ! writes a help text for using the online HP calculator implicit none !\end{verbatim} WRITE(*,10) 10 FORMAT(' This is a revese polish calculator'/& ' Input are numbers, + - * / and ^ and OPCODEs.',& ' Use HELP to list OPCODEs.'/' Several numbers and operations',& ' can be given on one line.'/' The content of the X register',& ' is displayed after each operation'//& ' Example input: 30000 8 1273 * / chs 1.5 3 ^ + exp 2 *'/& ' Computes 2*EXP(1.5**3-30000/(8*1273))'//) RETURN END SUBROUTINE HPHLP !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ ! ! >>>> subsection ! WPACK can convert from an integer workspace to normal double/character ! used to save data on an unformatted Fortran file ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine winit & Initate integer workspace !\begin{verbatim} SUBROUTINE WINIT(NWT,NWR,IWS) !...INITIATES A WORKSPACE ! INPUT: NWT IS THE DIMENSION OF THE WORKSPACE ! NWR IS THE NUMBER OF WORDS TO BE EXCLUDED IN THE BEGINNING ! IWS IS THE WORKSPACE ! EXIT: THE FREE LIST IS INITIATED IN IWS ! ERRORS: NWR LESSER THAN ZERO ! NWT LESSER THAN NWR+100 implicit none integer nwt,nwr,iws(*) ! DIMENSION IWS(*) !\end{verbatim} %+ integer nwres,ifri IF(NWR.LT.0) GOTO 910 IF(NWT.LT.NWR+100) GOTO 920 NWRES=NWR+3 !...IWS(1) IS PUT TO THE FIRST FREE AREA IN THE WORKSPACE AND IWS(2) ! TO THE SIZE OF THE WORKSPACE. THE APPLICATION PROGRAM MUST NOT ! CHANGE THESE LOCATIONS! IWS(1)=NWRES IWS(2)=NWT !...PUT ALL WORDS FROM 3 TO NWRES TO ZERO ! THIS INCLUDES THE FIRST WORD IN THE FREE AREA DO IFRI=3,NWRES IWS(IFRI)=0 enddo !...THE SECOND WORD IN THE FREE AREA IS PUT THE THE NUMBER OF FREE WORDS THIS ! NUMBER IS NWT-NWR-(TWO WORDS IN THE BEGINNING)-(TWO WORDS IN THE END) IWS(NWRES+1)=NWT-NWR-4 900 RETURN 910 buperr=1008 goto 900 920 buperr=1002 GOTO 900 END SUBROUTINE WINIT !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine wold & Read an integer workspace from file !\begin{verbatim} SUBROUTINE WOLD(FIL,NW,IWS) !...READS A FILE INTO A WORKSPACE. THE FILE MUST HAVE BEEN WRITTEN BY WSAVE ! INPUT: FIL A CHARACTER WITH A LEGAL FILE NAME ! NW THE DIMENSION OF IWS ! IWS THE WORKSPACE ! CALLS: WRKCHK TO CHECK THE FREE LIST ! EXIT: THE CONTENT OF THE FILE IS IN IWS. THE DIMENSION OF IWS IS SET TO ! NW AND THE LAST FREE AREA IS CORRECTED implicit none CHARACTER FIL*(*) integer nw,iws(*) ! DIMENSION IWS(*) !\end{verbatim} %+ integer ierr,last,j,k OPEN(UNIT=LUN,FILE=FIL,ACCESS='SEQUENTIAL',STATUS='OLD',& IOSTAT=IERR,ERR=910,FORM='UNFORMATTED') ! note: first integer on file is size of unformatted file READ(LUN,END=100,ERR=100)J,(IWS(K),K=1,J) !...CHECK THE WORKSPACE CALL WRKCHK(LAST,NW,IWS) 100 CLOSE(LUN) RETURN 910 continue GOTO 100 END SUBROUTINE WOLD !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine wsave & Save integer worspace to file !\begin{verbatim} ! SUBROUTINE WSAVE(FIL,NW,IWS) SUBROUTINE WSAVE(FIL,IWS) !...WRITES A WORKSPACE ON A FILE ! INPUT: FIL IS A CHARACTER WITH A LEGAL FILE NAME ! NW IS THE DIMENSION OF THE WORKSPACE ! IWS IS THE WORKSPACE ! CALLS: WRKCHK TO CHECK THE WORKSPACE ! ERROR: IF THE WORKSPACE IS INCORRECT IT CANNOT BE SAVED implicit none ! integer nw,iws(*) integer iws(*) ! DIMENSION IWS(*) CHARACTER FIL*(*) !\end{verbatim} integer i,ierr,last I=IWS(2) CALL WRKCHK(LAST,I,IWS) ! IF(SG2ERR(IERR)) GOTO 900 if(buperr.ne.0) goto 900 OPEN(UNIT=LUN,FILE=FIL,ACCESS='SEQUENTIAL',STATUS='UNKNOWN',& IOSTAT=IERR,ERR=910,FORM='UNFORMATTED') ! note: first integer on file is size of unformatted file WRITE(LUN,ERR=910)LAST,(IWS(I),I=1,LAST) 800 CLOSE(LUN) 900 RETURN 910 continue GOTO 800 END SUBROUTINE WSAVE !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine wpatch & Patch an integer workspace !\begin{verbatim} SUBROUTINE WPATCH(NW,IWS) !...ROUTINE TO PATCH A WORKSPACE ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none integer nw,iws(*) ! DIMENSION IWS(*) !\end{verbatim} %+ integer idum,ip,iadr,ival,j CHARACTER LINE*80,CHX*(NBPW),CHHEX*(2*NBPW) double precision x,z IF(IWS(2).NE.NW) THEN WRITE(KOU,*)' WORKSPACE DIMENSION INCORRECT, SET TO ',NW IWS(2)=NW ENDIF CALL WRKCHK(IDUM,NW,IWS) ! IF(SG1ERR(IERR)) THEN if(buperr.ne.0) then WRITE(KOU,*)' YOU MAY ATTEMPT TO CORRECT THE FREE LIST' ! CALL RESERR buperr=0 ENDIF 10 WRITE(KOU,*)' ADDRESS: ' CALL BINTXT(KIU,LINE) IP=1 CALL GETINT(LINE,IP,IADR) if(buperr.ne.0) then buperr=0 ! IF(LINE(1:1).EQ.'?') CALL WPHLP(IP,LINE) IF(LINE(1:1).EQ.'?') CALL WPHLP IF(LINE(1:1).EQ.'@') GOTO 900 WRITE(KOU,20) 20 FORMAT(' TYPE ? FOR HELP'/) GOTO 10 ENDIF WRITE(KOU,30) 30 FORMAT(' ADDRESS INTEGER CHAR HEXADEC. REAL VALUE'/) 100 IF(IADR.LT.1 .OR. IADR.GT.NW) THEN WRITE(KOU,*)'OUTSIDE WORKSPACE',1,NW GOTO 900 ENDIF CALL LOADR(1,IWS(IADR),X) CALL LOADC(NBPW,IWS(IADR),CHX) CALL WRIHEX(CHHEX,IWS(IADR)) DO J=1,NBPW !...MACHDEP REPLACEMENT OF NON-PRINTABLE ASCII CHARACTERS WITH A PERIOD IF(LLT(CHX(J:J),' ') .OR. LGT(CHX(J:J),'~')) CHX(J:J)='.' enddo WRITE(KOU,110,ERR=911)IADR,IWS(IADR),CHX,CHHEX,X 110 FORMAT('$',I7,5X,I15,2X,A,2X,A,2X,E15.8) 111 CALL GPARR_old('NEW VALUE: ',LINE,IP,Z,RNONE,WPHLP) ! IF(SG2ERR(IERR)) THEN !... NOT A DIGIT: EXIT, STORE AS BYTES, OCTAL OR IGNORE if(buperr.ne.0) then buperr=0 ! CALL RESERR IF(LINE(1:1).EQ.'@') GOTO 900 IF(LINE(1:2).EQ.'EX'.OR.LINE(1:2).EQ.'ex') GOTO 900 IF(LINE(1:1).EQ.'"') THEN CALL STORC(NBPW,IWS(IADR),LINE(2:)) IADR=IADR+1 ELSEIF(LINE(1:1).EQ.'&') THEN ! OCTAL VALUE IP=2 CALL GETOCT(LINE,IP,IVAL) if(buperr.ne.0) then buperr=0 ! IF(SG2ERR(IERR)) THEN ! CALL RESERR WRITE(KOU,*)'VALUE AFTER & NOT OCTAL' ELSE IWS(IADR)=IVAL IADR=IADR+1 ENDIF ELSEIF(LINE(1:1).EQ.'#') THEN ! HEXADECIMAL VALUE IP=2 CALL GETHEX(LINE,IP,IVAL) ! IF(SG2ERR(IERR)) THEN ! CALL RESERR if(buperr.ne.0) then buperr=0 WRITE(KOU,*)'VALUE AFTER # NOT HEXADECIMAL' ELSE IWS(IADR)=IVAL IADR=IADR+1 ENDIF ELSEIF(EOLCH(LINE,IP)) THEN IADR=IADR+1 ELSE WRITE(KOU,20) ENDIF ELSE ! DIGIT IF(LINE(IP:IP).EQ.'/') THEN ! NEW ADDRESS IADR=INT(Z) ELSEIF(INDEX(LINE,'.').GT.0) THEN ! REAL VALUE CALL STORR(1,IWS(IADR),Z) IADR=IADR+NWPR ELSE ! INTEGER VALUE IWS(IADR)=INT(Z) IADR=IADR+1 ENDIF ENDIF ! SKIP REST OF LINE IP=LEN(LINE) GOTO 100 900 CALL WRKCHK(IDUM,NW,IWS) RETURN 911 continue GOTO 111 END SUBROUTINE WPATCH !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine wphlp & Help to patch workspace !\begin{verbatim} ! SUBROUTINE WPHLP(ITYP,LINE) SUBROUTINE WPHLP !...HELP ROUTINE FOR WPATCH implicit none ! CHARACTER LINE*(*) ! integer ityp !\end{verbatim} %+ WRITE(KOU,10) 10 FORMAT(' YOU MAY PATCH THE WORKSPACE.'/& ' THE VALUE AT THE SPECIFIED ADDRESS IN THE WORKSPACE',& ' IS DISPLAYED AS'/' INTEGER, CHAR (NON-PRINTABLE',& ' CHAR REPLACED BY .) HEXADECIMAL AND REAL.'//& ' THE FOLLOWING INPUT IS LEGAL:'/& ' VALUE IN NEXT ADDRESS IS DISPLAYED'/& ' IS STORED AT THE ADDRESS'/& ' A REAL NUMBER MUST INCLUDE A PERIOD (.)'/& ' / IS TAKEN AS NEW ADDRESS'/& ' & STORED AS OCTAL'/& ' # STORED AS HEXADECIMAL'/& ' " STORED AS BYTES',& ' (BYTES FOR ONE WORD ONLY)'/& ' @ OR EXIT EXIT'/& ' ? THIS TEXT'/& ' IGNORED'/) RETURN END SUBROUTINE WPHLP !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine wrkchk & Check consistency of workspace !\begin{verbatim} SUBROUTINE WRKCHK(LAST,NW,IWS) !...CHECKS THE FREE LIST IN A WORKSPACE ! INPUT: NW IS THE DIMENSION ! IWS IS THE WORKSPACE ! EXIT: LAST IS PUT TO THE LAST WORD USED IN THE WORKSPACE ! ERRORS: ANY ERROR IN THE FREE LIST (POINTER OUTSIDE WORKSPACE ETC) implicit none integer last,nw,iws(*) ! DIMENSION IWS(*) !\end{verbatim} %+ integer lok,lfr IF(NW.LT.100) GOTO 910 IWS(2)=NW !...SERACH THE FREE LIST STARTING IN WORD 1 ! (THERE MUST ALWAYS BE A FREE AREA!) LOK=IWS(1) !...A FREE AREA MUST LIE BETWEEN 2 AND THE DIMENSION 100 IF(LOK.LE.2 .OR. LOK.GE.NW) GOTO 920 LAST=LOK LOK=IWS(LOK) !...IN THE LAST FREE AREA LOK=0 IF(LOK.EQ.0) GOTO 200 !...THE FREE AREAS ARE ALWAYS ORDERD INCREASINGLY IF(LOK.LT.LAST+2) GOTO 930 LFR=IWS(LAST+1) !...A FREE AREA IS AT LEAST TWO WORDS AND NOT PAST THE NEXT AREA IF(LFR.LT.2 .OR. LAST+LFR.GT.LOK) GOTO 940 GOTO 100 !...THE FREE AREA SEEMS CORRECT 200 LFR=LAST+1 IWS(LFR)=NW-LFR LAST=LFR 900 RETURN 910 continue buperr=1002 GOTO 900 920 continue buperr=1003 GOTO 900 930 continue buperr=1004 GOTO 900 940 continue buperr=1005 GOTO 900 END SUBROUTINE WRKCHK !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine wlist & List free list in worspace !\begin{verbatim} SUBROUTINE WLIST(IWS) !...LISTS THE FREE AREAS implicit none integer iws(*) ! DIMENSION IWS(*) !\end{verbatim} integer n,nw,nwp N=1 NW=0 WRITE(KOU,10)IWS(2) 10 FORMAT(/' MAP OF THE FREE SPACE CONTAINING',I12,' WORDS') 100 N=IWS(N) IF(N.LE.0) GOTO 200 NWP=IWS(N+1) NW=NW+NWP WRITE(KOU,110)N,NWP 110 FORMAT(' FROM ',I12,' ARE ',I12,' WORDS FREE') GOTO 100 200 WRITE(KOU,210)NW 210 FORMAT(/' TOTAL NUMBER OF FREE WORDS ARE',I12/) RETURN END SUBROUTINE WLIST !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine wtrest & Reserve rest of workspace !\begin{verbatim} SUBROUTINE WTREST(NYB,NW,IWS) !...RESERVES THE LAST PART OF THE WORKSPACE ! INPUT: IWS IS A WORKSPACE ! EXIT: NYB IS A POINTER TO THE RESERVED PART ! NW IS THE NUMBER OF RESERVED WORDS implicit none integer nyb,nw,iws(*) ! DIMENSION IWS(*) !\end{verbatim} %+ integer lok,last LOK=1 100 LAST=LOK LOK=IWS(LAST) IF(LOK.GT.0) GOTO 100 NW=IWS(LAST+1) CALL WTAKE(NYB,NW,IWS) RETURN END SUBROUTINE WTREST !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine wtake & Reserve a record in workspace !\begin{verbatim} SUBROUTINE WTAKE(NYB,NW,IWS) !......RESERVS NW WORDS IN THE WORKSPACE ! INPUT: NW IS THE NUMBER OF WORDS TO BE RESERVED ! IWS IS THE WORKSPACE ! EXIT: NYB POINTS TO THE FIRST WORD THAT IS RESERVED ! ERROR: TOO SMALL OR TOO LARGE NUMBER OF WORDS TO BE RESERVED implicit none integer nyb,nw,iws(*) ! DIMENSION IWS(*) !...THE FREE LIST START IN THE FIRST WORD ! IN EACH FREE AREA THE FIRST WORD POINTS TO THE NEXT FREE AREA ! AND THE SECOND GIVES THE NUMBER OF WORDS IN THIS AREA ! THE FREE LIST ENDS WITH THE POINTER EQUAL TO ZERO !\end{verbatim} %+ integer loka,lokb,next IF(NW.LT.2) GOTO 910 LOKB=1 4 LOKA=IWS(LOKB) IF(LOKA.LE.0) GOTO 920 IF(LOKA.GE.IWS(2)) GOTO 930 ! deleted feature !!! if(X) <0 first label, =0 second label >0 third label ! IF(IWS(LOKA+1)-NW) 10,20,30 IF(IWS(LOKA+1)-NW .eq.0) then goto 20 elseif(iws(loka+1)-nw.gt.0) then goto 30 endif !...TOO SMALL AREA, CONTINUE WITH THE NEXT 10 LOKB=LOKA GOTO 4 !...EXACT FIT WITH THE REQUESTED NUMBER OF WORDS ! IF IWS(LOKA)=0 IT IS THE LAST FREE AREA OF THE WORKSPACE. ! AS WRELS WILL NOT WORK PROPERLY IF THERE IS NOT A FREE AREA AFTER THE ! LAST RESERVED A POINTER IS SET. IN WINIT THE SIZE OF THE LAST FREE AREA ! WAS DECREASED BY TWO TO LEAVE A UNRESERVABLE FREE AREA LAST 20 IF(IWS(LOKA).GT.0) THEN IWS(LOKB)=IWS(LOKA) ELSE GOTO 31 ENDIF GOTO 50 !...LARGER AREA THAN REQUESTED ! A FREE AREA MUST BE AT LEAST TWO WORDS, IF THIS AREA IS AT LEAST ! TWO WORDS LARGER THAN THE REQUEST IT IS DIVIDED, OTHERWISE SKIPPED 30 IF(IWS(LOKA+1)-NW-2.LT.0) GOTO 10 31 NEXT=LOKA+NW IWS(NEXT)=IWS(LOKA) IWS(NEXT+1)=IWS(LOKA+1)-NW IWS(LOKB)=NEXT 50 NYB=LOKA !...THE RESERVED AREA IS ZEROED LOKB=NYB+NW-1 DO LOKA=NYB,LOKB IWS(LOKA)=0 enddo 900 RETURN 910 continue buperr=1008 GOTO 900 920 continue buperr=1006 GOTO 900 930 continue buperr=1007 GOTO 900 END SUBROUTINE WTAKE !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine wrels & Release a record in workspace !\begin{verbatim} SUBROUTINE WRELS(IDP,NW,IWS) !......Returns NW words beginning from IDP to the free workspace list ! The free workspace list is in increasing order ! IWS(1) points to the first free space ! IWS(2) gives the total number of words in the workspace implicit none ! DIMENSION IWS(*) integer idp,nw,iws(*) !......Check that the released space is at lest 2 words and that it is ! inside the workspace (That is between 3 and IWS(2)) !\end{verbatim} integer loka,lokb,lokc IF(IDP.LT.3.OR.IDP.GE.IWS(2).OR.NW.LT.2.OR.NW.GE.IWS(2)) GOTO 910 LOKC=IDP LOKB=1 100 LOKA=LOKB LOKB=IWS(LOKA) IF(LOKB.LE.0) GOTO 920 IF(LOKB.LT.LOKC) GOTO 100 !..LOKA is the address of the nearest free space below LOKC IF(LOKA.EQ.1) GOTO 120 !..Check if the two areas can be merged ! IF(LOKA+IWS(LOKA+1)-LOKC) 120,110,930 IF(LOKA+IWS(LOKA+1)-LOKC .lt.0) then goto 120 ELSEIF(LOKA+IWS(LOKA+1)-LOKC .gt.0) then goto 930 endif !..The released space follows directly on LOKA => Merge LOKA and LOKC LOKC=LOKA IWS(LOKC+1)=IWS(LOKC+1)+NW GOTO 130 !..Set the pointer from LOKC to LOKB and from LOKA to LOKC 120 IWS(LOKC)=LOKB IWS(LOKA)=LOKC IWS(LOKC+1)=NW !..Check if LOKC now can be merged with LOKB! ! deleted fetaure !130 IF(LOKC+IWS(LOKC+1)-LOKB) 900,140,940 130 continue IF(LOKC+IWS(LOKC+1)-LOKB .lt.0) then goto 900 elseif(LOKC+IWS(LOKC+1)-LOKB.gt.0) then goto 940 endif !..Merge LOKC and LOKB IWS(LOKC)=IWS(LOKB) IWS(LOKC+1)=IWS(LOKC+1)+IWS(LOKB+1) 900 RETURN !...ERRORS ! TOO SMALL OR OUTSIDE WORKSPACE 910 buperr=1008 GOTO 900 ! ABOVE HIGHEST FREE WORKSPACE 920 buperr=1008 GOTO 900 ! FIRST PART ALREADY FREE 930 GOTO 920 ! LAST PART ALREADY FREE 940 GOTO 920 END SUBROUTINE WRELS !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable integer function nwch & Number of words to store a character !\begin{verbatim} INTEGER FUNCTION NWCH(NB) ! number of words to store a character with nb bytes ! nbpw is the number of bytes in a word. If not even multiple add 1 word implicit none integer nb !\end{verbatim} %+ integer i i=nb/nbpw if(mod(nb,nbpw).gt.0) then i=i+1 endif nwch=i return end FUNCTION NWCH !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine storc & Store a character in workspace !\begin{verbatim} SUBROUTINE STORC(N,IWS,text) ! Stores a text character in an integer workspace at position N ! The length of the character to store is len(text) !\end{verbatim} %+ implicit none integer n,iws(*) character text*(*) ! maximal size of character, note used also to store functions and bibliography integer, parameter :: maxchar=2048,maxequiv=512 ! NOTE BELOW DIMENSIONING BLEOW, maxchar=nbpw*maxequiv ! character (len=:), allocatable :: localtxt ! integer, allocatable, dimension(:) :: localint character*(maxchar) localtxt ! assumed 32 bit integres, 8 bits/character, 4 characters/word =nbpw integer llen,j,now integer localint(maxequiv) ! equivalence can only be made between local unallocated variables equivalence (localtxt,localint) ! equivalence (localtxt2,localint2) if(maxchar.ne.nbpw*maxequiv) then write(*,*)'METLIB utility error: maxchar and maxequiv do not match' stop endif llen=len(text) if(llen.gt.maxchar) then write(*,*)'Cannot store texts larger than ',maxchar,' characters' buperr=1010; goto 900 endif ! due to the equivalence this stores the character bit map into localint2 !! ! the localtext will be padded with spaces after text localtxt=text ! number of words to store rounding off?? integers are 4 bytes (32 bits) now=nwch(llen) do j=1,now iws(n+j-1)=localint(j) enddo ! localint2=localint ! write(*,800)llen,now,text(1:llen),localtxt(1:llen),localtxt2(1:llen) !800 format('storc: ',2i4,3('"',a),'"') 900 continue return end SUBROUTINE STORC !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine loadc & Load a character from workspace !\begin{verbatim} SUBROUTINE LOADC(N,IWS,text) ! copies a text from an integer workspace at position N into a character ! The number of characters to copy is len(text) implicit none integer n,iws(*) character text*(*) ! character (len=:), allocatable :: localtxt ! integer, allocatable, dimension(:) :: localint ! maximal size of character, note used also to store functions and bibliography !\end{verbatim} %+ integer, parameter :: maxchar=2048,maxequiv=512 ! NOTE BELOW DIMENSIONING BELOW, maxchar=nbpw*maxequiv character*(maxchar) localtxt ! assumed 32 bit integer, 8 bits character, 4 characters/word integer llen,j,now integer localint(maxequiv) ! equivalence can obly be made between local unallocated variables equivalence (localtxt,localint) llen=len(text) if(llen.gt.maxchar) then write(*,*)'Attempt to extract a text larger than ',maxchar buperr=1010;; goto 900 endif now=nwch(llen) do j=1,now localint(j)=iws(n+j-1) enddo ! write(*,800)llen,now,localtxt(1:llen) !800 format('LOADC: ',2i3,' "',a,'"') text=localtxt(1:llen) 900 continue return end SUBROUTINE LOADC !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine storr & Store a double in workspace !\begin{verbatim} SUBROUTINE STORR(N,IWS,VALUE) !...STORES A REAL NUMBER IN A WORKSPACE at index N ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) ! DIMENSION IWS(*) implicit none integer iws(*) double precision value integer n !\end{verbatim} %+ INTEGER JWS(2),int(2) DOUBLE PRECISION WS,aws EQUIVALENCE (WS,JWS),(int,aws) ! move the exact bit pattern from real VALUE to integer IWS(N) WS=VALUE IWS(N)=JWS(1) IWS(N+1)=JWS(2) ! int=jws ! write(*,17)value,ws,aws !17 format('storr: ',3(1pe14.6),/10x,4i14) RETURN END SUBROUTINE STORR !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine loadr & Load a double from workspace !\begin{verbatim} SUBROUTINE LOADR(N,IWS,VALUE) !...LOADS A REAL NUMBER FROM A WORKSPACE at index N ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none integer iws(*) ! DIMENSION IWS(*) DOUBLE PRECISION VALUE integer N !\end{verbatim} %+ DOUBLE PRECISION WS INTEGER JWS(2) EQUIVALENCE (WS,JWS) ! move the exact bit pattern from integer IWS(N) to real VALUE JWS(1)=IWS(N) JWS(2)=IWS(N+1) VALUE=WS RETURN END SUBROUTINE LOADR !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine storrn & Store N doubles in workspace !\begin{verbatim} SUBROUTINE STORRN(N,IWS,ARR) ! store N doubles in workspace ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none ! DIMENSION IWS(*),ARR(*) integer n,iws(*) double precision arr(*) !\end{verbatim} %+ integer, parameter :: maxr=256 double precision dlocal(maxr) integer ilocal(maxr*nwpr) integer i equivalence (dlocal,ilocal) ! if(n.gt.256) then if(n.gt.512) then write(*,*)'M4 STORRN cannot handle arrays larger than ',maxr,n buperr=1010; goto 900 endif do i=1,n dlocal(i)=arr(i) enddo DO I=1,N*nwpr iws(I)=ilocal(I) enddo 900 continue RETURN END SUBROUTINE STORRN !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine loadrn & Load N doubles frm workspace !\begin{verbatim} SUBROUTINE LOADRN(N,IWS,ARR) ! load N doubles from workspace ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none double precision ARR(*) integer n,iws(*) integer, parameter :: maxr=256 double precision dlocal(maxr) !\end{verbatim} %+ integer ilocal(maxr*nwpr) integer i equivalence (dlocal,ilocal) if(n.gt.256) then write(*,*)'LOADRN cannot handle arrays larger than ',maxr buperr=1010; goto 900 endif do i=1,n*nwpr ilocal(i)=iws(i) enddo DO I=1,N ARR(I)=dlocal(I) enddo 900 continue RETURN END SUBROUTINE LOADRN !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine storr1 & Store 1 double at current position !\begin{verbatim} SUBROUTINE STORR1(ARR,VAL) ! store a single double in workspace ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none double precision arr,val !\end{verbatim} %+ ARR=VAL RETURN END SUBROUTINE STORR1 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable subroutine loadr1 & Load 1 double from current position !\begin{verbatim} SUBROUTINE LOADR1(ARR,VAL) ! load a single double from workspace ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) implicit none double precision arr,val !\end{verbatim} VAL=ARR RETURN END SUBROUTINE LOADR1 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ ! ! >>>> subsection ! 2D matrix indexing ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable integer function ixsym & Index 2D array stored as upper triangle !\begin{verbatim} integer function ixsym(ix1,ix2) ! calculates the storage place of value at (i,j) for a symmetrix matrix ! storage order 11, 12, 22, 13, 23, 33, etc implicit none integer ix1,ix2 !\end{verbatim} %+ ! integer, save :: ncall=0, mcall=0 ! integer, allocatable, dimension(:) :: bug ! at a testing ncall=24623, mcall=507127 ! if(ix1.le.ix2) then ! mcall=mcall+1 ! else ! write(*,*)'Indices order',ncall,mcall,ix1,ix2 ! ncall=ncall+1 ! endif if(ix1.le.0 .or. ix2.le.0) then ixsym=0; buperr=1000; goto 1000 endif if(ix1.gt.ix2) then ixsym=ix2+ix1*(ix1-1)/2 else ixsym=ix1+ix2*(ix2-1)/2 endif 1000 continue return end function ixsym !\addtotable integer function kxsym & Index 2D array stored as upper triangle !\begin{verbatim} integer function kxsym(ix1,ix2) ! calculates the storage place of value at (i,j) for a symmetrix matrix ! storage order 11, 12, 22, 13, 23, 33, etc ! In OC the calls to ixsym take about 10 % of the CPU time ! I am trying to replace with local indexing but I need a routine ! that calculates the index when both indices are equal or when I know ! the second index is larger ! if(ix1.le.0 .or. ix2.le.0) then ! buperr=1000; goto 1000 ! endif implicit none integer ix1,ix2 !\end{verbatim} ! this if should be removed when all works if(ix1.gt.ix2) stop "Illegal call to kxsym" kxsym=ix1+ix2*(ix2-1)/2 return end function kxsym !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ ! ! >>>> subsection ! miscaleneous ! !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine fxdflt & Add file extension !\begin{verbatim} subroutine fxdflt(file,ext) ! add default file extention, no good as it thinks .. is an externtion implicit none character file*(*),ext*(*) !\end{verbatim} %+ integer kx if(len_trim(file).gt.0) then kx=index(file,'.') if(kx.le.0) then kx=len_trim(file) file(kx+1:)='.'//ext elseif(kx.lt.len(file)) then if(file(kx:kx+1).eq.'..') then kx=len_trim(file) file(kx+1:)='.'//ext endif endif else write(*,*)'No file name' file=' ' endif return end subroutine fxdflt !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine iniio & Initiate I/O variables !\begin{verbatim} subroutine iniio ! initiates i/o variables, they are all global variables implicit none !\end{verbatim} %+ kou=koud kiu=kiud ler=lerd iox=0 return end subroutine iniio !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine fisepa & Find separator !\begin{verbatim} SUBROUTINE FISEPA(STR,IP0,IP1) !...FINDS A SEPARATOR AFTER POSITION IP0 ! A separator is: ! Any character exept A-Z, 0-9 and _ implicit none CHARACTER STR*(*) integer IP0,IP1 !\end{verbatim} %+ CHARACTER CH1*1 integer l L=LEN_TRIM(STR) IP1=IP0 100 IP1=IP1+1 IF(IP1.GT.L) GOTO 900 CH1=BIGLET(STR(IP1:IP1)) IF((LGE(CH1,'0') .AND. LLE(CH1,'9')) .OR. & (LGE(CH1,'A') .AND. LLE(CH1,'Z')) .OR. CH1.EQ.'_') GOTO 100 !...Return position before separator IP1=IP1-1 900 RETURN END SUBROUTINE FISEPA !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine fdmtp & Find matching ) !\begin{verbatim} SUBROUTINE FDMTP(LINE1,IP,LINE2) !...FINDS A MATCHING ) AFTER THAT AT IP. IP UPDATED TO POSITION AFTER ) implicit none CHARACTER LINE1*(*),LINE2*(*) integer ip !\end{verbatim} %+ integer jp,np,kp1,kp2 IF(IP.LE.0) GOTO 900 JP=IP+1 !...np is number of inner levels of parenthesis NP=0 10 KP1=INDEX(LINE1(JP:),'(') KP2=INDEX(LINE1(JP:),')') IF(KP1.EQ.0) THEN IF(NP.EQ.0) GOTO 100 NP=NP-1 IF(KP2.EQ.0) GOTO 910 JP=JP+KP2 ELSEIF(KP1.LT.KP2) THEN !...INNER PAIR OF () JP=JP+KP1 NP=NP+1 ELSEIF(KP1.GT.KP2) THEN IF(NP.EQ.0) GOTO 100 NP=NP-1 IF(KP2.EQ.0) GOTO 910 JP=JP+KP2 ELSE ! STOP 'FDMTP' buperr=1237 goto 900 ENDIF GOTO 10 !...LINE2 SET TO TEXT INSIDE ( ), IP UPDATED TO POSITION BEHIND ) 100 IF(KP2.EQ.0) GOTO 920 LINE2=LINE1(IP+1:JP+KP2-2) IP=JP+KP2 900 RETURN !910 CALL ST2ERR(1235,'FDMTP','TOO MANY (') 910 buperr=1235 GOTO 900 !920 CALL ST2ERR(1235,'FDMTP','NO MATCHING )') 920 buperr=1236 GOTO 900 END SUBROUTINE FDMTP !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable integer function kndex & Find substring from current position !\begin{verbatim} INTEGER FUNCTION KNDEX(LINE,IP,SS) ! SUBROUTINE KNDEX !...SEARCHES FOR STRING SS IN LINE FROM IP implicit none CHARACTER LINE*(*),SS*(*) integer ip !\end{verbatim} %+ integer k K=INDEX(LINE(IP:),SS) IF(K.GT.0) K=IP-1+K KNDEX=K RETURN END FUNCTION KNDEX !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine cpsstr & Remove tabs and multiple spaces !\begin{verbatim} SUBROUTINE CPSSTR(STRING,LC) !...THIS SUBROUINE COMPRESSES STRING BY REPLACING MULTIPLE SPACES ! OR TABS WITH A SINGLE SPACE implicit none CHARACTER STRING*(*) integer LC !\end{verbatim} %+ integer i,k,l CALL UNTAB(STRING) 10 K=INDEX(STRING(1:LC),' ') IF(K.GT.0) THEN L=K IF(EOLCH(STRING(1:LC),L)) THEN LC=K-1 GOTO 900 ENDIF L=L-K-1 LC=LC-L REMSP: DO I=K+1,LC STRING(I:I)=STRING(I+L:I+L) enddo REMSP STRING(LC+1:)=' ' GOTO 10 ENDIF 900 RETURN END SUBROUTINE CPSSTR !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine untab & Remove tab characters !\begin{verbatim} SUBROUTINE UNTAB(LINE) !...REMOVES ALL TABS FROM LINE. INSERTS SPACES UP TO NEXT TAB STOP ! TAB STOPS GIVEN IN ITABS. TABS AFTER POSITION 80 REPLACED ! WITH A SPACE implicit none CHARACTER LINE*(*) !\end{verbatim} CHARACTER CHTAB*1,XLINE*128 integer ITABS(11) DATA ITABS/8,16,24,32,40,48,56,64,72,80,81/ integer k,i ! CHTAB=CHAR(9) 100 XLINE=LINE K=INDEX(XLINE,CHTAB) IF(K.GT.0) THEN ADDSP: DO I=1,10 IF(ITABS(I).GE.K) GOTO 120 enddo ADDSP !...BEYOND POSITION 80 I=11 ITABS(11)=K 120 I=ITABS(I) LINE(K:I)=' ' LINE(I+1:)=XLINE(K+1:) GOTO 100 ENDIF RETURN END SUBROUTINE UNTAB !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\addtotable subroutine incnum !\begin{verbatim} SUBROUTINE INCNUM(NUMB) !...increments the number in character NUMB by 1, if >9 set to 0 ! and increment precedent number ! if first number >9 set all to zero. implicit none CHARACTER numb*(*) !\end{verbatim} integer clen,ipos,idig,czero czero=ichar('0') clen=len(numb) ipos=clen loop: do while(ipos.gt.0) idig=ichar(numb(ipos:ipos))-czero if(idig.eq.9) then numb(ipos:ipos)='0' ipos=ipos-1 else numb(ipos:ipos)=char(czero+idig+1) exit loop endif enddo loop !1000 continue return end SUBROUTINE INCNUM !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\addtotable logical function compare_abbrev !\begin{verbatim} %- logical function compare_abbrev(name1,name2) ! returns TRUE if name1 is an abbreviation of name2 ! termintaes when a space is found in name1 ! each part between _ or - can be abbreviated from the left ! a slash is treated as _ ! case insensitive. Only 36 first characters compared implicit none character*(*) name1,name2 !\end{verbatim} integer, parameter :: maxl=36 integer jp,ip,noabbr character ch1*1 character (len=maxl) :: lname1,lname2 lname1=name1; lname2=name2 call capson(lname1) call capson(lname2) compare_abbrev=.FALSE. noabbr=0 jp=1 bigloop: do ip=1,36 ch1=lname1(ip:ip) if(ip.gt.1 .and. ch1.eq.' ') goto 900 ! in species - has a special meaning of charge (and other things) if(ch1.eq.'-') then if(ch1.eq.lname2(jp:jp)) goto 300 ch1='_' endif ! in species / has a special meaning of cluster ! if(ch1.eq.'/') then ! if(ch1.eq.lname2(jp:jp)) goto 300 ! write(*,*)'3Z accepting /' ! endif if(ch1.eq.lname2(jp:jp)) goto 300 ! if(ch1.eq.'_' .or. ch1.eq.'-') then if(ch1.eq.'_') then ! we can abbreviate up to "_" in full name 200 continue if(jp.eq.maxl) goto 1000 jp=jp+1 if(lname2(jp:jp).eq.'_') goto 300 if(lname2(jp:jp).eq.' ') goto 1000 goto 200 endif goto 1000 300 continue jp=jp+1 !310 continue enddo bigloop 900 continue compare_abbrev=.TRUE. 1000 continue return end function compare_abbrev !/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ !\addtotable subroutine replacetab !\begin{verbatim} %- subroutine replacetab(line,nl) ! replaces TAB by space in line implicit none character line*(*) integer nl !\end{verbatim} integer ip 100 continue ip=index(line,char(9)) if(ip.gt.0) then line(ip:ip)=' ' nl=ip ! write(*,*)'Replaced TAB by space on line ',nl goto 100 endif !1000 continue return end subroutine replacetab !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ END MODULE METLIB